206 lines
6.5 KiB
Plaintext
206 lines
6.5 KiB
Plaintext
;; Function To Be Tested: labels
|
|
;;
|
|
;; Source: CLtL Section 7.5: Establishing New Variable Bindings Page: 113
|
|
;;
|
|
;; Created By: Karin M. Sye
|
|
;;
|
|
;; Creation Date: Oct. 26 ,1986
|
|
;;
|
|
;; Last Update: Feb 4, 1987 Jim Blum - removed empty body test, and changed (declare (integer 0 *) n)
|
|
;; to (declare (type (integer 0 *) n))
|
|
;;
|
|
;; Filed As: {eris}<lispcore>cml>test>7-5-labels.test
|
|
;;
|
|
;;
|
|
;; Syntax: labels ({(NAME LAMBDA-LIST {DECLARATION | DOC-STRING}* {FORM}*)}*) {FORM}*
|
|
;;
|
|
;; Function Description: labels may be used to define locally named functions. Within the body of the labels form, function names
|
|
;; matching those defined by the labels refer to the locally defined functions rather than to the global
|
|
;; function definitions of the same name. Any number of functions may be simultaneously defined.
|
|
;; Each definition is similar in format to a defun form. The scope of the defined function names encompasses
|
|
;; both the body and the function definitions. That is, labels can be used to define mutually recursive
|
|
;; functions.
|
|
;;
|
|
;; Argument(s): NAME - a function name
|
|
;; LAMBDA-LIST -
|
|
;; DECLARATION -
|
|
;; DOC-STRING - a string
|
|
;; FORM -
|
|
;;
|
|
;; Returns: anything
|
|
;;
|
|
|
|
(do-test "test labels - test case copied from page 113 of CLtL (flet was replaced by labels)"
|
|
|
|
(labels ((safesqrt (x) (sqrt (abs x)) ))
|
|
;;
|
|
;; The safesqrt function is used in two places
|
|
;;
|
|
(let ( (longlist1 '(1 4 -25 100 -144)) (longlist2 '(10000 -25 9 16 -36)) (longlist3 '( -1.21 4.84 -10.89 19.36 -30.25)) )
|
|
(and
|
|
(= (safesqrt (apply #'+ (map 'list #'safesqrt longlist1))) (sqrt 30))
|
|
(= (safesqrt (apply #'+ (map 'list #'safesqrt longlist2))) (sqrt 118))
|
|
(= (safesqrt (apply #'+ (map 'list #'safesqrt longlist3))) (sqrt 16.5))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(do-test-group ( "test labels - test case copied from page 113 of CLtL"
|
|
:before (test-defun integer-power (n k) ; a highly "bummed" integer
|
|
(declare (integer n)) ; exponentiation routine.
|
|
(declare (type (integer 0 *) k ))
|
|
(labels ((expt0 (x k a)
|
|
(declare (integer x a) (type (integer 0 *) k ))
|
|
(cond ((zerop k) a)
|
|
((evenp k) (expt1 (* x x) (floor k 2) a))
|
|
(t (expt0 (* x x) (floor k 2) (* x a)))))
|
|
|
|
(expt1 (x k a)
|
|
(declare (integer x a) (type (integer 1 *) k ))
|
|
(cond ((evenp k) (expt1 (* x x) (floor k 2) a))
|
|
(t (expt0 (* x x) (floor k 2) (* x a))))))
|
|
|
|
(expt0 n k 1)
|
|
)
|
|
)
|
|
)
|
|
|
|
(do-test "test labels - test case copied from page 113 of CLtL"
|
|
|
|
(equal (mapcar #'integer-power '(100 9 8 7 6 5 4 3 2 -4 -6 -7 -9) '( 0 2 2 3 1 4 5 2 1 3 3 2 1))
|
|
'(1 81 64 343 6 625 1024 9 2 -64 -216 49 -9)
|
|
)
|
|
)
|
|
)
|
|
|
|
|
|
|
|
|
|
(do-test "test labels - with declare statements / parameter list keywords"
|
|
|
|
(and
|
|
(eq (labels () t) t)
|
|
|
|
(equal (labels ( (let1 () (values 10 20 30 40))
|
|
(let2 () (values "a" "b" "c" "d" "e"))
|
|
(let3 () (values-list '(writing code for labels))) )
|
|
(multiple-value-call #'list (let1) (let2) (let3)) )
|
|
|
|
'(10 20 30 40 "a" "b" "c" "d" "e" writing code for labels) )
|
|
|
|
(equalp (labels ( (fun1 (m n) (declare (integer m n)) (+ m n))
|
|
(fun2 (m n ) (declare (string m n)) (concatenate 'string m n))
|
|
(fun3 (m n o p) (declare (type (integer 2 10) m n o p)) (max m n o p))
|
|
(fun4 (s) (declare (complex s)) (type-of s))
|
|
(fun5 (s r) (declare (number s r)) (vector (gcd s r) (lcm s r))) )
|
|
|
|
(list (fun1 30 29) (fun2 "ac" "e") (fun3 5 7 6 3) (fun4 #c(2 -1)) (fun5 100 23)) )
|
|
|
|
(list 59 "ace" 7 'complex (vector 1 2300)) )
|
|
|
|
(equal (labels ( (fun1 (m n &key o p) (list m n o p))
|
|
(fun2 (m n &optional (o 2 oflag) (p 30 pflag)) (list m n o p oflag pflag))
|
|
(fun3 (m n &rest x &key (y 6) (z 7 zflag)) (list m n x y z zflag)) )
|
|
|
|
(list (fun1 3 4 :p 7 :o 10) (fun2 1 2 3) (fun2 10 20 30 4) (fun3 9 8 :z 11) (fun3 7 6 :y 10) (fun3 3 2)) )
|
|
|
|
'( (3 4 10 7) (1 2 3 30 t nil) (10 20 30 4 t t) (9 8 (:z 11) 6 11 t) (7 6 (:y 10) 10 7 nil) (3 2 nil 6 7 nil)) )
|
|
)
|
|
)
|
|
|
|
|
|
(do-test-group ( "more tests for labels"
|
|
:before (progn
|
|
(test-defun fun1 () 1)
|
|
(test-defun fun2 () 2)
|
|
(test-defun fun3 () 3)
|
|
(test-defun fun4 () 4)
|
|
(test-setq buf '(results ) )) )
|
|
|
|
(do-test "test labels - locally defined functions overshadow the global functions of the same names"
|
|
|
|
(equal (list (fun1) (fun2) (fun3)
|
|
(labels ((fun1 () 10)
|
|
(fun2 () 20)
|
|
(fun3 () 30))
|
|
(list (fun1) (fun2) (fun3) (fun4)) )
|
|
(fun1) (fun2) (fun3) (fun4) )
|
|
|
|
'(1 2 3 ( 10 20 30 4) 1 2 3 4))
|
|
)
|
|
|
|
(do-test "test labels - the scope of the defined function names for labels encompasses the function definitions"
|
|
|
|
(and
|
|
|
|
(equal (labels ((fun1 () (+ (fun2) (fun3)))
|
|
(fun2 () 20)
|
|
(fun3 () (+ (fun2) (fun4))) )
|
|
|
|
(list (fun1) (fun2) (fun3)) )
|
|
|
|
'(44 20 24))
|
|
|
|
(equal (labels ((fun (n) (declare (type (integer 0 *) n))
|
|
(cond ( (zerop n) 1)
|
|
( t (* n (fun (1- n))))
|
|
) ))
|
|
(map 'list #'fun '(10 8 6 4 2 0 1 3 5)) )
|
|
|
|
'(3628800 40320 720 24 2 1 1 6 120))
|
|
|
|
(equal (block done
|
|
(labels (;;
|
|
;; buf was initialized in :before section
|
|
;;
|
|
|
|
(next-index-type (x y) (declare (list x) (atom y))
|
|
(nconc buf (list (search x input :test #'equal ) y))
|
|
(typecase (second x)
|
|
( null (return-from done buf))
|
|
( list (lst (cdr x)) )
|
|
( string (str (cdr x)) )
|
|
( number (num (cdr x)) )
|
|
( t (other (cdr x)) )
|
|
))
|
|
|
|
|
|
(num (x) (declare (list x))
|
|
(next-index-type x 'number))
|
|
|
|
|
|
(lst (x) (declare (list x))
|
|
(next-index-type x 'list))
|
|
|
|
(str (x) (declare (list x))
|
|
(next-index-type x 'string))
|
|
|
|
(other (x) (declare (list x))
|
|
(next-index-type x 'other)))
|
|
|
|
( num (setq input '(4 "st" (3) #\a 4/5 (4 . 5) "labels") ) )
|
|
))
|
|
'(results 0 number 1 string 2 list 3 other 4 number 5 list 6 string))
|
|
|
|
|
|
)
|
|
)
|
|
)
|
|
|
|
(do-test "test labels - make sure those named functions are defined locally"
|
|
|
|
(progn (dolist (x '(fun1 fun2 fun3)) (fmakunbound x))
|
|
(labels ((fun1 () 1) (fun2 () 2) (fun3 () 3))
|
|
(list (fun1) (fun2) (fun3)) )
|
|
(notany #'fboundp '(fun1 fun2 fun3))
|
|
)
|
|
)
|
|
STOP
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|