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