Amiga ISO Collection/AmigaUtilCD2.iso/Programming/Misc/CLISP-1.LHA/CLISP960530-sr.lha/tests/steele7.tst

Text File | 1996-04-15 | 5.5 KB | 457 lines

;;;
;;; testfile nach steele-beispielen
;;;

;7.3


(let ((f '+))
     (apply f '(1 2)))
3

(let    ((f #'-))
        (apply f '(1 2)))
-1
(apply #'max 3 5 '(2 7 3))
7

(apply 'cons '((+ 2 3) 4))
((+ 2 3) . 4)


(apply #'+ '())
0

(apply #'(lambda (&key a b)(list a b)) '(:b 3))
(nil 3)


(funcall '+ 2 3)
5

(let    ((c (symbol-function '+)))
        (funcall c 1 2 3 4))
10


;;abschnitt 7.4

;progn
(progn 1 2 3)
3

(progn (+ 2 1) 2)
2

(progn 1 2 (values  2 3))
2

(progn)
nil


;prog1
(prog1 1 2 3)
1

(prog1 3 (+ 1 2) 2)
3

(prog1 (values  2 3) 1 2 )
2

(let ((x '(a b c)))
(prog1 (car x)(rplaca x 'foo)))
a

;prog2

(prog2 1 2 3)
2

(prog2  (+ 1 2) 2 3)
2

(prog2 1 (values  2 3) 4)
2

;7.5

;let
(setf a 0)
0

(let ((a 1)(b 2) c )
     (declare (integer a b))
     (list a b c))
(1 2 nil)


(let ((a 1)(b a))
     (declare (integer a b))
     (list a b))
(1 0)

;let*
(let* ((a 1)(b 2) c )
     (declare (integer a b))
     (list a b c))
(1 2 nil)


(let* ((a 1)(b a))
     (declare (integer a b))
     (list a b))
(1 1)

;compiler-let (?)


;progv

(progv '(a b c) '(1 2 3)(+ a b c))
6

(progv '(a b c) '(1 2)(list a b c))
error

(let ((v '(a b c))
      (val '(3 2 1)))
     (progv v val (mapcar #'eval v)))
(3 2 1)


;flet

(flet ((plus (a b)(+ a b))
       (minus (a b)(- a b)))
      (list (plus 1 2)(minus 1 2)))
(3 -1)


(list (flet ( (+ (a b)(- a b)))(+ 3 2))(+ 3 2))
(1 5)

(flet ((+ (a b)(+ (+ a b a) b)))(+ 3 2))
10

;Labels
(labels ((queue (l)(if (car l)(queue (cdr l))'ende)))(queue '(1 2 3)))
ENDE

(labels ((+ (a b)(* a (+ a a b))))(+ 1 2 3))
ERROR

;macrolet ?


;7.6

;if

(let ((a t)(b nil))(list (if a 1 2)(if b 1 2)(if a 1)(if b 1)))
(1 2 1 nil)


;when
(let ((a t)(b nil))(list (when a 1 2)(when b 1 2)(when a 1)))
(2 nil 1)


;unless
(let ((a t)(b nil))(list (unless a 1 2)(unless b 1 2)(unless a 1)))
(nil 2 nil)


;cond
(let ((a t)(b 10)(c nil))
     (list (cond (a 1)(t 'END))(cond (b)(t 'END))(cond (c 1)(t 'END))))
(1 10 END)


;case
(case (+  1 2)
      (1 -1)
      (2 -2)
      (3 -3))
-3

(case (+  1 2)
      (1 -1)
      (2 -2))
nil


;(case (+  1 2)
;      (1 -1)
;      (2 -2)
;      (1 -1)
;      (3 -3))
;ERROR


(case (+  1 2)
      ((1 3) -1)
      (2 -2)
      (otherwise 100))
-1


;
;(case (+  1 2)
;      ((1 3) -1)
;      ((2 1) -2)
;      (t 100))
;ERROR          ;weil ein key nur einmal erscheinen darf!
;



;typecase

(typecase (+  1 2)
      (list -2)
      (null -3)
      (integer -1))
-1

;7.7

;block

(block blocktest (if t (return 0) ) 1)
error

(block blocktest (if t (return-from blocktest 0) ) 1)
0


(block blocktest (if nil (return-from blocktest 0) ) 1)
1


(block blocktest (catch 'catcher
                        (if t (throw 'catcher 0) ) 1))
0


;7.8

;7.8.1

;loop

(let ((i 10))
(loop (if (< (decf i) 1)(return i))))
0


(let ((i 10))
     (catch 'catcher
            (loop (if (< (decf i) 1)(return i)))))
0

;7.8.2
;do,do*

(setf a 0)
0


(do ((a 1 (+ a 1))(b a))
    ((> a 9) (list b c))
    (setf c (+ a b)))
(0 9)

(do* ((a 1 (+ a 1))(b a))
    ((> a 9) b)
    )
1

(let ((a 0))
(do* ((a 1 (+ a 1))(b a))
    ((> a 9) a)(declare (integer a b)))
    a)
0



;7.8.3


;dolist
(let    ((l '(1 2 3))
         (r 0))
        (dolist (x l r)
                (setf r (+ r  x)) ))
6


;dolist
(let ((l '(1 2 3)))
(dolist (x l)(if (> 0 x)(incf x)(return 10))))
10

(let ((l '(1 2 3)))
(dolist (x l )(incf x)))
nil

;dotimes

(let ((s 0))
(dotimes (i (+ 1 9)s)(setf s (+ s i))))
45


;7.8.4


;mapcar

(mapcar #'abs '(3 -4 2 -5 -6))
(3 4 2 5 6)

(mapcar #'cons '(a b c) '(1 2 3))
((a . 1) (b . 2) (c . 3))


;maplist

(maplist #'(lambda (x)(cons 'foo x))'(a b c d))
((foo a b c d)(foo b c d)(foo c d)(foo d))


(maplist #'(lambda (x) (if (member (car x)(cdr x)) 0 1))
         '(a b a c d b c))
(0 0 1 0 1 1 1)


;mapc
(mapc #'abs '(3 -4 2 -5 -6))
(3 -4 2 -5 -6)

;mapc

(mapl #'(lambda (x y)(cons x y))'(a b c d)'(1 2 3 4))
(a b c d)

;mapcan

(mapcan #'(lambda (x)(and (numberp x)(list x)))'(a 1 b c 3 4 d 5))
(1 3 4 5)

;mapcon

(mapcon #'(lambda (x)(and (oddp (car x))(list (car x))))'(5 4 3 2 1))
(5 3 1)

;7.8.5

;tagbody
(let ((a 0))
(tagbody (if nil (go tag0) (go tag1))
         (this will never be reached)
         tag0
         (setf a 1)
         tag1
         (setf a 2))a)
2


(let ((a 0))
(tagbody (if t (go tag0) (go tag1))
         (this will never be reached)
         tag0
         (setf a 1)
         )a)
1




;prog*

(let ((z '(1 0)))
     (prog* ((y z)(x (car y)))
            (return x)))
1
(prog  (a (b 1))
         (if a (go tag0) (go tag1))
         (this will never be reached)
         tag0
         (setf a 1)
         (this will never be reached)
         tag1
         (setf a 2))
nil



(prog  (a (b 1))
         (if a (return nil) (go tag1))
         (this will never be reached)
         tag0
         (return (list a 1))
         tag1
         (setf a 2)
         (go tag0))
(2 1)


;7.9

;multiple-value-bind
(defun adder (x y)(values (+ 1 x)(+ 1 y) ) )
adder


(multiple-value-bind (a b)(adder 1 2)(+ a b))
5

(defun adder (x y)(values-list (list  (+ 1 x)(+ 1 y))))
adder


(multiple-value-bind (a b)(adder 1 2)(+ a b))
5


(multiple-value-list (floor -3 4))
(-1 1)


(multiple-value-call #'+ (floor 5 3)(floor 19 4))
10

(multiple-value-bind (c d)
                     (multiple-value-prog1 (floor -3 4) (+ 1 2))
                     (list c d))
(-1 1)


(multiple-value-bind (x)(floor 5 3)(list x))
(1)


(multiple-value-bind (x y)(floor 5 3)(list x y))
(1 2)


(multiple-value-bind (x y z)(floor 5 3)(list x y z))
(1 2 nil)




(multiple-value-setq (a b) (values 10 20))
10

b
20


;7.10

;catch/throw/unwind-protect