Commit | Line | Data |
---|---|---|
ce09ee19 AW |
1 | ;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*- |
2 | ;;;; Andy Wingo <wingo@pobox.com> --- May 2009 | |
3 | ;;;; | |
a4060f67 LC |
4 | ;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc. |
5 | ;;;; | |
ce09ee19 AW |
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 | |
53befeb7 | 9 | ;;;; version 3 of the License, or (at your option) any later version. |
a4060f67 | 10 | ;;;; |
ce09ee19 AW |
11 | ;;;; This library is distributed in the hope that it will be useful, |
12 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
14 | ;;;; Lesser General Public License for more details. | |
a4060f67 | 15 | ;;;; |
ce09ee19 AW |
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 | |
19 | ||
20 | (define-module (test-suite tree-il) | |
21 | #:use-module (test-suite lib) | |
22 | #:use-module (system base compile) | |
23 | #:use-module (system base pmatch) | |
4b856371 | 24 | #:use-module (system base message) |
ce09ee19 | 25 | #:use-module (language tree-il) |
4b856371 LC |
26 | #:use-module (language glil) |
27 | #:use-module (srfi srfi-13)) | |
ce09ee19 | 28 | |
e0c90f90 AW |
29 | ;; Of course, the GLIL that is emitted depends on the source info of the |
30 | ;; input. Here we're not concerned about that, so we strip source | |
31 | ;; information from the incoming tree-il. | |
32 | ||
33 | (define (strip-source x) | |
34 | (post-order! (lambda (x) (set! (tree-il-src x) #f)) | |
35 | x)) | |
36 | ||
ce09ee19 AW |
37 | (define-syntax assert-scheme->glil |
38 | (syntax-rules () | |
39 | ((_ in out) | |
e0c90f90 AW |
40 | (let ((tree-il (strip-source |
41 | (compile 'in #:from 'scheme #:to 'tree-il)))) | |
ce09ee19 AW |
42 | (pass-if 'in |
43 | (equal? (unparse-glil (compile tree-il #:from 'tree-il #:to 'glil)) | |
44 | 'out)))))) | |
45 | ||
46 | (define-syntax assert-tree-il->glil | |
ce09ee19 AW |
47 | (syntax-rules () |
48 | ((_ in pat test ...) | |
49 | (let ((exp 'in)) | |
50 | (pass-if 'in | |
51 | (let ((glil (unparse-glil | |
e0c90f90 | 52 | (compile (strip-source (parse-tree-il exp)) |
ce09ee19 AW |
53 | #:from 'tree-il #:to 'glil)))) |
54 | (pmatch glil | |
55 | (pat (guard test ...) #t) | |
56 | (else #f)))))))) | |
57 | ||
335c8a89 AW |
58 | (define-syntax pass-if-tree-il->scheme |
59 | (syntax-rules () | |
60 | ((_ in pat) | |
61 | (assert-scheme->tree-il->scheme in pat #t)) | |
62 | ((_ in pat guard-exp) | |
63 | (pass-if 'in | |
64 | (pmatch (tree-il->scheme | |
65 | (compile 'in #:from 'scheme #:to 'tree-il)) | |
66 | (pat (guard guard-exp) #t) | |
67 | (_ #f)))))) | |
68 | ||
69 | (with-test-prefix "tree-il->scheme" | |
70 | (pass-if-tree-il->scheme | |
71 | (case-lambda ((a) a) ((b c) (list b c))) | |
72 | (case-lambda ((,a) ,a1) ((,b ,c) (list ,b1 ,c1))) | |
73 | (and (eq? a a1) (eq? b b1) (eq? c c1)))) | |
74 | ||
ce09ee19 AW |
75 | (with-test-prefix "void" |
76 | (assert-tree-il->glil | |
77 | (void) | |
8a4ca0ea | 78 | (program () (std-prelude 0 0 #f) (label _) (void) (call return 1))) |
ce09ee19 AW |
79 | (assert-tree-il->glil |
80 | (begin (void) (const 1)) | |
8a4ca0ea | 81 | (program () (std-prelude 0 0 #f) (label _) (const 1) (call return 1))) |
ce09ee19 AW |
82 | (assert-tree-il->glil |
83 | (apply (primitive +) (void) (const 1)) | |
8a4ca0ea | 84 | (program () (std-prelude 0 0 #f) (label _) (void) (call add1 1) (call return 1)))) |
ce09ee19 AW |
85 | |
86 | (with-test-prefix "application" | |
87 | (assert-tree-il->glil | |
88 | (apply (toplevel foo) (const 1)) | |
a5bbb22e | 89 | (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (const 1) (call tail-call 1))) |
8a4ca0ea | 90 | (assert-tree-il->glil |
ce09ee19 | 91 | (begin (apply (toplevel foo) (const 1)) (void)) |
8a4ca0ea | 92 | (program () (std-prelude 0 0 #f) (label _) (call new-frame 0) (toplevel ref foo) (const 1) (mv-call 1 ,l1) |
0f423f20 | 93 | (call drop 1) (branch br ,l2) |
05c51bcf | 94 | (label ,l3) (mv-bind 0 #f) |
0f423f20 | 95 | (label ,l4) |
30a5e062 | 96 | (void) (call return 1)) |
0f423f20 | 97 | (and (eq? l1 l3) (eq? l2 l4))) |
ce09ee19 AW |
98 | (assert-tree-il->glil |
99 | (apply (toplevel foo) (apply (toplevel bar))) | |
8a4ca0ea | 100 | (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call new-frame 0) (toplevel ref bar) (call call 0) |
a5bbb22e | 101 | (call tail-call 1)))) |
ce09ee19 AW |
102 | |
103 | (with-test-prefix "conditional" | |
8a4ca0ea | 104 | (assert-tree-il->glil |
0e4b7818 AW |
105 | (if (toplevel foo) (const 1) (const 2)) |
106 | (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1) | |
ce09ee19 AW |
107 | (const 1) (call return 1) |
108 | (label ,l2) (const 2) (call return 1)) | |
109 | (eq? l1 l2)) | |
110 | ||
8a4ca0ea | 111 | (assert-tree-il->glil |
0e4b7818 AW |
112 | (begin (if (toplevel foo) (const 1) (const 2)) (const #f)) |
113 | (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1) (branch br ,l2) | |
ce09ee19 AW |
114 | (label ,l3) (label ,l4) (const #f) (call return 1)) |
115 | (eq? l1 l3) (eq? l2 l4)) | |
116 | ||
8a4ca0ea | 117 | (assert-tree-il->glil |
0e4b7818 AW |
118 | (apply (primitive null?) (if (toplevel foo) (const 1) (const 2))) |
119 | (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1) | |
ce09ee19 AW |
120 | (const 1) (branch br ,l2) |
121 | (label ,l3) (const 2) (label ,l4) | |
122 | (call null? 1) (call return 1)) | |
123 | (eq? l1 l3) (eq? l2 l4))) | |
124 | ||
125 | (with-test-prefix "primitive-ref" | |
126 | (assert-tree-il->glil | |
127 | (primitive +) | |
8a4ca0ea | 128 | (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call return 1))) |
ce09ee19 AW |
129 | |
130 | (assert-tree-il->glil | |
131 | (begin (primitive +) (const #f)) | |
8a4ca0ea | 132 | (program () (std-prelude 0 0 #f) (label _) (const #f) (call return 1))) |
ce09ee19 AW |
133 | |
134 | (assert-tree-il->glil | |
135 | (apply (primitive null?) (primitive +)) | |
8a4ca0ea | 136 | (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call null? 1) |
ce09ee19 AW |
137 | (call return 1)))) |
138 | ||
139 | (with-test-prefix "lexical refs" | |
140 | (assert-tree-il->glil | |
141 | (let (x) (y) ((const 1)) (lexical x y)) | |
8a4ca0ea | 142 | (program () (std-prelude 0 1 #f) (label _) |
66d3e9a3 AW |
143 | (const 1) (bind (x #f 0)) (lexical #t #f set 0) |
144 | (lexical #t #f ref 0) (call return 1) | |
ce09ee19 AW |
145 | (unbind))) |
146 | ||
147 | (assert-tree-il->glil | |
148 | (let (x) (y) ((const 1)) (begin (lexical x y) (const #f))) | |
8a4ca0ea | 149 | (program () (std-prelude 0 1 #f) (label _) |
66d3e9a3 | 150 | (const 1) (bind (x #f 0)) (lexical #t #f set 0) |
ce09ee19 AW |
151 | (const #f) (call return 1) |
152 | (unbind))) | |
153 | ||
154 | (assert-tree-il->glil | |
155 | (let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y))) | |
8a4ca0ea | 156 | (program () (std-prelude 0 1 #f) (label _) |
66d3e9a3 AW |
157 | (const 1) (bind (x #f 0)) (lexical #t #f set 0) |
158 | (lexical #t #f ref 0) (call null? 1) (call return 1) | |
ce09ee19 AW |
159 | (unbind)))) |
160 | ||
161 | (with-test-prefix "lexical sets" | |
162 | (assert-tree-il->glil | |
aaae0d5a AW |
163 | ;; unreferenced sets may be optimized away -- make sure they are ref'd |
164 | (let (x) (y) ((const 1)) | |
165 | (set! (lexical x y) (apply (primitive 1+) (lexical x y)))) | |
8a4ca0ea | 166 | (program () (std-prelude 0 1 #f) (label _) |
66d3e9a3 | 167 | (const 1) (bind (x #t 0)) (lexical #t #t box 0) |
aaae0d5a AW |
168 | (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) |
169 | (void) (call return 1) | |
ce09ee19 AW |
170 | (unbind))) |
171 | ||
172 | (assert-tree-il->glil | |
aaae0d5a AW |
173 | (let (x) (y) ((const 1)) |
174 | (begin (set! (lexical x y) (apply (primitive 1+) (lexical x y))) | |
175 | (lexical x y))) | |
8a4ca0ea | 176 | (program () (std-prelude 0 1 #f) (label _) |
66d3e9a3 | 177 | (const 1) (bind (x #t 0)) (lexical #t #t box 0) |
aaae0d5a AW |
178 | (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) |
179 | (lexical #t #t ref 0) (call return 1) | |
ce09ee19 AW |
180 | (unbind))) |
181 | ||
182 | (assert-tree-il->glil | |
183 | (let (x) (y) ((const 1)) | |
aaae0d5a AW |
184 | (apply (primitive null?) |
185 | (set! (lexical x y) (apply (primitive 1+) (lexical x y))))) | |
8a4ca0ea | 186 | (program () (std-prelude 0 1 #f) (label _) |
66d3e9a3 | 187 | (const 1) (bind (x #t 0)) (lexical #t #t box 0) |
aaae0d5a AW |
188 | (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (void) |
189 | (call null? 1) (call return 1) | |
ce09ee19 AW |
190 | (unbind)))) |
191 | ||
192 | (with-test-prefix "module refs" | |
193 | (assert-tree-il->glil | |
194 | (@ (foo) bar) | |
8a4ca0ea | 195 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
196 | (module public ref (foo) bar) |
197 | (call return 1))) | |
198 | ||
199 | (assert-tree-il->glil | |
200 | (begin (@ (foo) bar) (const #f)) | |
8a4ca0ea | 201 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
202 | (module public ref (foo) bar) (call drop 1) |
203 | (const #f) (call return 1))) | |
204 | ||
205 | (assert-tree-il->glil | |
206 | (apply (primitive null?) (@ (foo) bar)) | |
8a4ca0ea | 207 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
208 | (module public ref (foo) bar) |
209 | (call null? 1) (call return 1))) | |
210 | ||
211 | (assert-tree-il->glil | |
212 | (@@ (foo) bar) | |
8a4ca0ea | 213 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
214 | (module private ref (foo) bar) |
215 | (call return 1))) | |
216 | ||
217 | (assert-tree-il->glil | |
218 | (begin (@@ (foo) bar) (const #f)) | |
8a4ca0ea | 219 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
220 | (module private ref (foo) bar) (call drop 1) |
221 | (const #f) (call return 1))) | |
222 | ||
223 | (assert-tree-il->glil | |
224 | (apply (primitive null?) (@@ (foo) bar)) | |
8a4ca0ea | 225 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
226 | (module private ref (foo) bar) |
227 | (call null? 1) (call return 1)))) | |
228 | ||
229 | (with-test-prefix "module sets" | |
230 | (assert-tree-il->glil | |
231 | (set! (@ (foo) bar) (const 2)) | |
8a4ca0ea | 232 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
233 | (const 2) (module public set (foo) bar) |
234 | (void) (call return 1))) | |
235 | ||
236 | (assert-tree-il->glil | |
237 | (begin (set! (@ (foo) bar) (const 2)) (const #f)) | |
8a4ca0ea | 238 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
239 | (const 2) (module public set (foo) bar) |
240 | (const #f) (call return 1))) | |
241 | ||
242 | (assert-tree-il->glil | |
243 | (apply (primitive null?) (set! (@ (foo) bar) (const 2))) | |
8a4ca0ea | 244 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
245 | (const 2) (module public set (foo) bar) |
246 | (void) (call null? 1) (call return 1))) | |
247 | ||
248 | (assert-tree-il->glil | |
249 | (set! (@@ (foo) bar) (const 2)) | |
8a4ca0ea | 250 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
251 | (const 2) (module private set (foo) bar) |
252 | (void) (call return 1))) | |
253 | ||
254 | (assert-tree-il->glil | |
255 | (begin (set! (@@ (foo) bar) (const 2)) (const #f)) | |
8a4ca0ea | 256 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
257 | (const 2) (module private set (foo) bar) |
258 | (const #f) (call return 1))) | |
259 | ||
260 | (assert-tree-il->glil | |
261 | (apply (primitive null?) (set! (@@ (foo) bar) (const 2))) | |
8a4ca0ea | 262 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
263 | (const 2) (module private set (foo) bar) |
264 | (void) (call null? 1) (call return 1)))) | |
265 | ||
266 | (with-test-prefix "toplevel refs" | |
267 | (assert-tree-il->glil | |
268 | (toplevel bar) | |
8a4ca0ea | 269 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
270 | (toplevel ref bar) |
271 | (call return 1))) | |
272 | ||
273 | (assert-tree-il->glil | |
274 | (begin (toplevel bar) (const #f)) | |
8a4ca0ea | 275 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
276 | (toplevel ref bar) (call drop 1) |
277 | (const #f) (call return 1))) | |
278 | ||
279 | (assert-tree-il->glil | |
280 | (apply (primitive null?) (toplevel bar)) | |
8a4ca0ea | 281 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
282 | (toplevel ref bar) |
283 | (call null? 1) (call return 1)))) | |
284 | ||
285 | (with-test-prefix "toplevel sets" | |
286 | (assert-tree-il->glil | |
287 | (set! (toplevel bar) (const 2)) | |
8a4ca0ea | 288 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
289 | (const 2) (toplevel set bar) |
290 | (void) (call return 1))) | |
291 | ||
292 | (assert-tree-il->glil | |
293 | (begin (set! (toplevel bar) (const 2)) (const #f)) | |
8a4ca0ea | 294 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
295 | (const 2) (toplevel set bar) |
296 | (const #f) (call return 1))) | |
297 | ||
298 | (assert-tree-il->glil | |
299 | (apply (primitive null?) (set! (toplevel bar) (const 2))) | |
8a4ca0ea | 300 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
301 | (const 2) (toplevel set bar) |
302 | (void) (call null? 1) (call return 1)))) | |
303 | ||
304 | (with-test-prefix "toplevel defines" | |
305 | (assert-tree-il->glil | |
306 | (define bar (const 2)) | |
8a4ca0ea | 307 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
308 | (const 2) (toplevel define bar) |
309 | (void) (call return 1))) | |
310 | ||
311 | (assert-tree-il->glil | |
312 | (begin (define bar (const 2)) (const #f)) | |
8a4ca0ea | 313 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
314 | (const 2) (toplevel define bar) |
315 | (const #f) (call return 1))) | |
316 | ||
317 | (assert-tree-il->glil | |
318 | (apply (primitive null?) (define bar (const 2))) | |
8a4ca0ea | 319 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
320 | (const 2) (toplevel define bar) |
321 | (void) (call null? 1) (call return 1)))) | |
322 | ||
323 | (with-test-prefix "constants" | |
324 | (assert-tree-il->glil | |
325 | (const 2) | |
8a4ca0ea | 326 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
327 | (const 2) (call return 1))) |
328 | ||
329 | (assert-tree-il->glil | |
330 | (begin (const 2) (const #f)) | |
8a4ca0ea | 331 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
332 | (const #f) (call return 1))) |
333 | ||
334 | (assert-tree-il->glil | |
335 | (apply (primitive null?) (const 2)) | |
8a4ca0ea | 336 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
337 | (const 2) (call null? 1) (call return 1)))) |
338 | ||
60d4b224 AW |
339 | (with-test-prefix "letrec" |
340 | ;; simple bindings -> let | |
341 | (assert-tree-il->glil | |
342 | (letrec (x y) (x1 y1) ((const 10) (const 20)) | |
343 | (apply (toplevel foo) (lexical x x1) (lexical y y1))) | |
344 | (program () (std-prelude 0 2 #f) (label _) | |
345 | (const 10) (const 20) | |
346 | (bind (x #f 0) (y #f 1)) | |
347 | (lexical #t #f set 1) (lexical #t #f set 0) | |
348 | (toplevel ref foo) | |
349 | (lexical #t #f ref 0) (lexical #t #f ref 1) | |
350 | (call tail-call 2) | |
351 | (unbind))) | |
352 | ||
353 | ;; complex bindings -> box and set! within let | |
354 | (assert-tree-il->glil | |
355 | (letrec (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar))) | |
356 | (apply (primitive +) (lexical x x1) (lexical y y1))) | |
357 | (program () (std-prelude 0 4 #f) (label _) | |
358 | (void) (void) ;; what are these? | |
359 | (bind (x #t 0) (y #t 1)) | |
360 | (lexical #t #t box 1) (lexical #t #t box 0) | |
361 | (call new-frame 0) (toplevel ref foo) (call call 0) | |
362 | (call new-frame 0) (toplevel ref bar) (call call 0) | |
363 | (bind (x #f 2) (y #f 3)) (lexical #t #f set 3) (lexical #t #f set 2) | |
364 | (lexical #t #f ref 2) (lexical #t #t set 0) | |
365 | (lexical #t #f ref 3) (lexical #t #t set 1) (unbind) | |
366 | (lexical #t #t ref 0) (lexical #t #t ref 1) | |
367 | (call add 2) (call return 1) (unbind))) | |
368 | ||
369 | ;; complex bindings in letrec* -> box and set! in order | |
370 | (assert-tree-il->glil | |
371 | (letrec* (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar))) | |
372 | (apply (primitive +) (lexical x x1) (lexical y y1))) | |
373 | (program () (std-prelude 0 2 #f) (label _) | |
374 | (void) (void) ;; what are these? | |
375 | (bind (x #t 0) (y #t 1)) | |
376 | (lexical #t #t box 1) (lexical #t #t box 0) | |
377 | (call new-frame 0) (toplevel ref foo) (call call 0) | |
378 | (lexical #t #t set 0) | |
379 | (call new-frame 0) (toplevel ref bar) (call call 0) | |
380 | (lexical #t #t set 1) | |
381 | (lexical #t #t ref 0) | |
382 | (lexical #t #t ref 1) | |
65ea26c5 LC |
383 | (call add 2) (call return 1) (unbind))) |
384 | ||
385 | ;; simple bindings in letrec* -> equivalent to letrec | |
386 | (assert-tree-il->glil | |
387 | (letrec* (x y) (xx yy) ((const 1) (const 2)) | |
388 | (lexical y yy)) | |
389 | (program () (std-prelude 0 1 #f) (label _) | |
390 | (const 2) | |
391 | (bind (y #f 0)) ;; X is removed, and Y is unboxed | |
392 | (lexical #t #f set 0) | |
393 | (lexical #t #f ref 0) | |
394 | (call return 1) (unbind)))) | |
60d4b224 | 395 | |
ce09ee19 AW |
396 | (with-test-prefix "lambda" |
397 | (assert-tree-il->glil | |
8a4ca0ea | 398 | (lambda () |
1e2a8edb | 399 | (lambda-case (((x) #f #f #f () (y)) (const 2)) #f)) |
8a4ca0ea | 400 | (program () (std-prelude 0 0 #f) (label _) |
258344b4 | 401 | (program () (std-prelude 1 1 #f) |
8a4ca0ea AW |
402 | (bind (x #f 0)) (label _) |
403 | (const 2) (call return 1) (unbind)) | |
ce09ee19 AW |
404 | (call return 1))) |
405 | ||
406 | (assert-tree-il->glil | |
8a4ca0ea | 407 | (lambda () |
1e2a8edb | 408 | (lambda-case (((x y) #f #f #f () (x1 y1)) |
8a4ca0ea AW |
409 | (const 2)) |
410 | #f)) | |
411 | (program () (std-prelude 0 0 #f) (label _) | |
258344b4 | 412 | (program () (std-prelude 2 2 #f) |
8a4ca0ea AW |
413 | (bind (x #f 0) (y #f 1)) (label _) |
414 | (const 2) (call return 1) | |
415 | (unbind)) | |
ce09ee19 AW |
416 | (call return 1))) |
417 | ||
418 | (assert-tree-il->glil | |
8a4ca0ea | 419 | (lambda () |
1e2a8edb | 420 | (lambda-case ((() #f x #f () (y)) (const 2)) |
8a4ca0ea AW |
421 | #f)) |
422 | (program () (std-prelude 0 0 #f) (label _) | |
899d37a6 | 423 | (program () (opt-prelude 0 0 0 1 #f) |
8a4ca0ea AW |
424 | (bind (x #f 0)) (label _) |
425 | (const 2) (call return 1) | |
426 | (unbind)) | |
ce09ee19 AW |
427 | (call return 1))) |
428 | ||
429 | (assert-tree-il->glil | |
8a4ca0ea | 430 | (lambda () |
1e2a8edb | 431 | (lambda-case (((x) #f x1 #f () (y y1)) (const 2)) |
8a4ca0ea AW |
432 | #f)) |
433 | (program () (std-prelude 0 0 #f) (label _) | |
899d37a6 | 434 | (program () (opt-prelude 1 0 1 2 #f) |
8a4ca0ea AW |
435 | (bind (x #f 0) (x1 #f 1)) (label _) |
436 | (const 2) (call return 1) | |
437 | (unbind)) | |
ce09ee19 AW |
438 | (call return 1))) |
439 | ||
440 | (assert-tree-il->glil | |
8a4ca0ea | 441 | (lambda () |
1e2a8edb | 442 | (lambda-case (((x) #f x1 #f () (y y1)) (lexical x y)) |
8a4ca0ea AW |
443 | #f)) |
444 | (program () (std-prelude 0 0 #f) (label _) | |
899d37a6 | 445 | (program () (opt-prelude 1 0 1 2 #f) |
8a4ca0ea AW |
446 | (bind (x #f 0) (x1 #f 1)) (label _) |
447 | (lexical #t #f ref 0) (call return 1) | |
448 | (unbind)) | |
ce09ee19 AW |
449 | (call return 1))) |
450 | ||
451 | (assert-tree-il->glil | |
8a4ca0ea | 452 | (lambda () |
1e2a8edb | 453 | (lambda-case (((x) #f x1 #f () (y y1)) (lexical x1 y1)) |
8a4ca0ea AW |
454 | #f)) |
455 | (program () (std-prelude 0 0 #f) (label _) | |
899d37a6 | 456 | (program () (opt-prelude 1 0 1 2 #f) |
8a4ca0ea AW |
457 | (bind (x #f 0) (x1 #f 1)) (label _) |
458 | (lexical #t #f ref 1) (call return 1) | |
459 | (unbind)) | |
a1a482e0 AW |
460 | (call return 1))) |
461 | ||
462 | (assert-tree-il->glil | |
8a4ca0ea | 463 | (lambda () |
1e2a8edb | 464 | (lambda-case (((x) #f #f #f () (x1)) |
8a4ca0ea | 465 | (lambda () |
1e2a8edb | 466 | (lambda-case (((y) #f #f #f () (y1)) |
8a4ca0ea AW |
467 | (lexical x x1)) |
468 | #f))) | |
469 | #f)) | |
470 | (program () (std-prelude 0 0 #f) (label _) | |
471 | (program () (std-prelude 1 1 #f) | |
472 | (bind (x #f 0)) (label _) | |
258344b4 | 473 | (program () (std-prelude 1 1 #f) |
8a4ca0ea AW |
474 | (bind (y #f 0)) (label _) |
475 | (lexical #f #f ref 0) (call return 1) | |
476 | (unbind)) | |
66d3e9a3 | 477 | (lexical #t #f ref 0) |
6f16379e | 478 | (call make-closure 1) |
8a4ca0ea AW |
479 | (call return 1) |
480 | (unbind)) | |
ce09ee19 AW |
481 | (call return 1)))) |
482 | ||
483 | (with-test-prefix "sequence" | |
484 | (assert-tree-il->glil | |
485 | (begin (begin (const 2) (const #f)) (const #t)) | |
8a4ca0ea | 486 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 AW |
487 | (const #t) (call return 1))) |
488 | ||
489 | (assert-tree-il->glil | |
490 | (apply (primitive null?) (begin (const #f) (const 2))) | |
8a4ca0ea | 491 | (program () (std-prelude 0 0 #f) (label _) |
ce09ee19 | 492 | (const 2) (call null? 1) (call return 1)))) |
5af166bd | 493 | |
b88fef55 AW |
494 | (with-test-prefix "values" |
495 | (assert-tree-il->glil | |
496 | (apply (primitive values) | |
497 | (apply (primitive values) (const 1) (const 2))) | |
498 | (program () (std-prelude 0 0 #f) (label _) | |
499 | (const 1) (call return 1))) | |
500 | ||
501 | (assert-tree-il->glil | |
502 | (apply (primitive values) | |
503 | (apply (primitive values) (const 1) (const 2)) | |
504 | (const 3)) | |
505 | (program () (std-prelude 0 0 #f) (label _) | |
506 | (const 1) (const 3) (call return/values 2))) | |
507 | ||
508 | (assert-tree-il->glil | |
509 | (apply (primitive +) | |
510 | (apply (primitive values) (const 1) (const 2))) | |
511 | (program () (std-prelude 0 0 #f) (label _) | |
512 | (const 1) (call return 1)))) | |
513 | ||
5af166bd AW |
514 | ;; FIXME: binding info for or-hacked locals might bork the disassembler, |
515 | ;; and could be tightened in any case | |
516 | (with-test-prefix "the or hack" | |
8a4ca0ea | 517 | (assert-tree-il->glil |
5af166bd AW |
518 | (let (x) (y) ((const 1)) |
519 | (if (lexical x y) | |
520 | (lexical x y) | |
521 | (let (a) (b) ((const 2)) | |
522 | (lexical a b)))) | |
8a4ca0ea | 523 | (program () (std-prelude 0 1 #f) (label _) |
66d3e9a3 AW |
524 | (const 1) (bind (x #f 0)) (lexical #t #f set 0) |
525 | (lexical #t #f ref 0) (branch br-if-not ,l1) | |
526 | (lexical #t #f ref 0) (call return 1) | |
5af166bd | 527 | (label ,l2) |
66d3e9a3 AW |
528 | (const 2) (bind (a #f 0)) (lexical #t #f set 0) |
529 | (lexical #t #f ref 0) (call return 1) | |
5af166bd AW |
530 | (unbind) |
531 | (unbind)) | |
532 | (eq? l1 l2)) | |
533 | ||
aaae0d5a | 534 | ;; second bound var is unreferenced |
8a4ca0ea | 535 | (assert-tree-il->glil |
5af166bd AW |
536 | (let (x) (y) ((const 1)) |
537 | (if (lexical x y) | |
538 | (lexical x y) | |
539 | (let (a) (b) ((const 2)) | |
540 | (lexical x y)))) | |
8a4ca0ea | 541 | (program () (std-prelude 0 1 #f) (label _) |
66d3e9a3 AW |
542 | (const 1) (bind (x #f 0)) (lexical #t #f set 0) |
543 | (lexical #t #f ref 0) (branch br-if-not ,l1) | |
544 | (lexical #t #f ref 0) (call return 1) | |
5af166bd | 545 | (label ,l2) |
66d3e9a3 | 546 | (lexical #t #f ref 0) (call return 1) |
5af166bd AW |
547 | (unbind)) |
548 | (eq? l1 l2))) | |
0f423f20 AW |
549 | |
550 | (with-test-prefix "apply" | |
551 | (assert-tree-il->glil | |
552 | (apply (primitive @apply) (toplevel foo) (toplevel bar)) | |
a5bbb22e | 553 | (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (toplevel ref bar) (call tail-apply 2))) |
8a4ca0ea | 554 | (assert-tree-il->glil |
0f423f20 | 555 | (begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void)) |
8a4ca0ea | 556 | (program () (std-prelude 0 0 #f) (label _) |
b7946e9e | 557 | (call new-frame 0) (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1) |
05c51bcf | 558 | (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f) |
0f423f20 AW |
559 | (label ,l4) |
560 | (void) (call return 1)) | |
561 | (and (eq? l1 l3) (eq? l2 l4))) | |
562 | (assert-tree-il->glil | |
563 | (apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz))) | |
8a4ca0ea | 564 | (program () (std-prelude 0 0 #f) (label _) |
0f423f20 | 565 | (toplevel ref foo) |
b7946e9e | 566 | (call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call apply 2) |
a5bbb22e | 567 | (call tail-call 1)))) |
0f423f20 AW |
568 | |
569 | (with-test-prefix "call/cc" | |
570 | (assert-tree-il->glil | |
571 | (apply (primitive @call-with-current-continuation) (toplevel foo)) | |
a5bbb22e | 572 | (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call tail-call/cc 1))) |
8a4ca0ea | 573 | (assert-tree-il->glil |
0f423f20 | 574 | (begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void)) |
8a4ca0ea | 575 | (program () (std-prelude 0 0 #f) (label _) |
b7946e9e | 576 | (call new-frame 0) (toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1) |
05c51bcf | 577 | (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f) |
0f423f20 AW |
578 | (label ,l4) |
579 | (void) (call return 1)) | |
580 | (and (eq? l1 l3) (eq? l2 l4))) | |
581 | (assert-tree-il->glil | |
582 | (apply (toplevel foo) | |
583 | (apply (toplevel @call-with-current-continuation) (toplevel bar))) | |
8a4ca0ea | 584 | (program () (std-prelude 0 0 #f) (label _) |
0f423f20 AW |
585 | (toplevel ref foo) |
586 | (toplevel ref bar) (call call/cc 1) | |
a5bbb22e | 587 | (call tail-call 1)))) |
0f423f20 | 588 | |
f4aa0f10 LC |
589 | \f |
590 | (with-test-prefix "tree-il-fold" | |
591 | ||
592 | (pass-if "empty tree" | |
593 | (let ((leaf? #f) (up? #f) (down? #f) (mark (list 'mark))) | |
594 | (and (eq? mark | |
595 | (tree-il-fold (lambda (x y) (set! leaf? #t) y) | |
596 | (lambda (x y) (set! down? #t) y) | |
597 | (lambda (x y) (set! up? #t) y) | |
598 | mark | |
599 | '())) | |
600 | (not leaf?) | |
601 | (not up?) | |
602 | (not down?)))) | |
603 | ||
604 | (pass-if "lambda and application" | |
605 | (let* ((leaves '()) (ups '()) (downs '()) | |
606 | (result (tree-il-fold (lambda (x y) | |
607 | (set! leaves (cons x leaves)) | |
608 | (1+ y)) | |
609 | (lambda (x y) | |
610 | (set! downs (cons x downs)) | |
611 | (1+ y)) | |
612 | (lambda (x y) | |
613 | (set! ups (cons x ups)) | |
614 | (1+ y)) | |
615 | 0 | |
616 | (parse-tree-il | |
8a4ca0ea AW |
617 | '(lambda () |
618 | (lambda-case | |
1e2a8edb | 619 | (((x y) #f #f #f () (x1 y1)) |
8a4ca0ea AW |
620 | (apply (toplevel +) |
621 | (lexical x x1) | |
622 | (lexical y y1))) | |
623 | #f)))))) | |
f4aa0f10 LC |
624 | (and (equal? (map strip-source leaves) |
625 | (list (make-lexical-ref #f 'y 'y1) | |
626 | (make-lexical-ref #f 'x 'x1) | |
627 | (make-toplevel-ref #f '+))) | |
8a4ca0ea | 628 | (= (length downs) 3) |
f4aa0f10 LC |
629 | (equal? (reverse (map strip-source ups)) |
630 | (map strip-source downs)))))) | |
4b856371 LC |
631 | |
632 | \f | |
633 | ;;; | |
634 | ;;; Warnings. | |
635 | ;;; | |
636 | ||
637 | ;; Make sure we get English messages. | |
638 | (setlocale LC_ALL "C") | |
639 | ||
640 | (define (call-with-warnings thunk) | |
641 | (let ((port (open-output-string))) | |
a4060f67 LC |
642 | (with-fluids ((*current-warning-port* port) |
643 | (*current-warning-prefix* "")) | |
644 | (thunk)) | |
4b856371 LC |
645 | (let ((warnings (get-output-string port))) |
646 | (string-tokenize warnings | |
647 | (char-set-complement (char-set #\newline)))))) | |
648 | ||
649 | (define %opts-w-unused | |
650 | '(#:warnings (unused-variable))) | |
651 | ||
bcae9a98 LC |
652 | (define %opts-w-unused-toplevel |
653 | '(#:warnings (unused-toplevel))) | |
654 | ||
f67ddf9d LC |
655 | (define %opts-w-unbound |
656 | '(#:warnings (unbound-variable))) | |
4b856371 | 657 | |
ae03cf1f LC |
658 | (define %opts-w-arity |
659 | '(#:warnings (arity-mismatch))) | |
660 | ||
75365375 LC |
661 | (define %opts-w-format |
662 | '(#:warnings (format))) | |
663 | ||
ae03cf1f | 664 | |
4b856371 LC |
665 | (with-test-prefix "warnings" |
666 | ||
667 | (pass-if "unknown warning type" | |
668 | (let ((w (call-with-warnings | |
669 | (lambda () | |
670 | (compile #t #:opts '(#:warnings (does-not-exist))))))) | |
671 | (and (= (length w) 1) | |
672 | (number? (string-contains (car w) "unknown warning"))))) | |
673 | ||
674 | (with-test-prefix "unused-variable" | |
675 | ||
676 | (pass-if "quiet" | |
677 | (null? (call-with-warnings | |
678 | (lambda () | |
679 | (compile '(lambda (x y) (+ x y)) | |
680 | #:opts %opts-w-unused))))) | |
681 | ||
682 | (pass-if "let/unused" | |
683 | (let ((w (call-with-warnings | |
684 | (lambda () | |
685 | (compile '(lambda (x) | |
686 | (let ((y (+ x 2))) | |
687 | x)) | |
688 | #:opts %opts-w-unused))))) | |
689 | (and (= (length w) 1) | |
690 | (number? (string-contains (car w) "unused variable `y'"))))) | |
691 | ||
692 | (pass-if "shadowed variable" | |
693 | (let ((w (call-with-warnings | |
694 | (lambda () | |
695 | (compile '(lambda (x) | |
696 | (let ((y x)) | |
697 | (let ((y (+ x 2))) | |
698 | (+ x y)))) | |
699 | #:opts %opts-w-unused))))) | |
700 | (and (= (length w) 1) | |
701 | (number? (string-contains (car w) "unused variable `y'"))))) | |
702 | ||
703 | (pass-if "letrec" | |
704 | (null? (call-with-warnings | |
705 | (lambda () | |
706 | (compile '(lambda () | |
707 | (letrec ((x (lambda () (y))) | |
708 | (y (lambda () (x)))) | |
709 | y)) | |
710 | #:opts %opts-w-unused))))) | |
711 | ||
712 | (pass-if "unused argument" | |
713 | ;; Unused arguments should not be reported. | |
714 | (null? (call-with-warnings | |
715 | (lambda () | |
716 | (compile '(lambda (x y z) #t) | |
3a1a883b LC |
717 | #:opts %opts-w-unused))))) |
718 | ||
719 | (pass-if "special variable names" | |
720 | (null? (call-with-warnings | |
721 | (lambda () | |
722 | (compile '(lambda () | |
723 | (let ((_ 'underscore) | |
724 | (#{gensym name}# 'ignore-me)) | |
725 | #t)) | |
726 | #:to 'assembly | |
f67ddf9d LC |
727 | #:opts %opts-w-unused)))))) |
728 | ||
bcae9a98 LC |
729 | (with-test-prefix "unused-toplevel" |
730 | ||
731 | (pass-if "used after definition" | |
732 | (null? (call-with-warnings | |
733 | (lambda () | |
734 | (let ((in (open-input-string | |
735 | "(define foo 2) foo"))) | |
736 | (read-and-compile in | |
737 | #:to 'assembly | |
738 | #:opts %opts-w-unused-toplevel)))))) | |
739 | ||
740 | (pass-if "used before definition" | |
741 | (null? (call-with-warnings | |
742 | (lambda () | |
743 | (let ((in (open-input-string | |
744 | "(define (bar) foo) (define foo 2) (bar)"))) | |
745 | (read-and-compile in | |
746 | #:to 'assembly | |
747 | #:opts %opts-w-unused-toplevel)))))) | |
748 | ||
749 | (pass-if "unused but public" | |
750 | (let ((in (open-input-string | |
751 | "(define-module (test-suite tree-il x) #:export (bar)) | |
752 | (define (bar) #t)"))) | |
753 | (null? (call-with-warnings | |
754 | (lambda () | |
755 | (read-and-compile in | |
756 | #:to 'assembly | |
757 | #:opts %opts-w-unused-toplevel)))))) | |
758 | ||
759 | (pass-if "unused but public (more)" | |
760 | (let ((in (open-input-string | |
761 | "(define-module (test-suite tree-il x) #:export (bar)) | |
762 | (define (bar) (baz)) | |
763 | (define (baz) (foo)) | |
764 | (define (foo) #t)"))) | |
765 | (null? (call-with-warnings | |
766 | (lambda () | |
767 | (read-and-compile in | |
768 | #:to 'assembly | |
769 | #:opts %opts-w-unused-toplevel)))))) | |
770 | ||
771 | (pass-if "unused but define-public" | |
bcae9a98 LC |
772 | (null? (call-with-warnings |
773 | (lambda () | |
774 | (compile '(define-public foo 2) | |
775 | #:to 'assembly | |
776 | #:opts %opts-w-unused-toplevel))))) | |
777 | ||
778 | (pass-if "used by macro" | |
779 | ;; FIXME: See comment about macros at `unused-toplevel-analysis'. | |
780 | (throw 'unresolved) | |
781 | ||
782 | (null? (call-with-warnings | |
783 | (lambda () | |
784 | (let ((in (open-input-string | |
785 | "(define (bar) 'foo) | |
786 | (define-syntax baz | |
787 | (syntax-rules () ((_) (bar))))"))) | |
788 | (read-and-compile in | |
789 | #:to 'assembly | |
790 | #:opts %opts-w-unused-toplevel)))))) | |
791 | ||
792 | (pass-if "unused" | |
793 | (let ((w (call-with-warnings | |
794 | (lambda () | |
795 | (compile '(define foo 2) | |
796 | #:to 'assembly | |
797 | #:opts %opts-w-unused-toplevel))))) | |
798 | (and (= (length w) 1) | |
799 | (number? (string-contains (car w) | |
800 | (format #f "top-level variable `~A'" | |
801 | 'foo)))))) | |
802 | ||
803 | (pass-if "unused recursive" | |
804 | (let ((w (call-with-warnings | |
805 | (lambda () | |
806 | (compile '(define (foo) (foo)) | |
807 | #:to 'assembly | |
808 | #:opts %opts-w-unused-toplevel))))) | |
809 | (and (= (length w) 1) | |
810 | (number? (string-contains (car w) | |
811 | (format #f "top-level variable `~A'" | |
812 | 'foo)))))) | |
813 | ||
814 | (pass-if "unused mutually recursive" | |
815 | (let* ((in (open-input-string | |
816 | "(define (foo) (bar)) (define (bar) (foo))")) | |
817 | (w (call-with-warnings | |
818 | (lambda () | |
819 | (read-and-compile in | |
820 | #:to 'assembly | |
821 | #:opts %opts-w-unused-toplevel))))) | |
822 | (and (= (length w) 2) | |
823 | (number? (string-contains (car w) | |
824 | (format #f "top-level variable `~A'" | |
825 | 'foo))) | |
826 | (number? (string-contains (cadr w) | |
827 | (format #f "top-level variable `~A'" | |
3a1a883b LC |
828 | 'bar)))))) |
829 | ||
830 | (pass-if "special variable names" | |
831 | (null? (call-with-warnings | |
832 | (lambda () | |
833 | (compile '(define #{gensym name}# 'ignore-me) | |
834 | #:to 'assembly | |
835 | #:opts %opts-w-unused-toplevel)))))) | |
bcae9a98 | 836 | |
f67ddf9d LC |
837 | (with-test-prefix "unbound variable" |
838 | ||
839 | (pass-if "quiet" | |
840 | (null? (call-with-warnings | |
841 | (lambda () | |
842 | (compile '+ #:opts %opts-w-unbound))))) | |
843 | ||
844 | (pass-if "ref" | |
845 | (let* ((v (gensym)) | |
846 | (w (call-with-warnings | |
847 | (lambda () | |
848 | (compile v | |
849 | #:to 'assembly | |
850 | #:opts %opts-w-unbound))))) | |
851 | (and (= (length w) 1) | |
852 | (number? (string-contains (car w) | |
853 | (format #f "unbound variable `~A'" | |
854 | v)))))) | |
855 | ||
856 | (pass-if "set!" | |
857 | (let* ((v (gensym)) | |
858 | (w (call-with-warnings | |
859 | (lambda () | |
860 | (compile `(set! ,v 7) | |
861 | #:to 'assembly | |
862 | #:opts %opts-w-unbound))))) | |
863 | (and (= (length w) 1) | |
864 | (number? (string-contains (car w) | |
865 | (format #f "unbound variable `~A'" | |
866 | v)))))) | |
867 | ||
868 | (pass-if "module-local top-level is visible" | |
869 | (let ((m (make-module)) | |
870 | (v (gensym))) | |
871 | (beautify-user-module! m) | |
872 | (compile `(define ,v 123) | |
873 | #:env m #:opts %opts-w-unbound) | |
874 | (null? (call-with-warnings | |
875 | (lambda () | |
876 | (compile v | |
877 | #:env m | |
878 | #:to 'assembly | |
879 | #:opts %opts-w-unbound)))))) | |
880 | ||
881 | (pass-if "module-local top-level is visible after" | |
882 | (let ((m (make-module)) | |
883 | (v (gensym))) | |
884 | (beautify-user-module! m) | |
885 | (null? (call-with-warnings | |
886 | (lambda () | |
887 | (let ((in (open-input-string | |
888 | "(define (f) | |
889 | (set! chbouib 3)) | |
890 | (define chbouib 5)"))) | |
b6d2306d LC |
891 | (read-and-compile in |
892 | #:env m | |
893 | #:opts %opts-w-unbound))))))) | |
894 | ||
bd36e901 LC |
895 | (pass-if "optional arguments are visible" |
896 | (null? (call-with-warnings | |
897 | (lambda () | |
898 | (compile '(lambda* (x #:optional y z) (list x y z)) | |
899 | #:opts %opts-w-unbound | |
900 | #:to 'assembly))))) | |
901 | ||
902 | (pass-if "keyword arguments are visible" | |
903 | (null? (call-with-warnings | |
904 | (lambda () | |
905 | (compile '(lambda* (x #:key y z) (list x y z)) | |
906 | #:opts %opts-w-unbound | |
907 | #:to 'assembly))))) | |
908 | ||
b6d2306d LC |
909 | (pass-if "GOOPS definitions are visible" |
910 | (let ((m (make-module)) | |
911 | (v (gensym))) | |
912 | (beautify-user-module! m) | |
913 | (module-use! m (resolve-interface '(oop goops))) | |
914 | (null? (call-with-warnings | |
915 | (lambda () | |
916 | (let ((in (open-input-string | |
917 | "(define-class <foo> () | |
918 | (bar #:getter foo-bar)) | |
919 | (define z (foo-bar (make <foo>)))"))) | |
f67ddf9d LC |
920 | (read-and-compile in |
921 | #:env m | |
ae03cf1f LC |
922 | #:opts %opts-w-unbound)))))))) |
923 | ||
924 | (with-test-prefix "arity mismatch" | |
925 | ||
926 | (pass-if "quiet" | |
927 | (null? (call-with-warnings | |
928 | (lambda () | |
929 | (compile '(cons 'a 'b) #:opts %opts-w-arity))))) | |
930 | ||
931 | (pass-if "direct application" | |
932 | (let ((w (call-with-warnings | |
933 | (lambda () | |
934 | (compile '((lambda (x y) (or x y)) 1 2 3 4 5) | |
935 | #:opts %opts-w-arity | |
936 | #:to 'assembly))))) | |
937 | (and (= (length w) 1) | |
938 | (number? (string-contains (car w) | |
939 | "wrong number of arguments to"))))) | |
940 | (pass-if "local" | |
941 | (let ((w (call-with-warnings | |
942 | (lambda () | |
943 | (compile '(let ((f (lambda (x y) (+ x y)))) | |
944 | (f 2)) | |
945 | #:opts %opts-w-arity | |
946 | #:to 'assembly))))) | |
947 | (and (= (length w) 1) | |
948 | (number? (string-contains (car w) | |
949 | "wrong number of arguments to"))))) | |
950 | ||
951 | (pass-if "global" | |
952 | (let ((w (call-with-warnings | |
953 | (lambda () | |
954 | (compile '(cons 1 2 3 4) | |
955 | #:opts %opts-w-arity | |
956 | #:to 'assembly))))) | |
957 | (and (= (length w) 1) | |
958 | (number? (string-contains (car w) | |
959 | "wrong number of arguments to"))))) | |
960 | ||
961 | (pass-if "alias to global" | |
962 | (let ((w (call-with-warnings | |
963 | (lambda () | |
964 | (compile '(let ((f cons)) (f 1 2 3 4)) | |
965 | #:opts %opts-w-arity | |
966 | #:to 'assembly))))) | |
967 | (and (= (length w) 1) | |
968 | (number? (string-contains (car w) | |
969 | "wrong number of arguments to"))))) | |
970 | ||
971 | (pass-if "alias to lexical to global" | |
972 | (let ((w (call-with-warnings | |
973 | (lambda () | |
974 | (compile '(let ((f number?)) | |
975 | (let ((g f)) | |
976 | (f 1 2 3 4))) | |
977 | #:opts %opts-w-arity | |
978 | #:to 'assembly))))) | |
979 | (and (= (length w) 1) | |
980 | (number? (string-contains (car w) | |
981 | "wrong number of arguments to"))))) | |
982 | ||
983 | (pass-if "alias to lexical" | |
984 | (let ((w (call-with-warnings | |
985 | (lambda () | |
986 | (compile '(let ((f (lambda (x y z) (+ x y z)))) | |
987 | (let ((g f)) | |
988 | (g 1))) | |
989 | #:opts %opts-w-arity | |
990 | #:to 'assembly))))) | |
991 | (and (= (length w) 1) | |
992 | (number? (string-contains (car w) | |
993 | "wrong number of arguments to"))))) | |
994 | ||
995 | (pass-if "letrec" | |
996 | (let ((w (call-with-warnings | |
997 | (lambda () | |
998 | (compile '(letrec ((odd? (lambda (x) (even? (1- x)))) | |
999 | (even? (lambda (x) | |
1000 | (or (= 0 x) | |
1001 | (odd?))))) | |
1002 | (odd? 1)) | |
1003 | #:opts %opts-w-arity | |
1004 | #:to 'assembly))))) | |
1005 | (and (= (length w) 1) | |
1006 | (number? (string-contains (car w) | |
1007 | "wrong number of arguments to"))))) | |
1008 | ||
99480e11 LC |
1009 | (pass-if "case-lambda" |
1010 | (null? (call-with-warnings | |
1011 | (lambda () | |
1012 | (compile '(let ((f (case-lambda | |
1013 | ((x) 1) | |
1014 | ((x y) 2) | |
1015 | ((x y z) 3)))) | |
1016 | (list (f 1) | |
1017 | (f 1 2) | |
1018 | (f 1 2 3))) | |
1019 | #:opts %opts-w-arity | |
1020 | #:to 'assembly))))) | |
1021 | ||
1022 | (pass-if "case-lambda with wrong number of arguments" | |
1023 | (let ((w (call-with-warnings | |
1024 | (lambda () | |
1025 | (compile '(let ((f (case-lambda | |
1026 | ((x) 1) | |
1027 | ((x y) 2)))) | |
1028 | (f 1 2 3)) | |
1029 | #:opts %opts-w-arity | |
1030 | #:to 'assembly))))) | |
1031 | (and (= (length w) 1) | |
1032 | (number? (string-contains (car w) | |
1033 | "wrong number of arguments to"))))) | |
1034 | ||
1035 | (pass-if "case-lambda*" | |
1036 | (null? (call-with-warnings | |
1037 | (lambda () | |
1038 | (compile '(let ((f (case-lambda* | |
1039 | ((x #:optional y) 1) | |
1040 | ((x #:key y) 2) | |
1041 | ((x y #:key z) 3)))) | |
1042 | (list (f 1) | |
1043 | (f 1 2) | |
1044 | (f #:y 2) | |
1045 | (f 1 2 #:z 3))) | |
1046 | #:opts %opts-w-arity | |
1047 | #:to 'assembly))))) | |
1048 | ||
1049 | (pass-if "case-lambda* with wrong arguments" | |
1050 | (let ((w (call-with-warnings | |
1051 | (lambda () | |
1052 | (compile '(let ((f (case-lambda* | |
1053 | ((x #:optional y) 1) | |
1054 | ((x #:key y) 2) | |
1055 | ((x y #:key z) 3)))) | |
1056 | (list (f) | |
1057 | (f 1 #:z 3))) | |
1058 | #:opts %opts-w-arity | |
1059 | #:to 'assembly))))) | |
1060 | (and (= (length w) 2) | |
1061 | (null? (filter (lambda (w) | |
1062 | (not | |
1063 | (number? | |
1064 | (string-contains | |
1065 | w "wrong number of arguments to")))) | |
1066 | w))))) | |
1067 | ||
ae03cf1f LC |
1068 | (pass-if "local toplevel-defines" |
1069 | (let ((w (call-with-warnings | |
1070 | (lambda () | |
1071 | (let ((in (open-input-string " | |
1072 | (define (g x) (f x)) | |
1073 | (define (f) 1)"))) | |
1074 | (read-and-compile in | |
1075 | #:opts %opts-w-arity | |
1076 | #:to 'assembly)))))) | |
1077 | (and (= (length w) 1) | |
1078 | (number? (string-contains (car w) | |
1079 | "wrong number of arguments to"))))) | |
1080 | ||
1081 | (pass-if "global toplevel alias" | |
1082 | (let ((w (call-with-warnings | |
1083 | (lambda () | |
1084 | (let ((in (open-input-string " | |
1085 | (define f cons) | |
1086 | (define (g) (f))"))) | |
1087 | (read-and-compile in | |
1088 | #:opts %opts-w-arity | |
1089 | #:to 'assembly)))))) | |
1090 | (and (= (length w) 1) | |
1091 | (number? (string-contains (car w) | |
1092 | "wrong number of arguments to"))))) | |
1093 | ||
1094 | (pass-if "local toplevel overrides global" | |
1095 | (null? (call-with-warnings | |
1096 | (lambda () | |
1097 | (let ((in (open-input-string " | |
1098 | (define (cons) 0) | |
1099 | (define (foo x) (cons))"))) | |
1100 | (read-and-compile in | |
1101 | #:opts %opts-w-arity | |
af5ed549 LC |
1102 | #:to 'assembly)))))) |
1103 | ||
1104 | (pass-if "keyword not passed and quiet" | |
1105 | (null? (call-with-warnings | |
1106 | (lambda () | |
1107 | (compile '(let ((f (lambda* (x #:key y) y))) | |
1108 | (f 2)) | |
1109 | #:opts %opts-w-arity | |
1110 | #:to 'assembly))))) | |
1111 | ||
1112 | (pass-if "keyword passed and quiet" | |
1113 | (null? (call-with-warnings | |
1114 | (lambda () | |
1115 | (compile '(let ((f (lambda* (x #:key y) y))) | |
1116 | (f 2 #:y 3)) | |
1117 | #:opts %opts-w-arity | |
1118 | #:to 'assembly))))) | |
1119 | ||
1120 | (pass-if "keyword passed to global and quiet" | |
1121 | (null? (call-with-warnings | |
1122 | (lambda () | |
1123 | (let ((in (open-input-string " | |
1124 | (use-modules (system base compile)) | |
1125 | (compile '(+ 2 3) #:env (current-module))"))) | |
1126 | (read-and-compile in | |
1127 | #:opts %opts-w-arity | |
1128 | #:to 'assembly)))))) | |
1129 | ||
1130 | (pass-if "extra keyword" | |
1131 | (let ((w (call-with-warnings | |
1132 | (lambda () | |
1133 | (compile '(let ((f (lambda* (x #:key y) y))) | |
1134 | (f 2 #:Z 3)) | |
1135 | #:opts %opts-w-arity | |
1136 | #:to 'assembly))))) | |
1137 | (and (= (length w) 1) | |
1138 | (number? (string-contains (car w) | |
1139 | "wrong number of arguments to"))))) | |
1140 | ||
1141 | (pass-if "extra keywords allowed" | |
1142 | (null? (call-with-warnings | |
1143 | (lambda () | |
1144 | (compile '(let ((f (lambda* (x #:key y #:allow-other-keys) | |
1145 | y))) | |
1146 | (f 2 #:Z 3)) | |
1147 | #:opts %opts-w-arity | |
75365375 LC |
1148 | #:to 'assembly)))))) |
1149 | ||
1150 | (with-test-prefix "format" | |
1151 | ||
1152 | (pass-if "quiet (no args)" | |
1153 | (null? (call-with-warnings | |
1154 | (lambda () | |
1155 | (compile '(format #t "hey!") | |
1156 | #:opts %opts-w-format | |
1157 | #:to 'assembly))))) | |
1158 | ||
1159 | (pass-if "quiet (1 arg)" | |
1160 | (null? (call-with-warnings | |
1161 | (lambda () | |
1162 | (compile '(format #t "hey ~A!" "you") | |
1163 | #:opts %opts-w-format | |
1164 | #:to 'assembly))))) | |
1165 | ||
1166 | (pass-if "quiet (2 args)" | |
1167 | (null? (call-with-warnings | |
1168 | (lambda () | |
1169 | (compile '(format #t "~A ~A!" "hello" "world") | |
1170 | #:opts %opts-w-format | |
1171 | #:to 'assembly))))) | |
1172 | ||
60f01304 LC |
1173 | (pass-if "wrong port arg" |
1174 | (let ((w (call-with-warnings | |
1175 | (lambda () | |
1176 | (compile '(format 10 "foo") | |
1177 | #:opts %opts-w-format | |
1178 | #:to 'assembly))))) | |
1179 | (and (= (length w) 1) | |
1180 | (number? (string-contains (car w) | |
1181 | "wrong port argument"))))) | |
1182 | ||
1183 | (pass-if "non-literal format string" | |
1184 | (let ((w (call-with-warnings | |
1185 | (lambda () | |
1186 | (compile '(format #f fmt) | |
1187 | #:opts %opts-w-format | |
1188 | #:to 'assembly))))) | |
1189 | (and (= (length w) 1) | |
1190 | (number? (string-contains (car w) | |
1191 | "non-literal format string"))))) | |
1192 | ||
022ae742 LC |
1193 | (pass-if "non-literal format string using gettext" |
1194 | (null? (call-with-warnings | |
1195 | (lambda () | |
1196 | (compile '(format #t (_ "~A ~A!") "hello" "world") | |
1197 | #:opts %opts-w-format | |
1198 | #:to 'assembly))))) | |
1199 | ||
60f01304 LC |
1200 | (pass-if "wrong format string" |
1201 | (let ((w (call-with-warnings | |
1202 | (lambda () | |
1203 | (compile '(format #f 'not-a-string) | |
1204 | #:opts %opts-w-format | |
1205 | #:to 'assembly))))) | |
1206 | (and (= (length w) 1) | |
1207 | (number? (string-contains (car w) | |
1208 | "wrong format string"))))) | |
1209 | ||
1210 | (pass-if "wrong number of args" | |
1211 | (let ((w (call-with-warnings | |
1212 | (lambda () | |
1213 | (compile '(format "shbweeb") | |
1214 | #:opts %opts-w-format | |
1215 | #:to 'assembly))))) | |
1216 | (and (= (length w) 1) | |
1217 | (number? (string-contains (car w) | |
1218 | "wrong number of arguments"))))) | |
1219 | ||
e0697241 | 1220 | (pass-if "~%, ~~, ~&, ~t, ~_, and ~\\n" |
75365375 LC |
1221 | (null? (call-with-warnings |
1222 | (lambda () | |
e0697241 | 1223 | (compile '(format some-port "~&~3_~~ ~\n~12they~%") |
75365375 LC |
1224 | #:opts %opts-w-format |
1225 | #:to 'assembly))))) | |
1226 | ||
1227 | (pass-if "one missing argument" | |
1228 | (let ((w (call-with-warnings | |
1229 | (lambda () | |
1230 | (compile '(format some-port "foo ~A~%") | |
1231 | #:opts %opts-w-format | |
1232 | #:to 'assembly))))) | |
1233 | (and (= (length w) 1) | |
1234 | (number? (string-contains (car w) | |
1235 | "expected 1, got 0"))))) | |
1236 | ||
022ae742 LC |
1237 | (pass-if "one missing argument, gettext" |
1238 | (let ((w (call-with-warnings | |
1239 | (lambda () | |
1240 | (compile '(format some-port (_ "foo ~A~%")) | |
1241 | #:opts %opts-w-format | |
1242 | #:to 'assembly))))) | |
1243 | (and (= (length w) 1) | |
1244 | (number? (string-contains (car w) | |
1245 | "expected 1, got 0"))))) | |
1246 | ||
75365375 LC |
1247 | (pass-if "two missing arguments" |
1248 | (let ((w (call-with-warnings | |
1249 | (lambda () | |
1250 | (compile '(format #f "foo ~10,2f and bar ~S~%") | |
1251 | #:opts %opts-w-format | |
1252 | #:to 'assembly))))) | |
1253 | (and (= (length w) 1) | |
1254 | (number? (string-contains (car w) | |
1255 | "expected 2, got 0"))))) | |
1256 | ||
1257 | (pass-if "one given, one missing argument" | |
1258 | (let ((w (call-with-warnings | |
1259 | (lambda () | |
1260 | (compile '(format #t "foo ~A and ~S~%" hey) | |
1261 | #:opts %opts-w-format | |
1262 | #:to 'assembly))))) | |
1263 | (and (= (length w) 1) | |
1264 | (number? (string-contains (car w) | |
1265 | "expected 2, got 1"))))) | |
1266 | ||
1267 | (pass-if "too many arguments" | |
1268 | (let ((w (call-with-warnings | |
1269 | (lambda () | |
1270 | (compile '(format #t "foo ~A~%" 1 2) | |
1271 | #:opts %opts-w-format | |
1272 | #:to 'assembly))))) | |
1273 | (and (= (length w) 1) | |
1274 | (number? (string-contains (car w) | |
1275 | "expected 1, got 2"))))) | |
1276 | ||
e0697241 LC |
1277 | (with-test-prefix "conditionals" |
1278 | (pass-if "literals" | |
1279 | (null? (call-with-warnings | |
1280 | (lambda () | |
1281 | (compile '(format #f "~A ~[foo~;bar~;baz~;~] ~10,2f" | |
1282 | 'a 1 3.14) | |
1283 | #:opts %opts-w-format | |
1284 | #:to 'assembly))))) | |
1285 | ||
1286 | (pass-if "literals with selector" | |
1287 | (let ((w (call-with-warnings | |
1288 | (lambda () | |
1289 | (compile '(format #f "~2[foo~;bar~;baz~;~] ~A" | |
1290 | 1 'dont-ignore-me) | |
1291 | #:opts %opts-w-format | |
1292 | #:to 'assembly))))) | |
1293 | (and (= (length w) 1) | |
1294 | (number? (string-contains (car w) | |
1295 | "expected 1, got 2"))))) | |
1296 | ||
1297 | (pass-if "escapes (exact count)" | |
1298 | (let ((w (call-with-warnings | |
1299 | (lambda () | |
1300 | (compile '(format #f "~[~a~;~a~]") | |
1301 | #:opts %opts-w-format | |
1302 | #:to 'assembly))))) | |
1303 | (and (= (length w) 1) | |
1304 | (number? (string-contains (car w) | |
1305 | "expected 2, got 0"))))) | |
1306 | ||
1307 | (pass-if "escapes with selector" | |
1308 | (let ((w (call-with-warnings | |
1309 | (lambda () | |
1310 | (compile '(format #f "~1[chbouib~;~a~]") | |
1311 | #:opts %opts-w-format | |
1312 | #:to 'assembly))))) | |
1313 | (and (= (length w) 1) | |
1314 | (number? (string-contains (car w) | |
1315 | "expected 1, got 0"))))) | |
1316 | ||
1317 | (pass-if "escapes, range" | |
1318 | (let ((w (call-with-warnings | |
1319 | (lambda () | |
1320 | (compile '(format #f "~[chbouib~;~a~;~2*~a~]") | |
1321 | #:opts %opts-w-format | |
1322 | #:to 'assembly))))) | |
1323 | (and (= (length w) 1) | |
1324 | (number? (string-contains (car w) | |
1325 | "expected 1 to 4, got 0"))))) | |
1326 | ||
1327 | (pass-if "@" | |
1328 | (let ((w (call-with-warnings | |
1329 | (lambda () | |
1330 | (compile '(format #f "~@[temperature=~d~]") | |
1331 | #:opts %opts-w-format | |
1332 | #:to 'assembly))))) | |
1333 | (and (= (length w) 1) | |
1334 | (number? (string-contains (car w) | |
1335 | "expected 1, got 0"))))) | |
1336 | ||
1337 | (pass-if "nested" | |
1338 | (let ((w (call-with-warnings | |
1339 | (lambda () | |
1340 | (compile '(format #f "~:[~[hey~;~a~;~va~]~;~3*~]") | |
1341 | #:opts %opts-w-format | |
1342 | #:to 'assembly))))) | |
1343 | (and (= (length w) 1) | |
1344 | (number? (string-contains (car w) | |
1345 | "expected 2 to 4, got 0"))))) | |
1346 | ||
8e6c15a6 LC |
1347 | (pass-if "unterminated" |
1348 | (let ((w (call-with-warnings | |
1349 | (lambda () | |
1350 | (compile '(format #f "~[unterminated") | |
1351 | #:opts %opts-w-format | |
1352 | #:to 'assembly))))) | |
1353 | (and (= (length w) 1) | |
1354 | (number? (string-contains (car w) | |
1355 | "unterminated conditional"))))) | |
1356 | ||
1357 | (pass-if "unexpected ~;" | |
1358 | (let ((w (call-with-warnings | |
1359 | (lambda () | |
1360 | (compile '(format #f "foo~;bar") | |
1361 | #:opts %opts-w-format | |
1362 | #:to 'assembly))))) | |
1363 | (and (= (length w) 1) | |
1364 | (number? (string-contains (car w) | |
1365 | "unexpected"))))) | |
1366 | ||
1367 | (pass-if "unexpected ~]" | |
1368 | (let ((w (call-with-warnings | |
1369 | (lambda () | |
1370 | (compile '(format #f "foo~]") | |
1371 | #:opts %opts-w-format | |
1372 | #:to 'assembly))))) | |
1373 | (and (= (length w) 1) | |
1374 | (number? (string-contains (car w) | |
1375 | "unexpected")))))) | |
e0697241 LC |
1376 | |
1377 | (pass-if "~{...~}" | |
1378 | (null? (call-with-warnings | |
1379 | (lambda () | |
1380 | (compile '(format #f "~A ~{~S~} ~A" | |
1381 | 'hello '("ladies" "and") | |
1382 | 'gentlemen) | |
1383 | #:opts %opts-w-format | |
1384 | #:to 'assembly))))) | |
1385 | ||
1386 | (pass-if "~{...~}, too many args" | |
1387 | (let ((w (call-with-warnings | |
1388 | (lambda () | |
1389 | (compile '(format #f "~{~S~}" 1 2 3) | |
1390 | #:opts %opts-w-format | |
1391 | #:to 'assembly))))) | |
1392 | (and (= (length w) 1) | |
1393 | (number? (string-contains (car w) | |
1394 | "expected 1, got 3"))))) | |
1395 | ||
1396 | (pass-if "~@{...~}" | |
1397 | (null? (call-with-warnings | |
1398 | (lambda () | |
1399 | (compile '(format #f "~@{~S~}" 1 2 3) | |
1400 | #:opts %opts-w-format | |
1401 | #:to 'assembly))))) | |
1402 | ||
1403 | (pass-if "~@{...~}, too few args" | |
1404 | (let ((w (call-with-warnings | |
1405 | (lambda () | |
1406 | (compile '(format #f "~A ~@{~S~}") | |
1407 | #:opts %opts-w-format | |
1408 | #:to 'assembly))))) | |
1409 | (and (= (length w) 1) | |
1410 | (number? (string-contains (car w) | |
1411 | "expected at least 1, got 0"))))) | |
1412 | ||
8e6c15a6 LC |
1413 | (pass-if "unterminated ~{...~}" |
1414 | (let ((w (call-with-warnings | |
1415 | (lambda () | |
1416 | (compile '(format #f "~{") | |
1417 | #:opts %opts-w-format | |
1418 | #:to 'assembly))))) | |
1419 | (and (= (length w) 1) | |
1420 | (number? (string-contains (car w) | |
1421 | "unterminated"))))) | |
1422 | ||
e0697241 LC |
1423 | (pass-if "~(...~)" |
1424 | (null? (call-with-warnings | |
1425 | (lambda () | |
1426 | (compile '(format #f "~:@(~A ~A~)" 'foo 'bar) | |
1427 | #:opts %opts-w-format | |
1428 | #:to 'assembly))))) | |
1429 | ||
1430 | (pass-if "~v" | |
1431 | (let ((w (call-with-warnings | |
1432 | (lambda () | |
1433 | (compile '(format #f "~v_foo") | |
1434 | #:opts %opts-w-format | |
1435 | #:to 'assembly))))) | |
1436 | (and (= (length w) 1) | |
1437 | (number? (string-contains (car w) | |
1438 | "expected 1, got 0"))))) | |
1439 | (pass-if "~v:@y" | |
1440 | (null? (call-with-warnings | |
1441 | (lambda () | |
1442 | (compile '(format #f "~v:@y" 1 123) | |
1443 | #:opts %opts-w-format | |
1444 | #:to 'assembly))))) | |
1445 | ||
1446 | ||
1447 | (pass-if "~*" | |
1448 | (let ((w (call-with-warnings | |
1449 | (lambda () | |
1450 | (compile '(format #f "~2*~a" 'a 'b) | |
1451 | #:opts %opts-w-format | |
1452 | #:to 'assembly))))) | |
1453 | (and (= (length w) 1) | |
1454 | (number? (string-contains (car w) | |
1455 | "expected 3, got 2"))))) | |
1456 | ||
1457 | (pass-if "~?" | |
1458 | (null? (call-with-warnings | |
1459 | (lambda () | |
1460 | (compile '(format #f "~?" "~d ~d" '(1 2)) | |
1461 | #:opts %opts-w-format | |
1462 | #:to 'assembly))))) | |
1463 | ||
1464 | (pass-if "complex 1" | |
1465 | (let ((w (call-with-warnings | |
1466 | (lambda () | |
1467 | (compile '(format #f | |
1468 | "~4@S ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n" | |
1469 | 1 2 3 4 5 6) | |
1470 | #:opts %opts-w-format | |
1471 | #:to 'assembly))))) | |
1472 | (and (= (length w) 1) | |
1473 | (number? (string-contains (car w) | |
1474 | "expected 4, got 6"))))) | |
1475 | ||
1476 | (pass-if "complex 2" | |
1477 | (let ((w (call-with-warnings | |
1478 | (lambda () | |
1479 | (compile '(format #f | |
1480 | "~:(~A~) Commands~:[~; [abbrev]~]:~2%" | |
1481 | 1 2 3 4) | |
1482 | #:opts %opts-w-format | |
1483 | #:to 'assembly))))) | |
1484 | (and (= (length w) 1) | |
1485 | (number? (string-contains (car w) | |
1486 | "expected 2, got 4"))))) | |
1487 | ||
1488 | (pass-if "complex 3" | |
1489 | (let ((w (call-with-warnings | |
1490 | (lambda () | |
1491 | (compile '(format #f "~9@a~:[~*~3_~;~3d~] ~v:@y~%") | |
1492 | #:opts %opts-w-format | |
1493 | #:to 'assembly))))) | |
1494 | (and (= (length w) 1) | |
1495 | (number? (string-contains (car w) | |
1496 | "expected 5, got 0"))))) | |
1497 | ||
75365375 LC |
1498 | (pass-if "ice-9 format" |
1499 | (let ((w (call-with-warnings | |
1500 | (lambda () | |
1501 | (let ((in (open-input-string | |
1502 | "(use-modules ((ice-9 format) | |
1503 | #:renamer (symbol-prefix-proc 'i9-))) | |
1504 | (i9-format #t \"yo! ~A\" 1 2)"))) | |
1505 | (read-and-compile in | |
1506 | #:opts %opts-w-format | |
1507 | #:to 'assembly)))))) | |
1508 | (and (= (length w) 1) | |
1509 | (number? (string-contains (car w) | |
1510 | "expected 1, got 2"))))) | |
1511 | ||
1512 | (pass-if "not format" | |
1513 | (null? (call-with-warnings | |
1514 | (lambda () | |
1515 | (compile '(let ((format chbouib)) | |
1516 | (format #t "not ~A a format string")) | |
1517 | #:opts %opts-w-format | |
1518 | #:to 'assembly))))))) |