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