/[gcl]/gcl/tests/steele7.tst
ViewVC logotype

Diff of /gcl/tests/steele7.tst

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by camm, Thu Dec 20 20:29:54 2001 UTC revision 1.2 by camm, Sun Feb 3 18:44:08 2002 UTC
# Line 0  Line 1 
1    ;;;
2    ;;; testfile nach steele-beispielen
3    ;;;
4    
5    ;7.3
6    
7    
8    (let ((f '+))
9         (apply f '(1 2)))
10    3
11    
12    (let    ((f #'-))
13            (apply f '(1 2)))
14    -1
15    (apply #'max 3 5 '(2 7 3))
16    7
17    
18    (apply 'cons '((+ 2 3) 4))
19    ((+ 2 3) . 4)
20    
21    
22    (apply #'+ '())
23    0
24    
25    (apply #'(lambda (&key a b)(list a b)) '(:b 3))
26    (nil 3)
27    
28    
29    (funcall '+ 2 3)
30    5
31    
32    (let    ((c (symbol-function '+)))
33            (funcall c 1 2 3 4))
34    10
35    
36    
37    ;;abschnitt 7.4
38    
39    ;progn
40    (progn 1 2 3)
41    3
42    
43    (progn (+ 2 1) 2)
44    2
45    
46    (progn 1 2 (values  2 3))
47    2
48    
49    (progn)
50    nil
51    
52    
53    ;prog1
54    (prog1 1 2 3)
55    1
56    
57    (prog1 3 (+ 1 2) 2)
58    3
59    
60    (prog1 (values  2 3) 1 2 )
61    2
62    
63    (let ((x '(a b c)))
64    (prog1 (car x)(rplaca x 'foo)))
65    a
66    
67    ;prog2
68    
69    (prog2 1 2 3)
70    2
71    
72    (prog2  (+ 1 2) 2 3)
73    2
74    
75    (prog2 1 (values  2 3) 4)
76    2
77    
78    ;7.5
79    
80    ;let
81    (setf a 0)
82    0
83    
84    (let ((a 1)(b 2) c )
85         (declare (integer a b))
86         (list a b c))
87    (1 2 nil)
88    
89    
90    (let ((a 1)(b a))
91         (declare (integer a b))
92         (list a b))
93    (1 0)
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    
110    ;progv
111    
112    (progv '(a b c) '(1 2 3)(+ a b c))
113    6
114    
115    (progv '(a b c) '(1 2)(list a b c))
116    error
117    
118    (let ((v '(a b c))
119          (val '(3 2 1)))
120         (progv v val (mapcar #'eval v)))
121    (3 2 1)
122    
123    
124    ;flet
125    
126    (flet ((plus (a b)(+ a b))
127           (minus (a b)(- a b)))
128          (list (plus 1 2)(minus 1 2)))
129    (3 -1)
130    
131    
132    (list (flet ( (+ (a b)(- a b)))(+ 3 2))(+ 3 2))
133    (1 5)
134    
135    (flet ((+ (a b)(+ (+ a b a) b)))(+ 3 2))
136    10
137    
138    ;Labels
139    (labels ((queue (l)(if (car l)(queue (cdr l))'ende)))(queue '(1 2 3)))
140    ENDE
141    
142    (labels ((+ (a b)(* a (+ a a b))))(+ 1 2 3))
143    ERROR
144    
145    ;macrolet ?
146    
147    
148    ;7.6
149    
150    ;if
151    
152    (let ((a t)(b nil))(list (if a 1 2)(if b 1 2)(if a 1)(if b 1)))
153    (1 2 1 nil)
154    
155    
156    ;when
157    (let ((a t)(b nil))(list (when a 1 2)(when b 1 2)(when a 1)))
158    (2 nil 1)
159    
160    
161    ;unless
162    (let ((a t)(b nil))(list (unless a 1 2)(unless b 1 2)(unless a 1)))
163    (nil 2 nil)
164    
165    
166    ;cond
167    (let ((a t)(b 10)(c nil))
168         (list (cond (a 1)(t 'END))(cond (b)(t 'END))(cond (c 1)(t 'END))))
169    (1 10 END)
170    
171    
172    ;case
173    (case (+  1 2)
174          (1 -1)
175          (2 -2)
176          (3 -3))
177    -3
178    
179    (case (+  1 2)
180          (1 -1)
181          (2 -2))
182    nil
183    
184    
185    ;(case (+  1 2)
186    ;      (1 -1)
187    ;      (2 -2)
188    ;      (1 -1)
189    ;      (3 -3))
190    ;ERROR
191    
192    
193    (case (+  1 2)
194          ((1 3) -1)
195          (2 -2)
196          (otherwise 100))
197    -1
198    
199    
200    ;
201    ;(case (+  1 2)
202    ;      ((1 3) -1)
203    ;      ((2 1) -2)
204    ;      (t 100))
205    ;ERROR          ;weil ein key nur einmal erscheinen darf!
206    ;
207    
208    
209    
210    ;typecase
211    
212    (typecase (+  1 2)
213          (list -2)
214          (null -3)
215          (integer -1))
216    -1
217    
218    ;7.7
219    
220    ;block
221    
222    (block blocktest (if t (return 0) ) 1)
223    error
224    
225    (block blocktest (if t (return-from blocktest 0) ) 1)
226    0
227    
228    
229    (block blocktest (if nil (return-from blocktest 0) ) 1)
230    1
231    
232    
233    (block blocktest (catch 'catcher
234                            (if t (throw 'catcher 0) ) 1))
235    0
236    
237    
238    ;7.8
239    
240    ;7.8.1
241    
242    ;loop
243    
244    (let ((i 10))
245    (loop (if (< (decf i) 1)(return i))))
246    0
247    
248    
249    (let ((i 10))
250         (catch 'catcher
251                (loop (if (< (decf i) 1)(return i)))))
252    0
253    
254    ;7.8.2
255    ;do,do*
256    
257    (setf a 0)
258    0
259    
260    
261    (do ((a 1 (+ a 1))(b a))
262        ((> a 9) (list b c))
263        (setf c (+ a b)))
264    (0 9)
265    
266    (do* ((a 1 (+ a 1))(b a))
267        ((> a 9) b)
268        )
269    1
270    
271    (let ((a 0))
272    (do* ((a 1 (+ a 1))(b a))
273        ((> a 9) a)(declare (integer a b)))
274        a)
275    0
276    
277    
278    
279    ;7.8.3
280    
281    
282    ;dolist
283    (let    ((l '(1 2 3))
284             (r 0))
285            (dolist (x l r)
286                    (setf r (+ r  x)) ))
287    6
288    
289    
290    ;dolist
291    (let ((l '(1 2 3)))
292    (dolist (x l)(if (> 0 x)(incf x)(return 10))))
293    10
294    
295    (let ((l '(1 2 3)))
296    (dolist (x l )(incf x)))
297    nil
298    
299    ;dotimes
300    
301    (let ((s 0))
302    (dotimes (i (+ 1 9)s)(setf s (+ s i))))
303    45
304    
305    
306    ;7.8.4
307    
308    
309    ;mapcar
310    
311    (mapcar #'abs '(3 -4 2 -5 -6))
312    (3 4 2 5 6)
313    
314    (mapcar #'cons '(a b c) '(1 2 3))
315    ((a . 1) (b . 2) (c . 3))
316    
317    
318    ;maplist
319    
320    (maplist #'(lambda (x)(cons 'foo x))'(a b c d))
321    ((foo a b c d)(foo b c d)(foo c d)(foo d))
322    
323    
324    (maplist #'(lambda (x) (if (member (car x)(cdr x)) 0 1))
325             '(a b a c d b c))
326    (0 0 1 0 1 1 1)
327    
328    
329    ;mapc
330    (mapc #'abs '(3 -4 2 -5 -6))
331    (3 -4 2 -5 -6)
332    
333    ;mapc
334    
335    (mapl #'(lambda (x y)(cons x y))'(a b c d)'(1 2 3 4))
336    (a b c d)
337    
338    ;mapcan
339    
340    (mapcan #'(lambda (x)(and (numberp x)(list x)))'(a 1 b c 3 4 d 5))
341    (1 3 4 5)
342    
343    ;mapcon
344    
345    (mapcon #'(lambda (x)(and (oddp (car x))(list (car x))))'(5 4 3 2 1))
346    (5 3 1)
347    
348    ;7.8.5
349    
350    ;tagbody
351    (let ((a 0))
352    (tagbody (if nil (go tag0) (go tag1))
353             (this will never be reached)
354             tag0
355             (setf a 1)
356             tag1
357             (setf a 2))a)
358    2
359    
360    
361    (let ((a 0))
362    (tagbody (if t (go tag0) (go tag1))
363             (this will never be reached)
364             tag0
365             (setf a 1)
366             )a)
367    1
368    
369    
370    
371    
372    ;prog*
373    
374    (let ((z '(1 0)))
375         (prog* ((y z)(x (car y)))
376                (return x)))
377    1
378    (prog  (a (b 1))
379             (if a (go tag0) (go tag1))
380             (this will never be reached)
381             tag0
382             (setf a 1)
383             (this will never be reached)
384             tag1
385             (setf a 2))
386    nil
387    
388    
389    
390    (prog  (a (b 1))
391             (if a (return nil) (go tag1))
392             (this will never be reached)
393             tag0
394             (return (list a 1))
395             tag1
396             (setf a 2)
397             (go tag0))
398    (2 1)
399    
400    
401    ;7.9
402    
403    ;multiple-value-bind
404    (defun adder (x y)(values (+ 1 x)(+ 1 y) ) )
405    adder
406    
407    
408    (multiple-value-bind (a b)(adder 1 2)(+ a b))
409    5
410    
411    (defun adder (x y)(values-list (list  (+ 1 x)(+ 1 y))))
412    adder
413    
414    
415    (multiple-value-bind (a b)(adder 1 2)(+ a b))
416    5
417    
418    
419    (multiple-value-list (floor -3 4))
420    (-1 1)
421    
422    
423    (multiple-value-call #'+ (floor 5 3)(floor 19 4))
424    10
425    
426    (multiple-value-bind (c d)
427                         (multiple-value-prog1 (floor -3 4) (+ 1 2))
428                         (list c d))
429    (-1 1)
430    
431    
432    (multiple-value-bind (x)(floor 5 3)(list x))
433    (1)
434    
435    
436    (multiple-value-bind (x y)(floor 5 3)(list x y))
437    (1 2)
438    
439    
440    (multiple-value-bind (x y z)(floor 5 3)(list x y z))
441    (1 2 nil)
442    
443    
444    
445    
446    (multiple-value-setq (a b) (values 10 20))
447    10
448    
449    b
450    20
451    
452    
453    ;7.10
454    
455    ;catch/throw/unwind-protect
456    

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26