1;;; -*- Lisp -*- vim:filetype=lisp 2;;; test file of examples from Steele 3;;; 4 5;; 7.3 6 7(let ((f '+)) 8 (apply f '(1 2))) 93 10 11(let ((f #'-)) 12 (apply f '(1 2))) 13-1 14 15(apply #'max 3 5 '(2 7 3)) 167 17 18(apply 'cons '((+ 2 3) 4)) 19((+ 2 3) . 4) 20 21(apply #'+ '()) 220 23 24(apply #'(lambda (&key a b) (list a b)) '(:b 3)) 25(nil 3) 26 27(funcall '+ 2 3) 285 29 30(let ((c (symbol-function '+))) 31 (funcall c 1 2 3 4)) 3210 33 34;; 7.4 35 36;;progn 37(progn 1 2 3) 383 39 40(progn (+ 2 1) 2) 412 42 43(progn 1 2 (values 2 3)) 442 45 46(progn) 47nil 48 49;;prog1 50(prog1 1 2 3) 511 52 53(prog1 3 (+ 1 2) 2) 543 55 56(prog1 (values 2 3) 1 2 ) 572 58 59(let ((x '(a b c))) 60(prog1 (car x) (rplaca x 'foo))) 61a 62 63;;prog2 64(prog2 1 2 3) 652 66 67(prog2 (+ 1 2) 2 3) 682 69 70(prog2 1 (values 2 3) 4) 712 72 73;; 7.5 74 75;;let 76(setf a 0) 770 78 79(let ((a 1) (b 2) c) 80 (declare (integer a b)) 81 (list a b c)) 82(1 2 nil) 83 84 85(let ((a 1) (b a)) 86 (declare (integer a b)) 87 (list a b)) 88(1 0) 89 90(let (x239) 91 (declare (special x239)) 92 (symbol-value 'x239)) 93nil 94 95;let* 96(let* ((a 1) (b 2) c ) 97 (declare (integer a b)) 98 (list a b c)) 99(1 2 nil) 100 101 102(let* ((a 1) (b a)) 103 (declare (integer a b)) 104 (list a b)) 105(1 1) 106 107;;compiler-let (?) 108 109;;progv 110 111(progv '(a b c) '(1 2 3) (+ a b c)) 1126 113 114(progv '(a b c) '(1 2) (list a b c)) 115error 116 117(let ((v '(a b c)) 118 (val '(3 2 1))) 119 (progv v val (mapcar #'eval v))) 120(3 2 1) 121 122;;flet 123 124(defun plus (&rest args) (apply #'+ args)) 125plus 126 127(flet ((plus (a b) (+ a b)) 128 (minus (a b) (- a b))) 129 (list (plus 1 2) (minus 1 2))) 130(3 -1) 131 132(list (flet ((plus (a b) (- a b))) (plus 3 2)) (+ 3 2)) 133(1 5) 134 135(flet ((plus (a b) (plus (plus a b a) b))) (plus 3 2)) 13610 137 138;;Labels 139(labels ((queue (l) (if (car l) (queue (cdr l))'ende))) (queue '(1 2 3))) 140ENDE 141 142(labels ((plus (a b) (* a (plus a a b)))) (plus 1 2 3)) 143ERROR 144 145;;macrolet ? 146 147;; 7.6 148 149;;if 150 151(let ((a t) (b nil)) (list (if a 1 2) (if b 1 2) (if a 1) (if b 1))) 152(1 2 1 nil) 153 154;;when 155(let ((a t) (b nil)) (list (when a 1 2) (when b 1 2) (when a 1))) 156(2 nil 1) 157 158;;unless 159(let ((a t) (b nil)) (list (unless a 1 2) (unless b 1 2) (unless a 1))) 160(nil 2 nil) 161 162;;cond 163(let ((a t) (b 10) (c nil)) 164 (list (cond (a 1) (t 'END)) (cond (b) (t 'END)) (cond (c 1) (t 'END)))) 165(1 10 END) 166 167;;case 168(case (+ 1 2) 169 (1 -1) 170 (2 -2) 171 (3 -3)) 172-3 173 174(case (+ 1 2) 175 (1 -1) 176 (2 -2)) 177nil 178 179;;(case (+ 1 2) 180;; (1 -1) 181;; (2 -2) 182;; (1 -1) 183;; (3 -3)) 184;;ERROR ; because a key may appear only once 185 186(case (+ 1 2) 187 ((1 3) -1) 188 (2 -2) 189 (otherwise 100)) 190-1 191 192;;(case (+ 1 2) 193;; ((1 3) -1) 194;; ((2 1) -2) 195;; (t 100)) 196;;ERROR ; because a key may appear only once 197 198;;typecase 199(typecase (+ 1 2) 200 (list -2) 201 (null -3) 202 (integer -1)) 203-1 204 205;; 7.7 206 207;;block 208(block blocktest (if t (return 0) ) 1) 209error 210 211(block blocktest (if t (return-from blocktest 0) ) 1) 2120 213 214(block blocktest (if nil (return-from blocktest 0) ) 1) 2151 216 217(block blocktest (catch 'catcher 218 (if t (throw 'catcher 0) ) 1)) 2190 220 221;; 7.8 222 223;; 7.8.1 224 225;;loop 226(let ((i 10)) 227 (loop (if (< (decf i) 1) (return i)))) 2280 229 230(let ((i 10)) 231 (catch 'catcher 232 (loop (if (< (decf i) 1) (return i))))) 2330 234 235;; 7.8.2 236 237;;do,do* 238(setf a 0) 2390 240 241(do ((a 1 (+ a 1)) (b a)) 242 ((> a 9) (list b c)) 243 (setf c (+ a b))) 244(0 9) 245 246(do* ((a 1 (+ a 1)) (b a)) 247 ((> a 9) b)) 2481 249 250(let ((a 0)) 251 (do* ((a 1 (+ a 1)) (b a)) 252 ((> a 9) a) (declare (integer a b))) 253 a) 2540 255 256;; 7.8.3 257 258;;dolist 259(let ((l '(1 2 3)) 260 (r 0)) 261 (dolist (x l r) 262 (setf r (+ r x)) )) 2636 264 265;;dolist 266(let ((l '(1 2 3))) 267 (dolist (x l) (if (> 0 x) (incf x) (return 10)))) 26810 269 270(let ((l '(1 2 3))) 271 (dolist (x l ) (incf x))) 272nil 273 274;;dotimes 275(let ((s 0)) 276 (dotimes (i (+ 1 9)s) (setf s (+ s i)))) 27745 278 279;; 7.8.4 280 281;;mapcar 282(mapcar #'abs '(3 -4 2 -5 -6)) 283(3 4 2 5 6) 284 285(mapcar #'cons '(a b c) '(1 2 3)) 286((a . 1) (b . 2) (c . 3)) 287 288;;maplist 289(maplist #'(lambda (x) (cons 'foo x))'(a b c d)) 290((foo a b c d) (foo b c d) (foo c d) (foo d)) 291 292(maplist #'(lambda (x) (if (member (car x) (cdr x)) 0 1)) 293 '(a b a c d b c)) 294(0 0 1 0 1 1 1) 295 296;;mapc 297(mapc #'abs '(3 -4 2 -5 -6)) 298(3 -4 2 -5 -6) 299 300;;mapl 301(mapl #'(lambda (x y) (cons x y))'(a b c d)'(1 2 3 4)) 302(a b c d) 303 304;;mapcan 305(mapcan #'(lambda (x) (and (numberp x) (list x)))'(a 1 b c 3 4 d 5)) 306(1 3 4 5) 307 308;;mapcon 309(mapcon #'(lambda (x) (and (oddp (car x)) (list (car x))))'(5 4 3 2 1)) 310(5 3 1) 311 312;; 7.8.5 313 314;;tagbody 315(let ((a 0)) 316 (tagbody (if nil (go tag0) (go tag1)) 317 (this will never be reached) 318 tag0 319 (setf a 1) 320 tag1 321 (setf a 2)) 322 a) 3232 324 325(let ((a 0)) 326 (tagbody (if t (go tag0) (go tag1)) 327 (this will never be reached) 328 tag0 329 (setf a 1)) 330 a) 331;; CMUCL compiles on the fly and therefore signals an error 332#-(or CMU LISPWORKS) 1 333#+(or CMU LISPWORKS) ERROR 334 335;;prog* 336(let ((z '(1 0))) 337 (prog* ((y z) (x (car y))) 338 (return x))) 3391 340 341(prog (a (b 1)) 342 (if a (go tag0) (go tag1)) 343 (this will never be reached) 344 tag0 345 (setf a 1) 346 (this will never be reached) 347 tag1 348 (setf a 2)) 349nil 350 351(prog (a (b 1)) 352 (if a (return nil) (go tag1)) 353 (this will never be reached) 354 tag0 355 (return (list a 1)) 356 tag1 357 (setf a 2) 358 (go tag0)) 359(2 1) 360 361;; 7.9 362 363;;multiple-value-bind 364(defun adder (x y) (values (+ 1 x) (+ 1 y) ) ) 365adder 366 367(multiple-value-bind (a b) (adder 1 2) (+ a b)) 3685 369 370(defun adder (x y) (values-list (list (+ 1 x) (+ 1 y)))) 371adder 372 373(multiple-value-bind (a b) (adder 1 2) (+ a b)) 3745 375 376(multiple-value-list (floor -3 4)) 377(-1 1) 378 379(multiple-value-call #'+ (floor 5 3) (floor 19 4)) 38010 381 382(multiple-value-bind (c d) 383 (multiple-value-prog1 (floor -3 4) (+ 1 2)) 384 (list c d)) 385(-1 1) 386 387(multiple-value-bind (x) (floor 5 3) (list x)) 388(1) 389 390(multiple-value-bind (x y) (floor 5 3) (list x y)) 391(1 2) 392 393(multiple-value-bind (x y z) (floor 5 3) (list x y z)) 394(1 2 nil) 395 396(multiple-value-setq (a b) (values 10 20)) 39710 398 399b 40020 401 402;; 7.10 403 404;;catch/throw/unwind-protect 405 406;;; https://sourceforge.net/p/clisp/bugs/186/ 407 408(funcall (compile nil (lambda (x) (flet ((z (x) (return-from z x))) (z x)))) 7) 4097 410 411(flet ((z () (return-from z 6))) (z)) 4126 413 414(funcall (compile nil (lambda () (labels ((z () (return-from z 5))) (z))))) 4155 416 417(labels ((z () (return-from z 4))) (z)) 4184 419 420(symbols-cleanup '(plus adder a b)) 421() 422