Commit | Line | Data |
---|---|---|
025f75b4 MV |
1 | ;;;; optargs.test --- test suite for optional arg processing -*- scheme -*- |
2 | ;;;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de> --- June 2001 | |
3 | ;;;; | |
581f410f | 4 | ;;;; Copyright (C) 2001, 2006, 2009, 2010, 2013 Free Software Foundation, Inc. |
025f75b4 | 5 | ;;;; |
53befeb7 NJ |
6 | ;;;; This library is free software; you can redistribute it and/or |
7 | ;;;; modify it under the terms of the GNU Lesser General Public | |
8 | ;;;; License as published by the Free Software Foundation; either | |
9 | ;;;; version 3 of the License, or (at your option) any later version. | |
025f75b4 | 10 | ;;;; |
53befeb7 | 11 | ;;;; This library is distributed in the hope that it will be useful, |
025f75b4 | 12 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
53befeb7 NJ |
13 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
14 | ;;;; Lesser General Public License for more details. | |
025f75b4 | 15 | ;;;; |
53befeb7 NJ |
16 | ;;;; You should have received a copy of the GNU Lesser General Public |
17 | ;;;; License along with this library; if not, write to the Free Software | |
18 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
025f75b4 | 19 | |
560434b3 | 20 | (define-module (test-suite test-optargs) |
7ab42fa2 AW |
21 | #:use-module (test-suite lib) |
22 | #:use-module (system base compile) | |
23 | #:use-module (ice-9 optargs)) | |
24 | ||
581f410f AW |
25 | (define exception:invalid-keyword |
26 | '(keyword-argument-error . "Invalid keyword")) | |
27 | ||
ee2a69f5 | 28 | (define exception:unrecognized-keyword |
f6a8e791 | 29 | '(keyword-argument-error . "Unrecognized keyword")) |
ee2a69f5 LC |
30 | |
31 | (define exception:extraneous-arguments | |
f6a8e791 AW |
32 | ;; Message depends on whether we use the interpreter or VM, and on the |
33 | ;; evenness of the number of extra arguments (!). | |
34 | ;'(keyword-argument-error . ".*") | |
35 | '(#t . ".*")) | |
ee2a69f5 | 36 | |
7ab42fa2 | 37 | (with-test-prefix/c&e "optional argument processing" |
025f75b4 | 38 | (pass-if "local defines work with optional arguments" |
560434b3 DH |
39 | (eval '(begin |
40 | (define* (test-1 #:optional (x 0)) | |
41 | (define d 1) ; local define | |
42 | #t) | |
43 | (false-if-exception (test-1))) | |
44 | (interaction-environment)))) | |
927a122d KR |
45 | |
46 | ;;; | |
47 | ;;; let-keywords | |
48 | ;;; | |
49 | ||
7ab42fa2 | 50 | (with-test-prefix/c&e "let-keywords" |
927a122d KR |
51 | |
52 | ;; in guile 1.6.4 and earlier, an empty binding list only used `begin', | |
53 | ;; which caused apparently internal defines to "leak" out into the | |
54 | ;; encompasing environment | |
55 | (pass-if-exception "empty bindings internal defines leaking out" | |
56 | exception:unbound-var | |
57 | (let ((rest '())) | |
58 | (let-keywords rest #f () | |
59 | (define localvar #f) | |
60 | #f) | |
61 | localvar)) | |
62 | ||
63 | (pass-if "one key" | |
64 | (let-keywords '(#:foo 123) #f (foo) | |
65 | (= foo 123)))) | |
66 | ||
67 | ;;; | |
68 | ;;; let-keywords* | |
69 | ;;; | |
70 | ||
7ab42fa2 | 71 | (with-test-prefix/c&e "let-keywords*" |
927a122d KR |
72 | |
73 | ;; in guile 1.6.4 and earlier, an empty binding list only used `begin', | |
74 | ;; which caused apparently internal defines to "leak" out into the | |
75 | ;; encompasing environment | |
76 | (pass-if-exception "empty bindings internal defines leaking out" | |
77 | exception:unbound-var | |
78 | (let ((rest '())) | |
79 | (let-keywords* rest #f () | |
80 | (define localvar #f) | |
81 | #f) | |
82 | localvar)) | |
83 | ||
84 | (pass-if "one key" | |
85 | (let-keywords* '(#:foo 123) #f (foo) | |
86 | (= foo 123)))) | |
87 | ||
88 | ;;; | |
89 | ;;; let-optional | |
90 | ;;; | |
91 | ||
7ab42fa2 | 92 | (with-test-prefix/c&e "let-optional" |
927a122d KR |
93 | |
94 | ;; in guile 1.6.4 and earlier, an empty binding list only used `begin', | |
95 | ;; which caused apparently internal defines to "leak" out into the | |
96 | ;; encompasing environment | |
97 | (pass-if-exception "empty bindings internal defines leaking out" | |
98 | exception:unbound-var | |
99 | (let ((rest '())) | |
100 | (let-optional rest () | |
101 | (define localvar #f) | |
102 | #f) | |
103 | localvar)) | |
104 | ||
105 | (pass-if "one var" | |
106 | (let ((rest '(123))) | |
107 | (let-optional rest ((foo 999)) | |
108 | (= foo 123))))) | |
109 | ||
110 | ;;; | |
111 | ;;; let-optional* | |
112 | ;;; | |
113 | ||
7ab42fa2 | 114 | (with-test-prefix/c&e "let-optional*" |
927a122d KR |
115 | |
116 | ;; in guile 1.6.4 and earlier, an empty binding list only used `begin', | |
117 | ;; which caused apparently internal defines to "leak" out into the | |
118 | ;; encompasing environment | |
119 | (pass-if-exception "empty bindings internal defines leaking out" | |
120 | exception:unbound-var | |
121 | (let ((rest '())) | |
122 | (let-optional* rest () | |
123 | (define localvar #f) | |
124 | #f) | |
125 | localvar)) | |
126 | ||
127 | (pass-if "one var" | |
128 | (let ((rest '(123))) | |
129 | (let-optional* rest ((foo 999)) | |
130 | (= foo 123))))) | |
7ab42fa2 AW |
131 | |
132 | (define* (foo a b #:optional c (d 1) (e c) f #:key g (h a) (i r) #:rest r) | |
133 | (list a b c d e f g h i r)) | |
134 | ||
135 | ;; So we could use lots more tests here, but the fact that lambda* is in | |
136 | ;; the compiler, and the compiler compiles itself, using the evaluator | |
137 | ;; (when bootstrapping) and compiled code (when doing a partial rebuild) | |
138 | ;; makes me a bit complacent. | |
139 | (with-test-prefix/c&e "define*" | |
140 | (pass-if "the whole enchilada" | |
141 | (equal? (foo 1 2) | |
ee2a69f5 LC |
142 | '(1 2 #f 1 #f #f #f 1 () ()))) |
143 | ||
144 | (pass-if-exception "extraneous arguments" | |
145 | exception:extraneous-arguments | |
146 | (let ((f (lambda* (#:key x) x))) | |
147 | (f 1 2 #:x 'x))) | |
148 | ||
4af0d97e LC |
149 | (pass-if-equal "unrecognized keyword" '(#:y) |
150 | (catch 'keyword-argument-error | |
151 | (lambda () | |
152 | (let ((f (lambda* (#:key x) x))) | |
153 | (f #:y 'not-recognized))) | |
154 | (lambda (key proc fmt args data) | |
155 | data))) | |
156 | ||
157 | (pass-if-equal "invalid keyword" '(not-a-keyword) | |
158 | (catch 'keyword-argument-error | |
159 | (lambda () | |
160 | (let ((f (lambda* (#:key x) x))) | |
161 | (f 'not-a-keyword 'something))) | |
162 | (lambda (key proc fmt args data) | |
163 | data))) | |
ee2a69f5 LC |
164 | |
165 | (pass-if "rest given before keywords" | |
166 | ;; Passing the rest argument before the keyword arguments should not | |
167 | ;; prevent keyword argument binding. | |
168 | (let ((f (lambda* (#:key x y z #:rest r) (list x y z r)))) | |
169 | (equal? (f 1 2 3 #:x 'x #:z 'z) | |
170 | '(x #f z (1 2 3 #:x x #:z z)))))) | |
aac006dd | 171 | |
79a9a2c2 LC |
172 | (with-test-prefix "scm_c_bind_keyword_arguments" |
173 | ||
174 | (pass-if-equal "unrecognized keyword" '(#:y) | |
175 | (catch 'keyword-argument-error | |
176 | (lambda () | |
177 | (open-file "/dev/null" "r" #:y 'not-recognized)) | |
178 | (lambda (key proc fmt args data) | |
179 | data))) | |
180 | ||
181 | (pass-if-equal "invalid keyword" '(not-a-keyword) | |
182 | (catch 'keyword-argument-error | |
183 | (lambda () | |
184 | (open-file "/dev/null" "r" 'not-a-keyword 'something)) | |
185 | (lambda (key proc fmt args data) | |
186 | data)))) | |
187 | ||
a310a1d1 | 188 | (with-test-prefix/c&e "lambda* inits" |
9a9d82c2 AW |
189 | (pass-if "can bind lexicals within inits" |
190 | (begin | |
d8a071fc AW |
191 | (define qux |
192 | (lambda* (#:optional a #:key (b (or a 13) #:a)) | |
193 | b)) | |
9a9d82c2 AW |
194 | #t)) |
195 | (pass-if "testing qux" | |
196 | (and (equal? (qux) 13) | |
197 | (equal? (qux 1) 1) | |
84b67e19 AW |
198 | (equal? (qux #:a 2) 2))) |
199 | (pass-if "nested lambda* with optional" | |
200 | (begin | |
201 | (define (foo x) | |
202 | (define baz x) | |
203 | (define* (bar #:optional (y baz)) | |
204 | (or (zero? y) (bar (1- y)))) | |
205 | (bar)) | |
206 | (foo 10))) | |
207 | (pass-if "nested lambda* with key" | |
208 | (begin | |
209 | (define (foo x) | |
210 | (define baz x) | |
211 | (define* (bar #:key (y baz)) | |
212 | (or (zero? y) (bar #:y (1- y)))) | |
213 | (bar)) | |
214 | (foo 10)))) | |
215 | ||
9a9d82c2 | 216 | |
aac006dd AW |
217 | (with-test-prefix/c&e "defmacro*" |
218 | (pass-if "definition" | |
219 | (begin | |
220 | (defmacro* transmogrify (a #:optional (b 10)) | |
221 | `(,a ,b)) | |
222 | #t)) | |
223 | ||
224 | (pass-if "explicit arg" | |
225 | (equal? (transmogrify quote 5) | |
226 | 5)) | |
227 | ||
228 | (pass-if "default arg" | |
229 | (equal? (transmogrify quote) | |
230 | 10))) | |
581f410f | 231 | |
19113f1c AW |
232 | (with-test-prefix/c&e "case-lambda" |
233 | (pass-if-exception "no clauses, no args" exception:wrong-num-args | |
234 | ((case-lambda))) | |
235 | ||
236 | (pass-if-exception "no clauses, args" exception:wrong-num-args | |
0426b3f8 MW |
237 | ((case-lambda) 1)) |
238 | ||
239 | (pass-if "docstring" | |
240 | (equal? "docstring test" | |
241 | (procedure-documentation | |
242 | (case-lambda | |
243 | "docstring test" | |
244 | (() 0) | |
245 | ((x) 1)))))) | |
19113f1c | 246 | |
581f410f | 247 | (with-test-prefix/c&e "case-lambda*" |
19113f1c AW |
248 | (pass-if-exception "no clauses, no args" exception:wrong-num-args |
249 | ((case-lambda*))) | |
250 | ||
251 | (pass-if-exception "no clauses, args" exception:wrong-num-args | |
252 | ((case-lambda*) 1)) | |
253 | ||
0426b3f8 MW |
254 | (pass-if "docstring" |
255 | (equal? "docstring test" | |
256 | (procedure-documentation | |
257 | (case-lambda* | |
258 | "docstring test" | |
259 | (() 0) | |
260 | ((x) 1))))) | |
261 | ||
581f410f AW |
262 | (pass-if "unambiguous" |
263 | ((case-lambda* | |
264 | ((a b) #t) | |
265 | ((a) #f)) | |
266 | 1 2)) | |
267 | ||
268 | (pass-if "unambiguous (reversed)" | |
269 | ((case-lambda* | |
270 | ((a) #f) | |
271 | ((a b) #t)) | |
272 | 1 2)) | |
273 | ||
274 | (pass-if "optionals (order disambiguates)" | |
275 | ((case-lambda* | |
276 | ((a #:optional b) #t) | |
277 | ((a b) #f)) | |
278 | 1 2)) | |
279 | ||
280 | (pass-if "optionals (order disambiguates (2))" | |
281 | ((case-lambda* | |
282 | ((a b) #t) | |
283 | ((a #:optional b) #f)) | |
284 | 1 2)) | |
285 | ||
286 | (pass-if "optionals (one arg)" | |
287 | ((case-lambda* | |
288 | ((a b) #f) | |
289 | ((a #:optional b) #t)) | |
290 | 1)) | |
291 | ||
292 | (pass-if "optionals (one arg (2))" | |
293 | ((case-lambda* | |
294 | ((a #:optional b) #t) | |
295 | ((a b) #f)) | |
296 | 1)) | |
297 | ||
298 | (pass-if "keywords without keyword" | |
299 | ((case-lambda* | |
300 | ((a #:key c) #t) | |
301 | ((a b) #f)) | |
302 | 1)) | |
303 | ||
304 | (pass-if "keywords with keyword" | |
305 | ((case-lambda* | |
306 | ((a #:key c) #t) | |
307 | ((a b) #f)) | |
308 | 1 #:c 2)) | |
309 | ||
310 | (pass-if "keywords (too many positionals)" | |
311 | ((case-lambda* | |
312 | ((a #:key c) #f) | |
313 | ((a b) #t)) | |
314 | 1 2)) | |
315 | ||
316 | (pass-if "keywords (order disambiguates)" | |
317 | ((case-lambda* | |
318 | ((a #:key c) #t) | |
319 | ((a b c) #f)) | |
320 | 1 #:c 2)) | |
321 | ||
322 | (pass-if "keywords (order disambiguates (2))" | |
323 | ((case-lambda* | |
324 | ((a b c) #t) | |
325 | ((a #:key c) #f)) | |
326 | 1 #:c 2))) |