1 ;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
2 ;;;; Andy Wingo <wingo@pobox.com> --- May 2009
4 ;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
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.
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.
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
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)
24 #:use-module (system base message)
25 #:use-module (language tree-il)
26 #:use-module (language tree-il primitives)
27 #:use-module (language glil)
28 #:use-module (srfi srfi-13))
30 ;; Of course, the GLIL that is emitted depends on the source info of the
31 ;; input. Here we're not concerned about that, so we strip source
32 ;; information from the incoming tree-il.
34 (define (strip-source x)
35 (post-order! (lambda (x) (set! (tree-il-src x) #f))
38 (define-syntax assert-tree-il->glil
39 (syntax-rules (with-partial-evaluation without-partial-evaluation
41 ((_ with-partial-evaluation in pat test ...)
42 (assert-tree-il->glil with-options (#:partial-eval? #t)
44 ((_ without-partial-evaluation in pat test ...)
45 (assert-tree-il->glil with-options (#:partial-eval? #f)
47 ((_ with-options opts in pat test ...)
50 (let ((glil (unparse-glil
51 (compile (strip-source (parse-tree-il exp))
52 #:from 'tree-il #:to 'glil
55 (pat (guard test ...) #t)
58 (assert-tree-il->glil with-partial-evaluation
61 (define-syntax-rule (pass-if-primitives-resolved in expected)
62 (pass-if (format #f "primitives-resolved in ~s" 'in)
63 (let* ((module (let ((m (make-module)))
64 (beautify-user-module! m)
66 (orig (parse-tree-il 'in))
67 (resolved (expand-primitives! (resolve-primitives! orig module))))
68 (or (equal? (unparse-tree-il resolved) 'expected)
70 (format (current-error-port)
71 "primitive test failed: got ~s, expected ~s"
75 (define-syntax pass-if-tree-il->scheme
78 (assert-scheme->tree-il->scheme in pat #t))
81 (pmatch (tree-il->scheme
82 (compile 'in #:from 'scheme #:to 'tree-il))
83 (pat (guard guard-exp) #t)
87 (with-test-prefix "primitives"
89 (with-test-prefix "eqv?"
91 (pass-if-primitives-resolved
92 (apply (primitive eqv?) (const #f) (toplevel x))
93 (apply (primitive eq?) (const #f) (toplevel x)))
95 (pass-if-primitives-resolved
96 (apply (primitive eqv?) (const ()) (toplevel x))
97 (apply (primitive eq?) (const ()) (toplevel x)))
99 (pass-if-primitives-resolved
100 (apply (primitive eqv?) (const #t) (lexical x y))
101 (apply (primitive eq?) (const #t) (lexical x y)))
103 (pass-if-primitives-resolved
104 (apply (primitive eqv?) (const this-is-a-symbol) (toplevel x))
105 (apply (primitive eq?) (const this-is-a-symbol) (toplevel x)))
107 (pass-if-primitives-resolved
108 (apply (primitive eqv?) (const 42) (toplevel x))
109 (apply (primitive eq?) (const 42) (toplevel x)))
111 (pass-if-primitives-resolved
112 (apply (primitive eqv?) (const 42.0) (toplevel x))
113 (apply (primitive eqv?) (const 42.0) (toplevel x)))
115 (pass-if-primitives-resolved
116 (apply (primitive eqv?) (const #nil) (toplevel x))
117 (apply (primitive eq?) (const #nil) (toplevel x))))
119 (with-test-prefix "equal?"
121 (pass-if-primitives-resolved
122 (apply (primitive equal?) (const #f) (toplevel x))
123 (apply (primitive eq?) (const #f) (toplevel x)))
125 (pass-if-primitives-resolved
126 (apply (primitive equal?) (const ()) (toplevel x))
127 (apply (primitive eq?) (const ()) (toplevel x)))
129 (pass-if-primitives-resolved
130 (apply (primitive equal?) (const #t) (lexical x y))
131 (apply (primitive eq?) (const #t) (lexical x y)))
133 (pass-if-primitives-resolved
134 (apply (primitive equal?) (const this-is-a-symbol) (toplevel x))
135 (apply (primitive eq?) (const this-is-a-symbol) (toplevel x)))
137 (pass-if-primitives-resolved
138 (apply (primitive equal?) (const 42) (toplevel x))
139 (apply (primitive eq?) (const 42) (toplevel x)))
141 (pass-if-primitives-resolved
142 (apply (primitive equal?) (const 42.0) (toplevel x))
143 (apply (primitive equal?) (const 42.0) (toplevel x)))
145 (pass-if-primitives-resolved
146 (apply (primitive equal?) (const #nil) (toplevel x))
147 (apply (primitive eq?) (const #nil) (toplevel x)))))
150 (with-test-prefix "tree-il->scheme"
151 (pass-if-tree-il->scheme
152 (case-lambda ((a) a) ((b c) (list b c)))
153 (case-lambda ((,a) ,a1) ((,b ,c) (list ,b1 ,c1)))
154 (and (eq? a a1) (eq? b b1) (eq? c c1))))
156 (with-test-prefix "void"
157 (assert-tree-il->glil
159 (program () (std-prelude 0 0 #f) (label _) (void) (call return 1)))
160 (assert-tree-il->glil
161 (begin (void) (const 1))
162 (program () (std-prelude 0 0 #f) (label _) (const 1) (call return 1)))
163 (assert-tree-il->glil
164 (apply (primitive +) (void) (const 1))
165 (program () (std-prelude 0 0 #f) (label _) (void) (call add1 1) (call return 1))))
167 (with-test-prefix "application"
168 (assert-tree-il->glil
169 (apply (toplevel foo) (const 1))
170 (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (const 1) (call tail-call 1)))
171 (assert-tree-il->glil
172 (begin (apply (toplevel foo) (const 1)) (void))
173 (program () (std-prelude 0 0 #f) (label _) (call new-frame 0) (toplevel ref foo) (const 1) (mv-call 1 ,l1)
174 (call drop 1) (branch br ,l2)
175 (label ,l3) (mv-bind 0 #f)
177 (void) (call return 1))
178 (and (eq? l1 l3) (eq? l2 l4)))
179 (assert-tree-il->glil
180 (apply (toplevel foo) (apply (toplevel bar)))
181 (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call new-frame 0) (toplevel ref bar) (call call 0)
182 (call tail-call 1))))
184 (with-test-prefix "conditional"
185 (assert-tree-il->glil
186 (if (toplevel foo) (const 1) (const 2))
187 (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1)
188 (const 1) (call return 1)
189 (label ,l2) (const 2) (call return 1))
192 (assert-tree-il->glil without-partial-evaluation
193 (begin (if (toplevel foo) (const 1) (const 2)) (const #f))
194 (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1) (branch br ,l2)
195 (label ,l3) (label ,l4) (const #f) (call return 1))
196 (eq? l1 l3) (eq? l2 l4))
198 (assert-tree-il->glil
199 (apply (primitive null?) (if (toplevel foo) (const 1) (const 2)))
200 (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1)
201 (const 1) (branch br ,l2)
202 (label ,l3) (const 2) (label ,l4)
203 (call null? 1) (call return 1))
204 (eq? l1 l3) (eq? l2 l4)))
206 (with-test-prefix "primitive-ref"
207 (assert-tree-il->glil
209 (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call return 1)))
211 (assert-tree-il->glil
212 (begin (primitive +) (const #f))
213 (program () (std-prelude 0 0 #f) (label _) (const #f) (call return 1)))
215 (assert-tree-il->glil
216 (apply (primitive null?) (primitive +))
217 (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call null? 1)
220 (with-test-prefix "lexical refs"
221 (assert-tree-il->glil without-partial-evaluation
222 (let (x) (y) ((const 1)) (lexical x y))
223 (program () (std-prelude 0 1 #f) (label _)
224 (const 1) (bind (x #f 0)) (lexical #t #f set 0)
225 (lexical #t #f ref 0) (call return 1)
228 (assert-tree-il->glil with-options (#:partial-eval? #f #:cse? #f)
229 (let (x) (y) ((const 1)) (begin (lexical x y) (const #f)))
230 (program () (std-prelude 0 1 #f) (label _)
231 (const 1) (bind (x #f 0)) (lexical #t #f set 0)
232 (const #f) (call return 1)
235 (assert-tree-il->glil without-partial-evaluation
236 (let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y)))
237 (program () (std-prelude 0 1 #f) (label _)
238 (const 1) (bind (x #f 0)) (lexical #t #f set 0)
239 (lexical #t #f ref 0) (call null? 1) (call return 1)
242 (with-test-prefix "lexical sets"
243 (assert-tree-il->glil
244 ;; unreferenced sets may be optimized away -- make sure they are ref'd
245 (let (x) (y) ((const 1))
246 (set! (lexical x y) (apply (primitive 1+) (lexical x y))))
247 (program () (std-prelude 0 1 #f) (label _)
248 (const 1) (bind (x #t 0)) (lexical #t #t box 0)
249 (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
250 (void) (call return 1)
253 (assert-tree-il->glil
254 (let (x) (y) ((const 1))
255 (begin (set! (lexical x y) (apply (primitive 1+) (lexical x y)))
257 (program () (std-prelude 0 1 #f) (label _)
258 (const 1) (bind (x #t 0)) (lexical #t #t box 0)
259 (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
260 (lexical #t #t ref 0) (call return 1)
263 (assert-tree-il->glil
264 (let (x) (y) ((const 1))
265 (apply (primitive null?)
266 (set! (lexical x y) (apply (primitive 1+) (lexical x y)))))
267 (program () (std-prelude 0 1 #f) (label _)
268 (const 1) (bind (x #t 0)) (lexical #t #t box 0)
269 (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (void)
270 (call null? 1) (call return 1)
273 (with-test-prefix "module refs"
274 (assert-tree-il->glil
276 (program () (std-prelude 0 0 #f) (label _)
277 (module public ref (foo) bar)
280 (assert-tree-il->glil
281 (begin (@ (foo) bar) (const #f))
282 (program () (std-prelude 0 0 #f) (label _)
283 (module public ref (foo) bar) (call drop 1)
284 (const #f) (call return 1)))
286 (assert-tree-il->glil
287 (apply (primitive null?) (@ (foo) bar))
288 (program () (std-prelude 0 0 #f) (label _)
289 (module public ref (foo) bar)
290 (call null? 1) (call return 1)))
292 (assert-tree-il->glil
294 (program () (std-prelude 0 0 #f) (label _)
295 (module private ref (foo) bar)
298 (assert-tree-il->glil
299 (begin (@@ (foo) bar) (const #f))
300 (program () (std-prelude 0 0 #f) (label _)
301 (module private ref (foo) bar) (call drop 1)
302 (const #f) (call return 1)))
304 (assert-tree-il->glil
305 (apply (primitive null?) (@@ (foo) bar))
306 (program () (std-prelude 0 0 #f) (label _)
307 (module private ref (foo) bar)
308 (call null? 1) (call return 1))))
310 (with-test-prefix "module sets"
311 (assert-tree-il->glil
312 (set! (@ (foo) bar) (const 2))
313 (program () (std-prelude 0 0 #f) (label _)
314 (const 2) (module public set (foo) bar)
315 (void) (call return 1)))
317 (assert-tree-il->glil
318 (begin (set! (@ (foo) bar) (const 2)) (const #f))
319 (program () (std-prelude 0 0 #f) (label _)
320 (const 2) (module public set (foo) bar)
321 (const #f) (call return 1)))
323 (assert-tree-il->glil
324 (apply (primitive null?) (set! (@ (foo) bar) (const 2)))
325 (program () (std-prelude 0 0 #f) (label _)
326 (const 2) (module public set (foo) bar)
327 (void) (call null? 1) (call return 1)))
329 (assert-tree-il->glil
330 (set! (@@ (foo) bar) (const 2))
331 (program () (std-prelude 0 0 #f) (label _)
332 (const 2) (module private set (foo) bar)
333 (void) (call return 1)))
335 (assert-tree-il->glil
336 (begin (set! (@@ (foo) bar) (const 2)) (const #f))
337 (program () (std-prelude 0 0 #f) (label _)
338 (const 2) (module private set (foo) bar)
339 (const #f) (call return 1)))
341 (assert-tree-il->glil
342 (apply (primitive null?) (set! (@@ (foo) bar) (const 2)))
343 (program () (std-prelude 0 0 #f) (label _)
344 (const 2) (module private set (foo) bar)
345 (void) (call null? 1) (call return 1))))
347 (with-test-prefix "toplevel refs"
348 (assert-tree-il->glil
350 (program () (std-prelude 0 0 #f) (label _)
354 (assert-tree-il->glil without-partial-evaluation
355 (begin (toplevel bar) (const #f))
356 (program () (std-prelude 0 0 #f) (label _)
357 (toplevel ref bar) (call drop 1)
358 (const #f) (call return 1)))
360 (assert-tree-il->glil
361 (apply (primitive null?) (toplevel bar))
362 (program () (std-prelude 0 0 #f) (label _)
364 (call null? 1) (call return 1))))
366 (with-test-prefix "toplevel sets"
367 (assert-tree-il->glil
368 (set! (toplevel bar) (const 2))
369 (program () (std-prelude 0 0 #f) (label _)
370 (const 2) (toplevel set bar)
371 (void) (call return 1)))
373 (assert-tree-il->glil
374 (begin (set! (toplevel bar) (const 2)) (const #f))
375 (program () (std-prelude 0 0 #f) (label _)
376 (const 2) (toplevel set bar)
377 (const #f) (call return 1)))
379 (assert-tree-il->glil
380 (apply (primitive null?) (set! (toplevel bar) (const 2)))
381 (program () (std-prelude 0 0 #f) (label _)
382 (const 2) (toplevel set bar)
383 (void) (call null? 1) (call return 1))))
385 (with-test-prefix "toplevel defines"
386 (assert-tree-il->glil
387 (define bar (const 2))
388 (program () (std-prelude 0 0 #f) (label _)
389 (const 2) (toplevel define bar)
390 (void) (call return 1)))
392 (assert-tree-il->glil
393 (begin (define bar (const 2)) (const #f))
394 (program () (std-prelude 0 0 #f) (label _)
395 (const 2) (toplevel define bar)
396 (const #f) (call return 1)))
398 (assert-tree-il->glil
399 (apply (primitive null?) (define bar (const 2)))
400 (program () (std-prelude 0 0 #f) (label _)
401 (const 2) (toplevel define bar)
402 (void) (call null? 1) (call return 1))))
404 (with-test-prefix "constants"
405 (assert-tree-il->glil
407 (program () (std-prelude 0 0 #f) (label _)
408 (const 2) (call return 1)))
410 (assert-tree-il->glil
411 (begin (const 2) (const #f))
412 (program () (std-prelude 0 0 #f) (label _)
413 (const #f) (call return 1)))
415 (assert-tree-il->glil
416 ;; This gets simplified by `peval'.
417 (apply (primitive null?) (const 2))
418 (program () (std-prelude 0 0 #f) (label _)
419 (const #f) (call return 1))))
421 (with-test-prefix "letrec"
422 ;; simple bindings -> let
423 (assert-tree-il->glil without-partial-evaluation
424 (letrec (x y) (x1 y1) ((const 10) (const 20))
425 (apply (toplevel foo) (lexical x x1) (lexical y y1)))
426 (program () (std-prelude 0 2 #f) (label _)
427 (const 10) (const 20)
428 (bind (x #f 0) (y #f 1))
429 (lexical #t #f set 1) (lexical #t #f set 0)
431 (lexical #t #f ref 0) (lexical #t #f ref 1)
435 ;; complex bindings -> box and set! within let
436 (assert-tree-il->glil without-partial-evaluation
437 (letrec (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar)))
438 (apply (primitive +) (lexical x x1) (lexical y y1)))
439 (program () (std-prelude 0 4 #f) (label _)
440 (void) (void) ;; what are these?
441 (bind (x #t 0) (y #t 1))
442 (lexical #t #t box 1) (lexical #t #t box 0)
443 (call new-frame 0) (toplevel ref foo) (call call 0)
444 (call new-frame 0) (toplevel ref bar) (call call 0)
445 (bind (x #f 2) (y #f 3)) (lexical #t #f set 3) (lexical #t #f set 2)
446 (lexical #t #f ref 2) (lexical #t #t set 0)
447 (lexical #t #f ref 3) (lexical #t #t set 1)
448 (void) (lexical #t #f set 2) (void) (lexical #t #f set 3) ;; clear bindings
450 (lexical #t #t ref 0) (lexical #t #t ref 1)
451 (call add 2) (call return 1) (unbind)))
453 ;; complex bindings in letrec* -> box and set! in order
454 (assert-tree-il->glil without-partial-evaluation
455 (letrec* (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar)))
456 (apply (primitive +) (lexical x x1) (lexical y y1)))
457 (program () (std-prelude 0 2 #f) (label _)
458 (void) (void) ;; what are these?
459 (bind (x #t 0) (y #t 1))
460 (lexical #t #t box 1) (lexical #t #t box 0)
461 (call new-frame 0) (toplevel ref foo) (call call 0)
462 (lexical #t #t set 0)
463 (call new-frame 0) (toplevel ref bar) (call call 0)
464 (lexical #t #t set 1)
465 (lexical #t #t ref 0)
466 (lexical #t #t ref 1)
467 (call add 2) (call return 1) (unbind)))
469 ;; simple bindings in letrec* -> equivalent to letrec
470 (assert-tree-il->glil without-partial-evaluation
471 (letrec* (x y) (xx yy) ((const 1) (const 2))
473 (program () (std-prelude 0 1 #f) (label _)
475 (bind (y #f 0)) ;; X is removed, and Y is unboxed
476 (lexical #t #f set 0)
477 (lexical #t #f ref 0)
478 (call return 1) (unbind))))
480 (with-test-prefix "lambda"
481 (assert-tree-il->glil
483 (lambda-case (((x) #f #f #f () (y)) (const 2)) #f))
484 (program () (std-prelude 0 0 #f) (label _)
485 (program () (std-prelude 1 1 #f)
486 (bind (x #f 0)) (label _)
487 (const 2) (call return 1) (unbind))
490 (assert-tree-il->glil
492 (lambda-case (((x y) #f #f #f () (x1 y1))
495 (program () (std-prelude 0 0 #f) (label _)
496 (program () (std-prelude 2 2 #f)
497 (bind (x #f 0) (y #f 1)) (label _)
498 (const 2) (call return 1)
502 (assert-tree-il->glil
504 (lambda-case ((() #f x #f () (y)) (const 2))
506 (program () (std-prelude 0 0 #f) (label _)
507 (program () (opt-prelude 0 0 0 1 #f)
508 (bind (x #f 0)) (label _)
509 (const 2) (call return 1)
513 (assert-tree-il->glil
515 (lambda-case (((x) #f x1 #f () (y y1)) (const 2))
517 (program () (std-prelude 0 0 #f) (label _)
518 (program () (opt-prelude 1 0 1 2 #f)
519 (bind (x #f 0) (x1 #f 1)) (label _)
520 (const 2) (call return 1)
524 (assert-tree-il->glil
526 (lambda-case (((x) #f x1 #f () (y y1)) (lexical x y))
528 (program () (std-prelude 0 0 #f) (label _)
529 (program () (opt-prelude 1 0 1 2 #f)
530 (bind (x #f 0) (x1 #f 1)) (label _)
531 (lexical #t #f ref 0) (call return 1)
535 (assert-tree-il->glil
537 (lambda-case (((x) #f x1 #f () (y y1)) (lexical x1 y1))
539 (program () (std-prelude 0 0 #f) (label _)
540 (program () (opt-prelude 1 0 1 2 #f)
541 (bind (x #f 0) (x1 #f 1)) (label _)
542 (lexical #t #f ref 1) (call return 1)
546 (assert-tree-il->glil
548 (lambda-case (((x) #f #f #f () (x1))
550 (lambda-case (((y) #f #f #f () (y1))
554 (program () (std-prelude 0 0 #f) (label _)
555 (program () (std-prelude 1 1 #f)
556 (bind (x #f 0)) (label _)
557 (program () (std-prelude 1 1 #f)
558 (bind (y #f 0)) (label _)
559 (lexical #f #f ref 0) (call return 1)
561 (lexical #t #f ref 0)
562 (call make-closure 1)
567 (with-test-prefix "sequence"
568 (assert-tree-il->glil
569 (begin (begin (const 2) (const #f)) (const #t))
570 (program () (std-prelude 0 0 #f) (label _)
571 (const #t) (call return 1)))
573 (assert-tree-il->glil
574 ;; This gets simplified by `peval'.
575 (apply (primitive null?) (begin (const #f) (const 2)))
576 (program () (std-prelude 0 0 #f) (label _)
577 (const #f) (call return 1))))
579 (with-test-prefix "values"
580 (assert-tree-il->glil
581 (apply (primitive values)
582 (apply (primitive values) (const 1) (const 2)))
583 (program () (std-prelude 0 0 #f) (label _)
584 (const 1) (call return 1)))
586 (assert-tree-il->glil
587 (apply (primitive values)
588 (apply (primitive values) (const 1) (const 2))
590 (program () (std-prelude 0 0 #f) (label _)
591 (const 1) (const 3) (call return/values 2)))
593 (assert-tree-il->glil
595 (apply (primitive values) (const 1) (const 2)))
596 (program () (std-prelude 0 0 #f) (label _)
597 (const 1) (call return 1)))
599 ;; Testing `(values foo)' in push context with RA.
600 (assert-tree-il->glil without-partial-evaluation
601 (apply (primitive cdr)
602 (letrec (lp) (#{lp ~V9KrhVD4PFEL6oCTrLg3A}#)
603 ((lambda ((name . lp))
604 (lambda-case ((() #f #f #f () ())
605 (apply (toplevel values) (const (one two)))))))
606 (apply (lexical lp #{lp ~V9KrhVD4PFEL6oCTrLg3A}#))))
607 (program () (std-prelude 0 0 #f) (label _)
608 (branch br _) ;; entering the fix, jump to :2
609 ;; :1 body of lp, jump to :3
610 (label _) (bind) (const (one two)) (branch br _) (unbind)
611 ;; :2 initial call of lp, jump to :1
612 (label _) (bind) (branch br _) (label _) (unbind)
613 ;; :3 the push continuation
614 (call cdr 1) (call return 1))))
616 ;; FIXME: binding info for or-hacked locals might bork the disassembler,
617 ;; and could be tightened in any case
618 (with-test-prefix "the or hack"
619 (assert-tree-il->glil without-partial-evaluation
620 (let (x) (y) ((const 1))
623 (let (a) (b) ((const 2))
625 (program () (std-prelude 0 1 #f) (label _)
626 (const 1) (bind (x #f 0)) (lexical #t #f set 0)
627 (lexical #t #f ref 0) (branch br-if-not ,l1)
628 (lexical #t #f ref 0) (call return 1)
630 (const 2) (bind (a #f 0)) (lexical #t #f set 0)
631 (lexical #t #f ref 0) (call return 1)
636 ;; second bound var is unreferenced
637 (assert-tree-il->glil without-partial-evaluation
638 (let (x) (y) ((const 1))
641 (let (a) (b) ((const 2))
643 (program () (std-prelude 0 1 #f) (label _)
644 (const 1) (bind (x #f 0)) (lexical #t #f set 0)
645 (lexical #t #f ref 0) (branch br-if-not ,l1)
646 (lexical #t #f ref 0) (call return 1)
648 (lexical #t #f ref 0) (call return 1)
652 (with-test-prefix "apply"
653 (assert-tree-il->glil
654 (apply (primitive @apply) (toplevel foo) (toplevel bar))
655 (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (toplevel ref bar) (call tail-apply 2)))
656 (assert-tree-il->glil
657 (begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void))
658 (program () (std-prelude 0 0 #f) (label _)
659 (call new-frame 0) (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1)
660 (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
662 (void) (call return 1))
663 (and (eq? l1 l3) (eq? l2 l4)))
664 (assert-tree-il->glil
665 (apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz)))
666 (program () (std-prelude 0 0 #f) (label _)
668 (call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call apply 2)
669 (call tail-call 1))))
671 (with-test-prefix "call/cc"
672 (assert-tree-il->glil
673 (apply (primitive @call-with-current-continuation) (toplevel foo))
674 (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call tail-call/cc 1)))
675 (assert-tree-il->glil
676 (begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void))
677 (program () (std-prelude 0 0 #f) (label _)
678 (call new-frame 0) (toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1)
679 (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
681 (void) (call return 1))
682 (and (eq? l1 l3) (eq? l2 l4)))
683 (assert-tree-il->glil
684 (apply (toplevel foo)
685 (apply (toplevel @call-with-current-continuation) (toplevel bar)))
686 (program () (std-prelude 0 0 #f) (label _)
688 (toplevel ref bar) (call call/cc 1)
689 (call tail-call 1))))
692 (with-test-prefix "labels allocation"
693 (pass-if "http://debbugs.gnu.org/9769"
694 ((compile '(lambda ()
695 (let ((fail (lambda () #f)))
696 (let ((test (lambda () (fail))))
699 ;; Prevent inlining. We're testing analyze.scm's
700 ;; labels allocator here, and inlining it will
701 ;; reduce the entire thing to #t.
702 #:opts '(#:partial-eval? #f)))))
705 (with-test-prefix "tree-il-fold"
707 (pass-if "empty tree"
708 (let ((leaf? #f) (up? #f) (down? #f) (mark (list 'mark)))
710 (tree-il-fold (lambda (x y) (set! leaf? #t) y)
711 (lambda (x y) (set! down? #t) y)
712 (lambda (x y) (set! up? #t) y)
719 (pass-if "lambda and application"
720 (let* ((leaves '()) (ups '()) (downs '())
721 (result (tree-il-fold (lambda (x y)
722 (set! leaves (cons x leaves))
725 (set! downs (cons x downs))
728 (set! ups (cons x ups))
734 (((x y) #f #f #f () (x1 y1))
739 (and (equal? (map strip-source leaves)
740 (list (make-lexical-ref #f 'y 'y1)
741 (make-lexical-ref #f 'x 'x1)
742 (make-toplevel-ref #f '+)))
744 (equal? (reverse (map strip-source ups))
745 (map strip-source downs))))))
752 ;; Make sure we get English messages.
753 (setlocale LC_ALL "C")
755 (define (call-with-warnings thunk)
756 (let ((port (open-output-string)))
757 (with-fluids ((*current-warning-port* port)
758 (*current-warning-prefix* ""))
760 (let ((warnings (get-output-string port)))
761 (string-tokenize warnings
762 (char-set-complement (char-set #\newline))))))
764 (define %opts-w-unused
765 '(#:warnings (unused-variable)))
767 (define %opts-w-unused-toplevel
768 '(#:warnings (unused-toplevel)))
770 (define %opts-w-unbound
771 '(#:warnings (unbound-variable)))
773 (define %opts-w-arity
774 '(#:warnings (arity-mismatch)))
776 (define %opts-w-format
777 '(#:warnings (format)))
779 (define %opts-w-duplicate-case-datum
780 '(#:warnings (duplicate-case-datum)))
782 (define %opts-w-bad-case-datum
783 '(#:warnings (bad-case-datum)))
786 (with-test-prefix "warnings"
788 (pass-if "unknown warning type"
789 (let ((w (call-with-warnings
791 (compile #t #:opts '(#:warnings (does-not-exist)))))))
792 (and (= (length w) 1)
793 (number? (string-contains (car w) "unknown warning")))))
795 (with-test-prefix "unused-variable"
798 (null? (call-with-warnings
800 (compile '(lambda (x y) (+ x y))
801 #:opts %opts-w-unused)))))
803 (pass-if "let/unused"
804 (let ((w (call-with-warnings
806 (compile '(lambda (x)
809 #:opts %opts-w-unused)))))
810 (and (= (length w) 1)
811 (number? (string-contains (car w) "unused variable `y'")))))
813 (pass-if "shadowed variable"
814 (let ((w (call-with-warnings
816 (compile '(lambda (x)
820 #:opts %opts-w-unused)))))
821 (and (= (length w) 1)
822 (number? (string-contains (car w) "unused variable `y'")))))
825 (null? (call-with-warnings
828 (letrec ((x (lambda () (y)))
831 #:opts %opts-w-unused)))))
833 (pass-if "unused argument"
834 ;; Unused arguments should not be reported.
835 (null? (call-with-warnings
837 (compile '(lambda (x y z) #t)
838 #:opts %opts-w-unused)))))
840 (pass-if "special variable names"
841 (null? (call-with-warnings
844 (let ((_ 'underscore)
845 (#{gensym name}# 'ignore-me))
848 #:opts %opts-w-unused))))))
850 (with-test-prefix "unused-toplevel"
852 (pass-if "used after definition"
853 (null? (call-with-warnings
855 (let ((in (open-input-string
856 "(define foo 2) foo")))
859 #:opts %opts-w-unused-toplevel))))))
861 (pass-if "used before definition"
862 (null? (call-with-warnings
864 (let ((in (open-input-string
865 "(define (bar) foo) (define foo 2) (bar)")))
868 #:opts %opts-w-unused-toplevel))))))
870 (pass-if "unused but public"
871 (let ((in (open-input-string
872 "(define-module (test-suite tree-il x) #:export (bar))
873 (define (bar) #t)")))
874 (null? (call-with-warnings
878 #:opts %opts-w-unused-toplevel))))))
880 (pass-if "unused but public (more)"
881 (let ((in (open-input-string
882 "(define-module (test-suite tree-il x) #:export (bar))
885 (define (foo) #t)")))
886 (null? (call-with-warnings
890 #:opts %opts-w-unused-toplevel))))))
892 (pass-if "unused but define-public"
893 (null? (call-with-warnings
895 (compile '(define-public foo 2)
897 #:opts %opts-w-unused-toplevel)))))
899 (pass-if "used by macro"
900 ;; FIXME: See comment about macros at `unused-toplevel-analysis'.
903 (null? (call-with-warnings
905 (let ((in (open-input-string
908 (syntax-rules () ((_) (bar))))")))
911 #:opts %opts-w-unused-toplevel))))))
914 (let ((w (call-with-warnings
916 (compile '(define foo 2)
918 #:opts %opts-w-unused-toplevel)))))
919 (and (= (length w) 1)
920 (number? (string-contains (car w)
921 (format #f "top-level variable `~A'"
924 (pass-if "unused recursive"
925 (let ((w (call-with-warnings
927 (compile '(define (foo) (foo))
929 #:opts %opts-w-unused-toplevel)))))
930 (and (= (length w) 1)
931 (number? (string-contains (car w)
932 (format #f "top-level variable `~A'"
935 (pass-if "unused mutually recursive"
936 (let* ((in (open-input-string
937 "(define (foo) (bar)) (define (bar) (foo))"))
938 (w (call-with-warnings
942 #:opts %opts-w-unused-toplevel)))))
943 (and (= (length w) 2)
944 (number? (string-contains (car w)
945 (format #f "top-level variable `~A'"
947 (number? (string-contains (cadr w)
948 (format #f "top-level variable `~A'"
951 (pass-if "special variable names"
952 (null? (call-with-warnings
954 (compile '(define #{gensym name}# 'ignore-me)
956 #:opts %opts-w-unused-toplevel))))))
958 (with-test-prefix "unbound variable"
961 (null? (call-with-warnings
963 (compile '+ #:opts %opts-w-unbound)))))
967 (w (call-with-warnings
971 #:opts %opts-w-unbound)))))
972 (and (= (length w) 1)
973 (number? (string-contains (car w)
974 (format #f "unbound variable `~A'"
979 (w (call-with-warnings
981 (compile `(set! ,v 7)
983 #:opts %opts-w-unbound)))))
984 (and (= (length w) 1)
985 (number? (string-contains (car w)
986 (format #f "unbound variable `~A'"
989 (pass-if "module-local top-level is visible"
990 (let ((m (make-module))
992 (beautify-user-module! m)
993 (compile `(define ,v 123)
994 #:env m #:opts %opts-w-unbound)
995 (null? (call-with-warnings
1000 #:opts %opts-w-unbound))))))
1002 (pass-if "module-local top-level is visible after"
1003 (let ((m (make-module))
1005 (beautify-user-module! m)
1006 (null? (call-with-warnings
1008 (let ((in (open-input-string
1011 (define chbouib 5)")))
1012 (read-and-compile in
1014 #:opts %opts-w-unbound)))))))
1016 (pass-if "optional arguments are visible"
1017 (null? (call-with-warnings
1019 (compile '(lambda* (x #:optional y z) (list x y z))
1020 #:opts %opts-w-unbound
1023 (pass-if "keyword arguments are visible"
1024 (null? (call-with-warnings
1026 (compile '(lambda* (x #:key y z) (list x y z))
1027 #:opts %opts-w-unbound
1030 (pass-if "GOOPS definitions are visible"
1031 (let ((m (make-module))
1033 (beautify-user-module! m)
1034 (module-use! m (resolve-interface '(oop goops)))
1035 (null? (call-with-warnings
1037 (let ((in (open-input-string
1038 "(define-class <foo> ()
1039 (bar #:getter foo-bar))
1040 (define z (foo-bar (make <foo>)))")))
1041 (read-and-compile in
1043 #:opts %opts-w-unbound))))))))
1045 (with-test-prefix "arity mismatch"
1048 (null? (call-with-warnings
1050 (compile '(cons 'a 'b) #:opts %opts-w-arity)))))
1052 (pass-if "direct application"
1053 (let ((w (call-with-warnings
1055 (compile '((lambda (x y) (or x y)) 1 2 3 4 5)
1056 #:opts %opts-w-arity
1058 (and (= (length w) 1)
1059 (number? (string-contains (car w)
1060 "wrong number of arguments to")))))
1062 (let ((w (call-with-warnings
1064 (compile '(let ((f (lambda (x y) (+ x y))))
1066 #:opts %opts-w-arity
1068 (and (= (length w) 1)
1069 (number? (string-contains (car w)
1070 "wrong number of arguments to")))))
1073 (let ((w (call-with-warnings
1075 (compile '(cons 1 2 3 4)
1076 #:opts %opts-w-arity
1078 (and (= (length w) 1)
1079 (number? (string-contains (car w)
1080 "wrong number of arguments to")))))
1082 (pass-if "alias to global"
1083 (let ((w (call-with-warnings
1085 (compile '(let ((f cons)) (f 1 2 3 4))
1086 #:opts %opts-w-arity
1088 (and (= (length w) 1)
1089 (number? (string-contains (car w)
1090 "wrong number of arguments to")))))
1092 (pass-if "alias to lexical to global"
1093 (let ((w (call-with-warnings
1095 (compile '(let ((f number?))
1098 #:opts %opts-w-arity
1100 (and (= (length w) 1)
1101 (number? (string-contains (car w)
1102 "wrong number of arguments to")))))
1104 (pass-if "alias to lexical"
1105 (let ((w (call-with-warnings
1107 (compile '(let ((f (lambda (x y z) (+ x y z))))
1110 #:opts %opts-w-arity
1112 (and (= (length w) 1)
1113 (number? (string-contains (car w)
1114 "wrong number of arguments to")))))
1117 (let ((w (call-with-warnings
1119 (compile '(letrec ((odd? (lambda (x) (even? (1- x))))
1124 #:opts %opts-w-arity
1126 (and (= (length w) 1)
1127 (number? (string-contains (car w)
1128 "wrong number of arguments to")))))
1130 (pass-if "case-lambda"
1131 (null? (call-with-warnings
1133 (compile '(let ((f (case-lambda
1140 #:opts %opts-w-arity
1143 (pass-if "case-lambda with wrong number of arguments"
1144 (let ((w (call-with-warnings
1146 (compile '(let ((f (case-lambda
1150 #:opts %opts-w-arity
1152 (and (= (length w) 1)
1153 (number? (string-contains (car w)
1154 "wrong number of arguments to")))))
1156 (pass-if "case-lambda*"
1157 (null? (call-with-warnings
1159 (compile '(let ((f (case-lambda*
1160 ((x #:optional y) 1)
1162 ((x y #:key z) 3))))
1167 #:opts %opts-w-arity
1170 (pass-if "case-lambda* with wrong arguments"
1171 (let ((w (call-with-warnings
1173 (compile '(let ((f (case-lambda*
1174 ((x #:optional y) 1)
1176 ((x y #:key z) 3))))
1179 #:opts %opts-w-arity
1181 (and (= (length w) 2)
1182 (null? (filter (lambda (w)
1186 w "wrong number of arguments to"))))
1189 (pass-if "top-level applicable struct"
1190 (null? (call-with-warnings
1192 (compile '(let ((p current-warning-port))
1195 #:opts %opts-w-arity
1198 (pass-if "top-level applicable struct with wrong arguments"
1199 (let ((w (call-with-warnings
1201 (compile '(let ((p current-warning-port))
1203 #:opts %opts-w-arity
1205 (and (= (length w) 1)
1206 (number? (string-contains (car w)
1207 "wrong number of arguments to")))))
1209 (pass-if "local toplevel-defines"
1210 (let ((w (call-with-warnings
1212 (let ((in (open-input-string "
1213 (define (g x) (f x))
1215 (read-and-compile in
1216 #:opts %opts-w-arity
1217 #:to 'assembly))))))
1218 (and (= (length w) 1)
1219 (number? (string-contains (car w)
1220 "wrong number of arguments to")))))
1222 (pass-if "global toplevel alias"
1223 (let ((w (call-with-warnings
1225 (let ((in (open-input-string "
1227 (define (g) (f))")))
1228 (read-and-compile in
1229 #:opts %opts-w-arity
1230 #:to 'assembly))))))
1231 (and (= (length w) 1)
1232 (number? (string-contains (car w)
1233 "wrong number of arguments to")))))
1235 (pass-if "local toplevel overrides global"
1236 (null? (call-with-warnings
1238 (let ((in (open-input-string "
1240 (define (foo x) (cons))")))
1241 (read-and-compile in
1242 #:opts %opts-w-arity
1243 #:to 'assembly))))))
1245 (pass-if "keyword not passed and quiet"
1246 (null? (call-with-warnings
1248 (compile '(let ((f (lambda* (x #:key y) y)))
1250 #:opts %opts-w-arity
1253 (pass-if "keyword passed and quiet"
1254 (null? (call-with-warnings
1256 (compile '(let ((f (lambda* (x #:key y) y)))
1258 #:opts %opts-w-arity
1261 (pass-if "keyword passed to global and quiet"
1262 (null? (call-with-warnings
1264 (let ((in (open-input-string "
1265 (use-modules (system base compile))
1266 (compile '(+ 2 3) #:env (current-module))")))
1267 (read-and-compile in
1268 #:opts %opts-w-arity
1269 #:to 'assembly))))))
1271 (pass-if "extra keyword"
1272 (let ((w (call-with-warnings
1274 (compile '(let ((f (lambda* (x #:key y) y)))
1276 #:opts %opts-w-arity
1278 (and (= (length w) 1)
1279 (number? (string-contains (car w)
1280 "wrong number of arguments to")))))
1282 (pass-if "extra keywords allowed"
1283 (null? (call-with-warnings
1285 (compile '(let ((f (lambda* (x #:key y #:allow-other-keys)
1288 #:opts %opts-w-arity
1289 #:to 'assembly))))))
1291 (with-test-prefix "format"
1293 (pass-if "quiet (no args)"
1294 (null? (call-with-warnings
1296 (compile '(format #t "hey!")
1297 #:opts %opts-w-format
1300 (pass-if "quiet (1 arg)"
1301 (null? (call-with-warnings
1303 (compile '(format #t "hey ~A!" "you")
1304 #:opts %opts-w-format
1307 (pass-if "quiet (2 args)"
1308 (null? (call-with-warnings
1310 (compile '(format #t "~A ~A!" "hello" "world")
1311 #:opts %opts-w-format
1314 (pass-if "wrong port arg"
1315 (let ((w (call-with-warnings
1317 (compile '(format 10 "foo")
1318 #:opts %opts-w-format
1320 (and (= (length w) 1)
1321 (number? (string-contains (car w)
1322 "wrong port argument")))))
1324 (pass-if "non-literal format string"
1325 (let ((w (call-with-warnings
1327 (compile '(format #f fmt)
1328 #:opts %opts-w-format
1330 (and (= (length w) 1)
1331 (number? (string-contains (car w)
1332 "non-literal format string")))))
1334 (pass-if "non-literal format string using gettext"
1335 (null? (call-with-warnings
1337 (compile '(format #t (gettext "~A ~A!") "hello" "world")
1338 #:opts %opts-w-format
1341 (pass-if "non-literal format string using gettext as _"
1342 (null? (call-with-warnings
1344 (compile '(format #t (_ "~A ~A!") "hello" "world")
1345 #:opts %opts-w-format
1348 (pass-if "non-literal format string using gettext as top-level _"
1349 (null? (call-with-warnings
1352 (define (_ s) (gettext s "my-domain"))
1353 (format #t (_ "~A ~A!") "hello" "world"))
1354 #:opts %opts-w-format
1357 (pass-if "non-literal format string using gettext as module-ref _"
1358 (null? (call-with-warnings
1360 (compile '(format #t ((@@ (foo) _) "~A ~A!") "hello" "world")
1361 #:opts %opts-w-format
1364 (pass-if "non-literal format string using gettext as lexical _"
1365 (null? (call-with-warnings
1367 (compile '(let ((_ (lambda (s)
1368 (gettext s "my-domain"))))
1369 (format #t (_ "~A ~A!") "hello" "world"))
1370 #:opts %opts-w-format
1373 (pass-if "non-literal format string using ngettext"
1374 (null? (call-with-warnings
1376 (compile '(format #t
1377 (ngettext "~a thing" "~a things" n "dom") n)
1378 #:opts %opts-w-format
1381 (pass-if "non-literal format string using ngettext as N_"
1382 (null? (call-with-warnings
1384 (compile '(format #t (N_ "~a thing" "~a things" n) n)
1385 #:opts %opts-w-format
1388 (pass-if "non-literal format string with (define _ gettext)"
1389 (null? (call-with-warnings
1394 (format #t (_ "~A ~A!") "hello" "world")))
1395 #:opts %opts-w-format
1398 (pass-if "wrong format string"
1399 (let ((w (call-with-warnings
1401 (compile '(format #f 'not-a-string)
1402 #:opts %opts-w-format
1404 (and (= (length w) 1)
1405 (number? (string-contains (car w)
1406 "wrong format string")))))
1408 (pass-if "wrong number of args"
1409 (let ((w (call-with-warnings
1411 (compile '(format "shbweeb")
1412 #:opts %opts-w-format
1414 (and (= (length w) 1)
1415 (number? (string-contains (car w)
1416 "wrong number of arguments")))))
1418 (pass-if "~%, ~~, ~&, ~t, ~_, ~!, ~|, ~/, ~q and ~\\n"
1419 (null? (call-with-warnings
1421 (compile '((@ (ice-9 format) format) some-port
1422 "~&~3_~~ ~\n~12they~% ~!~|~/~q")
1423 #:opts %opts-w-format
1426 (pass-if "one missing argument"
1427 (let ((w (call-with-warnings
1429 (compile '(format some-port "foo ~A~%")
1430 #:opts %opts-w-format
1432 (and (= (length w) 1)
1433 (number? (string-contains (car w)
1434 "expected 1, got 0")))))
1436 (pass-if "one missing argument, gettext"
1437 (let ((w (call-with-warnings
1439 (compile '(format some-port (gettext "foo ~A~%"))
1440 #:opts %opts-w-format
1442 (and (= (length w) 1)
1443 (number? (string-contains (car w)
1444 "expected 1, got 0")))))
1446 (pass-if "two missing arguments"
1447 (let ((w (call-with-warnings
1449 (compile '((@ (ice-9 format) format) #f
1450 "foo ~10,2f and bar ~S~%")
1451 #:opts %opts-w-format
1453 (and (= (length w) 1)
1454 (number? (string-contains (car w)
1455 "expected 2, got 0")))))
1457 (pass-if "one given, one missing argument"
1458 (let ((w (call-with-warnings
1460 (compile '(format #t "foo ~A and ~S~%" hey)
1461 #:opts %opts-w-format
1463 (and (= (length w) 1)
1464 (number? (string-contains (car w)
1465 "expected 2, got 1")))))
1467 (pass-if "too many arguments"
1468 (let ((w (call-with-warnings
1470 (compile '(format #t "foo ~A~%" 1 2)
1471 #:opts %opts-w-format
1473 (and (= (length w) 1)
1474 (number? (string-contains (car w)
1475 "expected 1, got 2")))))
1478 (null? (call-with-warnings
1480 (compile '((@ (ice-9 format) format) #t
1481 "foo ~h ~a~%" 123.4 'bar)
1482 #:opts %opts-w-format
1485 (pass-if "~:h with locale object"
1486 (null? (call-with-warnings
1488 (compile '((@ (ice-9 format) format) #t
1489 "foo ~:h~%" 123.4 %global-locale)
1490 #:opts %opts-w-format
1493 (pass-if "~:h without locale object"
1494 (let ((w (call-with-warnings
1496 (compile '((@ (ice-9 format) format) #t "foo ~,2:h" 123.4)
1497 #:opts %opts-w-format
1499 (and (= (length w) 1)
1500 (number? (string-contains (car w)
1501 "expected 2, got 1")))))
1503 (with-test-prefix "conditionals"
1505 (null? (call-with-warnings
1507 (compile '((@ (ice-9 format) format) #f "~A ~[foo~;bar~;baz~;~] ~10,2f"
1509 #:opts %opts-w-format
1512 (pass-if "literals with selector"
1513 (let ((w (call-with-warnings
1515 (compile '((@ (ice-9 format) format) #f "~2[foo~;bar~;baz~;~] ~A"
1517 #:opts %opts-w-format
1519 (and (= (length w) 1)
1520 (number? (string-contains (car w)
1521 "expected 1, got 2")))))
1523 (pass-if "escapes (exact count)"
1524 (let ((w (call-with-warnings
1526 (compile '((@ (ice-9 format) format) #f "~[~a~;~a~]")
1527 #:opts %opts-w-format
1529 (and (= (length w) 1)
1530 (number? (string-contains (car w)
1531 "expected 2, got 0")))))
1533 (pass-if "escapes with selector"
1534 (let ((w (call-with-warnings
1536 (compile '((@ (ice-9 format) format) #f "~1[chbouib~;~a~]")
1537 #:opts %opts-w-format
1539 (and (= (length w) 1)
1540 (number? (string-contains (car w)
1541 "expected 1, got 0")))))
1543 (pass-if "escapes, range"
1544 (let ((w (call-with-warnings
1546 (compile '((@ (ice-9 format) format) #f "~[chbouib~;~a~;~2*~a~]")
1547 #:opts %opts-w-format
1549 (and (= (length w) 1)
1550 (number? (string-contains (car w)
1551 "expected 1 to 4, got 0")))))
1554 (let ((w (call-with-warnings
1556 (compile '((@ (ice-9 format) format) #f "~@[temperature=~d~]")
1557 #:opts %opts-w-format
1559 (and (= (length w) 1)
1560 (number? (string-contains (car w)
1561 "expected 1, got 0")))))
1564 (let ((w (call-with-warnings
1566 (compile '((@ (ice-9 format) format) #f "~:[~[hey~;~a~;~va~]~;~3*~]")
1567 #:opts %opts-w-format
1569 (and (= (length w) 1)
1570 (number? (string-contains (car w)
1571 "expected 2 to 4, got 0")))))
1573 (pass-if "unterminated"
1574 (let ((w (call-with-warnings
1576 (compile '((@ (ice-9 format) format) #f "~[unterminated")
1577 #:opts %opts-w-format
1579 (and (= (length w) 1)
1580 (number? (string-contains (car w)
1581 "unterminated conditional")))))
1583 (pass-if "unexpected ~;"
1584 (let ((w (call-with-warnings
1586 (compile '((@ (ice-9 format) format) #f "foo~;bar")
1587 #:opts %opts-w-format
1589 (and (= (length w) 1)
1590 (number? (string-contains (car w)
1593 (pass-if "unexpected ~]"
1594 (let ((w (call-with-warnings
1596 (compile '((@ (ice-9 format) format) #f "foo~]")
1597 #:opts %opts-w-format
1599 (and (= (length w) 1)
1600 (number? (string-contains (car w)
1604 (null? (call-with-warnings
1606 (compile '((@ (ice-9 format) format) #f "~A ~{~S~} ~A"
1607 'hello '("ladies" "and")
1609 #:opts %opts-w-format
1612 (pass-if "~{...~}, too many args"
1613 (let ((w (call-with-warnings
1615 (compile '((@ (ice-9 format) format) #f "~{~S~}" 1 2 3)
1616 #:opts %opts-w-format
1618 (and (= (length w) 1)
1619 (number? (string-contains (car w)
1620 "expected 1, got 3")))))
1623 (null? (call-with-warnings
1625 (compile '((@ (ice-9 format) format) #f "~@{~S~}" 1 2 3)
1626 #:opts %opts-w-format
1629 (pass-if "~@{...~}, too few args"
1630 (let ((w (call-with-warnings
1632 (compile '((@ (ice-9 format) format) #f "~A ~@{~S~}")
1633 #:opts %opts-w-format
1635 (and (= (length w) 1)
1636 (number? (string-contains (car w)
1637 "expected at least 1, got 0")))))
1639 (pass-if "unterminated ~{...~}"
1640 (let ((w (call-with-warnings
1642 (compile '((@ (ice-9 format) format) #f "~{")
1643 #:opts %opts-w-format
1645 (and (= (length w) 1)
1646 (number? (string-contains (car w)
1650 (null? (call-with-warnings
1652 (compile '((@ (ice-9 format) format) #f "~:@(~A ~A~)" 'foo 'bar)
1653 #:opts %opts-w-format
1657 (let ((w (call-with-warnings
1659 (compile '((@ (ice-9 format) format) #f "~v_foo")
1660 #:opts %opts-w-format
1662 (and (= (length w) 1)
1663 (number? (string-contains (car w)
1664 "expected 1, got 0")))))
1666 (null? (call-with-warnings
1668 (compile '((@ (ice-9 format) format) #f "~v:@y" 1 123)
1669 #:opts %opts-w-format
1674 (let ((w (call-with-warnings
1676 (compile '((@ (ice-9 format) format) #f "~2*~a" 'a 'b)
1677 #:opts %opts-w-format
1679 (and (= (length w) 1)
1680 (number? (string-contains (car w)
1681 "expected 3, got 2")))))
1684 (null? (call-with-warnings
1686 (compile '((@ (ice-9 format) format) #f "~?" "~d ~d" '(1 2))
1687 #:opts %opts-w-format
1691 (null? (call-with-warnings
1693 (compile '((@ (ice-9 format) format) #f "~a ~^ ~a" 0 1)
1694 #:opts %opts-w-format
1697 (pass-if "~^, too few args"
1698 (let ((w (call-with-warnings
1700 (compile '((@ (ice-9 format) format) #f "~a ~^ ~a")
1701 #:opts %opts-w-format
1703 (and (= (length w) 1)
1704 (number? (string-contains (car w)
1705 "expected at least 1, got 0")))))
1707 (pass-if "parameters: +,-,#, and '"
1708 (null? (call-with-warnings
1710 (compile '((@ (ice-9 format) format) some-port
1711 "~#~ ~,,-2f ~,,+2f ~'A~" 1234 1234)
1712 #:opts %opts-w-format
1715 (pass-if "complex 1"
1716 (let ((w (call-with-warnings
1718 (compile '((@ (ice-9 format) format) #f
1719 "~4@S ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n"
1721 #:opts %opts-w-format
1723 (and (= (length w) 1)
1724 (number? (string-contains (car w)
1725 "expected 4, got 6")))))
1727 (pass-if "complex 2"
1728 (let ((w (call-with-warnings
1730 (compile '((@ (ice-9 format) format) #f
1731 "~:(~A~) Commands~:[~; [abbrev]~]:~2%"
1733 #:opts %opts-w-format
1735 (and (= (length w) 1)
1736 (number? (string-contains (car w)
1737 "expected 2, got 4")))))
1739 (pass-if "complex 3"
1740 (let ((w (call-with-warnings
1742 (compile '((@ (ice-9 format) format) #f "~9@a~:[~*~3_~;~3d~] ~v:@y~%")
1743 #:opts %opts-w-format
1745 (and (= (length w) 1)
1746 (number? (string-contains (car w)
1747 "expected 5, got 0")))))
1749 (pass-if "ice-9 format"
1750 (let ((w (call-with-warnings
1752 (let ((in (open-input-string
1753 "(use-modules ((ice-9 format)
1754 #:renamer (symbol-prefix-proc 'i9-)))
1755 (i9-format #t \"yo! ~A\" 1 2)")))
1756 (read-and-compile in
1757 #:opts %opts-w-format
1758 #:to 'assembly))))))
1759 (and (= (length w) 1)
1760 (number? (string-contains (car w)
1761 "expected 1, got 2")))))
1763 (pass-if "not format"
1764 (null? (call-with-warnings
1766 (compile '(let ((format chbouib))
1767 (format #t "not ~A a format string"))
1768 #:opts %opts-w-format
1771 (with-test-prefix "simple-format"
1774 (null? (call-with-warnings
1776 (compile '(simple-format #t "foo ~a bar ~s ~%~~" 1 2)
1777 #:opts %opts-w-format
1780 (pass-if "wrong number of args"
1781 (let ((w (call-with-warnings
1783 (compile '(simple-format #t "foo ~a ~s~%" 'one-missing)
1784 #:opts %opts-w-format
1786 (and (= (length w) 1)
1787 (number? (string-contains (car w) "wrong number")))))
1789 (pass-if "unsupported"
1790 (let ((w (call-with-warnings
1792 (compile '(simple-format #t "foo ~x~%" 16)
1793 #:opts %opts-w-format
1795 (and (= (length w) 1)
1796 (number? (string-contains (car w) "unsupported format option")))))
1798 (pass-if "unsupported, gettext"
1799 (let ((w (call-with-warnings
1801 (compile '(simple-format #t (gettext "foo ~2f~%") 3.14)
1802 #:opts %opts-w-format
1804 (and (= (length w) 1)
1805 (number? (string-contains (car w) "unsupported format option")))))
1807 (pass-if "unsupported, ngettext"
1808 (let ((w (call-with-warnings
1810 (compile '(simple-format #t (ngettext "s ~x" "p ~x" x) x)
1811 #:opts %opts-w-format
1813 (and (= (length w) 1)
1814 (number? (string-contains (car w) "unsupported format option")))))))
1816 (with-test-prefix "duplicate-case-datum"
1819 (null? (call-with-warnings
1821 (compile '(case x ((1) 'one) ((2) 'two))
1822 #:opts %opts-w-duplicate-case-datum
1825 (pass-if "one duplicate"
1826 (let ((w (call-with-warnings
1832 #:opts %opts-w-duplicate-case-datum
1834 (and (= (length w) 1)
1835 (number? (string-contains (car w) "duplicate")))))
1837 (pass-if "one duplicate"
1838 (let ((w (call-with-warnings
1843 #:opts %opts-w-duplicate-case-datum
1845 (and (= (length w) 1)
1846 (number? (string-contains (car w) "duplicate"))))))
1848 (with-test-prefix "bad-case-datum"
1851 (null? (call-with-warnings
1853 (compile '(case x ((1) 'one) ((2) 'two))
1854 #:opts %opts-w-bad-case-datum
1858 (let ((w (call-with-warnings
1863 #:opts %opts-w-bad-case-datum
1865 (and (= (length w) 1)
1866 (number? (string-contains (car w)
1867 "cannot be meaningfully compared")))))
1869 (pass-if "one clause element not eqv?"
1870 (let ((w (call-with-warnings
1874 #:opts %opts-w-duplicate-case-datum
1876 (and (= (length w) 1)
1877 (number? (string-contains (car w)
1878 "cannot be meaningfully compared")))))))
1881 ;; eval: (put 'pass-if-primitives-resolved 'scheme-indent-function 1)
1882 ;; eval: (put 'pass-if-tree-il->scheme 'scheme-indent-function 1)