test-suite/tests/tree-il.test

   1 ;;;; tree-il.test --- test suite for compiling tree-il   -*- scheme -*-
   2 ;;;; Andy Wingo <wingo@pobox.com> --- May 2009
   3 ;;;;
   4 ;;;;    Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
   5 ;;;;
   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.
  10 ;;;;
  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.
  15 ;;;;
  16 ;;;; You should have received a copy of the GNU Lesser General Public
  17 ;;;; License along with this library; if not, write to the Free Software
  18 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  19
  20 (define-module (test-suite tree-il)
  21   #:use-module (test-suite lib)
  22   #:use-module (system base compile)
  23   #:use-module (system base pmatch)
  24   #:use-module (system base message)
  25   #:use-module (language tree-il)
  26   #:use-module (language glil)
  27   #:use-module (srfi srfi-13))
  28
  29 ;; Of course, the GLIL that is emitted depends on the source info of the
  30 ;; input. Here we're not concerned about that, so we strip source
  31 ;; information from the incoming tree-il.
  32
  33 (define (strip-source x)
  34   (post-order! (lambda (x) (set! (tree-il-src x) #f))
  35                x))
  36
  37 (define-syntax assert-tree-il->glil
  38   (syntax-rules (with-partial-evaluation without-partial-evaluation
  39                  with-options)
  40     ((_ with-partial-evaluation in pat test ...)
  41      (assert-tree-il->glil with-options (#:partial-eval? #t)
  42                            in pat test ...))
  43     ((_ without-partial-evaluation in pat test ...)
  44      (assert-tree-il->glil with-options (#:partial-eval? #f)
  45                            in pat test ...))
  46     ((_ with-options opts in pat test ...)
  47      (let ((exp 'in))
  48        (pass-if 'in
  49          (let ((glil (unparse-glil
  50                       (compile (strip-source (parse-tree-il exp))
  51                                #:from 'tree-il #:to 'glil
  52                                #:opts 'opts))))
  53            (pmatch glil
  54              (pat (guard test ...) #t)
  55              (else #f))))))
  56     ((_ in pat test ...)
  57      (assert-tree-il->glil with-partial-evaluation
  58                            in pat test ...))))
  59
  60 (define-syntax pass-if-tree-il->scheme
  61   (syntax-rules ()
  62     ((_ in pat)
  63      (assert-scheme->tree-il->scheme in pat #t))
  64     ((_ in pat guard-exp)
  65      (pass-if 'in
  66        (pmatch (tree-il->scheme
  67                 (compile 'in #:from 'scheme #:to 'tree-il))
  68          (pat (guard guard-exp) #t)
  69          (_ #f))))))
  70
  71 (define peval
  72   ;; The partial evaluator.
  73   (@@ (language tree-il optimize) peval))
  74
  75 (define-syntax pass-if-peval
  76   (syntax-rules ()
  77     ((_ in pat)
  78      (pass-if 'in
  79        (let ((evaled (unparse-tree-il
  80                       (peval (compile 'in #:from 'scheme #:to 'tree-il)))))
  81          (pmatch evaled
  82            (pat #t)
  83            (_   (pk 'peval-mismatch evaled) #f)))))))
  84
  85 \f
  86 (with-test-prefix "tree-il->scheme"
  87   (pass-if-tree-il->scheme
  88    (case-lambda ((a) a) ((b c) (list b c)))
  89    (case-lambda ((,a) ,a1) ((,b ,c) (list ,b1 ,c1)))
  90    (and (eq? a a1) (eq? b b1) (eq? c c1))))
  91
  92 (with-test-prefix "void"
  93   (assert-tree-il->glil
  94    (void)
  95    (program () (std-prelude 0 0 #f) (label _) (void) (call return 1)))
  96   (assert-tree-il->glil
  97    (begin (void) (const 1))
  98    (program () (std-prelude 0 0 #f) (label _) (const 1) (call return 1)))
  99   (assert-tree-il->glil
 100    (apply (primitive +) (void) (const 1))
 101    (program () (std-prelude 0 0 #f) (label _) (void) (call add1 1) (call return 1))))
 102
 103 (with-test-prefix "application"
 104   (assert-tree-il->glil
 105    (apply (toplevel foo) (const 1))
 106    (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (const 1) (call tail-call 1)))
 107   (assert-tree-il->glil
 108    (begin (apply (toplevel foo) (const 1)) (void))
 109    (program () (std-prelude 0 0 #f) (label _) (call new-frame 0) (toplevel ref foo) (const 1) (mv-call 1 ,l1)
 110             (call drop 1) (branch br ,l2)
 111             (label ,l3) (mv-bind 0 #f)
 112             (label ,l4)
 113             (void) (call return 1))
 114    (and (eq? l1 l3) (eq? l2 l4)))
 115   (assert-tree-il->glil
 116    (apply (toplevel foo) (apply (toplevel bar)))
 117    (program ()  (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call new-frame 0) (toplevel ref bar) (call call 0)
 118             (call tail-call 1))))
 119
 120 (with-test-prefix "conditional"
 121   (assert-tree-il->glil
 122    (if (toplevel foo) (const 1) (const 2))
 123    (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1)
 124             (const 1) (call return 1)
 125             (label ,l2) (const 2) (call return 1))
 126    (eq? l1 l2))
 127
 128   (assert-tree-il->glil without-partial-evaluation
 129    (begin (if (toplevel foo) (const 1) (const 2)) (const #f))
 130    (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1) (branch br ,l2)
 131             (label ,l3) (label ,l4) (const #f) (call return 1))
 132    (eq? l1 l3) (eq? l2 l4))
 133
 134   (assert-tree-il->glil
 135    (apply (primitive null?) (if (toplevel foo) (const 1) (const 2)))
 136    (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1)
 137             (const 1) (branch br ,l2)
 138                     (label ,l3) (const 2) (label ,l4)
 139                     (call null? 1) (call return 1))
 140    (eq? l1 l3) (eq? l2 l4)))
 141
 142 (with-test-prefix "primitive-ref"
 143   (assert-tree-il->glil
 144    (primitive +)
 145    (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call return 1)))
 146
 147   (assert-tree-il->glil
 148    (begin (primitive +) (const #f))
 149    (program () (std-prelude 0 0 #f) (label _) (const #f) (call return 1)))
 150
 151   (assert-tree-il->glil
 152    (apply (primitive null?) (primitive +))
 153    (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call null? 1)
 154             (call return 1))))
 155
 156 (with-test-prefix "lexical refs"
 157   (assert-tree-il->glil without-partial-evaluation
 158    (let (x) (y) ((const 1)) (lexical x y))
 159    (program () (std-prelude 0 1 #f) (label _)
 160             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
 161             (lexical #t #f ref 0) (call return 1)
 162             (unbind)))
 163
 164   (assert-tree-il->glil without-partial-evaluation
 165    (let (x) (y) ((const 1)) (begin (lexical x y) (const #f)))
 166    (program () (std-prelude 0 1 #f) (label _)
 167             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
 168             (const #f) (call return 1)
 169             (unbind)))
 170
 171   (assert-tree-il->glil without-partial-evaluation
 172    (let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y)))
 173    (program () (std-prelude 0 1 #f) (label _)
 174             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
 175             (lexical #t #f ref 0) (call null? 1) (call return 1)
 176             (unbind))))
 177
 178 (with-test-prefix "lexical sets"
 179   (assert-tree-il->glil
 180    ;; unreferenced sets may be optimized away -- make sure they are ref'd
 181    (let (x) (y) ((const 1))
 182         (set! (lexical x y) (apply (primitive 1+) (lexical x y))))
 183    (program () (std-prelude 0 1 #f) (label _)
 184             (const 1) (bind (x #t 0)) (lexical #t #t box 0)
 185             (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
 186             (void) (call return 1)
 187             (unbind)))
 188
 189   (assert-tree-il->glil
 190    (let (x) (y) ((const 1))
 191         (begin (set! (lexical x y) (apply (primitive 1+) (lexical x y)))
 192                (lexical x y)))
 193    (program () (std-prelude 0 1 #f) (label _)
 194             (const 1) (bind (x #t 0)) (lexical #t #t box 0)
 195             (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
 196             (lexical #t #t ref 0) (call return 1)
 197             (unbind)))
 198
 199   (assert-tree-il->glil
 200    (let (x) (y) ((const 1))
 201      (apply (primitive null?)
 202             (set! (lexical x y) (apply (primitive 1+) (lexical x y)))))
 203    (program () (std-prelude 0 1 #f) (label _)
 204             (const 1) (bind (x #t 0)) (lexical #t #t box 0)
 205             (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (void)
 206             (call null? 1) (call return 1)
 207             (unbind))))
 208
 209 (with-test-prefix "module refs"
 210   (assert-tree-il->glil
 211    (@ (foo) bar)
 212    (program () (std-prelude 0 0 #f) (label _)
 213             (module public ref (foo) bar)
 214             (call return 1)))
 215
 216   (assert-tree-il->glil
 217    (begin (@ (foo) bar) (const #f))
 218    (program () (std-prelude 0 0 #f) (label _)
 219             (module public ref (foo) bar) (call drop 1)
 220             (const #f) (call return 1)))
 221
 222   (assert-tree-il->glil
 223    (apply (primitive null?) (@ (foo) bar))
 224    (program () (std-prelude 0 0 #f) (label _)
 225             (module public ref (foo) bar)
 226             (call null? 1) (call return 1)))
 227
 228   (assert-tree-il->glil
 229    (@@ (foo) bar)
 230    (program () (std-prelude 0 0 #f) (label _)
 231             (module private ref (foo) bar)
 232             (call return 1)))
 233
 234   (assert-tree-il->glil
 235    (begin (@@ (foo) bar) (const #f))
 236    (program () (std-prelude 0 0 #f) (label _)
 237             (module private ref (foo) bar) (call drop 1)
 238             (const #f) (call return 1)))
 239
 240   (assert-tree-il->glil
 241    (apply (primitive null?) (@@ (foo) bar))
 242    (program () (std-prelude 0 0 #f) (label _)
 243             (module private ref (foo) bar)
 244             (call null? 1) (call return 1))))
 245
 246 (with-test-prefix "module sets"
 247   (assert-tree-il->glil
 248    (set! (@ (foo) bar) (const 2))
 249    (program () (std-prelude 0 0 #f) (label _)
 250             (const 2) (module public set (foo) bar)
 251             (void) (call return 1)))
 252
 253   (assert-tree-il->glil
 254    (begin (set! (@ (foo) bar) (const 2)) (const #f))
 255    (program () (std-prelude 0 0 #f) (label _)
 256             (const 2) (module public set (foo) bar)
 257             (const #f) (call return 1)))
 258
 259   (assert-tree-il->glil
 260    (apply (primitive null?) (set! (@ (foo) bar) (const 2)))
 261    (program () (std-prelude 0 0 #f) (label _)
 262             (const 2) (module public set (foo) bar)
 263             (void) (call null? 1) (call return 1)))
 264
 265   (assert-tree-il->glil
 266    (set! (@@ (foo) bar) (const 2))
 267    (program () (std-prelude 0 0 #f) (label _)
 268             (const 2) (module private set (foo) bar)
 269             (void) (call return 1)))
 270
 271   (assert-tree-il->glil
 272    (begin (set! (@@ (foo) bar) (const 2)) (const #f))
 273    (program () (std-prelude 0 0 #f) (label _)
 274             (const 2) (module private set (foo) bar)
 275             (const #f) (call return 1)))
 276
 277   (assert-tree-il->glil
 278    (apply (primitive null?) (set! (@@ (foo) bar) (const 2)))
 279    (program () (std-prelude 0 0 #f) (label _)
 280             (const 2) (module private set (foo) bar)
 281             (void) (call null? 1) (call return 1))))
 282
 283 (with-test-prefix "toplevel refs"
 284   (assert-tree-il->glil
 285    (toplevel bar)
 286    (program () (std-prelude 0 0 #f) (label _)
 287             (toplevel ref bar)
 288             (call return 1)))
 289
 290   (assert-tree-il->glil without-partial-evaluation
 291    (begin (toplevel bar) (const #f))
 292    (program () (std-prelude 0 0 #f) (label _)
 293             (toplevel ref bar) (call drop 1)
 294             (const #f) (call return 1)))
 295
 296   (assert-tree-il->glil
 297    (apply (primitive null?) (toplevel bar))
 298    (program () (std-prelude 0 0 #f) (label _)
 299             (toplevel ref bar)
 300             (call null? 1) (call return 1))))
 301
 302 (with-test-prefix "toplevel sets"
 303   (assert-tree-il->glil
 304    (set! (toplevel bar) (const 2))
 305    (program () (std-prelude 0 0 #f) (label _)
 306             (const 2) (toplevel set bar)
 307             (void) (call return 1)))
 308
 309   (assert-tree-il->glil
 310    (begin (set! (toplevel bar) (const 2)) (const #f))
 311    (program () (std-prelude 0 0 #f) (label _)
 312             (const 2) (toplevel set bar)
 313             (const #f) (call return 1)))
 314
 315   (assert-tree-il->glil
 316    (apply (primitive null?) (set! (toplevel bar) (const 2)))
 317    (program () (std-prelude 0 0 #f) (label _)
 318             (const 2) (toplevel set bar)
 319             (void) (call null? 1) (call return 1))))
 320
 321 (with-test-prefix "toplevel defines"
 322   (assert-tree-il->glil
 323    (define bar (const 2))
 324    (program () (std-prelude 0 0 #f) (label _)
 325             (const 2) (toplevel define bar)
 326             (void) (call return 1)))
 327
 328   (assert-tree-il->glil
 329    (begin (define bar (const 2)) (const #f))
 330    (program () (std-prelude 0 0 #f) (label _)
 331             (const 2) (toplevel define bar)
 332             (const #f) (call return 1)))
 333
 334   (assert-tree-il->glil
 335    (apply (primitive null?) (define bar (const 2)))
 336    (program () (std-prelude 0 0 #f) (label _)
 337             (const 2) (toplevel define bar)
 338             (void) (call null? 1) (call return 1))))
 339
 340 (with-test-prefix "constants"
 341   (assert-tree-il->glil
 342    (const 2)
 343    (program () (std-prelude 0 0 #f) (label _)
 344             (const 2) (call return 1)))
 345
 346   (assert-tree-il->glil
 347    (begin (const 2) (const #f))
 348    (program () (std-prelude 0 0 #f) (label _)
 349             (const #f) (call return 1)))
 350
 351   (assert-tree-il->glil
 352    ;; This gets simplified by `peval'.
 353    (apply (primitive null?) (const 2))
 354    (program () (std-prelude 0 0 #f) (label _)
 355             (const #f) (call return 1))))
 356
 357 (with-test-prefix "letrec"
 358   ;; simple bindings -> let
 359   (assert-tree-il->glil without-partial-evaluation
 360    (letrec (x y) (x1 y1) ((const 10) (const 20))
 361            (apply (toplevel foo) (lexical x x1) (lexical y y1)))
 362    (program () (std-prelude 0 2 #f) (label _)
 363             (const 10) (const 20)
 364             (bind (x #f 0) (y #f 1))
 365             (lexical #t #f set 1) (lexical #t #f set 0)
 366             (toplevel ref foo)
 367             (lexical #t #f ref 0) (lexical #t #f ref 1)
 368             (call tail-call 2)
 369             (unbind)))
 370
 371   ;; complex bindings -> box and set! within let
 372   (assert-tree-il->glil without-partial-evaluation
 373    (letrec (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar)))
 374            (apply (primitive +) (lexical x x1) (lexical y y1)))
 375    (program () (std-prelude 0 4 #f) (label _)
 376             (void) (void) ;; what are these?
 377             (bind (x #t 0) (y #t 1))
 378             (lexical #t #t box 1) (lexical #t #t box 0)
 379             (call new-frame 0) (toplevel ref foo) (call call 0)
 380             (call new-frame 0) (toplevel ref bar) (call call 0)
 381             (bind (x #f 2) (y #f 3)) (lexical #t #f set 3) (lexical #t #f set 2)
 382             (lexical #t #f ref 2) (lexical #t #t set 0)
 383             (lexical #t #f ref 3) (lexical #t #t set 1) (unbind)
 384             (lexical #t #t ref 0) (lexical #t #t ref 1)
 385             (call add 2) (call return 1) (unbind)))
 386
 387   ;; complex bindings in letrec* -> box and set! in order
 388   (assert-tree-il->glil without-partial-evaluation
 389    (letrec* (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar)))
 390             (apply (primitive +) (lexical x x1) (lexical y y1)))
 391    (program () (std-prelude 0 2 #f) (label _)
 392             (void) (void) ;; what are these?
 393             (bind (x #t 0) (y #t 1))
 394             (lexical #t #t box 1) (lexical #t #t box 0)
 395             (call new-frame 0) (toplevel ref foo) (call call 0)
 396             (lexical #t #t set 0)
 397             (call new-frame 0) (toplevel ref bar) (call call 0)
 398             (lexical #t #t set 1)
 399             (lexical #t #t ref 0)
 400             (lexical #t #t ref 1)
 401             (call add 2) (call return 1) (unbind)))
 402
 403   ;; simple bindings in letrec* -> equivalent to letrec
 404   (assert-tree-il->glil without-partial-evaluation
 405    (letrec* (x y) (xx yy) ((const 1) (const 2))
 406             (lexical y yy))
 407    (program () (std-prelude 0 1 #f) (label _)
 408             (const 2)
 409             (bind (y #f 0)) ;; X is removed, and Y is unboxed
 410             (lexical #t #f set 0)
 411             (lexical #t #f ref 0)
 412             (call return 1) (unbind))))
 413
 414 (with-test-prefix "lambda"
 415   (assert-tree-il->glil
 416    (lambda ()
 417      (lambda-case (((x) #f #f #f () (y)) (const 2)) #f))
 418    (program ()  (std-prelude 0 0 #f) (label _)
 419             (program () (std-prelude 1 1 #f)
 420                      (bind (x #f 0)) (label _)
 421                      (const 2) (call return 1) (unbind))
 422             (call return 1)))
 423
 424   (assert-tree-il->glil
 425    (lambda ()
 426      (lambda-case (((x y) #f #f #f () (x1 y1))
 427                    (const 2))
 428                   #f))
 429    (program () (std-prelude 0 0 #f) (label _)
 430             (program () (std-prelude 2 2 #f)
 431                      (bind (x #f 0) (y #f 1)) (label _)
 432                      (const 2) (call return 1)
 433                      (unbind))
 434             (call return 1)))
 435
 436   (assert-tree-il->glil
 437    (lambda ()
 438      (lambda-case ((() #f x #f () (y)) (const 2))
 439                   #f))
 440    (program () (std-prelude 0 0 #f) (label _)
 441             (program () (opt-prelude 0 0 0 1 #f)
 442                      (bind (x #f 0)) (label _)
 443                      (const 2) (call return 1)
 444                      (unbind))
 445             (call return 1)))
 446
 447   (assert-tree-il->glil
 448    (lambda ()
 449      (lambda-case (((x) #f x1 #f () (y y1)) (const 2))
 450                   #f))
 451    (program () (std-prelude 0 0 #f) (label _)
 452             (program () (opt-prelude 1 0 1 2 #f)
 453                      (bind (x #f 0) (x1 #f 1)) (label _)
 454                      (const 2) (call return 1)
 455                      (unbind))
 456             (call return 1)))
 457
 458   (assert-tree-il->glil
 459    (lambda ()
 460      (lambda-case (((x) #f x1 #f () (y y1)) (lexical x y))
 461                   #f))
 462    (program () (std-prelude 0 0 #f) (label _)
 463             (program () (opt-prelude 1 0 1 2 #f)
 464                      (bind (x #f 0) (x1 #f 1)) (label _)
 465                      (lexical #t #f ref 0) (call return 1)
 466                      (unbind))
 467             (call return 1)))
 468
 469   (assert-tree-il->glil
 470    (lambda ()
 471      (lambda-case (((x) #f x1 #f () (y y1)) (lexical x1 y1))
 472                   #f))
 473    (program () (std-prelude 0 0 #f) (label _)
 474             (program () (opt-prelude 1 0 1 2 #f)
 475                      (bind (x #f 0) (x1 #f 1)) (label _)
 476                      (lexical #t #f ref 1) (call return 1)
 477                      (unbind))
 478             (call return 1)))
 479
 480   (assert-tree-il->glil
 481    (lambda ()
 482      (lambda-case (((x) #f #f #f () (x1))
 483                    (lambda ()
 484                      (lambda-case (((y) #f #f #f () (y1))
 485                                    (lexical x x1))
 486                                   #f)))
 487                   #f))
 488    (program () (std-prelude 0 0 #f) (label _)
 489             (program () (std-prelude 1 1 #f)
 490                      (bind (x #f 0)) (label _)
 491                      (program () (std-prelude 1 1 #f)
 492                               (bind (y #f 0)) (label _)
 493                               (lexical #f #f ref 0) (call return 1)
 494                               (unbind))
 495                      (lexical #t #f ref 0)
 496                      (call make-closure 1)
 497                      (call return 1)
 498                      (unbind))
 499             (call return 1))))
 500
 501 (with-test-prefix "sequence"
 502   (assert-tree-il->glil
 503    (begin (begin (const 2) (const #f)) (const #t))
 504    (program () (std-prelude 0 0 #f) (label _)
 505             (const #t) (call return 1)))
 506
 507   (assert-tree-il->glil
 508    ;; This gets simplified by `peval'.
 509    (apply (primitive null?) (begin (const #f) (const 2)))
 510    (program () (std-prelude 0 0 #f) (label _)
 511             (const #f) (call return 1))))
 512
 513 (with-test-prefix "values"
 514   (assert-tree-il->glil
 515    (apply (primitive values)
 516           (apply (primitive values) (const 1) (const 2)))
 517    (program () (std-prelude 0 0 #f) (label _)
 518             (const 1) (call return 1)))
 519
 520   (assert-tree-il->glil
 521    (apply (primitive values)
 522           (apply (primitive values) (const 1) (const 2))
 523           (const 3))
 524    (program () (std-prelude 0 0 #f) (label _)
 525             (const 1) (const 3) (call return/values 2)))
 526
 527   (assert-tree-il->glil
 528    (apply (primitive +)
 529           (apply (primitive values) (const 1) (const 2)))
 530    (program () (std-prelude 0 0 #f) (label _)
 531             (const 1) (call return 1))))
 532
 533 ;; FIXME: binding info for or-hacked locals might bork the disassembler,
 534 ;; and could be tightened in any case
 535 (with-test-prefix "the or hack"
 536   (assert-tree-il->glil without-partial-evaluation
 537    (let (x) (y) ((const 1))
 538         (if (lexical x y)
 539             (lexical x y)
 540             (let (a) (b) ((const 2))
 541                  (lexical a b))))
 542    (program () (std-prelude 0 1 #f) (label _)
 543             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
 544             (lexical #t #f ref 0) (branch br-if-not ,l1)
 545             (lexical #t #f ref 0) (call return 1)
 546             (label ,l2)
 547             (const 2) (bind (a #f 0)) (lexical #t #f set 0)
 548             (lexical #t #f ref 0) (call return 1)
 549             (unbind)
 550             (unbind))
 551    (eq? l1 l2))
 552
 553   ;; second bound var is unreferenced
 554   (assert-tree-il->glil without-partial-evaluation
 555    (let (x) (y) ((const 1))
 556         (if (lexical x y)
 557             (lexical x y)
 558             (let (a) (b) ((const 2))
 559                  (lexical x y))))
 560    (program () (std-prelude 0 1 #f) (label _)
 561             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
 562             (lexical #t #f ref 0) (branch br-if-not ,l1)
 563             (lexical #t #f ref 0) (call return 1)
 564             (label ,l2)
 565             (lexical #t #f ref 0) (call return 1)
 566             (unbind))
 567    (eq? l1 l2)))
 568
 569 (with-test-prefix "apply"
 570   (assert-tree-il->glil
 571    (apply (primitive @apply) (toplevel foo) (toplevel bar))
 572    (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (toplevel ref bar) (call tail-apply 2)))
 573   (assert-tree-il->glil
 574    (begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void))
 575    (program () (std-prelude 0 0 #f) (label _)
 576             (call new-frame 0) (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1)
 577             (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
 578             (label ,l4)
 579             (void) (call return 1))
 580    (and (eq? l1 l3) (eq? l2 l4)))
 581   (assert-tree-il->glil
 582    (apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz)))
 583    (program () (std-prelude 0 0 #f) (label _)
 584             (toplevel ref foo)
 585             (call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call apply 2)
 586             (call tail-call 1))))
 587
 588 (with-test-prefix "call/cc"
 589   (assert-tree-il->glil
 590    (apply (primitive @call-with-current-continuation) (toplevel foo))
 591    (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call tail-call/cc 1)))
 592   (assert-tree-il->glil
 593    (begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void))
 594    (program () (std-prelude 0 0 #f) (label _)
 595             (call new-frame 0) (toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1)
 596             (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
 597             (label ,l4)
 598             (void) (call return 1))
 599    (and (eq? l1 l3) (eq? l2 l4)))
 600   (assert-tree-il->glil
 601    (apply (toplevel foo)
 602           (apply (toplevel @call-with-current-continuation) (toplevel bar)))
 603    (program () (std-prelude 0 0 #f) (label _)
 604             (toplevel ref foo)
 605             (toplevel ref bar) (call call/cc 1)
 606             (call tail-call 1))))
 607
 608 \f
 609 (with-test-prefix "partial evaluation"
 610
 611   (pass-if-peval
 612     ;; First order, primitive.
 613     (let ((x 1) (y 2)) (+ x y))
 614     (const 3))
 615
 616   (pass-if-peval
 617     ;; First order, thunk.
 618     (let ((x 1) (y 2))
 619       (let ((f (lambda () (+ x y))))
 620         (f)))
 621     (const 3))
 622
 623   (pass-if-peval
 624     ;; First order, coalesced.
 625     (cons 0 (cons 1 (cons 2 (list 3 4 5))))
 626     (const (0 1 2 3 4 5)))
 627
 628   (pass-if-peval
 629     ;; First order, coalesced, mutability preserved.
 630     (define mutable
 631       (cons 0 (cons 1 (cons 2 (list 3 4 5)))))
 632     (define mutable
 633       ;; This must not be a constant.
 634       (apply (primitive list)
 635              (const 0) (const 1) (const 2) (const 3) (const 4) (const 5))))
 636
 637   (pass-if-peval
 638     ;; First order, mutability preserved.
 639     (define mutable
 640       (let loop ((i 3) (r '()))
 641         (if (zero? i)
 642             r
 643             (loop (1- i) (cons (cons i i) r)))))
 644     (define mutable
 645       (apply (primitive list)
 646              (apply (primitive cons) (const 1) (const 1))
 647              (apply (primitive cons) (const 2) (const 2))
 648              (apply (primitive cons) (const 3) (const 3)))))
 649
 650   (pass-if-peval
 651     ;; Mutability preserved.
 652     (define mutable
 653       ((lambda (x y z) (list x y z)) 1 2 3))
 654     (define mutable
 655       (apply (primitive list) (const 1) (const 2) (const 3))))
 656
 657   (pass-if-peval
 658     ;; First order, evaluated.
 659     (define one
 660       (let loop ((i 7)
 661                  (r '()))
 662         (if (<= i 0)
 663             (car r)
 664             (loop (1- i) (cons i r)))))
 665     (define one (const 1)))
 666
 667   (pass-if-peval
 668     ;; First order, aliased primitive.
 669     (let* ((x *) (y (x 1 2))) y)
 670     (const 2))
 671
 672   (pass-if-peval
 673     ;; First order, shadowed primitive.
 674     (begin
 675       (define (+ x y) (pk x y))
 676       (+ 1 2))
 677     (begin
 678       (define +
 679         (lambda (_)
 680           (lambda-case
 681            (((x y) #f #f #f () (_ _))
 682             (apply (toplevel pk) (lexical x _) (lexical y _))))))
 683       (apply (toplevel +) (const 1) (const 2))))
 684
 685   (pass-if-peval
 686     ;; First-order, effects preserved.
 687     (let ((x 2))
 688       (do-something!)
 689       x)
 690     (begin
 691       (apply (toplevel do-something!))
 692       (const 2)))
 693
 694   (pass-if-peval
 695     ;; First order, residual bindings removed.
 696     (let ((x 2) (y 3))
 697       (* (+ x y) z))
 698     (apply (primitive *) (const 5) (toplevel z)))
 699
 700   (pass-if-peval
 701     ;; First order, with lambda.
 702     (define (foo x)
 703       (define (bar z) (* z z))
 704       (+ x (bar 3)))
 705     (define foo
 706       (lambda (_)
 707         (lambda-case
 708          (((x) #f #f #f () (_))
 709           (letrec* (bar) (_) ((lambda (_) . _))
 710                    (apply (primitive +) (lexical x _) (const 9))))))))
 711
 712   (pass-if-peval
 713     ;; First order, with lambda inlined & specialized twice.
 714     (let ((f (lambda (x y)
 715                (+ (* x top) y)))
 716           (x 2)
 717           (y 3))
 718       (+ (* x (f x y))
 719          (f something x)))
 720     (let (f) (_) ((lambda (_)
 721                     (lambda-case
 722                      (((x y) #f #f #f () (_ _))
 723                       (apply (primitive +)
 724                              (apply (primitive *)
 725                                     (lexical x _)
 726                                     (toplevel top))
 727                              (lexical y _))))))
 728          (apply (primitive +)
 729                 (apply (primitive *)
 730                        (const 2)
 731                        (apply (primitive +)       ; (f 2 3)
 732                               (apply (primitive *)
 733                                      (const 2)
 734                                      (toplevel top))
 735                               (const 3)))
 736                 (apply (primitive +)              ; (f something 2)
 737                        (apply (primitive *)
 738                               (toplevel something)
 739                               (toplevel top))
 740                        (const 2)))))
 741
 742   (pass-if-peval
 743     ;; First order, with lambda inlined & specialized 3 times.
 744     (let ((f (lambda (x y) (if (> x 0) y x))))
 745       (+ (f -1 x) (f 2 y) (f z y)))
 746     (let (f) (_)
 747          ((lambda (_)
 748             (lambda-case
 749              (((x y) #f #f #f () (_ _))
 750               (if (apply (primitive >) (lexical x _) (const 0))
 751                   (lexical y _)
 752                   (lexical x _))))))
 753          (apply (primitive +)
 754                 (const -1)                        ; (f -1 x)
 755                 (toplevel y)                      ; (f 2 y)
 756                 (apply (lexical f _)              ; (f z y)
 757                        (toplevel z) (toplevel y)))))
 758
 759   (pass-if-peval
 760     ;; First order, conditional.
 761     (let ((y 2))
 762       (lambda (x)
 763         (if (> y 0)
 764             (display x)
 765             'never-reached)))
 766     (lambda ()
 767       (lambda-case
 768        (((x) #f #f #f () (_))
 769         (apply (toplevel display) (lexical x _))))))
 770
 771   (pass-if-peval
 772     ;; First order, recursive procedure.
 773     (letrec ((fibo (lambda (n)
 774                      (if (<= n 1)
 775                          n
 776                          (+ (fibo (- n 1))
 777                             (fibo (- n 2)))))))
 778       (fibo 7))
 779     (const 13))
 780
 781   (pass-if-peval
 782     ;; Higher order.
 783     ((lambda (f x)
 784        (f (* (car x) (cadr x))))
 785      (lambda (x)
 786        (+ x 1))
 787      '(2 3))
 788     (const 7))
 789
 790   (pass-if-peval
 791     ;; Higher order with optional argument (default value).
 792     ((lambda* (f x #:optional (y 0))
 793        (+ y (f (* (car x) (cadr x)))))
 794      (lambda (x)
 795        (+ x 1))
 796      '(2 3))
 797     (const 7))
 798
 799   (pass-if-peval
 800     ;; Higher order with optional argument (caller-supplied value).
 801     ((lambda* (f x #:optional (y 0))
 802        (+ y (f (* (car x) (cadr x)))))
 803      (lambda (x)
 804        (+ x 1))
 805      '(2 3)
 806      35)
 807     (const 42))
 808
 809   (pass-if-peval
 810     ;; Higher order.
 811     ((lambda (f) (f x)) (lambda (x) x))
 812     (apply (lambda ()
 813              (lambda-case
 814               (((x) #f #f #f () (_))
 815                (lexical x _))))
 816            (toplevel x)))
 817
 818   (pass-if-peval
 819     ;; Bug reported at
 820     ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>.
 821     (let ((fold (lambda (f g) (f (g top)))))
 822       (fold 1+ (lambda (x) x)))
 823     (let (fold) (_) (_)
 824          (apply (primitive 1+)
 825                 (apply (lambda ()
 826                          (lambda-case
 827                           (((x) #f #f #f () (_))
 828                            (lexical x _))))
 829                        (toplevel top)))))
 830
 831   (pass-if-peval
 832     ;; Higher order, mutually recursive procedures.
 833     (letrec ((even? (lambda (x)
 834                       (or (= 0 x)
 835                           (odd? (- x 1)))))
 836              (odd?  (lambda (x)
 837                       (not (even? (- x 1))))))
 838       (and (even? 4) (odd? 7)))
 839     (const #t))
 840
 841   ;;
 842   ;; Below are cases where constant propagation should bail out.
 843   ;;
 844
 845   (pass-if-peval
 846     ;; Non-constant lexical is not propagated.
 847     (let ((v (make-vector 6 #f)))
 848       (lambda (n)
 849         (vector-set! v n n)))
 850     (let (v) (_)
 851          ((apply (toplevel make-vector) (const 6) (const #f)))
 852          (lambda ()
 853            (lambda-case
 854             (((n) #f #f #f () (_))
 855              (apply (toplevel vector-set!)
 856                     (lexical v _) (lexical n _) (lexical n _)))))))
 857
 858   (pass-if-peval
 859     ;; Mutable lexical is not propagated.
 860     (let ((v (vector 1 2 3)))
 861       (lambda ()
 862         v))
 863     (let (v) (_)
 864          ((apply (primitive vector) (const 1) (const 2) (const 3)))
 865          (lambda ()
 866            (lambda-case
 867             ((() #f #f #f () ())
 868              (lexical v _))))))
 869
 870   (pass-if-peval
 871     ;; Lexical that is not provably pure is not inlined nor propagated.
 872     (let* ((x (if (> p q) (frob!) (display 'chbouib)))
 873            (y (* x 2)))
 874       (+ x x y))
 875     (let (x) (_) ((if (apply (primitive >) (toplevel p) (toplevel q))
 876                       (apply (toplevel frob!))
 877                       (apply (toplevel display) (const chbouib))))
 878          (let (y) (_) ((apply (primitive *) (lexical x _) (const 2)))
 879               (apply (primitive +) (lexical x _) (lexical x _)
 880                      (apply (primitive *) (lexical x _) (const 2))))))
 881
 882   (pass-if-peval
 883     ;; Non-constant arguments not propagated to lambdas.
 884     ((lambda (x y z)
 885        (vector-set! x 0 0)
 886        (set-car! y 0)
 887        (set-cdr! z '()))
 888      (vector 1 2 3)
 889      (make-list 10)
 890      (list 1 2 3))
 891     (apply (lambda ()
 892              (lambda-case
 893               (((x y z) #f #f #f () (_ _ _))
 894                (begin
 895                  (apply (toplevel vector-set!)
 896                         (lexical x _) (const 0) (const 0))
 897                  (apply (toplevel set-car!)
 898                         (lexical y _) (const 0))
 899                  (apply (toplevel set-cdr!)
 900                         (lexical z _) (const ()))))))
 901            (apply (primitive vector) (const 1) (const 2) (const 3))
 902            (apply (toplevel make-list) (const 10))
 903            (apply (primitive list) (const 1) (const 2) (const 3))))
 904
 905   (pass-if-peval
 906     ;; Procedure only called with dynamic args is not inlined.
 907     (let* ((g (lambda (x y) (+ x y)))
 908            (f (lambda (g x) (g x x))))
 909       (+ (f g foo) (f g bar)))
 910     (let (g) (_)
 911          ((lambda _                              ; g
 912              (lambda-case
 913               (((x y) #f #f #f () (_ _))
 914                (apply (primitive +) (lexical x _) (lexical y _))))))
 915          (let (f) (_)
 916               ((lambda _                         ; f
 917                  (lambda-case
 918                   (((g x) #f #f #f () (_ _))
 919                    (apply (lexical g _) (lexical x _) (lexical x _))))))
 920               (apply (primitive +)
 921                      (apply (lexical g _) (toplevel foo) (toplevel foo))
 922                      (apply (lexical g _) (toplevel bar) (toplevel bar))))))
 923
 924   (pass-if-peval
 925     ;; Fresh objects are not turned into constants.
 926     (let* ((c '(2 3))
 927            (x (cons 1 c))
 928            (y (cons 0 x)))
 929       y)
 930     (let (x) (_) ((apply (primitive list) (const 1) (const 2) (const 3)))
 931          (let (y) (_) ((apply (primitive cons) (const 0) (lexical x _)))
 932               (lexical y _))))
 933
 934   (pass-if-peval
 935     ;; Bindings mutated.
 936     (let ((x 2))
 937       (set! x 3)
 938       x)
 939     (let (x) (_) ((const 2))
 940          (begin
 941            (set! (lexical x _) (const 3))
 942            (lexical x _))))
 943
 944   (pass-if-peval
 945     ;; Bindings mutated.
 946     (letrec ((x 0)
 947              (f (lambda ()
 948                   (set! x (+ 1 x))
 949                   x)))
 950       (frob f) ; may mutate `x'
 951       x)
 952     (letrec (x f) (_ _) ((const 0) _)
 953             (begin
 954              (apply (toplevel frob) (lexical f _))
 955              (lexical x _))))
 956
 957   (pass-if-peval
 958     ;; Bindings mutated.
 959     (letrec ((f (lambda (x)
 960                   (set! f (lambda (_) x))
 961                   x)))
 962       (f 2))
 963     (letrec _ . _))
 964
 965   (pass-if-peval
 966     ;; Bindings possibly mutated.
 967     (let ((x (make-foo)))
 968       (frob! x) ; may mutate `x'
 969       x)
 970     (let (x) (_) ((apply (toplevel make-foo)))
 971          (begin
 972            (apply (toplevel frob!) (lexical x _))
 973            (lexical x _))))
 974
 975   (pass-if-peval
 976     ;; Inlining stops at recursive calls with dynamic arguments.
 977     (let loop ((x x))
 978       (if (< x 0) x (loop (1- x))))
 979     (letrec (loop) (_) ((lambda (_)
 980                           (lambda-case
 981                            (((x) #f #f #f () (_))
 982                             (if _ _
 983                                 (apply (lexical loop _)
 984                                        (apply (primitive 1-)
 985                                               (lexical x _))))))))
 986             (apply (lexical loop _) (toplevel x))))
 987
 988   (pass-if-peval
 989     ;; Inlining stops at recursive calls (mixed static/dynamic arguments).
 990     (let loop ((x x) (y 0))
 991       (if (> y 0)
 992           (loop (1+ x) (1+ y))
 993           (if (< x 0) x (loop (1- x)))))
 994     (letrec (loop) (_) ((lambda (_)
 995                           (lambda-case
 996                            (((x y) #f #f #f () (_ _))
 997                             (if (apply (primitive >)
 998                                        (lexical y _) (const 0))
 999                                 _ _)))))
1000             ;; call to (loop x 0) is inlined & specialized
1001             (if (apply (primitive <) (toplevel x) (const 0))
1002                 (toplevel x)
1003                 (apply (lexical loop _)
1004                        (apply (primitive 1-) (toplevel x))))))
1005
1006   (pass-if-peval
1007     ;; Infinite recursion: `peval' gives up and leaves it as is.
1008     (letrec ((f (lambda (x) (g (1- x))))
1009              (g (lambda (x) (h (1+ x))))
1010              (h (lambda (x) (f x))))
1011       (f 0))
1012     (letrec _ . _)))
1013
1014 \f
1015 (with-test-prefix "tree-il-fold"
1016
1017   (pass-if "empty tree"
1018     (let ((leaf? #f) (up? #f) (down? #f) (mark (list 'mark)))
1019       (and (eq? mark
1020                 (tree-il-fold (lambda (x y) (set! leaf? #t) y)
1021                               (lambda (x y) (set! down? #t) y)
1022                               (lambda (x y) (set! up? #t) y)
1023                               mark
1024                               '()))
1025            (not leaf?)
1026            (not up?)
1027            (not down?))))
1028
1029   (pass-if "lambda and application"
1030     (let* ((leaves '()) (ups '()) (downs '())
1031            (result (tree-il-fold (lambda (x y)
1032                                    (set! leaves (cons x leaves))
1033                                    (1+ y))
1034                                  (lambda (x y)
1035                                    (set! downs (cons x downs))
1036                                    (1+ y))
1037                                  (lambda (x y)
1038                                    (set! ups (cons x ups))
1039                                    (1+ y))
1040                                  0
1041                                  (parse-tree-il
1042                                   '(lambda ()
1043                                      (lambda-case
1044                                       (((x y) #f #f #f () (x1 y1))
1045                                        (apply (toplevel +)
1046                                               (lexical x x1)
1047                                               (lexical y y1)))
1048                                       #f))))))
1049       (and (equal? (map strip-source leaves)
1050                    (list (make-lexical-ref #f 'y 'y1)
1051                          (make-lexical-ref #f 'x 'x1)
1052                          (make-toplevel-ref #f '+)))
1053            (= (length downs) 3)
1054            (equal? (reverse (map strip-source ups))
1055                    (map strip-source downs))))))
1056
1057 \f
1058 ;;;
1059 ;;; Warnings.
1060 ;;;
1061
1062 ;; Make sure we get English messages.
1063 (setlocale LC_ALL "C")
1064
1065 (define (call-with-warnings thunk)
1066   (let ((port (open-output-string)))
1067     (with-fluids ((*current-warning-port*   port)
1068                   (*current-warning-prefix* ""))
1069       (thunk))
1070     (let ((warnings (get-output-string port)))
1071       (string-tokenize warnings
1072                        (char-set-complement (char-set #\newline))))))
1073
1074 (define %opts-w-unused
1075   '(#:warnings (unused-variable)))
1076
1077 (define %opts-w-unused-toplevel
1078   '(#:warnings (unused-toplevel)))
1079
1080 (define %opts-w-unbound
1081   '(#:warnings (unbound-variable)))
1082
1083 (define %opts-w-arity
1084   '(#:warnings (arity-mismatch)))
1085
1086 (define %opts-w-format
1087   '(#:warnings (format)))
1088
1089
1090 (with-test-prefix "warnings"
1091
1092    (pass-if "unknown warning type"
1093      (let ((w (call-with-warnings
1094                 (lambda ()
1095                   (compile #t #:opts '(#:warnings (does-not-exist)))))))
1096        (and (= (length w) 1)
1097             (number? (string-contains (car w) "unknown warning")))))
1098
1099    (with-test-prefix "unused-variable"
1100
1101      (pass-if "quiet"
1102        (null? (call-with-warnings
1103                 (lambda ()
1104                   (compile '(lambda (x y) (+ x y))
1105                            #:opts %opts-w-unused)))))
1106
1107      (pass-if "let/unused"
1108        (let ((w (call-with-warnings
1109                   (lambda ()
1110                     (compile '(lambda (x)
1111                                 (let ((y (+ x 2)))
1112                                   x))
1113                              #:opts %opts-w-unused)))))
1114          (and (= (length w) 1)
1115               (number? (string-contains (car w) "unused variable `y'")))))
1116
1117      (pass-if "shadowed variable"
1118        (let ((w (call-with-warnings
1119                   (lambda ()
1120                     (compile '(lambda (x)
1121                                 (let ((y x))
1122                                   (let ((y (+ x 2)))
1123                                     (+ x y))))
1124                              #:opts %opts-w-unused)))))
1125          (and (= (length w) 1)
1126               (number? (string-contains (car w) "unused variable `y'")))))
1127
1128      (pass-if "letrec"
1129        (null? (call-with-warnings
1130                 (lambda ()
1131                   (compile '(lambda ()
1132                               (letrec ((x (lambda () (y)))
1133                                        (y (lambda () (x))))
1134                                 y))
1135                            #:opts %opts-w-unused)))))
1136
1137      (pass-if "unused argument"
1138        ;; Unused arguments should not be reported.
1139        (null? (call-with-warnings
1140                 (lambda ()
1141                   (compile '(lambda (x y z) #t)
1142                            #:opts %opts-w-unused)))))
1143
1144      (pass-if "special variable names"
1145        (null? (call-with-warnings
1146                 (lambda ()
1147                   (compile '(lambda ()
1148                               (let ((_ 'underscore)
1149                                     (#{gensym name}# 'ignore-me))
1150                                 #t))
1151                            #:to 'assembly
1152                            #:opts %opts-w-unused))))))
1153
1154    (with-test-prefix "unused-toplevel"
1155
1156      (pass-if "used after definition"
1157        (null? (call-with-warnings
1158                 (lambda ()
1159                   (let ((in (open-input-string
1160                              "(define foo 2) foo")))
1161                     (read-and-compile in
1162                                       #:to 'assembly
1163                                       #:opts %opts-w-unused-toplevel))))))
1164
1165      (pass-if "used before definition"
1166        (null? (call-with-warnings
1167                 (lambda ()
1168                   (let ((in (open-input-string
1169                              "(define (bar) foo) (define foo 2) (bar)")))
1170                     (read-and-compile in
1171                                       #:to 'assembly
1172                                       #:opts %opts-w-unused-toplevel))))))
1173
1174      (pass-if "unused but public"
1175        (let ((in (open-input-string
1176                   "(define-module (test-suite tree-il x) #:export (bar))
1177                    (define (bar) #t)")))
1178          (null? (call-with-warnings
1179                   (lambda ()
1180                     (read-and-compile in
1181                                       #:to 'assembly
1182                                       #:opts %opts-w-unused-toplevel))))))
1183
1184      (pass-if "unused but public (more)"
1185        (let ((in (open-input-string
1186                   "(define-module (test-suite tree-il x) #:export (bar))
1187                    (define (bar) (baz))
1188                    (define (baz) (foo))
1189                    (define (foo) #t)")))
1190          (null? (call-with-warnings
1191                   (lambda ()
1192                     (read-and-compile in
1193                                       #:to 'assembly
1194                                       #:opts %opts-w-unused-toplevel))))))
1195
1196      (pass-if "unused but define-public"
1197        (null? (call-with-warnings
1198                 (lambda ()
1199                   (compile '(define-public foo 2)
1200                            #:to 'assembly
1201                            #:opts %opts-w-unused-toplevel)))))
1202
1203      (pass-if "used by macro"
1204        ;; FIXME: See comment about macros at `unused-toplevel-analysis'.
1205        (throw 'unresolved)
1206
1207        (null? (call-with-warnings
1208                 (lambda ()
1209                   (let ((in (open-input-string
1210                              "(define (bar) 'foo)
1211                               (define-syntax baz
1212                                 (syntax-rules () ((_) (bar))))")))
1213                     (read-and-compile in
1214                                       #:to 'assembly
1215                                       #:opts %opts-w-unused-toplevel))))))
1216
1217      (pass-if "unused"
1218        (let ((w (call-with-warnings
1219                   (lambda ()
1220                     (compile '(define foo 2)
1221                              #:to 'assembly
1222                              #:opts %opts-w-unused-toplevel)))))
1223          (and (= (length w) 1)
1224               (number? (string-contains (car w)
1225                                         (format #f "top-level variable `~A'"
1226                                                 'foo))))))
1227
1228      (pass-if "unused recursive"
1229        (let ((w (call-with-warnings
1230                   (lambda ()
1231                     (compile '(define (foo) (foo))
1232                              #:to 'assembly
1233                              #:opts %opts-w-unused-toplevel)))))
1234          (and (= (length w) 1)
1235               (number? (string-contains (car w)
1236                                         (format #f "top-level variable `~A'"
1237                                                 'foo))))))
1238
1239      (pass-if "unused mutually recursive"
1240        (let* ((in (open-input-string
1241                    "(define (foo) (bar)) (define (bar) (foo))"))
1242               (w  (call-with-warnings
1243                     (lambda ()
1244                       (read-and-compile in
1245                                         #:to 'assembly
1246                                         #:opts %opts-w-unused-toplevel)))))
1247          (and (= (length w) 2)
1248               (number? (string-contains (car w)
1249                                         (format #f "top-level variable `~A'"
1250                                                 'foo)))
1251               (number? (string-contains (cadr w)
1252                                         (format #f "top-level variable `~A'"
1253                                                 'bar))))))
1254
1255      (pass-if "special variable names"
1256        (null? (call-with-warnings
1257                 (lambda ()
1258                   (compile '(define #{gensym name}# 'ignore-me)
1259                            #:to 'assembly
1260                            #:opts %opts-w-unused-toplevel))))))
1261
1262    (with-test-prefix "unbound variable"
1263
1264      (pass-if "quiet"
1265        (null? (call-with-warnings
1266                 (lambda ()
1267                   (compile '+ #:opts %opts-w-unbound)))))
1268
1269      (pass-if "ref"
1270        (let* ((v (gensym))
1271               (w (call-with-warnings
1272                    (lambda ()
1273                      (compile v
1274                               #:to 'assembly
1275                               #:opts %opts-w-unbound)))))
1276          (and (= (length w) 1)
1277               (number? (string-contains (car w)
1278                                         (format #f "unbound variable `~A'"
1279                                                 v))))))
1280
1281      (pass-if "set!"
1282        (let* ((v (gensym))
1283               (w (call-with-warnings
1284                    (lambda ()
1285                      (compile `(set! ,v 7)
1286                               #:to 'assembly
1287                               #:opts %opts-w-unbound)))))
1288          (and (= (length w) 1)
1289               (number? (string-contains (car w)
1290                                         (format #f "unbound variable `~A'"
1291                                                 v))))))
1292
1293      (pass-if "module-local top-level is visible"
1294        (let ((m (make-module))
1295              (v (gensym)))
1296          (beautify-user-module! m)
1297          (compile `(define ,v 123)
1298                   #:env m #:opts %opts-w-unbound)
1299          (null? (call-with-warnings
1300                   (lambda ()
1301                     (compile v
1302                              #:env m
1303                              #:to 'assembly
1304                              #:opts %opts-w-unbound))))))
1305
1306      (pass-if "module-local top-level is visible after"
1307        (let ((m (make-module))
1308              (v (gensym)))
1309          (beautify-user-module! m)
1310          (null? (call-with-warnings
1311                   (lambda ()
1312                     (let ((in (open-input-string
1313                                "(define (f)
1314                                   (set! chbouib 3))
1315                                 (define chbouib 5)")))
1316                       (read-and-compile in
1317                                         #:env m
1318                                         #:opts %opts-w-unbound)))))))
1319
1320      (pass-if "optional arguments are visible"
1321        (null? (call-with-warnings
1322                 (lambda ()
1323                   (compile '(lambda* (x #:optional y z) (list x y z))
1324                            #:opts %opts-w-unbound
1325                            #:to 'assembly)))))
1326
1327      (pass-if "keyword arguments are visible"
1328        (null? (call-with-warnings
1329                 (lambda ()
1330                   (compile '(lambda* (x #:key y z) (list x y z))
1331                            #:opts %opts-w-unbound
1332                            #:to 'assembly)))))
1333
1334      (pass-if "GOOPS definitions are visible"
1335        (let ((m (make-module))
1336              (v (gensym)))
1337          (beautify-user-module! m)
1338          (module-use! m (resolve-interface '(oop goops)))
1339          (null? (call-with-warnings
1340                   (lambda ()
1341                     (let ((in (open-input-string
1342                                "(define-class <foo> ()
1343                                   (bar #:getter foo-bar))
1344                                 (define z (foo-bar (make <foo>)))")))
1345                       (read-and-compile in
1346                                         #:env m
1347                                         #:opts %opts-w-unbound))))))))
1348
1349    (with-test-prefix "arity mismatch"
1350
1351      (pass-if "quiet"
1352        (null? (call-with-warnings
1353                 (lambda ()
1354                   (compile '(cons 'a 'b) #:opts %opts-w-arity)))))
1355
1356      (pass-if "direct application"
1357        (let ((w (call-with-warnings
1358                   (lambda ()
1359                     (compile '((lambda (x y) (or x y)) 1 2 3 4 5)
1360                              #:opts %opts-w-arity
1361                              #:to 'assembly)))))
1362          (and (= (length w) 1)
1363               (number? (string-contains (car w)
1364                                         "wrong number of arguments to")))))
1365      (pass-if "local"
1366        (let ((w (call-with-warnings
1367                   (lambda ()
1368                     (compile '(let ((f (lambda (x y) (+ x y))))
1369                                 (f 2))
1370                              #:opts %opts-w-arity
1371                              #:to 'assembly)))))
1372          (and (= (length w) 1)
1373               (number? (string-contains (car w)
1374                                         "wrong number of arguments to")))))
1375
1376      (pass-if "global"
1377        (let ((w (call-with-warnings
1378                   (lambda ()
1379                     (compile '(cons 1 2 3 4)
1380                              #:opts %opts-w-arity
1381                              #:to 'assembly)))))
1382          (and (= (length w) 1)
1383               (number? (string-contains (car w)
1384                                         "wrong number of arguments to")))))
1385
1386      (pass-if "alias to global"
1387        (let ((w (call-with-warnings
1388                   (lambda ()
1389                     (compile '(let ((f cons)) (f 1 2 3 4))
1390                              #:opts %opts-w-arity
1391                              #:to 'assembly)))))
1392          (and (= (length w) 1)
1393               (number? (string-contains (car w)
1394                                         "wrong number of arguments to")))))
1395
1396      (pass-if "alias to lexical to global"
1397        (let ((w (call-with-warnings
1398                   (lambda ()
1399                     (compile '(let ((f number?))
1400                                 (let ((g f))
1401                                   (f 1 2 3 4)))
1402                              #:opts %opts-w-arity
1403                              #:to 'assembly)))))
1404          (and (= (length w) 1)
1405               (number? (string-contains (car w)
1406                                         "wrong number of arguments to")))))
1407
1408      (pass-if "alias to lexical"
1409        (let ((w (call-with-warnings
1410                   (lambda ()
1411                     (compile '(let ((f (lambda (x y z) (+ x y z))))
1412                                 (let ((g f))
1413                                   (g 1)))
1414                              #:opts %opts-w-arity
1415                              #:to 'assembly)))))
1416          (and (= (length w) 1)
1417               (number? (string-contains (car w)
1418                                         "wrong number of arguments to")))))
1419
1420      (pass-if "letrec"
1421        (let ((w (call-with-warnings
1422                   (lambda ()
1423                     (compile '(letrec ((odd?  (lambda (x) (even? (1- x))))
1424                                        (even? (lambda (x)
1425                                                 (or (= 0 x)
1426                                                     (odd?)))))
1427                                 (odd? 1))
1428                              #:opts %opts-w-arity
1429                              #:to 'assembly)))))
1430          (and (= (length w) 1)
1431               (number? (string-contains (car w)
1432                                         "wrong number of arguments to")))))
1433
1434      (pass-if "case-lambda"
1435        (null? (call-with-warnings
1436                 (lambda ()
1437                   (compile '(let ((f (case-lambda
1438                                        ((x)     1)
1439                                        ((x y)   2)
1440                                        ((x y z) 3))))
1441                               (list (f 1)
1442                                     (f 1 2)
1443                                     (f 1 2 3)))
1444                            #:opts %opts-w-arity
1445                            #:to 'assembly)))))
1446
1447      (pass-if "case-lambda with wrong number of arguments"
1448        (let ((w (call-with-warnings
1449                   (lambda ()
1450                     (compile '(let ((f (case-lambda
1451                                          ((x)     1)
1452                                          ((x y)   2))))
1453                                 (f 1 2 3))
1454                              #:opts %opts-w-arity
1455                              #:to 'assembly)))))
1456          (and (= (length w) 1)
1457               (number? (string-contains (car w)
1458                                         "wrong number of arguments to")))))
1459
1460      (pass-if "case-lambda*"
1461        (null? (call-with-warnings
1462                 (lambda ()
1463                   (compile '(let ((f (case-lambda*
1464                                        ((x #:optional y) 1)
1465                                        ((x #:key y)      2)
1466                                        ((x y #:key z)    3))))
1467                               (list (f 1)
1468                                     (f 1 2)
1469                                     (f #:y 2)
1470                                     (f 1 2 #:z 3)))
1471                            #:opts %opts-w-arity
1472                            #:to 'assembly)))))
1473
1474      (pass-if "case-lambda* with wrong arguments"
1475        (let ((w (call-with-warnings
1476                   (lambda ()
1477                     (compile '(let ((f (case-lambda*
1478                                          ((x #:optional y) 1)
1479                                          ((x #:key y)      2)
1480                                          ((x y #:key z)    3))))
1481                                 (list (f)
1482                                       (f 1 #:z 3)))
1483                              #:opts %opts-w-arity
1484                              #:to 'assembly)))))
1485          (and (= (length w) 2)
1486               (null? (filter (lambda (w)
1487                                (not
1488                                 (number?
1489                                  (string-contains
1490                                   w "wrong number of arguments to"))))
1491                              w)))))
1492
1493      (pass-if "local toplevel-defines"
1494        (let ((w (call-with-warnings
1495                   (lambda ()
1496                     (let ((in (open-input-string "
1497                                 (define (g x) (f x))
1498                                 (define (f) 1)")))
1499                       (read-and-compile in
1500                                         #:opts %opts-w-arity
1501                                         #:to 'assembly))))))
1502          (and (= (length w) 1)
1503               (number? (string-contains (car w)
1504                                         "wrong number of arguments to")))))
1505
1506      (pass-if "global toplevel alias"
1507        (let ((w (call-with-warnings
1508                   (lambda ()
1509                     (let ((in (open-input-string "
1510                                 (define f cons)
1511                                 (define (g) (f))")))
1512                       (read-and-compile in
1513                                         #:opts %opts-w-arity
1514                                         #:to 'assembly))))))
1515          (and (= (length w) 1)
1516               (number? (string-contains (car w)
1517                                         "wrong number of arguments to")))))
1518
1519      (pass-if "local toplevel overrides global"
1520        (null? (call-with-warnings
1521                 (lambda ()
1522                   (let ((in (open-input-string "
1523                               (define (cons) 0)
1524                               (define (foo x) (cons))")))
1525                     (read-and-compile in
1526                                       #:opts %opts-w-arity
1527                                       #:to 'assembly))))))
1528
1529      (pass-if "keyword not passed and quiet"
1530        (null? (call-with-warnings
1531                 (lambda ()
1532                   (compile '(let ((f (lambda* (x #:key y) y)))
1533                               (f 2))
1534                            #:opts %opts-w-arity
1535                            #:to 'assembly)))))
1536
1537      (pass-if "keyword passed and quiet"
1538        (null? (call-with-warnings
1539                 (lambda ()
1540                   (compile '(let ((f (lambda* (x #:key y) y)))
1541                               (f 2 #:y 3))
1542                            #:opts %opts-w-arity
1543                            #:to 'assembly)))))
1544
1545      (pass-if "keyword passed to global and quiet"
1546        (null? (call-with-warnings
1547                 (lambda ()
1548                   (let ((in (open-input-string "
1549                               (use-modules (system base compile))
1550                               (compile '(+ 2 3) #:env (current-module))")))
1551                     (read-and-compile in
1552                                       #:opts %opts-w-arity
1553                                       #:to 'assembly))))))
1554
1555      (pass-if "extra keyword"
1556        (let ((w (call-with-warnings
1557                   (lambda ()
1558                     (compile '(let ((f (lambda* (x #:key y) y)))
1559                                 (f 2 #:Z 3))
1560                              #:opts %opts-w-arity
1561                              #:to 'assembly)))))
1562          (and (= (length w) 1)
1563               (number? (string-contains (car w)
1564                                         "wrong number of arguments to")))))
1565
1566      (pass-if "extra keywords allowed"
1567        (null? (call-with-warnings
1568                 (lambda ()
1569                   (compile '(let ((f (lambda* (x #:key y #:allow-other-keys)
1570                                        y)))
1571                               (f 2 #:Z 3))
1572                            #:opts %opts-w-arity
1573                            #:to 'assembly))))))
1574
1575    (with-test-prefix "format"
1576
1577      (pass-if "quiet (no args)"
1578        (null? (call-with-warnings
1579                (lambda ()
1580                  (compile '(format #t "hey!")
1581                           #:opts %opts-w-format
1582                           #:to 'assembly)))))
1583
1584      (pass-if "quiet (1 arg)"
1585        (null? (call-with-warnings
1586                (lambda ()
1587                  (compile '(format #t "hey ~A!" "you")
1588                           #:opts %opts-w-format
1589                           #:to 'assembly)))))
1590
1591      (pass-if "quiet (2 args)"
1592        (null? (call-with-warnings
1593                (lambda ()
1594                  (compile '(format #t "~A ~A!" "hello" "world")
1595                           #:opts %opts-w-format
1596                           #:to 'assembly)))))
1597
1598      (pass-if "wrong port arg"
1599        (let ((w (call-with-warnings
1600                  (lambda ()
1601                    (compile '(format 10 "foo")
1602                             #:opts %opts-w-format
1603                             #:to 'assembly)))))
1604          (and (= (length w) 1)
1605               (number? (string-contains (car w)
1606                                         "wrong port argument")))))
1607
1608      (pass-if "non-literal format string"
1609        (let ((w (call-with-warnings
1610                  (lambda ()
1611                    (compile '(format #f fmt)
1612                             #:opts %opts-w-format
1613                             #:to 'assembly)))))
1614          (and (= (length w) 1)
1615               (number? (string-contains (car w)
1616                                         "non-literal format string")))))
1617
1618      (pass-if "non-literal format string using gettext"
1619        (null? (call-with-warnings
1620                (lambda ()
1621                  (compile '(format #t (_ "~A ~A!") "hello" "world")
1622                           #:opts %opts-w-format
1623                           #:to 'assembly)))))
1624
1625      (pass-if "wrong format string"
1626        (let ((w (call-with-warnings
1627                  (lambda ()
1628                    (compile '(format #f 'not-a-string)
1629                             #:opts %opts-w-format
1630                             #:to 'assembly)))))
1631          (and (= (length w) 1)
1632               (number? (string-contains (car w)
1633                                         "wrong format string")))))
1634
1635      (pass-if "wrong number of args"
1636        (let ((w (call-with-warnings
1637                  (lambda ()
1638                    (compile '(format "shbweeb")
1639                             #:opts %opts-w-format
1640                             #:to 'assembly)))))
1641          (and (= (length w) 1)
1642               (number? (string-contains (car w)
1643                                         "wrong number of arguments")))))
1644
1645      (pass-if "~%, ~~, ~&, ~t, ~_, and ~\\n"
1646        (null? (call-with-warnings
1647                (lambda ()
1648                  (compile '(format some-port "~&~3_~~ ~\n~12they~%")
1649                           #:opts %opts-w-format
1650                           #:to 'assembly)))))
1651
1652      (pass-if "one missing argument"
1653        (let ((w (call-with-warnings
1654                  (lambda ()
1655                    (compile '(format some-port "foo ~A~%")
1656                             #:opts %opts-w-format
1657                             #:to 'assembly)))))
1658          (and (= (length w) 1)
1659               (number? (string-contains (car w)
1660                                         "expected 1, got 0")))))
1661
1662      (pass-if "one missing argument, gettext"
1663        (let ((w (call-with-warnings
1664                  (lambda ()
1665                    (compile '(format some-port (_ "foo ~A~%"))
1666                             #:opts %opts-w-format
1667                             #:to 'assembly)))))
1668          (and (= (length w) 1)
1669               (number? (string-contains (car w)
1670                                         "expected 1, got 0")))))
1671
1672      (pass-if "two missing arguments"
1673        (let ((w (call-with-warnings
1674                  (lambda ()
1675                    (compile '(format #f "foo ~10,2f and bar ~S~%")
1676                             #:opts %opts-w-format
1677                             #:to 'assembly)))))
1678          (and (= (length w) 1)
1679               (number? (string-contains (car w)
1680                                         "expected 2, got 0")))))
1681
1682      (pass-if "one given, one missing argument"
1683        (let ((w (call-with-warnings
1684                  (lambda ()
1685                    (compile '(format #t "foo ~A and ~S~%" hey)
1686                             #:opts %opts-w-format
1687                             #:to 'assembly)))))
1688          (and (= (length w) 1)
1689               (number? (string-contains (car w)
1690                                         "expected 2, got 1")))))
1691
1692      (pass-if "too many arguments"
1693        (let ((w (call-with-warnings
1694                  (lambda ()
1695                    (compile '(format #t "foo ~A~%" 1 2)
1696                             #:opts %opts-w-format
1697                             #:to 'assembly)))))
1698          (and (= (length w) 1)
1699               (number? (string-contains (car w)
1700                                         "expected 1, got 2")))))
1701
1702      (with-test-prefix "conditionals"
1703        (pass-if "literals"
1704         (null? (call-with-warnings
1705                 (lambda ()
1706                   (compile '(format #f "~A ~[foo~;bar~;baz~;~] ~10,2f"
1707                                     'a 1 3.14)
1708                            #:opts %opts-w-format
1709                            #:to 'assembly)))))
1710
1711        (pass-if "literals with selector"
1712          (let ((w (call-with-warnings
1713                    (lambda ()
1714                      (compile '(format #f "~2[foo~;bar~;baz~;~] ~A"
1715                                        1 'dont-ignore-me)
1716                               #:opts %opts-w-format
1717                               #:to 'assembly)))))
1718            (and (= (length w) 1)
1719                 (number? (string-contains (car w)
1720                                           "expected 1, got 2")))))
1721
1722        (pass-if "escapes (exact count)"
1723          (let ((w (call-with-warnings
1724                    (lambda ()
1725                      (compile '(format #f "~[~a~;~a~]")
1726                               #:opts %opts-w-format
1727                               #:to 'assembly)))))
1728            (and (= (length w) 1)
1729                 (number? (string-contains (car w)
1730                                           "expected 2, got 0")))))
1731
1732        (pass-if "escapes with selector"
1733          (let ((w (call-with-warnings
1734                    (lambda ()
1735                      (compile '(format #f "~1[chbouib~;~a~]")
1736                               #:opts %opts-w-format
1737                               #:to 'assembly)))))
1738            (and (= (length w) 1)
1739                 (number? (string-contains (car w)
1740                                           "expected 1, got 0")))))
1741
1742        (pass-if "escapes, range"
1743          (let ((w (call-with-warnings
1744                    (lambda ()
1745                      (compile '(format #f "~[chbouib~;~a~;~2*~a~]")
1746                               #:opts %opts-w-format
1747                               #:to 'assembly)))))
1748            (and (= (length w) 1)
1749                 (number? (string-contains (car w)
1750                                           "expected 1 to 4, got 0")))))
1751
1752        (pass-if "@"
1753          (let ((w (call-with-warnings
1754                    (lambda ()
1755                      (compile '(format #f "~@[temperature=~d~]")
1756                               #:opts %opts-w-format
1757                               #:to 'assembly)))))
1758            (and (= (length w) 1)
1759                 (number? (string-contains (car w)
1760                                           "expected 1, got 0")))))
1761
1762        (pass-if "nested"
1763          (let ((w (call-with-warnings
1764                    (lambda ()
1765                      (compile '(format #f "~:[~[hey~;~a~;~va~]~;~3*~]")
1766                               #:opts %opts-w-format
1767                               #:to 'assembly)))))
1768            (and (= (length w) 1)
1769                 (number? (string-contains (car w)
1770                                           "expected 2 to 4, got 0")))))
1771
1772        (pass-if "unterminated"
1773          (let ((w (call-with-warnings
1774                    (lambda ()
1775                      (compile '(format #f "~[unterminated")
1776                               #:opts %opts-w-format
1777                               #:to 'assembly)))))
1778            (and (= (length w) 1)
1779                 (number? (string-contains (car w)
1780                                           "unterminated conditional")))))
1781
1782        (pass-if "unexpected ~;"
1783          (let ((w (call-with-warnings
1784                    (lambda ()
1785                      (compile '(format #f "foo~;bar")
1786                               #:opts %opts-w-format
1787                               #:to 'assembly)))))
1788            (and (= (length w) 1)
1789                 (number? (string-contains (car w)
1790                                           "unexpected")))))
1791
1792        (pass-if "unexpected ~]"
1793          (let ((w (call-with-warnings
1794                    (lambda ()
1795                      (compile '(format #f "foo~]")
1796                               #:opts %opts-w-format
1797                               #:to 'assembly)))))
1798            (and (= (length w) 1)
1799                 (number? (string-contains (car w)
1800                                           "unexpected"))))))
1801
1802      (pass-if "~{...~}"
1803        (null? (call-with-warnings
1804                (lambda ()
1805                  (compile '(format #f "~A ~{~S~} ~A"
1806                                    'hello '("ladies" "and")
1807                                    'gentlemen)
1808                           #:opts %opts-w-format
1809                           #:to 'assembly)))))
1810
1811      (pass-if "~{...~}, too many args"
1812        (let ((w (call-with-warnings
1813                  (lambda ()
1814                    (compile '(format #f "~{~S~}" 1 2 3)
1815                             #:opts %opts-w-format
1816                             #:to 'assembly)))))
1817          (and (= (length w) 1)
1818               (number? (string-contains (car w)
1819                                         "expected 1, got 3")))))
1820
1821      (pass-if "~@{...~}"
1822        (null? (call-with-warnings
1823                (lambda ()
1824                  (compile '(format #f "~@{~S~}" 1 2 3)
1825                           #:opts %opts-w-format
1826                           #:to 'assembly)))))
1827
1828      (pass-if "~@{...~}, too few args"
1829        (let ((w (call-with-warnings
1830                  (lambda ()
1831                    (compile '(format #f "~A ~@{~S~}")
1832                             #:opts %opts-w-format
1833                             #:to 'assembly)))))
1834          (and (= (length w) 1)
1835               (number? (string-contains (car w)
1836                                         "expected at least 1, got 0")))))
1837
1838      (pass-if "unterminated ~{...~}"
1839        (let ((w (call-with-warnings
1840                  (lambda ()
1841                    (compile '(format #f "~{")
1842                             #:opts %opts-w-format
1843                             #:to 'assembly)))))
1844          (and (= (length w) 1)
1845               (number? (string-contains (car w)
1846                                         "unterminated")))))
1847
1848      (pass-if "~(...~)"
1849        (null? (call-with-warnings
1850                (lambda ()
1851                  (compile '(format #f "~:@(~A ~A~)" 'foo 'bar)
1852                           #:opts %opts-w-format
1853                           #:to 'assembly)))))
1854
1855      (pass-if "~v"
1856        (let ((w (call-with-warnings
1857                  (lambda ()
1858                    (compile '(format #f "~v_foo")
1859                             #:opts %opts-w-format
1860                             #:to 'assembly)))))
1861          (and (= (length w) 1)
1862               (number? (string-contains (car w)
1863                                         "expected 1, got 0")))))
1864      (pass-if "~v:@y"
1865        (null? (call-with-warnings
1866                (lambda ()
1867                  (compile '(format #f "~v:@y" 1 123)
1868                           #:opts %opts-w-format
1869                           #:to 'assembly)))))
1870
1871
1872      (pass-if "~*"
1873        (let ((w (call-with-warnings
1874                  (lambda ()
1875                    (compile '(format #f "~2*~a" 'a 'b)
1876                             #:opts %opts-w-format
1877                             #:to 'assembly)))))
1878          (and (= (length w) 1)
1879               (number? (string-contains (car w)
1880                                         "expected 3, got 2")))))
1881
1882      (pass-if "~?"
1883        (null? (call-with-warnings
1884                (lambda ()
1885                  (compile '(format #f "~?" "~d ~d" '(1 2))
1886                           #:opts %opts-w-format
1887                           #:to 'assembly)))))
1888
1889      (pass-if "complex 1"
1890        (let ((w (call-with-warnings
1891                  (lambda ()
1892                    (compile '(format #f
1893                                      "~4@S    ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n"
1894                                      1 2 3 4 5 6)
1895                             #:opts %opts-w-format
1896                             #:to 'assembly)))))
1897          (and (= (length w) 1)
1898               (number? (string-contains (car w)
1899                                         "expected 4, got 6")))))
1900
1901      (pass-if "complex 2"
1902        (let ((w (call-with-warnings
1903                  (lambda ()
1904                    (compile '(format #f
1905                                      "~:(~A~) Commands~:[~; [abbrev]~]:~2%"
1906                                      1 2 3 4)
1907                             #:opts %opts-w-format
1908                             #:to 'assembly)))))
1909          (and (= (length w) 1)
1910               (number? (string-contains (car w)
1911                                         "expected 2, got 4")))))
1912
1913      (pass-if "complex 3"
1914        (let ((w (call-with-warnings
1915                  (lambda ()
1916                    (compile '(format #f "~9@a~:[~*~3_~;~3d~] ~v:@y~%")
1917                             #:opts %opts-w-format
1918                             #:to 'assembly)))))
1919          (and (= (length w) 1)
1920               (number? (string-contains (car w)
1921                                         "expected 5, got 0")))))
1922
1923      (pass-if "ice-9 format"
1924        (let ((w (call-with-warnings
1925                  (lambda ()
1926                    (let ((in (open-input-string
1927                               "(use-modules ((ice-9 format)
1928                                  #:renamer (symbol-prefix-proc 'i9-)))
1929                                (i9-format #t \"yo! ~A\" 1 2)")))
1930                      (read-and-compile in
1931                                        #:opts %opts-w-format
1932                                        #:to 'assembly))))))
1933          (and (= (length w) 1)
1934               (number? (string-contains (car w)
1935                                         "expected 1, got 2")))))
1936
1937      (pass-if "not format"
1938        (null? (call-with-warnings
1939                (lambda ()
1940                  (compile '(let ((format chbouib))
1941                              (format #t "not ~A a format string"))
1942                           #:opts %opts-w-format
1943                           #:to 'assembly)))))))