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, 2013,
5 ;;;; 2014 Free Software Foundation, Inc.
7 ;;;; This library is free software; you can redistribute it and/or
8 ;;;; modify it under the terms of the GNU Lesser General Public
9 ;;;; License as published by the Free Software Foundation; either
10 ;;;; version 3 of the License, or (at your option) any later version.
12 ;;;; This library is distributed in the hope that it will be useful,
13 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15 ;;;; Lesser General Public License for more details.
17 ;;;; You should have received a copy of the GNU Lesser General Public
18 ;;;; License along with this library; if not, write to the Free Software
19 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
21 (define-module (test-suite tree-il)
22 #:use-module (test-suite lib)
23 #:use-module (system base compile)
24 #:use-module (system base pmatch)
25 #:use-module (system base message)
26 #:use-module (language tree-il)
27 #:use-module (language tree-il primitives)
28 #:use-module (language glil)
29 #:use-module (srfi srfi-13))
31 ;; Of course, the GLIL that is emitted depends on the source info of the
32 ;; input. Here we're not concerned about that, so we strip source
33 ;; information from the incoming tree-il.
35 (define (strip-source x)
36 (post-order! (lambda (x) (set! (tree-il-src x) #f))
39 (define-syntax assert-tree-il->glil
40 (syntax-rules (with-partial-evaluation without-partial-evaluation
42 ((_ with-partial-evaluation in pat test ...)
43 (assert-tree-il->glil with-options (#:partial-eval? #t)
45 ((_ without-partial-evaluation in pat test ...)
46 (assert-tree-il->glil with-options (#:partial-eval? #f)
48 ((_ with-options opts in pat test ...)
51 (let ((glil (unparse-glil
52 (compile (strip-source (parse-tree-il exp))
53 #:from 'tree-il #:to 'glil
56 (pat (guard test ...) #t)
59 (assert-tree-il->glil with-partial-evaluation
62 (define-syntax-rule (pass-if-primitives-resolved in expected)
63 (pass-if (format #f "primitives-resolved in ~s" 'in)
64 (let* ((module (let ((m (make-module)))
65 (beautify-user-module! m)
67 (orig (parse-tree-il 'in))
68 (resolved (expand-primitives! (resolve-primitives! orig module))))
69 (or (equal? (unparse-tree-il resolved) 'expected)
71 (format (current-error-port)
72 "primitive test failed: got ~s, expected ~s"
76 (define-syntax pass-if-tree-il->scheme
79 (assert-scheme->tree-il->scheme in pat #t))
82 (pmatch (tree-il->scheme
83 (compile 'in #:from 'scheme #:to 'tree-il))
84 (pat (guard guard-exp) #t)
88 (with-test-prefix "primitives"
90 (with-test-prefix "eqv?"
92 (pass-if-primitives-resolved
93 (apply (primitive eqv?) (const #f) (toplevel x))
94 (apply (primitive eq?) (const #f) (toplevel x)))
96 (pass-if-primitives-resolved
97 (apply (primitive eqv?) (const ()) (toplevel x))
98 (apply (primitive eq?) (const ()) (toplevel x)))
100 (pass-if-primitives-resolved
101 (apply (primitive eqv?) (const #t) (lexical x y))
102 (apply (primitive eq?) (const #t) (lexical x y)))
104 (pass-if-primitives-resolved
105 (apply (primitive eqv?) (const this-is-a-symbol) (toplevel x))
106 (apply (primitive eq?) (const this-is-a-symbol) (toplevel x)))
108 (pass-if-primitives-resolved
109 (apply (primitive eqv?) (const 42) (toplevel x))
110 (apply (primitive eq?) (const 42) (toplevel x)))
112 (pass-if-primitives-resolved
113 (apply (primitive eqv?) (const 42.0) (toplevel x))
114 (apply (primitive eqv?) (const 42.0) (toplevel x)))
116 (pass-if-primitives-resolved
117 (apply (primitive eqv?) (const #nil) (toplevel x))
118 (apply (primitive eq?) (const #nil) (toplevel x))))
120 (with-test-prefix "equal?"
122 (pass-if-primitives-resolved
123 (apply (primitive equal?) (const #f) (toplevel x))
124 (apply (primitive eq?) (const #f) (toplevel x)))
126 (pass-if-primitives-resolved
127 (apply (primitive equal?) (const ()) (toplevel x))
128 (apply (primitive eq?) (const ()) (toplevel x)))
130 (pass-if-primitives-resolved
131 (apply (primitive equal?) (const #t) (lexical x y))
132 (apply (primitive eq?) (const #t) (lexical x y)))
134 (pass-if-primitives-resolved
135 (apply (primitive equal?) (const this-is-a-symbol) (toplevel x))
136 (apply (primitive eq?) (const this-is-a-symbol) (toplevel x)))
138 (pass-if-primitives-resolved
139 (apply (primitive equal?) (const 42) (toplevel x))
140 (apply (primitive eq?) (const 42) (toplevel x)))
142 (pass-if-primitives-resolved
143 (apply (primitive equal?) (const 42.0) (toplevel x))
144 (apply (primitive equal?) (const 42.0) (toplevel x)))
146 (pass-if-primitives-resolved
147 (apply (primitive equal?) (const #nil) (toplevel x))
148 (apply (primitive eq?) (const #nil) (toplevel x)))))
151 (with-test-prefix "tree-il->scheme"
152 (pass-if-tree-il->scheme
153 (case-lambda ((a) a) ((b c) (list b c)))
154 (case-lambda ((,a) ,a1) ((,b ,c) (list ,b1 ,c1)))
155 (and (eq? a a1) (eq? b b1) (eq? c c1))))
157 (with-test-prefix "void"
158 (assert-tree-il->glil
160 (program () (std-prelude 0 0 #f) (label _) (void) (call return 1)))
161 (assert-tree-il->glil
162 (begin (void) (const 1))
163 (program () (std-prelude 0 0 #f) (label _) (const 1) (call return 1)))
164 (assert-tree-il->glil
165 (apply (primitive +) (void) (const 1))
166 (program () (std-prelude 0 0 #f) (label _) (void) (call add1 1) (call return 1))))
168 (with-test-prefix "application"
169 (assert-tree-il->glil
170 (apply (toplevel foo) (const 1))
171 (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (const 1) (call tail-call 1)))
172 (assert-tree-il->glil
173 (begin (apply (toplevel foo) (const 1)) (void))
174 (program () (std-prelude 0 0 #f) (label _) (call new-frame 0) (toplevel ref foo) (const 1) (mv-call 1 ,l1)
175 (call drop 1) (branch br ,l2)
176 (label ,l3) (mv-bind 0 #f)
178 (void) (call return 1))
179 (and (eq? l1 l3) (eq? l2 l4)))
180 (assert-tree-il->glil
181 (apply (toplevel foo) (apply (toplevel bar)))
182 (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call new-frame 0) (toplevel ref bar) (call call 0)
183 (call tail-call 1))))
185 (with-test-prefix "conditional"
186 (assert-tree-il->glil
187 (if (toplevel foo) (const 1) (const 2))
188 (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1)
189 (const 1) (call return 1)
190 (label ,l2) (const 2) (call return 1))
193 (assert-tree-il->glil without-partial-evaluation
194 (begin (if (toplevel foo) (const 1) (const 2)) (const #f))
195 (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1) (branch br ,l2)
196 (label ,l3) (label ,l4) (const #f) (call return 1))
197 (eq? l1 l3) (eq? l2 l4))
199 (assert-tree-il->glil
200 (apply (primitive null?) (if (toplevel foo) (const 1) (const 2)))
201 (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1)
202 (const 1) (branch br ,l2)
203 (label ,l3) (const 2) (label ,l4)
204 (call null? 1) (call return 1))
205 (eq? l1 l3) (eq? l2 l4)))
207 (with-test-prefix "primitive-ref"
208 (assert-tree-il->glil
210 (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call return 1)))
212 (assert-tree-il->glil
213 (begin (primitive +) (const #f))
214 (program () (std-prelude 0 0 #f) (label _) (const #f) (call return 1)))
216 (assert-tree-il->glil
217 (apply (primitive null?) (primitive +))
218 (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call null? 1)
221 (with-test-prefix "lexical refs"
222 (assert-tree-il->glil without-partial-evaluation
223 (let (x) (y) ((const 1)) (lexical x y))
224 (program () (std-prelude 0 1 #f) (label _)
225 (const 1) (bind (x #f 0)) (lexical #t #f set 0)
226 (lexical #t #f ref 0) (call return 1)
229 (assert-tree-il->glil with-options (#:partial-eval? #f #:cse? #f)
230 (let (x) (y) ((const 1)) (begin (lexical x y) (const #f)))
231 (program () (std-prelude 0 1 #f) (label _)
232 (const 1) (bind (x #f 0)) (lexical #t #f set 0)
233 (const #f) (call return 1)
236 (assert-tree-il->glil without-partial-evaluation
237 (let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y)))
238 (program () (std-prelude 0 1 #f) (label _)
239 (const 1) (bind (x #f 0)) (lexical #t #f set 0)
240 (lexical #t #f ref 0) (call null? 1) (call return 1)
243 (with-test-prefix "lexical sets"
244 (assert-tree-il->glil
245 ;; unreferenced sets may be optimized away -- make sure they are ref'd
246 (let (x) (y) ((const 1))
247 (set! (lexical x y) (apply (primitive 1+) (lexical x y))))
248 (program () (std-prelude 0 1 #f) (label _)
249 (const 1) (bind (x #t 0)) (lexical #t #t box 0)
250 (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
251 (void) (call return 1)
254 (assert-tree-il->glil
255 (let (x) (y) ((const 1))
256 (begin (set! (lexical x y) (apply (primitive 1+) (lexical x y)))
258 (program () (std-prelude 0 1 #f) (label _)
259 (const 1) (bind (x #t 0)) (lexical #t #t box 0)
260 (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
261 (lexical #t #t ref 0) (call return 1)
264 (assert-tree-il->glil
265 (let (x) (y) ((const 1))
266 (apply (primitive null?)
267 (set! (lexical x y) (apply (primitive 1+) (lexical x y)))))
268 (program () (std-prelude 0 1 #f) (label _)
269 (const 1) (bind (x #t 0)) (lexical #t #t box 0)
270 (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (void)
271 (call null? 1) (call return 1)
274 (with-test-prefix "module refs"
275 (assert-tree-il->glil
277 (program () (std-prelude 0 0 #f) (label _)
278 (module public ref (foo) bar)
281 (assert-tree-il->glil
282 (begin (@ (foo) bar) (const #f))
283 (program () (std-prelude 0 0 #f) (label _)
284 (module public ref (foo) bar) (call drop 1)
285 (const #f) (call return 1)))
287 (assert-tree-il->glil
288 (apply (primitive null?) (@ (foo) bar))
289 (program () (std-prelude 0 0 #f) (label _)
290 (module public ref (foo) bar)
291 (call null? 1) (call return 1)))
293 (assert-tree-il->glil
295 (program () (std-prelude 0 0 #f) (label _)
296 (module private ref (foo) bar)
299 (assert-tree-il->glil
300 (begin (@@ (foo) bar) (const #f))
301 (program () (std-prelude 0 0 #f) (label _)
302 (module private ref (foo) bar) (call drop 1)
303 (const #f) (call return 1)))
305 (assert-tree-il->glil
306 (apply (primitive null?) (@@ (foo) bar))
307 (program () (std-prelude 0 0 #f) (label _)
308 (module private ref (foo) bar)
309 (call null? 1) (call return 1))))
311 (with-test-prefix "module sets"
312 (assert-tree-il->glil
313 (set! (@ (foo) bar) (const 2))
314 (program () (std-prelude 0 0 #f) (label _)
315 (const 2) (module public set (foo) bar)
316 (void) (call return 1)))
318 (assert-tree-il->glil
319 (begin (set! (@ (foo) bar) (const 2)) (const #f))
320 (program () (std-prelude 0 0 #f) (label _)
321 (const 2) (module public set (foo) bar)
322 (const #f) (call return 1)))
324 (assert-tree-il->glil
325 (apply (primitive null?) (set! (@ (foo) bar) (const 2)))
326 (program () (std-prelude 0 0 #f) (label _)
327 (const 2) (module public set (foo) bar)
328 (void) (call null? 1) (call return 1)))
330 (assert-tree-il->glil
331 (set! (@@ (foo) bar) (const 2))
332 (program () (std-prelude 0 0 #f) (label _)
333 (const 2) (module private set (foo) bar)
334 (void) (call return 1)))
336 (assert-tree-il->glil
337 (begin (set! (@@ (foo) bar) (const 2)) (const #f))
338 (program () (std-prelude 0 0 #f) (label _)
339 (const 2) (module private set (foo) bar)
340 (const #f) (call return 1)))
342 (assert-tree-il->glil
343 (apply (primitive null?) (set! (@@ (foo) bar) (const 2)))
344 (program () (std-prelude 0 0 #f) (label _)
345 (const 2) (module private set (foo) bar)
346 (void) (call null? 1) (call return 1))))
348 (with-test-prefix "toplevel refs"
349 (assert-tree-il->glil
351 (program () (std-prelude 0 0 #f) (label _)
355 (assert-tree-il->glil without-partial-evaluation
356 (begin (toplevel bar) (const #f))
357 (program () (std-prelude 0 0 #f) (label _)
358 (toplevel ref bar) (call drop 1)
359 (const #f) (call return 1)))
361 (assert-tree-il->glil
362 (apply (primitive null?) (toplevel bar))
363 (program () (std-prelude 0 0 #f) (label _)
365 (call null? 1) (call return 1))))
367 (with-test-prefix "toplevel sets"
368 (assert-tree-il->glil
369 (set! (toplevel bar) (const 2))
370 (program () (std-prelude 0 0 #f) (label _)
371 (const 2) (toplevel set bar)
372 (void) (call return 1)))
374 (assert-tree-il->glil
375 (begin (set! (toplevel bar) (const 2)) (const #f))
376 (program () (std-prelude 0 0 #f) (label _)
377 (const 2) (toplevel set bar)
378 (const #f) (call return 1)))
380 (assert-tree-il->glil
381 (apply (primitive null?) (set! (toplevel bar) (const 2)))
382 (program () (std-prelude 0 0 #f) (label _)
383 (const 2) (toplevel set bar)
384 (void) (call null? 1) (call return 1))))
386 (with-test-prefix "toplevel defines"
387 (assert-tree-il->glil
388 (define bar (const 2))
389 (program () (std-prelude 0 0 #f) (label _)
390 (const 2) (toplevel define bar)
391 (void) (call return 1)))
393 (assert-tree-il->glil
394 (begin (define bar (const 2)) (const #f))
395 (program () (std-prelude 0 0 #f) (label _)
396 (const 2) (toplevel define bar)
397 (const #f) (call return 1)))
399 (assert-tree-il->glil
400 (apply (primitive null?) (define bar (const 2)))
401 (program () (std-prelude 0 0 #f) (label _)
402 (const 2) (toplevel define bar)
403 (void) (call null? 1) (call return 1))))
405 (with-test-prefix "constants"
406 (assert-tree-il->glil
408 (program () (std-prelude 0 0 #f) (label _)
409 (const 2) (call return 1)))
411 (assert-tree-il->glil
412 (begin (const 2) (const #f))
413 (program () (std-prelude 0 0 #f) (label _)
414 (const #f) (call return 1)))
416 (assert-tree-il->glil
417 ;; This gets simplified by `peval'.
418 (apply (primitive null?) (const 2))
419 (program () (std-prelude 0 0 #f) (label _)
420 (const #f) (call return 1))))
422 (with-test-prefix "letrec"
423 ;; simple bindings -> let
424 (assert-tree-il->glil without-partial-evaluation
425 (letrec (x y) (x1 y1) ((const 10) (const 20))
426 (apply (toplevel foo) (lexical x x1) (lexical y y1)))
427 (program () (std-prelude 0 2 #f) (label _)
428 (const 10) (const 20)
429 (bind (x #f 0) (y #f 1))
430 (lexical #t #f set 1) (lexical #t #f set 0)
432 (lexical #t #f ref 0) (lexical #t #f ref 1)
436 ;; complex bindings -> box and set! within let
437 (assert-tree-il->glil without-partial-evaluation
438 (letrec (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar)))
439 (apply (primitive +) (lexical x x1) (lexical y y1)))
440 (program () (std-prelude 0 4 #f) (label _)
441 (void) (void) ;; what are these?
442 (bind (x #t 0) (y #t 1))
443 (lexical #t #t box 1) (lexical #t #t box 0)
444 (call new-frame 0) (toplevel ref foo) (call call 0)
445 (call new-frame 0) (toplevel ref bar) (call call 0)
446 (bind (x #f 2) (y #f 3)) (lexical #t #f set 3) (lexical #t #f set 2)
447 (lexical #t #f ref 2) (lexical #t #t set 0)
448 (lexical #t #f ref 3) (lexical #t #t set 1)
449 (void) (lexical #t #f set 2) (void) (lexical #t #f set 3) ;; clear bindings
451 (lexical #t #t ref 0) (lexical #t #t ref 1)
452 (call add 2) (call return 1) (unbind)))
454 ;; complex bindings in letrec* -> box and set! in order
455 (assert-tree-il->glil without-partial-evaluation
456 (letrec* (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar)))
457 (apply (primitive +) (lexical x x1) (lexical y y1)))
458 (program () (std-prelude 0 2 #f) (label _)
459 (void) (void) ;; what are these?
460 (bind (x #t 0) (y #t 1))
461 (lexical #t #t box 1) (lexical #t #t box 0)
462 (call new-frame 0) (toplevel ref foo) (call call 0)
463 (lexical #t #t set 0)
464 (call new-frame 0) (toplevel ref bar) (call call 0)
465 (lexical #t #t set 1)
466 (lexical #t #t ref 0)
467 (lexical #t #t ref 1)
468 (call add 2) (call return 1) (unbind)))
470 ;; simple bindings in letrec* -> equivalent to letrec
471 (assert-tree-il->glil without-partial-evaluation
472 (letrec* (x y) (xx yy) ((const 1) (const 2))
474 (program () (std-prelude 0 1 #f) (label _)
476 (bind (y #f 0)) ;; X is removed, and Y is unboxed
477 (lexical #t #f set 0)
478 (lexical #t #f ref 0)
479 (call return 1) (unbind))))
481 (with-test-prefix "lambda"
482 (assert-tree-il->glil
484 (lambda-case (((x) #f #f #f () (y)) (const 2)) #f))
485 (program () (std-prelude 0 0 #f) (label _)
486 (program () (std-prelude 1 1 #f)
487 (bind (x #f 0)) (label _)
488 (const 2) (call return 1) (unbind))
491 (assert-tree-il->glil
493 (lambda-case (((x y) #f #f #f () (x1 y1))
496 (program () (std-prelude 0 0 #f) (label _)
497 (program () (std-prelude 2 2 #f)
498 (bind (x #f 0) (y #f 1)) (label _)
499 (const 2) (call return 1)
503 (assert-tree-il->glil
505 (lambda-case ((() #f x #f () (y)) (const 2))
507 (program () (std-prelude 0 0 #f) (label _)
508 (program () (opt-prelude 0 0 0 1 #f)
509 (bind (x #f 0)) (label _)
510 (const 2) (call return 1)
514 (assert-tree-il->glil
516 (lambda-case (((x) #f x1 #f () (y y1)) (const 2))
518 (program () (std-prelude 0 0 #f) (label _)
519 (program () (opt-prelude 1 0 1 2 #f)
520 (bind (x #f 0) (x1 #f 1)) (label _)
521 (const 2) (call return 1)
525 (assert-tree-il->glil
527 (lambda-case (((x) #f x1 #f () (y y1)) (lexical x y))
529 (program () (std-prelude 0 0 #f) (label _)
530 (program () (opt-prelude 1 0 1 2 #f)
531 (bind (x #f 0) (x1 #f 1)) (label _)
532 (lexical #t #f ref 0) (call return 1)
536 (assert-tree-il->glil
538 (lambda-case (((x) #f x1 #f () (y y1)) (lexical x1 y1))
540 (program () (std-prelude 0 0 #f) (label _)
541 (program () (opt-prelude 1 0 1 2 #f)
542 (bind (x #f 0) (x1 #f 1)) (label _)
543 (lexical #t #f ref 1) (call return 1)
547 (assert-tree-il->glil
549 (lambda-case (((x) #f #f #f () (x1))
551 (lambda-case (((y) #f #f #f () (y1))
555 (program () (std-prelude 0 0 #f) (label _)
556 (program () (std-prelude 1 1 #f)
557 (bind (x #f 0)) (label _)
558 (program () (std-prelude 1 1 #f)
559 (bind (y #f 0)) (label _)
560 (lexical #f #f ref 0) (call return 1)
562 (lexical #t #f ref 0)
563 (call make-closure 1)
568 (with-test-prefix "sequence"
569 (assert-tree-il->glil
570 (begin (begin (const 2) (const #f)) (const #t))
571 (program () (std-prelude 0 0 #f) (label _)
572 (const #t) (call return 1)))
574 (assert-tree-il->glil
575 ;; This gets simplified by `peval'.
576 (apply (primitive null?) (begin (const #f) (const 2)))
577 (program () (std-prelude 0 0 #f) (label _)
578 (const #f) (call return 1))))
580 (with-test-prefix "values"
581 (assert-tree-il->glil
582 (apply (primitive values)
583 (apply (primitive values) (const 1) (const 2)))
584 (program () (std-prelude 0 0 #f) (label _)
585 (const 1) (call return 1)))
587 (assert-tree-il->glil
588 (apply (primitive values)
589 (apply (primitive values) (const 1) (const 2))
591 (program () (std-prelude 0 0 #f) (label _)
592 (const 1) (const 3) (call return/values 2)))
594 (assert-tree-il->glil
596 (apply (primitive values) (const 1) (const 2)))
597 (program () (std-prelude 0 0 #f) (label _)
598 (const 1) (call return 1)))
600 ;; Testing `(values foo)' in push context with RA.
601 (assert-tree-il->glil without-partial-evaluation
602 (apply (primitive cdr)
603 (letrec (lp) (#{lp ~V9KrhVD4PFEL6oCTrLg3A}#)
604 ((lambda ((name . lp))
605 (lambda-case ((() #f #f #f () ())
606 (apply (toplevel values) (const (one two)))))))
607 (apply (lexical lp #{lp ~V9KrhVD4PFEL6oCTrLg3A}#))))
608 (program () (std-prelude 0 0 #f) (label _)
609 (branch br _) ;; entering the fix, jump to :2
610 ;; :1 body of lp, jump to :3
611 (label _) (bind) (const (one two)) (branch br _) (unbind)
612 ;; :2 initial call of lp, jump to :1
613 (label _) (bind) (branch br _) (label _) (unbind)
614 ;; :3 the push continuation
615 (call cdr 1) (call return 1))))
617 ;; FIXME: binding info for or-hacked locals might bork the disassembler,
618 ;; and could be tightened in any case
619 (with-test-prefix "the or hack"
620 (assert-tree-il->glil without-partial-evaluation
621 (let (x) (y) ((const 1))
624 (let (a) (b) ((const 2))
626 (program () (std-prelude 0 1 #f) (label _)
627 (const 1) (bind (x #f 0)) (lexical #t #f set 0)
628 (lexical #t #f ref 0) (branch br-if-not ,l1)
629 (lexical #t #f ref 0) (call return 1)
631 (const 2) (bind (a #f 0)) (lexical #t #f set 0)
632 (lexical #t #f ref 0) (call return 1)
637 ;; second bound var is unreferenced
638 (assert-tree-il->glil without-partial-evaluation
639 (let (x) (y) ((const 1))
642 (let (a) (b) ((const 2))
644 (program () (std-prelude 0 1 #f) (label _)
645 (const 1) (bind (x #f 0)) (lexical #t #f set 0)
646 (lexical #t #f ref 0) (branch br-if-not ,l1)
647 (lexical #t #f ref 0) (call return 1)
649 (lexical #t #f ref 0) (call return 1)
653 (with-test-prefix "apply"
654 (assert-tree-il->glil
655 (apply (primitive @apply) (toplevel foo) (toplevel bar))
656 (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (toplevel ref bar) (call tail-apply 2)))
657 (assert-tree-il->glil
658 (begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void))
659 (program () (std-prelude 0 0 #f) (label _)
660 (call new-frame 0) (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1)
661 (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
663 (void) (call return 1))
664 (and (eq? l1 l3) (eq? l2 l4)))
665 (assert-tree-il->glil
666 (apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz)))
667 (program () (std-prelude 0 0 #f) (label _)
669 (call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call apply 2)
670 (call tail-call 1))))
672 (with-test-prefix "call/cc"
673 (assert-tree-il->glil
674 (apply (primitive @call-with-current-continuation) (toplevel foo))
675 (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call tail-call/cc 1)))
676 (assert-tree-il->glil
677 (begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void))
678 (program () (std-prelude 0 0 #f) (label _)
679 (call new-frame 0) (toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1)
680 (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
682 (void) (call return 1))
683 (and (eq? l1 l3) (eq? l2 l4)))
684 (assert-tree-il->glil
685 (apply (toplevel foo)
686 (apply (toplevel @call-with-current-continuation) (toplevel bar)))
687 (program () (std-prelude 0 0 #f) (label _)
689 (toplevel ref bar) (call call/cc 1)
690 (call tail-call 1))))
693 (with-test-prefix "labels allocation"
694 (pass-if "http://debbugs.gnu.org/9769"
695 ((compile '(lambda ()
696 (let ((fail (lambda () #f)))
697 (let ((test (lambda () (fail))))
700 ;; Prevent inlining. We're testing analyze.scm's
701 ;; labels allocator here, and inlining it will
702 ;; reduce the entire thing to #t.
703 #:opts '(#:partial-eval? #f)))))
709 (with-test-prefix "many args"
710 (pass-if "call with > 256 args"
711 (equal? (compile `(1+ (sum ,@(iota 1000)))
712 #:env (current-module))
713 (1+ (apply sum (iota 1000)))))
715 (pass-if "tail call with > 256 args"
716 (equal? (compile `(sum ,@(iota 1000))
717 #:env (current-module))
718 (apply sum (iota 1000)))))
722 (with-test-prefix "tree-il-fold"
724 (pass-if "empty tree"
725 (let ((leaf? #f) (up? #f) (down? #f) (mark (list 'mark)))
727 (tree-il-fold (lambda (x y) (set! leaf? #t) y)
728 (lambda (x y) (set! down? #t) y)
729 (lambda (x y) (set! up? #t) y)
736 (pass-if "lambda and application"
737 (let* ((leaves '()) (ups '()) (downs '())
738 (result (tree-il-fold (lambda (x y)
739 (set! leaves (cons x leaves))
742 (set! downs (cons x downs))
745 (set! ups (cons x ups))
751 (((x y) #f #f #f () (x1 y1))
756 (and (equal? (map strip-source leaves)
757 (list (make-lexical-ref #f 'y 'y1)
758 (make-lexical-ref #f 'x 'x1)
759 (make-toplevel-ref #f '+)))
761 (equal? (reverse (map strip-source ups))
762 (map strip-source downs))))))
769 ;; Make sure we get English messages.
770 (when (defined? 'setlocale)
771 (setlocale LC_ALL "C"))
773 (define (call-with-warnings thunk)
774 (let ((port (open-output-string)))
775 (with-fluids ((*current-warning-port* port)
776 (*current-warning-prefix* ""))
778 (let ((warnings (get-output-string port)))
779 (string-tokenize warnings
780 (char-set-complement (char-set #\newline))))))
782 (define %opts-w-unused
783 '(#:warnings (unused-variable)))
785 (define %opts-w-unused-toplevel
786 '(#:warnings (unused-toplevel)))
788 (define %opts-w-unbound
789 '(#:warnings (unbound-variable)))
791 (define %opts-w-arity
792 '(#:warnings (arity-mismatch)))
794 (define %opts-w-format
795 '(#:warnings (format)))
797 (define %opts-w-duplicate-case-datum
798 '(#:warnings (duplicate-case-datum)))
800 (define %opts-w-bad-case-datum
801 '(#:warnings (bad-case-datum)))
804 (with-test-prefix "warnings"
806 (pass-if "unknown warning type"
807 (let ((w (call-with-warnings
809 (compile #t #:opts '(#:warnings (does-not-exist)))))))
810 (and (= (length w) 1)
811 (number? (string-contains (car w) "unknown warning")))))
813 (with-test-prefix "unused-variable"
816 (null? (call-with-warnings
818 (compile '(lambda (x y) (+ x y))
819 #:opts %opts-w-unused)))))
821 (pass-if "let/unused"
822 (let ((w (call-with-warnings
824 (compile '(lambda (x)
827 #:opts %opts-w-unused)))))
828 (and (= (length w) 1)
829 (number? (string-contains (car w) "unused variable `y'")))))
831 (pass-if "shadowed variable"
832 (let ((w (call-with-warnings
834 (compile '(lambda (x)
838 #:opts %opts-w-unused)))))
839 (and (= (length w) 1)
840 (number? (string-contains (car w) "unused variable `y'")))))
843 (null? (call-with-warnings
846 (letrec ((x (lambda () (y)))
849 #:opts %opts-w-unused)))))
851 (pass-if "unused argument"
852 ;; Unused arguments should not be reported.
853 (null? (call-with-warnings
855 (compile '(lambda (x y z) #t)
856 #:opts %opts-w-unused)))))
858 (pass-if "special variable names"
859 (null? (call-with-warnings
862 (let ((_ 'underscore)
863 (#{gensym name}# 'ignore-me))
866 #:opts %opts-w-unused))))))
868 (with-test-prefix "unused-toplevel"
870 (pass-if "used after definition"
871 (null? (call-with-warnings
873 (let ((in (open-input-string
874 "(define foo 2) foo")))
877 #:opts %opts-w-unused-toplevel))))))
879 (pass-if "used before definition"
880 (null? (call-with-warnings
882 (let ((in (open-input-string
883 "(define (bar) foo) (define foo 2) (bar)")))
886 #:opts %opts-w-unused-toplevel))))))
888 (pass-if "unused but public"
889 (let ((in (open-input-string
890 "(define-module (test-suite tree-il x) #:export (bar))
891 (define (bar) #t)")))
892 (null? (call-with-warnings
896 #:opts %opts-w-unused-toplevel))))))
898 (pass-if "unused but public (more)"
899 (let ((in (open-input-string
900 "(define-module (test-suite tree-il x) #:export (bar))
903 (define (foo) #t)")))
904 (null? (call-with-warnings
908 #:opts %opts-w-unused-toplevel))))))
910 (pass-if "unused but define-public"
911 (null? (call-with-warnings
913 (compile '(define-public foo 2)
915 #:opts %opts-w-unused-toplevel)))))
917 (pass-if "used by macro"
918 ;; FIXME: See comment about macros at `unused-toplevel-analysis'.
921 (null? (call-with-warnings
923 (let ((in (open-input-string
926 (syntax-rules () ((_) (bar))))")))
929 #:opts %opts-w-unused-toplevel))))))
932 (let ((w (call-with-warnings
934 (compile '(define foo 2)
936 #:opts %opts-w-unused-toplevel)))))
937 (and (= (length w) 1)
938 (number? (string-contains (car w)
939 (format #f "top-level variable `~A'"
942 (pass-if "unused recursive"
943 (let ((w (call-with-warnings
945 (compile '(define (foo) (foo))
947 #:opts %opts-w-unused-toplevel)))))
948 (and (= (length w) 1)
949 (number? (string-contains (car w)
950 (format #f "top-level variable `~A'"
953 (pass-if "unused mutually recursive"
954 (let* ((in (open-input-string
955 "(define (foo) (bar)) (define (bar) (foo))"))
956 (w (call-with-warnings
960 #:opts %opts-w-unused-toplevel)))))
961 (and (= (length w) 2)
962 (number? (string-contains (car w)
963 (format #f "top-level variable `~A'"
965 (number? (string-contains (cadr w)
966 (format #f "top-level variable `~A'"
969 (pass-if "special variable names"
970 (null? (call-with-warnings
972 (compile '(define #{gensym name}# 'ignore-me)
974 #:opts %opts-w-unused-toplevel))))))
976 (with-test-prefix "unbound variable"
979 (null? (call-with-warnings
981 (compile '+ #:opts %opts-w-unbound)))))
985 (w (call-with-warnings
989 #:opts %opts-w-unbound)))))
990 (and (= (length w) 1)
991 (number? (string-contains (car w)
992 (format #f "unbound variable `~A'"
997 (w (call-with-warnings
999 (compile `(set! ,v 7)
1001 #:opts %opts-w-unbound)))))
1002 (and (= (length w) 1)
1003 (number? (string-contains (car w)
1004 (format #f "unbound variable `~A'"
1007 (pass-if "module-local top-level is visible"
1008 (let ((m (make-module))
1010 (beautify-user-module! m)
1011 (compile `(define ,v 123)
1012 #:env m #:opts %opts-w-unbound)
1013 (null? (call-with-warnings
1018 #:opts %opts-w-unbound))))))
1020 (pass-if "module-local top-level is visible after"
1021 (let ((m (make-module))
1023 (beautify-user-module! m)
1024 (null? (call-with-warnings
1026 (let ((in (open-input-string
1029 (define chbouib 5)")))
1030 (read-and-compile in
1032 #:opts %opts-w-unbound)))))))
1034 (pass-if "optional arguments are visible"
1035 (null? (call-with-warnings
1037 (compile '(lambda* (x #:optional y z) (list x y z))
1038 #:opts %opts-w-unbound
1041 (pass-if "keyword arguments are visible"
1042 (null? (call-with-warnings
1044 (compile '(lambda* (x #:key y z) (list x y z))
1045 #:opts %opts-w-unbound
1048 (pass-if "GOOPS definitions are visible"
1049 (let ((m (make-module))
1051 (beautify-user-module! m)
1052 (module-use! m (resolve-interface '(oop goops)))
1053 (null? (call-with-warnings
1055 (let ((in (open-input-string
1056 "(define-class <foo> ()
1057 (bar #:getter foo-bar))
1058 (define z (foo-bar (make <foo>)))")))
1059 (read-and-compile in
1061 #:opts %opts-w-unbound))))))))
1063 (with-test-prefix "arity mismatch"
1066 (null? (call-with-warnings
1068 (compile '(cons 'a 'b) #:opts %opts-w-arity)))))
1070 (pass-if "direct application"
1071 (let ((w (call-with-warnings
1073 (compile '((lambda (x y) (or x y)) 1 2 3 4 5)
1074 #:opts %opts-w-arity
1076 (and (= (length w) 1)
1077 (number? (string-contains (car w)
1078 "wrong number of arguments to")))))
1080 (let ((w (call-with-warnings
1082 (compile '(let ((f (lambda (x y) (+ x y))))
1084 #:opts %opts-w-arity
1086 (and (= (length w) 1)
1087 (number? (string-contains (car w)
1088 "wrong number of arguments to")))))
1091 (let ((w (call-with-warnings
1093 (compile '(cons 1 2 3 4)
1094 #:opts %opts-w-arity
1096 (and (= (length w) 1)
1097 (number? (string-contains (car w)
1098 "wrong number of arguments to")))))
1100 (pass-if "alias to global"
1101 (let ((w (call-with-warnings
1103 (compile '(let ((f cons)) (f 1 2 3 4))
1104 #:opts %opts-w-arity
1106 (and (= (length w) 1)
1107 (number? (string-contains (car w)
1108 "wrong number of arguments to")))))
1110 (pass-if "alias to lexical to global"
1111 (let ((w (call-with-warnings
1113 (compile '(let ((f number?))
1116 #:opts %opts-w-arity
1118 (and (= (length w) 1)
1119 (number? (string-contains (car w)
1120 "wrong number of arguments to")))))
1122 (pass-if "alias to lexical"
1123 (let ((w (call-with-warnings
1125 (compile '(let ((f (lambda (x y z) (+ x y z))))
1128 #:opts %opts-w-arity
1130 (and (= (length w) 1)
1131 (number? (string-contains (car w)
1132 "wrong number of arguments to")))))
1135 (let ((w (call-with-warnings
1137 (compile '(letrec ((odd? (lambda (x) (even? (1- x))))
1142 #:opts %opts-w-arity
1144 (and (= (length w) 1)
1145 (number? (string-contains (car w)
1146 "wrong number of arguments to")))))
1148 (pass-if "case-lambda"
1149 (null? (call-with-warnings
1151 (compile '(let ((f (case-lambda
1158 #:opts %opts-w-arity
1161 (pass-if "case-lambda with wrong number of arguments"
1162 (let ((w (call-with-warnings
1164 (compile '(let ((f (case-lambda
1168 #:opts %opts-w-arity
1170 (and (= (length w) 1)
1171 (number? (string-contains (car w)
1172 "wrong number of arguments to")))))
1174 (pass-if "case-lambda*"
1175 (null? (call-with-warnings
1177 (compile '(let ((f (case-lambda*
1178 ((x #:optional y) 1)
1180 ((x y #:key z) 3))))
1185 #:opts %opts-w-arity
1188 (pass-if "case-lambda* with wrong arguments"
1189 (let ((w (call-with-warnings
1191 (compile '(let ((f (case-lambda*
1192 ((x #:optional y) 1)
1194 ((x y #:key z) 3))))
1197 #:opts %opts-w-arity
1199 (and (= (length w) 2)
1200 (null? (filter (lambda (w)
1204 w "wrong number of arguments to"))))
1207 (pass-if "top-level applicable struct"
1208 (null? (call-with-warnings
1210 (compile '(let ((p current-warning-port))
1213 #:opts %opts-w-arity
1216 (pass-if "top-level applicable struct with wrong arguments"
1217 (let ((w (call-with-warnings
1219 (compile '(let ((p current-warning-port))
1221 #:opts %opts-w-arity
1223 (and (= (length w) 1)
1224 (number? (string-contains (car w)
1225 "wrong number of arguments to")))))
1227 (pass-if "local toplevel-defines"
1228 (let ((w (call-with-warnings
1230 (let ((in (open-input-string "
1231 (define (g x) (f x))
1233 (read-and-compile in
1234 #:opts %opts-w-arity
1235 #:to 'assembly))))))
1236 (and (= (length w) 1)
1237 (number? (string-contains (car w)
1238 "wrong number of arguments to")))))
1240 (pass-if "global toplevel alias"
1241 (let ((w (call-with-warnings
1243 (let ((in (open-input-string "
1245 (define (g) (f))")))
1246 (read-and-compile in
1247 #:opts %opts-w-arity
1248 #:to 'assembly))))))
1249 (and (= (length w) 1)
1250 (number? (string-contains (car w)
1251 "wrong number of arguments to")))))
1253 (pass-if "local toplevel overrides global"
1254 (null? (call-with-warnings
1256 (let ((in (open-input-string "
1258 (define (foo x) (cons))")))
1259 (read-and-compile in
1260 #:opts %opts-w-arity
1261 #:to 'assembly))))))
1263 (pass-if "keyword not passed and quiet"
1264 (null? (call-with-warnings
1266 (compile '(let ((f (lambda* (x #:key y) y)))
1268 #:opts %opts-w-arity
1271 (pass-if "keyword passed and quiet"
1272 (null? (call-with-warnings
1274 (compile '(let ((f (lambda* (x #:key y) y)))
1276 #:opts %opts-w-arity
1279 (pass-if "keyword passed to global and quiet"
1280 (null? (call-with-warnings
1282 (let ((in (open-input-string "
1283 (use-modules (system base compile))
1284 (compile '(+ 2 3) #:env (current-module))")))
1285 (read-and-compile in
1286 #:opts %opts-w-arity
1287 #:to 'assembly))))))
1289 (pass-if "extra keyword"
1290 (let ((w (call-with-warnings
1292 (compile '(let ((f (lambda* (x #:key y) y)))
1294 #:opts %opts-w-arity
1296 (and (= (length w) 1)
1297 (number? (string-contains (car w)
1298 "wrong number of arguments to")))))
1300 (pass-if "extra keywords allowed"
1301 (null? (call-with-warnings
1303 (compile '(let ((f (lambda* (x #:key y #:allow-other-keys)
1306 #:opts %opts-w-arity
1307 #:to 'assembly))))))
1309 (with-test-prefix "format"
1311 (pass-if "quiet (no args)"
1312 (null? (call-with-warnings
1314 (compile '(format #t "hey!")
1315 #:opts %opts-w-format
1318 (pass-if "quiet (1 arg)"
1319 (null? (call-with-warnings
1321 (compile '(format #t "hey ~A!" "you")
1322 #:opts %opts-w-format
1325 (pass-if "quiet (2 args)"
1326 (null? (call-with-warnings
1328 (compile '(format #t "~A ~A!" "hello" "world")
1329 #:opts %opts-w-format
1332 (pass-if "wrong port arg"
1333 (let ((w (call-with-warnings
1335 (compile '(format 10 "foo")
1336 #:opts %opts-w-format
1338 (and (= (length w) 1)
1339 (number? (string-contains (car w)
1340 "wrong port argument")))))
1342 (pass-if "non-literal format string"
1343 (let ((w (call-with-warnings
1345 (compile '(format #f fmt)
1346 #:opts %opts-w-format
1348 (and (= (length w) 1)
1349 (number? (string-contains (car w)
1350 "non-literal format string")))))
1352 (pass-if "non-literal format string using gettext"
1353 (null? (call-with-warnings
1355 (compile '(format #t (gettext "~A ~A!") "hello" "world")
1356 #:opts %opts-w-format
1359 (pass-if "non-literal format string using gettext as _"
1360 (null? (call-with-warnings
1362 (compile '(format #t (_ "~A ~A!") "hello" "world")
1363 #:opts %opts-w-format
1366 (pass-if "non-literal format string using gettext as top-level _"
1367 (null? (call-with-warnings
1370 (define (_ s) (gettext s "my-domain"))
1371 (format #t (_ "~A ~A!") "hello" "world"))
1372 #:opts %opts-w-format
1375 (pass-if "non-literal format string using gettext as module-ref _"
1376 (null? (call-with-warnings
1378 (compile '(format #t ((@@ (foo) _) "~A ~A!") "hello" "world")
1379 #:opts %opts-w-format
1382 (pass-if "non-literal format string using gettext as lexical _"
1383 (null? (call-with-warnings
1385 (compile '(let ((_ (lambda (s)
1386 (gettext s "my-domain"))))
1387 (format #t (_ "~A ~A!") "hello" "world"))
1388 #:opts %opts-w-format
1391 (pass-if "non-literal format string using ngettext"
1392 (null? (call-with-warnings
1394 (compile '(format #t
1395 (ngettext "~a thing" "~a things" n "dom") n)
1396 #:opts %opts-w-format
1399 (pass-if "non-literal format string using ngettext as N_"
1400 (null? (call-with-warnings
1402 (compile '(format #t (N_ "~a thing" "~a things" n) n)
1403 #:opts %opts-w-format
1406 (pass-if "non-literal format string with (define _ gettext)"
1407 (null? (call-with-warnings
1412 (format #t (_ "~A ~A!") "hello" "world")))
1413 #:opts %opts-w-format
1416 (pass-if "wrong format string"
1417 (let ((w (call-with-warnings
1419 (compile '(format #f 'not-a-string)
1420 #:opts %opts-w-format
1422 (and (= (length w) 1)
1423 (number? (string-contains (car w)
1424 "wrong format string")))))
1426 (pass-if "wrong number of args"
1427 (let ((w (call-with-warnings
1429 (compile '(format "shbweeb")
1430 #:opts %opts-w-format
1432 (and (= (length w) 1)
1433 (number? (string-contains (car w)
1434 "wrong number of arguments")))))
1436 (pass-if "~%, ~~, ~&, ~t, ~_, ~!, ~|, ~/, ~q and ~\\n"
1437 (null? (call-with-warnings
1439 (compile '((@ (ice-9 format) format) some-port
1440 "~&~3_~~ ~\n~12they~% ~!~|~/~q")
1441 #:opts %opts-w-format
1444 (pass-if "one missing argument"
1445 (let ((w (call-with-warnings
1447 (compile '(format some-port "foo ~A~%")
1448 #:opts %opts-w-format
1450 (and (= (length w) 1)
1451 (number? (string-contains (car w)
1452 "expected 1, got 0")))))
1454 (pass-if "one missing argument, gettext"
1455 (let ((w (call-with-warnings
1457 (compile '(format some-port (gettext "foo ~A~%"))
1458 #:opts %opts-w-format
1460 (and (= (length w) 1)
1461 (number? (string-contains (car w)
1462 "expected 1, got 0")))))
1464 (pass-if "two missing arguments"
1465 (let ((w (call-with-warnings
1467 (compile '((@ (ice-9 format) format) #f
1468 "foo ~10,2f and bar ~S~%")
1469 #:opts %opts-w-format
1471 (and (= (length w) 1)
1472 (number? (string-contains (car w)
1473 "expected 2, got 0")))))
1475 (pass-if "one given, one missing argument"
1476 (let ((w (call-with-warnings
1478 (compile '(format #t "foo ~A and ~S~%" hey)
1479 #:opts %opts-w-format
1481 (and (= (length w) 1)
1482 (number? (string-contains (car w)
1483 "expected 2, got 1")))))
1485 (pass-if "too many arguments"
1486 (let ((w (call-with-warnings
1488 (compile '(format #t "foo ~A~%" 1 2)
1489 #:opts %opts-w-format
1491 (and (= (length w) 1)
1492 (number? (string-contains (car w)
1493 "expected 1, got 2")))))
1496 (null? (call-with-warnings
1498 (compile '((@ (ice-9 format) format) #t
1499 "foo ~h ~a~%" 123.4 'bar)
1500 #:opts %opts-w-format
1503 (pass-if "~:h with locale object"
1504 (null? (call-with-warnings
1506 (compile '((@ (ice-9 format) format) #t
1507 "foo ~:h~%" 123.4 %global-locale)
1508 #:opts %opts-w-format
1511 (pass-if "~:h without locale object"
1512 (let ((w (call-with-warnings
1514 (compile '((@ (ice-9 format) format) #t "foo ~,2:h" 123.4)
1515 #:opts %opts-w-format
1517 (and (= (length w) 1)
1518 (number? (string-contains (car w)
1519 "expected 2, got 1")))))
1521 (with-test-prefix "conditionals"
1523 (null? (call-with-warnings
1525 (compile '((@ (ice-9 format) format) #f "~A ~[foo~;bar~;baz~;~] ~10,2f"
1527 #:opts %opts-w-format
1530 (pass-if "literals with selector"
1531 (let ((w (call-with-warnings
1533 (compile '((@ (ice-9 format) format) #f "~2[foo~;bar~;baz~;~] ~A"
1535 #:opts %opts-w-format
1537 (and (= (length w) 1)
1538 (number? (string-contains (car w)
1539 "expected 1, got 2")))))
1541 (pass-if "escapes (exact count)"
1542 (let ((w (call-with-warnings
1544 (compile '((@ (ice-9 format) format) #f "~[~a~;~a~]")
1545 #:opts %opts-w-format
1547 (and (= (length w) 1)
1548 (number? (string-contains (car w)
1549 "expected 2, got 0")))))
1551 (pass-if "escapes with selector"
1552 (let ((w (call-with-warnings
1554 (compile '((@ (ice-9 format) format) #f "~1[chbouib~;~a~]")
1555 #:opts %opts-w-format
1557 (and (= (length w) 1)
1558 (number? (string-contains (car w)
1559 "expected 1, got 0")))))
1561 (pass-if "escapes, range"
1562 (let ((w (call-with-warnings
1564 (compile '((@ (ice-9 format) format) #f "~[chbouib~;~a~;~2*~a~]")
1565 #:opts %opts-w-format
1567 (and (= (length w) 1)
1568 (number? (string-contains (car w)
1569 "expected 1 to 4, got 0")))))
1572 (let ((w (call-with-warnings
1574 (compile '((@ (ice-9 format) format) #f "~@[temperature=~d~]")
1575 #:opts %opts-w-format
1577 (and (= (length w) 1)
1578 (number? (string-contains (car w)
1579 "expected 1, got 0")))))
1582 (let ((w (call-with-warnings
1584 (compile '((@ (ice-9 format) format) #f "~:[~[hey~;~a~;~va~]~;~3*~]")
1585 #:opts %opts-w-format
1587 (and (= (length w) 1)
1588 (number? (string-contains (car w)
1589 "expected 2 to 4, got 0")))))
1591 (pass-if "unterminated"
1592 (let ((w (call-with-warnings
1594 (compile '((@ (ice-9 format) format) #f "~[unterminated")
1595 #:opts %opts-w-format
1597 (and (= (length w) 1)
1598 (number? (string-contains (car w)
1599 "unterminated conditional")))))
1601 (pass-if "unexpected ~;"
1602 (let ((w (call-with-warnings
1604 (compile '((@ (ice-9 format) format) #f "foo~;bar")
1605 #:opts %opts-w-format
1607 (and (= (length w) 1)
1608 (number? (string-contains (car w)
1611 (pass-if "unexpected ~]"
1612 (let ((w (call-with-warnings
1614 (compile '((@ (ice-9 format) format) #f "foo~]")
1615 #:opts %opts-w-format
1617 (and (= (length w) 1)
1618 (number? (string-contains (car w)
1622 (null? (call-with-warnings
1624 (compile '((@ (ice-9 format) format) #f "~A ~{~S~} ~A"
1625 'hello '("ladies" "and")
1627 #:opts %opts-w-format
1630 (pass-if "~{...~}, too many args"
1631 (let ((w (call-with-warnings
1633 (compile '((@ (ice-9 format) format) #f "~{~S~}" 1 2 3)
1634 #:opts %opts-w-format
1636 (and (= (length w) 1)
1637 (number? (string-contains (car w)
1638 "expected 1, got 3")))))
1641 (null? (call-with-warnings
1643 (compile '((@ (ice-9 format) format) #f "~@{~S~}" 1 2 3)
1644 #:opts %opts-w-format
1647 (pass-if "~@{...~}, too few args"
1648 (let ((w (call-with-warnings
1650 (compile '((@ (ice-9 format) format) #f "~A ~@{~S~}")
1651 #:opts %opts-w-format
1653 (and (= (length w) 1)
1654 (number? (string-contains (car w)
1655 "expected at least 1, got 0")))))
1657 (pass-if "unterminated ~{...~}"
1658 (let ((w (call-with-warnings
1660 (compile '((@ (ice-9 format) format) #f "~{")
1661 #:opts %opts-w-format
1663 (and (= (length w) 1)
1664 (number? (string-contains (car w)
1668 (null? (call-with-warnings
1670 (compile '((@ (ice-9 format) format) #f "~:@(~A ~A~)" 'foo 'bar)
1671 #:opts %opts-w-format
1675 (let ((w (call-with-warnings
1677 (compile '((@ (ice-9 format) format) #f "~v_foo")
1678 #:opts %opts-w-format
1680 (and (= (length w) 1)
1681 (number? (string-contains (car w)
1682 "expected 1, got 0")))))
1684 (null? (call-with-warnings
1686 (compile '((@ (ice-9 format) format) #f "~v:@y" 1 123)
1687 #:opts %opts-w-format
1692 (let ((w (call-with-warnings
1694 (compile '((@ (ice-9 format) format) #f "~2*~a" 'a 'b)
1695 #:opts %opts-w-format
1697 (and (= (length w) 1)
1698 (number? (string-contains (car w)
1699 "expected 3, got 2")))))
1702 (null? (call-with-warnings
1704 (compile '((@ (ice-9 format) format) #f "~?" "~d ~d" '(1 2))
1705 #:opts %opts-w-format
1709 (null? (call-with-warnings
1711 (compile '((@ (ice-9 format) format) #f "~a ~^ ~a" 0 1)
1712 #:opts %opts-w-format
1715 (pass-if "~^, too few args"
1716 (let ((w (call-with-warnings
1718 (compile '((@ (ice-9 format) format) #f "~a ~^ ~a")
1719 #:opts %opts-w-format
1721 (and (= (length w) 1)
1722 (number? (string-contains (car w)
1723 "expected at least 1, got 0")))))
1725 (pass-if "parameters: +,-,#, and '"
1726 (null? (call-with-warnings
1728 (compile '((@ (ice-9 format) format) some-port
1729 "~#~ ~,,-2f ~,,+2f ~'A~" 1234 1234)
1730 #:opts %opts-w-format
1733 (pass-if "complex 1"
1734 (let ((w (call-with-warnings
1736 (compile '((@ (ice-9 format) format) #f
1737 "~4@S ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n"
1739 #:opts %opts-w-format
1741 (and (= (length w) 1)
1742 (number? (string-contains (car w)
1743 "expected 4, got 6")))))
1745 (pass-if "complex 2"
1746 (let ((w (call-with-warnings
1748 (compile '((@ (ice-9 format) format) #f
1749 "~:(~A~) Commands~:[~; [abbrev]~]:~2%"
1751 #:opts %opts-w-format
1753 (and (= (length w) 1)
1754 (number? (string-contains (car w)
1755 "expected 2, got 4")))))
1757 (pass-if "complex 3"
1758 (let ((w (call-with-warnings
1760 (compile '((@ (ice-9 format) format) #f "~9@a~:[~*~3_~;~3d~] ~v:@y~%")
1761 #:opts %opts-w-format
1763 (and (= (length w) 1)
1764 (number? (string-contains (car w)
1765 "expected 5, got 0")))))
1767 (pass-if "ice-9 format"
1768 (let ((w (call-with-warnings
1770 (let ((in (open-input-string
1771 "(use-modules ((ice-9 format)
1772 #:renamer (symbol-prefix-proc 'i9-)))
1773 (i9-format #t \"yo! ~A\" 1 2)")))
1774 (read-and-compile in
1775 #:opts %opts-w-format
1776 #:to 'assembly))))))
1777 (and (= (length w) 1)
1778 (number? (string-contains (car w)
1779 "expected 1, got 2")))))
1781 (pass-if "not format"
1782 (null? (call-with-warnings
1784 (compile '(let ((format chbouib))
1785 (format #t "not ~A a format string"))
1786 #:opts %opts-w-format
1789 (with-test-prefix "simple-format"
1792 (null? (call-with-warnings
1794 (compile '(simple-format #t "foo ~a bar ~s ~%~~" 1 2)
1795 #:opts %opts-w-format
1798 (pass-if "wrong number of args"
1799 (let ((w (call-with-warnings
1801 (compile '(simple-format #t "foo ~a ~s~%" 'one-missing)
1802 #:opts %opts-w-format
1804 (and (= (length w) 1)
1805 (number? (string-contains (car w) "wrong number")))))
1807 (pass-if "unsupported"
1808 (let ((w (call-with-warnings
1810 (compile '(simple-format #t "foo ~x~%" 16)
1811 #:opts %opts-w-format
1813 (and (= (length w) 1)
1814 (number? (string-contains (car w) "unsupported format option")))))
1816 (pass-if "unsupported, gettext"
1817 (let ((w (call-with-warnings
1819 (compile '(simple-format #t (gettext "foo ~2f~%") 3.14)
1820 #:opts %opts-w-format
1822 (and (= (length w) 1)
1823 (number? (string-contains (car w) "unsupported format option")))))
1825 (pass-if "unsupported, ngettext"
1826 (let ((w (call-with-warnings
1828 (compile '(simple-format #t (ngettext "s ~x" "p ~x" x) x)
1829 #:opts %opts-w-format
1831 (and (= (length w) 1)
1832 (number? (string-contains (car w) "unsupported format option")))))))
1834 (with-test-prefix "duplicate-case-datum"
1837 (null? (call-with-warnings
1839 (compile '(case x ((1) 'one) ((2) 'two))
1840 #:opts %opts-w-duplicate-case-datum
1843 (pass-if "one duplicate"
1844 (let ((w (call-with-warnings
1850 #:opts %opts-w-duplicate-case-datum
1852 (and (= (length w) 1)
1853 (number? (string-contains (car w) "duplicate")))))
1855 (pass-if "one duplicate"
1856 (let ((w (call-with-warnings
1861 #:opts %opts-w-duplicate-case-datum
1863 (and (= (length w) 1)
1864 (number? (string-contains (car w) "duplicate"))))))
1866 (with-test-prefix "bad-case-datum"
1869 (null? (call-with-warnings
1871 (compile '(case x ((1) 'one) ((2) 'two))
1872 #:opts %opts-w-bad-case-datum
1876 (let ((w (call-with-warnings
1881 #:opts %opts-w-bad-case-datum
1883 (and (= (length w) 1)
1884 (number? (string-contains (car w)
1885 "cannot be meaningfully compared")))))
1887 (pass-if "one clause element not eqv?"
1888 (let ((w (call-with-warnings
1892 #:opts %opts-w-duplicate-case-datum
1894 (and (= (length w) 1)
1895 (number? (string-contains (car w)
1896 "cannot be meaningfully compared")))))))
1899 ;; eval: (put 'pass-if-primitives-resolved 'scheme-indent-function 1)
1900 ;; eval: (put 'pass-if-tree-il->scheme 'scheme-indent-function 1)