108 lines
4.3 KiB
Plaintext
108 lines
4.3 KiB
Plaintext
;; Function To Be Tested: apply
|
|
;;
|
|
;; Source: Steele's book Section 7.3: Function Invocation Page: 107
|
|
;;
|
|
;; Created By: Karin M. Sye
|
|
;;
|
|
;; Creation Date: June 5, 1986
|
|
;;
|
|
;; Last Update: June 5, 1986
|
|
;; June 16,1986 /sye add test case "test-apply7" to make sure APPLY returns multiple values.
|
|
;; Feb 4, 1987 Jim Blum - changed test2 apply cdddr to make it
|
|
;; run on the SUN
|
|
;;
|
|
;; Filed As: {eris}<lispcore>cml>test>7-3-apply.test
|
|
;;
|
|
;;
|
|
;; Syntax: APPLY function arg &rest more-args
|
|
;;
|
|
;; Function Description: APPLY applies function to a list of arguments. The last argumnet in the argument
|
|
;; list has to be a list.
|
|
;;
|
|
;; Argument(s): function - may be a compiled-code object, a lambda-expression, or a symbol
|
|
;;
|
|
;; Returns: value returned by applying the function to the arguments
|
|
;;
|
|
(do-test test-apply0
|
|
;;
|
|
;; test cases copied from page 107 of CLtL
|
|
;;
|
|
(and (setq f '+) (= (apply f '(1 2)) 3)
|
|
(setq f #'-) (= (apply f '(1 2)) -1)
|
|
(= (apply #'max 3 5 '(2 7 3)) 7)
|
|
(equal (apply 'cons '((+ 2 3) 4)) '((+ 2 3) . 4))
|
|
(= (apply #'+ '()) 0)))
|
|
|
|
(do-test test-apply1
|
|
;;
|
|
;; test cases copied from page 107 of CLtL
|
|
;;
|
|
(and (equal (apply #'(lambda (&key a b) (list a b)) '(:b 3)) '(nil 3))
|
|
;
|
|
(defun foo (size &rest keys &key double &allow-other-keys)
|
|
(let ((v (apply #'make-array size :allow-other-keys t keys)))
|
|
(if double (concatenate (type-of v) v v) v)))
|
|
(setq foo-array (foo 4 :initial-contents '(a b c d) :double t))
|
|
(= (apply 'array-total-size (list foo-array)) 8)
|
|
(eq (apply #'aref foo-array '(1)) 'b)
|
|
(eq (apply 'aref foo-array '(7)) 'd)
|
|
(eq (apply (function aref) foo-array '(4)) 'a)
|
|
(eq (apply #'aref foo-array '(6)) 'c)))
|
|
|
|
(do-test test-apply2
|
|
(and (= (apply #'cadddr '((0 1 2 3))) 3)
|
|
(equal (apply 'cons '(foo) '(bar)) '((foo) . bar))
|
|
(equal (apply (function list) '(foo) '(bar)) '((foo) bar))
|
|
(equal (apply #'append '(foo) '((bar))) '(foo bar))
|
|
(equal (apply 'intersection (list 2 4 6 8) (list '(1 3 5 7 8))) '(8))))
|
|
|
|
(do-test test-apply3
|
|
(and (equal (apply #'(lambda (&rest rest &key a b c) (list rest a b c)) '(:b 3 :a 9))
|
|
'((:b 3 :a 9) 9 3 nil))
|
|
(equal (apply #'(lambda (x) (multiple-value-list (values x (expt x 2) (expt x 3)))) '(2))
|
|
'(2 4 8))))
|
|
|
|
|
|
(do-test test-apply4
|
|
(equal (apply #'(lambda (x y z) (defun funx (x) (list x x))
|
|
(defun funy (y) (list y y y))
|
|
(defun funz (z) (list z z z z))
|
|
(append (funx x) (funy y) (funz z))) '(2 3 4))
|
|
'(2 2 3 3 3 4 4 4 4)))
|
|
|
|
(do-test test-apply5
|
|
(progn (defun bar (test bar-sequence &rest keys &key dummy &allow-other-keys)
|
|
(let ((x (apply #'remove-if test bar-sequence :allow-other-keys t keys)))
|
|
(list (length x) x)))
|
|
(and
|
|
(equal (bar #'oddp '(-2 5 -7 9 10 13 16)) '( 3 (-2 10 16)))
|
|
(equal (bar #'oddp '(-2 5 -7 9 10 13 16) :start 2) '( 4 (-2 5 10 16)))
|
|
(equal (bar 'plusp '(-2 5 -7 9 10 13 16) :start 4 :end 6) '( 5 (-2 5 -7 9 16))))))
|
|
|
|
(do-test test-apply6
|
|
;;
|
|
;; --It is illegal for the symbol to be the name of a macro or special form --
|
|
;; (page 107 CLtL)
|
|
;;
|
|
;; (progn (defmacro mac1 () ''mac1)
|
|
;; (defmacro mac2 () '(list 1 2))
|
|
;; (not (or (nlsetq (apply #'mac1 '()))
|
|
;; (nlsetq (apply #'mac2 '()))
|
|
;; (nlsetq (apply #'quote '(quote)))
|
|
;; (nlsetq (apply #'progn '()))
|
|
;;
|
|
;; setq is defined as a special-form in common lisp
|
|
;;
|
|
;; (nlsetq (apply 'setq '(foo (1+ 10))))
|
|
;; (nlsetq (apply 'no-such-fun1 '()))))))
|
|
t)
|
|
|
|
(do-test "test-apply7 make sure APPLY returns multiple values"
|
|
(and (multiple-value-setq (a b c d) (apply #'values 1.1 2.2 3.3 '(4.4)))
|
|
(= a 1.1) (= b 2.2) (= c 3.3) (= d 4.4)
|
|
(multiple-value-bind (a b c d e) (apply #'values-list '((1 2 3 4)))
|
|
(and (= a 1) (= b 2) (= c 3) (= d 4) (eq e nil)))))
|
|
;;
|
|
;;
|
|
;;
|
|
STOP |