source: trunk/source/tests/ansi-tests/case.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 11 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 3.5 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Fri Oct 18 19:56:44 2002
4;;;; Contains: Tests of CASE
5
6(in-package :cl-test)
7
8(deftest case.1
9  (case 'a)
10  nil)
11
12(deftest case.2
13  (case 10 (10 'a))
14  a)
15
16(deftest case.3
17  (case (copy-seq "abc") ("abc" 'a))
18  nil)
19
20(deftest case.4
21  (case 'z ((a b c) 1)
22           ((d e) 2)
23           ((f z g) 3)
24           (t 4))
25  3)
26
27(deftest case.5
28  (case (1+ most-positive-fixnum)
29    (#.(1+ most-positive-fixnum) 'a))
30  a)
31
32(deftest case.6
33  (case nil (nil 'a) (t 'b))
34  b)
35
36(deftest case.7
37  (case nil ((nil) 'a) (t 'b))
38  a)
39
40(deftest case.8
41  (case 'a (b 0) (a (values 1 2 3)) (t nil))
42  1 2 3)
43
44(deftest case.9
45  (case 'c (b 0) (a (values 1 2 3)) (t (values 'x 'y 'z)))
46  x y z)
47
48(deftest case.10
49  (case 'z (b 1) (a 2) (z (values)) (t nil)))
50
51(deftest case.11
52  (case 'z (b 1) (a 2) (t (values))))
53
54(deftest case.12
55  (case t (a 10))
56  nil)
57
58(deftest case.13
59  (case t ((t) 10) (t 20))
60  10)
61
62(deftest case.14
63  (let ((x (list 'a 'b)))
64    (eval `(case (quote ,x) ((,x) 1) (t 2))))
65  1)
66
67(deftest case.15
68  (case 'otherwise ((t) 10))
69  nil)
70
71(deftest case.16
72  (case t ((otherwise) 10))
73  nil)
74
75(deftest case.17
76  (case 'a (b 0) (c 1) (otherwise 2))
77  2)
78
79(deftest case.18
80  (case 'a (b 0) (c 1) ((otherwise) 2))
81  nil)
82
83(deftest case.19
84  (case 'a (b 0) (c 1) ((t) 2))
85  nil)
86
87(deftest case.20
88  (case #\a
89    ((#\b #\c) 10)
90    ((#\d #\e #\A) 20)
91    (() 30)
92    ((#\z #\a #\y) 40))
93  40)
94
95(deftest case.21 (case 1 (1 (values))))
96
97(deftest case.22 (case 2 (t (values))))
98
99(deftest case.23 (case 1 (1 (values 'a 'b 'c)))
100  a b c)
101
102(deftest case.24 (case 2 (t (values 'a 'b 'c)))
103  a b c)
104
105;;; Show that the key expression is evaluated only once.
106(deftest case.25
107  (let ((x 0))
108    (values
109     (case (progn (incf x) 'c)
110       (a 1)
111       (b 2)
112       (c 3)
113       (t 4))
114     x))
115  3 1)
116
117;;; Repeated keys are allowed (all but the first are ignored)
118
119(deftest case.26
120  (case 'b ((a b c) 10) (b 20))
121  10)
122
123(deftest case.27
124  (case 'b (b 20) ((a b c) 10))
125  20)
126
127(deftest case.28
128  (case 'b (b 20) (b 10) (t 0))
129  20)
130
131;;; There are implicit progns
132
133(deftest case.29
134  (let ((x nil))
135    (values
136     (case 2
137       (1 (setq x 'a) 'w)
138       (2 (setq x 'b) 'y)
139       (t (setq x 'c) 'z))
140     x))
141  y b)
142
143(deftest case.30
144  (let ((x nil))
145    (values
146     (case 10
147       (1 (setq x 'a) 'w)
148       (2 (setq x 'b) 'y)
149       (t (setq x 'c) 'z))
150     x))
151  z c)
152
153(deftest case.31
154  (case (values 'b 'c) (c 0) ((a b) 10) (t 20))
155  10)
156
157(deftest case.32
158  (case 'a (a) (t 'b))
159  nil)
160
161(deftest case.33
162  (case 'a (b 'b) (t))
163  nil)
164
165(deftest case.34
166  (case 'a (b 'b) (otherwise))
167  nil)
168
169;;; No implicit tagbody
170(deftest case.35
171  (block done
172    (tagbody
173     (case 'a (a (go 10)
174                 10
175                 (return-from done 'bad)))
176     10
177     (return-from done 'good)))
178  good)
179
180(deftest case.36
181  (block done
182    (tagbody
183     (case 'b
184       (a 'bad)
185       (otherwise (go 10)
186                  10
187                  (return-from done 'bad)))
188     10
189     (return-from done 'good)))
190  good)
191
192;;; Test that explicit calls to macroexpand in subforms
193;;; are done in the correct environment
194
195(deftest case.37
196  (macrolet
197   ((%m (z) z))
198   (case (expand-in-current-env (%m :b))
199         (:a :bad1)
200         (:b :good)
201         (:c :bad2)
202         (t :bad3)))
203  :good)
204
205;;; (deftest case.error.1
206;;;  (signals-error (case) program-error)
207;;;  t)
208
209(deftest case.error.1
210  (signals-error (funcall (macro-function 'case))
211                 program-error)
212  t)
213
214(deftest case.error.2
215  (signals-error (funcall (macro-function 'case) '(case t))
216                 program-error)
217  t)
218
219(deftest case.error.3
220  (signals-error (funcall (macro-function 'case) '(case t) nil nil)
221                 program-error)
222  t)
Note: See TracBrowser for help on using the repository browser.