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    (apply (primitive +) (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    (apply (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 (apply (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    (apply (toplevel foo) (apply (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    (apply (primitive 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    (apply (primitive 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)) (apply (primitive 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) (apply (primitive 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) (apply (primitive 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      (apply (primitive null?)
 168             (set! (lexical x y) (apply (primitive 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    (apply (primitive 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    (apply (primitive 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    (apply (primitive 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    (apply (primitive 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    (apply (primitive 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    (apply (primitive 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    (apply (primitive 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    (apply (primitive 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            (apply (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) ((apply (toplevel foo)) (apply (toplevel bar)))
 339            (apply (primitive +) (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) ((apply (toplevel foo)) (apply (toplevel bar)))
 355             (apply (primitive +) (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    (apply (primitive 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 (with-test-prefix "values"
 478   (assert-tree-il->glil
 479    (apply (primitive values)
 480           (apply (primitive values) (const 1) (const 2)))
 481    (program () (std-prelude 0 0 #f) (label _)
 482             (const 1) (call return 1)))
 483
 484   (assert-tree-il->glil
 485    (apply (primitive values)
 486           (apply (primitive values) (const 1) (const 2))
 487           (const 3))
 488    (program () (std-prelude 0 0 #f) (label _)
 489             (const 1) (const 3) (call return/values 2)))
 490
 491   (assert-tree-il->glil
 492    (apply (primitive +)
 493           (apply (primitive values) (const 1) (const 2)))
 494    (program () (std-prelude 0 0 #f) (label _)
 495             (const 1) (call return 1))))
 496
 497 ;; FIXME: binding info for or-hacked locals might bork the disassembler,
 498 ;; and could be tightened in any case
 499 (with-test-prefix "the or hack"
 500   (assert-tree-il->glil
 501    (let (x) (y) ((const 1))
 502         (if (lexical x y)
 503             (lexical x y)
 504             (let (a) (b) ((const 2))
 505                  (lexical a b))))
 506    (program () (std-prelude 0 1 #f) (label _)
 507             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
 508             (lexical #t #f ref 0) (branch br-if-not ,l1)
 509             (lexical #t #f ref 0) (call return 1)
 510             (label ,l2)
 511             (const 2) (bind (a #f 0)) (lexical #t #f set 0)
 512             (lexical #t #f ref 0) (call return 1)
 513             (unbind)
 514             (unbind))
 515    (eq? l1 l2))
 516
 517   ;; second bound var is unreferenced
 518   (assert-tree-il->glil
 519    (let (x) (y) ((const 1))
 520         (if (lexical x y)
 521             (lexical x y)
 522             (let (a) (b) ((const 2))
 523                  (lexical x y))))
 524    (program () (std-prelude 0 1 #f) (label _)
 525             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
 526             (lexical #t #f ref 0) (branch br-if-not ,l1)
 527             (lexical #t #f ref 0) (call return 1)
 528             (label ,l2)
 529             (lexical #t #f ref 0) (call return 1)
 530             (unbind))
 531    (eq? l1 l2)))
 532
 533 (with-test-prefix "apply"
 534   (assert-tree-il->glil
 535    (apply (primitive @apply) (toplevel foo) (toplevel bar))
 536    (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (toplevel ref bar) (call tail-apply 2)))
 537   (assert-tree-il->glil
 538    (begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void))
 539    (program () (std-prelude 0 0 #f) (label _)
 540             (call new-frame 0) (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1)
 541             (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
 542             (label ,l4)
 543             (void) (call return 1))
 544    (and (eq? l1 l3) (eq? l2 l4)))
 545   (assert-tree-il->glil
 546    (apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz)))
 547    (program () (std-prelude 0 0 #f) (label _)
 548             (toplevel ref foo)
 549             (call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call apply 2)
 550             (call tail-call 1))))
 551
 552 (with-test-prefix "call/cc"
 553   (assert-tree-il->glil
 554    (apply (primitive @call-with-current-continuation) (toplevel foo))
 555    (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call tail-call/cc 1)))
 556   (assert-tree-il->glil
 557    (begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void))
 558    (program () (std-prelude 0 0 #f) (label _)
 559             (call new-frame 0) (toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1)
 560             (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
 561             (label ,l4)
 562             (void) (call return 1))
 563    (and (eq? l1 l3) (eq? l2 l4)))
 564   (assert-tree-il->glil
 565    (apply (toplevel foo)
 566           (apply (toplevel @call-with-current-continuation) (toplevel bar)))
 567    (program () (std-prelude 0 0 #f) (label _)
 568             (toplevel ref foo)
 569             (toplevel ref bar) (call call/cc 1)
 570             (call tail-call 1))))
 571
 572 \f
 573 (with-test-prefix "tree-il-fold"
 574
 575   (pass-if "empty tree"
 576     (let ((leaf? #f) (up? #f) (down? #f) (mark (list 'mark)))
 577       (and (eq? mark
 578                 (tree-il-fold (lambda (x y) (set! leaf? #t) y)
 579                               (lambda (x y) (set! down? #t) y)
 580                               (lambda (x y) (set! up? #t) y)
 581                               mark
 582                               '()))
 583            (not leaf?)
 584            (not up?)
 585            (not down?))))
 586
 587   (pass-if "lambda and application"
 588     (let* ((leaves '()) (ups '()) (downs '())
 589            (result (tree-il-fold (lambda (x y)
 590                                    (set! leaves (cons x leaves))
 591                                    (1+ y))
 592                                  (lambda (x y)
 593                                    (set! downs (cons x downs))
 594                                    (1+ y))
 595                                  (lambda (x y)
 596                                    (set! ups (cons x ups))
 597                                    (1+ y))
 598                                  0
 599                                  (parse-tree-il
 600                                   '(lambda ()
 601                                      (lambda-case
 602                                       (((x y) #f #f #f () (x1 y1))
 603                                        (apply (toplevel +)
 604                                               (lexical x x1)
 605                                               (lexical y y1)))
 606                                       #f))))))
 607       (and (equal? (map strip-source leaves)
 608                    (list (make-lexical-ref #f 'y 'y1)
 609                          (make-lexical-ref #f 'x 'x1)
 610                          (make-toplevel-ref #f '+)))
 611            (= (length downs) 3)
 612            (equal? (reverse (map strip-source ups))
 613                    (map strip-source downs))))))
 614
 615 \f
 616 ;;;
 617 ;;; Warnings.
 618 ;;;
 619
 620 ;; Make sure we get English messages.
 621 (setlocale LC_ALL "C")
 622
 623 (define (call-with-warnings thunk)
 624   (let ((port (open-output-string)))
 625     (with-fluids ((*current-warning-port*   port)
 626                   (*current-warning-prefix* ""))
 627       (thunk))
 628     (let ((warnings (get-output-string port)))
 629       (string-tokenize warnings
 630                        (char-set-complement (char-set #\newline))))))
 631
 632 (define %opts-w-unused
 633   '(#:warnings (unused-variable)))
 634
 635 (define %opts-w-unused-toplevel
 636   '(#:warnings (unused-toplevel)))
 637
 638 (define %opts-w-unbound
 639   '(#:warnings (unbound-variable)))
 640
 641 (define %opts-w-arity
 642   '(#:warnings (arity-mismatch)))
 643
 644 (define %opts-w-format
 645   '(#:warnings (format)))
 646
 647
 648 (with-test-prefix "warnings"
 649
 650    (pass-if "unknown warning type"
 651      (let ((w (call-with-warnings
 652                 (lambda ()
 653                   (compile #t #:opts '(#:warnings (does-not-exist)))))))
 654        (and (= (length w) 1)
 655             (number? (string-contains (car w) "unknown warning")))))
 656
 657    (with-test-prefix "unused-variable"
 658
 659      (pass-if "quiet"
 660        (null? (call-with-warnings
 661                 (lambda ()
 662                   (compile '(lambda (x y) (+ x y))
 663                            #:opts %opts-w-unused)))))
 664
 665      (pass-if "let/unused"
 666        (let ((w (call-with-warnings
 667                   (lambda ()
 668                     (compile '(lambda (x)
 669                                 (let ((y (+ x 2)))
 670                                   x))
 671                              #:opts %opts-w-unused)))))
 672          (and (= (length w) 1)
 673               (number? (string-contains (car w) "unused variable `y'")))))
 674
 675      (pass-if "shadowed variable"
 676        (let ((w (call-with-warnings
 677                   (lambda ()
 678                     (compile '(lambda (x)
 679                                 (let ((y x))
 680                                   (let ((y (+ x 2)))
 681                                     (+ x y))))
 682                              #:opts %opts-w-unused)))))
 683          (and (= (length w) 1)
 684               (number? (string-contains (car w) "unused variable `y'")))))
 685
 686      (pass-if "letrec"
 687        (null? (call-with-warnings
 688                 (lambda ()
 689                   (compile '(lambda ()
 690                               (letrec ((x (lambda () (y)))
 691                                        (y (lambda () (x))))
 692                                 y))
 693                            #:opts %opts-w-unused)))))
 694
 695      (pass-if "unused argument"
 696        ;; Unused arguments should not be reported.
 697        (null? (call-with-warnings
 698                 (lambda ()
 699                   (compile '(lambda (x y z) #t)
 700                            #:opts %opts-w-unused)))))
 701
 702      (pass-if "special variable names"
 703        (null? (call-with-warnings
 704                 (lambda ()
 705                   (compile '(lambda ()
 706                               (let ((_ 'underscore)
 707                                     (#{gensym name}# 'ignore-me))
 708                                 #t))
 709                            #:to 'assembly
 710                            #:opts %opts-w-unused))))))
 711
 712    (with-test-prefix "unused-toplevel"
 713
 714      (pass-if "used after definition"
 715        (null? (call-with-warnings
 716                 (lambda ()
 717                   (let ((in (open-input-string
 718                              "(define foo 2) foo")))
 719                     (read-and-compile in
 720                                       #:to 'assembly
 721                                       #:opts %opts-w-unused-toplevel))))))
 722
 723      (pass-if "used before definition"
 724        (null? (call-with-warnings
 725                 (lambda ()
 726                   (let ((in (open-input-string
 727                              "(define (bar) foo) (define foo 2) (bar)")))
 728                     (read-and-compile in
 729                                       #:to 'assembly
 730                                       #:opts %opts-w-unused-toplevel))))))
 731
 732      (pass-if "unused but public"
 733        (let ((in (open-input-string
 734                   "(define-module (test-suite tree-il x) #:export (bar))
 735                    (define (bar) #t)")))
 736          (null? (call-with-warnings
 737                   (lambda ()
 738                     (read-and-compile in
 739                                       #:to 'assembly
 740                                       #:opts %opts-w-unused-toplevel))))))
 741
 742      (pass-if "unused but public (more)"
 743        (let ((in (open-input-string
 744                   "(define-module (test-suite tree-il x) #:export (bar))
 745                    (define (bar) (baz))
 746                    (define (baz) (foo))
 747                    (define (foo) #t)")))
 748          (null? (call-with-warnings
 749                   (lambda ()
 750                     (read-and-compile in
 751                                       #:to 'assembly
 752                                       #:opts %opts-w-unused-toplevel))))))
 753
 754      (pass-if "unused but define-public"
 755        (null? (call-with-warnings
 756                 (lambda ()
 757                   (compile '(define-public foo 2)
 758                            #:to 'assembly
 759                            #:opts %opts-w-unused-toplevel)))))
 760
 761      (pass-if "used by macro"
 762        ;; FIXME: See comment about macros at `unused-toplevel-analysis'.
 763        (throw 'unresolved)
 764
 765        (null? (call-with-warnings
 766                 (lambda ()
 767                   (let ((in (open-input-string
 768                              "(define (bar) 'foo)
 769                               (define-syntax baz
 770                                 (syntax-rules () ((_) (bar))))")))
 771                     (read-and-compile in
 772                                       #:to 'assembly
 773                                       #:opts %opts-w-unused-toplevel))))))
 774
 775      (pass-if "unused"
 776        (let ((w (call-with-warnings
 777                   (lambda ()
 778                     (compile '(define foo 2)
 779                              #:to 'assembly
 780                              #:opts %opts-w-unused-toplevel)))))
 781          (and (= (length w) 1)
 782               (number? (string-contains (car w)
 783                                         (format #f "top-level variable `~A'"
 784                                                 'foo))))))
 785
 786      (pass-if "unused recursive"
 787        (let ((w (call-with-warnings
 788                   (lambda ()
 789                     (compile '(define (foo) (foo))
 790                              #:to 'assembly
 791                              #:opts %opts-w-unused-toplevel)))))
 792          (and (= (length w) 1)
 793               (number? (string-contains (car w)
 794                                         (format #f "top-level variable `~A'"
 795                                                 'foo))))))
 796
 797      (pass-if "unused mutually recursive"
 798        (let* ((in (open-input-string
 799                    "(define (foo) (bar)) (define (bar) (foo))"))
 800               (w  (call-with-warnings
 801                     (lambda ()
 802                       (read-and-compile in
 803                                         #:to 'assembly
 804                                         #:opts %opts-w-unused-toplevel)))))
 805          (and (= (length w) 2)
 806               (number? (string-contains (car w)
 807                                         (format #f "top-level variable `~A'"
 808                                                 'foo)))
 809               (number? (string-contains (cadr w)
 810                                         (format #f "top-level variable `~A'"
 811                                                 'bar))))))
 812
 813      (pass-if "special variable names"
 814        (null? (call-with-warnings
 815                 (lambda ()
 816                   (compile '(define #{gensym name}# 'ignore-me)
 817                            #:to 'assembly
 818                            #:opts %opts-w-unused-toplevel))))))
 819
 820    (with-test-prefix "unbound variable"
 821
 822      (pass-if "quiet"
 823        (null? (call-with-warnings
 824                 (lambda ()
 825                   (compile '+ #:opts %opts-w-unbound)))))
 826
 827      (pass-if "ref"
 828        (let* ((v (gensym))
 829               (w (call-with-warnings
 830                    (lambda ()
 831                      (compile v
 832                               #:to 'assembly
 833                               #:opts %opts-w-unbound)))))
 834          (and (= (length w) 1)
 835               (number? (string-contains (car w)
 836                                         (format #f "unbound variable `~A'"
 837                                                 v))))))
 838
 839      (pass-if "set!"
 840        (let* ((v (gensym))
 841               (w (call-with-warnings
 842                    (lambda ()
 843                      (compile `(set! ,v 7)
 844                               #:to 'assembly
 845                               #:opts %opts-w-unbound)))))
 846          (and (= (length w) 1)
 847               (number? (string-contains (car w)
 848                                         (format #f "unbound variable `~A'"
 849                                                 v))))))
 850
 851      (pass-if "module-local top-level is visible"
 852        (let ((m (make-module))
 853              (v (gensym)))
 854          (beautify-user-module! m)
 855          (compile `(define ,v 123)
 856                   #:env m #:opts %opts-w-unbound)
 857          (null? (call-with-warnings
 858                   (lambda ()
 859                     (compile v
 860                              #:env m
 861                              #:to 'assembly
 862                              #:opts %opts-w-unbound))))))
 863
 864      (pass-if "module-local top-level is visible after"
 865        (let ((m (make-module))
 866              (v (gensym)))
 867          (beautify-user-module! m)
 868          (null? (call-with-warnings
 869                   (lambda ()
 870                     (let ((in (open-input-string
 871                                "(define (f)
 872                                   (set! chbouib 3))
 873                                 (define chbouib 5)")))
 874                       (read-and-compile in
 875                                         #:env m
 876                                         #:opts %opts-w-unbound)))))))
 877
 878      (pass-if "optional arguments are visible"
 879        (null? (call-with-warnings
 880                 (lambda ()
 881                   (compile '(lambda* (x #:optional y z) (list x y z))
 882                            #:opts %opts-w-unbound
 883                            #:to 'assembly)))))
 884
 885      (pass-if "keyword arguments are visible"
 886        (null? (call-with-warnings
 887                 (lambda ()
 888                   (compile '(lambda* (x #:key y z) (list x y z))
 889                            #:opts %opts-w-unbound
 890                            #:to 'assembly)))))
 891
 892      (pass-if "GOOPS definitions are visible"
 893        (let ((m (make-module))
 894              (v (gensym)))
 895          (beautify-user-module! m)
 896          (module-use! m (resolve-interface '(oop goops)))
 897          (null? (call-with-warnings
 898                   (lambda ()
 899                     (let ((in (open-input-string
 900                                "(define-class <foo> ()
 901                                   (bar #:getter foo-bar))
 902                                 (define z (foo-bar (make <foo>)))")))
 903                       (read-and-compile in
 904                                         #:env m
 905                                         #:opts %opts-w-unbound))))))))
 906
 907    (with-test-prefix "arity mismatch"
 908
 909      (pass-if "quiet"
 910        (null? (call-with-warnings
 911                 (lambda ()
 912                   (compile '(cons 'a 'b) #:opts %opts-w-arity)))))
 913
 914      (pass-if "direct application"
 915        (let ((w (call-with-warnings
 916                   (lambda ()
 917                     (compile '((lambda (x y) (or x y)) 1 2 3 4 5)
 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      (pass-if "local"
 924        (let ((w (call-with-warnings
 925                   (lambda ()
 926                     (compile '(let ((f (lambda (x y) (+ x y))))
 927                                 (f 2))
 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 "global"
 935        (let ((w (call-with-warnings
 936                   (lambda ()
 937                     (compile '(cons 1 2 3 4)
 938                              #:opts %opts-w-arity
 939                              #:to 'assembly)))))
 940          (and (= (length w) 1)
 941               (number? (string-contains (car w)
 942                                         "wrong number of arguments to")))))
 943
 944      (pass-if "alias to global"
 945        (let ((w (call-with-warnings
 946                   (lambda ()
 947                     (compile '(let ((f cons)) (f 1 2 3 4))
 948                              #:opts %opts-w-arity
 949                              #:to 'assembly)))))
 950          (and (= (length w) 1)
 951               (number? (string-contains (car w)
 952                                         "wrong number of arguments to")))))
 953
 954      (pass-if "alias to lexical to global"
 955        (let ((w (call-with-warnings
 956                   (lambda ()
 957                     (compile '(let ((f number?))
 958                                 (let ((g f))
 959                                   (f 1 2 3 4)))
 960                              #:opts %opts-w-arity
 961                              #:to 'assembly)))))
 962          (and (= (length w) 1)
 963               (number? (string-contains (car w)
 964                                         "wrong number of arguments to")))))
 965
 966      (pass-if "alias to lexical"
 967        (let ((w (call-with-warnings
 968                   (lambda ()
 969                     (compile '(let ((f (lambda (x y z) (+ x y z))))
 970                                 (let ((g f))
 971                                   (g 1)))
 972                              #:opts %opts-w-arity
 973                              #:to 'assembly)))))
 974          (and (= (length w) 1)
 975               (number? (string-contains (car w)
 976                                         "wrong number of arguments to")))))
 977
 978      (pass-if "letrec"
 979        (let ((w (call-with-warnings
 980                   (lambda ()
 981                     (compile '(letrec ((odd?  (lambda (x) (even? (1- x))))
 982                                        (even? (lambda (x)
 983                                                 (or (= 0 x)
 984                                                     (odd?)))))
 985                                 (odd? 1))
 986                              #:opts %opts-w-arity
 987                              #:to 'assembly)))))
 988          (and (= (length w) 1)
 989               (number? (string-contains (car w)
 990                                         "wrong number of arguments to")))))
 991
 992      (pass-if "case-lambda"
 993        (null? (call-with-warnings
 994                 (lambda ()
 995                   (compile '(let ((f (case-lambda
 996                                        ((x)     1)
 997                                        ((x y)   2)
 998                                        ((x y z) 3))))
 999                               (list (f 1)
1000                                     (f 1 2)
1001                                     (f 1 2 3)))
1002                            #:opts %opts-w-arity
1003                            #:to 'assembly)))))
1004
1005      (pass-if "case-lambda with wrong number of arguments"
1006        (let ((w (call-with-warnings
1007                   (lambda ()
1008                     (compile '(let ((f (case-lambda
1009                                          ((x)     1)
1010                                          ((x y)   2))))
1011                                 (f 1 2 3))
1012                              #:opts %opts-w-arity
1013                              #:to 'assembly)))))
1014          (and (= (length w) 1)
1015               (number? (string-contains (car w)
1016                                         "wrong number of arguments to")))))
1017
1018      (pass-if "case-lambda*"
1019        (null? (call-with-warnings
1020                 (lambda ()
1021                   (compile '(let ((f (case-lambda*
1022                                        ((x #:optional y) 1)
1023                                        ((x #:key y)      2)
1024                                        ((x y #:key z)    3))))
1025                               (list (f 1)
1026                                     (f 1 2)
1027                                     (f #:y 2)
1028                                     (f 1 2 #:z 3)))
1029                            #:opts %opts-w-arity
1030                            #:to 'assembly)))))
1031
1032      (pass-if "case-lambda* with wrong arguments"
1033        (let ((w (call-with-warnings
1034                   (lambda ()
1035                     (compile '(let ((f (case-lambda*
1036                                          ((x #:optional y) 1)
1037                                          ((x #:key y)      2)
1038                                          ((x y #:key z)    3))))
1039                                 (list (f)
1040                                       (f 1 #:z 3)))
1041                              #:opts %opts-w-arity
1042                              #:to 'assembly)))))
1043          (and (= (length w) 2)
1044               (null? (filter (lambda (w)
1045                                (not
1046                                 (number?
1047                                  (string-contains
1048                                   w "wrong number of arguments to"))))
1049                              w)))))
1050
1051      (pass-if "local toplevel-defines"
1052        (let ((w (call-with-warnings
1053                   (lambda ()
1054                     (let ((in (open-input-string "
1055                                 (define (g x) (f x))
1056                                 (define (f) 1)")))
1057                       (read-and-compile in
1058                                         #:opts %opts-w-arity
1059                                         #:to 'assembly))))))
1060          (and (= (length w) 1)
1061               (number? (string-contains (car w)
1062                                         "wrong number of arguments to")))))
1063
1064      (pass-if "global toplevel alias"
1065        (let ((w (call-with-warnings
1066                   (lambda ()
1067                     (let ((in (open-input-string "
1068                                 (define f cons)
1069                                 (define (g) (f))")))
1070                       (read-and-compile in
1071                                         #:opts %opts-w-arity
1072                                         #:to 'assembly))))))
1073          (and (= (length w) 1)
1074               (number? (string-contains (car w)
1075                                         "wrong number of arguments to")))))
1076
1077      (pass-if "local toplevel overrides global"
1078        (null? (call-with-warnings
1079                 (lambda ()
1080                   (let ((in (open-input-string "
1081                               (define (cons) 0)
1082                               (define (foo x) (cons))")))
1083                     (read-and-compile in
1084                                       #:opts %opts-w-arity
1085                                       #:to 'assembly))))))
1086
1087      (pass-if "keyword not passed and quiet"
1088        (null? (call-with-warnings
1089                 (lambda ()
1090                   (compile '(let ((f (lambda* (x #:key y) y)))
1091                               (f 2))
1092                            #:opts %opts-w-arity
1093                            #:to 'assembly)))))
1094
1095      (pass-if "keyword passed and quiet"
1096        (null? (call-with-warnings
1097                 (lambda ()
1098                   (compile '(let ((f (lambda* (x #:key y) y)))
1099                               (f 2 #:y 3))
1100                            #:opts %opts-w-arity
1101                            #:to 'assembly)))))
1102
1103      (pass-if "keyword passed to global and quiet"
1104        (null? (call-with-warnings
1105                 (lambda ()
1106                   (let ((in (open-input-string "
1107                               (use-modules (system base compile))
1108                               (compile '(+ 2 3) #:env (current-module))")))
1109                     (read-and-compile in
1110                                       #:opts %opts-w-arity
1111                                       #:to 'assembly))))))
1112
1113      (pass-if "extra keyword"
1114        (let ((w (call-with-warnings
1115                   (lambda ()
1116                     (compile '(let ((f (lambda* (x #:key y) y)))
1117                                 (f 2 #:Z 3))
1118                              #:opts %opts-w-arity
1119                              #:to 'assembly)))))
1120          (and (= (length w) 1)
1121               (number? (string-contains (car w)
1122                                         "wrong number of arguments to")))))
1123
1124      (pass-if "extra keywords allowed"
1125        (null? (call-with-warnings
1126                 (lambda ()
1127                   (compile '(let ((f (lambda* (x #:key y #:allow-other-keys)
1128                                        y)))
1129                               (f 2 #:Z 3))
1130                            #:opts %opts-w-arity
1131                            #:to 'assembly))))))
1132
1133    (with-test-prefix "format"
1134
1135      (pass-if "quiet (no args)"
1136        (null? (call-with-warnings
1137                (lambda ()
1138                  (compile '(format #t "hey!")
1139                           #:opts %opts-w-format
1140                           #:to 'assembly)))))
1141
1142      (pass-if "quiet (1 arg)"
1143        (null? (call-with-warnings
1144                (lambda ()
1145                  (compile '(format #t "hey ~A!" "you")
1146                           #:opts %opts-w-format
1147                           #:to 'assembly)))))
1148
1149      (pass-if "quiet (2 args)"
1150        (null? (call-with-warnings
1151                (lambda ()
1152                  (compile '(format #t "~A ~A!" "hello" "world")
1153                           #:opts %opts-w-format
1154                           #:to 'assembly)))))
1155
1156      (pass-if "wrong port arg"
1157        (let ((w (call-with-warnings
1158                  (lambda ()
1159                    (compile '(format 10 "foo")
1160                             #:opts %opts-w-format
1161                             #:to 'assembly)))))
1162          (and (= (length w) 1)
1163               (number? (string-contains (car w)
1164                                         "wrong port argument")))))
1165
1166      (pass-if "non-literal format string"
1167        (let ((w (call-with-warnings
1168                  (lambda ()
1169                    (compile '(format #f fmt)
1170                             #:opts %opts-w-format
1171                             #:to 'assembly)))))
1172          (and (= (length w) 1)
1173               (number? (string-contains (car w)
1174                                         "non-literal format string")))))
1175
1176      (pass-if "non-literal format string using gettext"
1177        (null? (call-with-warnings
1178                (lambda ()
1179                  (compile '(format #t (_ "~A ~A!") "hello" "world")
1180                           #:opts %opts-w-format
1181                           #:to 'assembly)))))
1182
1183      (pass-if "wrong format string"
1184        (let ((w (call-with-warnings
1185                  (lambda ()
1186                    (compile '(format #f 'not-a-string)
1187                             #:opts %opts-w-format
1188                             #:to 'assembly)))))
1189          (and (= (length w) 1)
1190               (number? (string-contains (car w)
1191                                         "wrong format string")))))
1192
1193      (pass-if "wrong number of args"
1194        (let ((w (call-with-warnings
1195                  (lambda ()
1196                    (compile '(format "shbweeb")
1197                             #:opts %opts-w-format
1198                             #:to 'assembly)))))
1199          (and (= (length w) 1)
1200               (number? (string-contains (car w)
1201                                         "wrong number of arguments")))))
1202
1203      (pass-if "~%, ~~, ~&, ~t, ~_, and ~\\n"
1204        (null? (call-with-warnings
1205                (lambda ()
1206                  (compile '(format some-port "~&~3_~~ ~\n~12they~%")
1207                           #:opts %opts-w-format
1208                           #:to 'assembly)))))
1209
1210      (pass-if "one missing argument"
1211        (let ((w (call-with-warnings
1212                  (lambda ()
1213                    (compile '(format some-port "foo ~A~%")
1214                             #:opts %opts-w-format
1215                             #:to 'assembly)))))
1216          (and (= (length w) 1)
1217               (number? (string-contains (car w)
1218                                         "expected 1, got 0")))))
1219
1220      (pass-if "one missing argument, gettext"
1221        (let ((w (call-with-warnings
1222                  (lambda ()
1223                    (compile '(format some-port (_ "foo ~A~%"))
1224                             #:opts %opts-w-format
1225                             #:to 'assembly)))))
1226          (and (= (length w) 1)
1227               (number? (string-contains (car w)
1228                                         "expected 1, got 0")))))
1229
1230      (pass-if "two missing arguments"
1231        (let ((w (call-with-warnings
1232                  (lambda ()
1233                    (compile '(format #f "foo ~10,2f and bar ~S~%")
1234                             #:opts %opts-w-format
1235                             #:to 'assembly)))))
1236          (and (= (length w) 1)
1237               (number? (string-contains (car w)
1238                                         "expected 2, got 0")))))
1239
1240      (pass-if "one given, one missing argument"
1241        (let ((w (call-with-warnings
1242                  (lambda ()
1243                    (compile '(format #t "foo ~A and ~S~%" hey)
1244                             #:opts %opts-w-format
1245                             #:to 'assembly)))))
1246          (and (= (length w) 1)
1247               (number? (string-contains (car w)
1248                                         "expected 2, got 1")))))
1249
1250      (pass-if "too many arguments"
1251        (let ((w (call-with-warnings
1252                  (lambda ()
1253                    (compile '(format #t "foo ~A~%" 1 2)
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      (with-test-prefix "conditionals"
1261        (pass-if "literals"
1262         (null? (call-with-warnings
1263                 (lambda ()
1264                   (compile '(format #f "~A ~[foo~;bar~;baz~;~] ~10,2f"
1265                                     'a 1 3.14)
1266                            #:opts %opts-w-format
1267                            #:to 'assembly)))))
1268
1269        (pass-if "literals with selector"
1270          (let ((w (call-with-warnings
1271                    (lambda ()
1272                      (compile '(format #f "~2[foo~;bar~;baz~;~] ~A"
1273                                        1 'dont-ignore-me)
1274                               #:opts %opts-w-format
1275                               #:to 'assembly)))))
1276            (and (= (length w) 1)
1277                 (number? (string-contains (car w)
1278                                           "expected 1, got 2")))))
1279
1280        (pass-if "escapes (exact count)"
1281          (let ((w (call-with-warnings
1282                    (lambda ()
1283                      (compile '(format #f "~[~a~;~a~]")
1284                               #:opts %opts-w-format
1285                               #:to 'assembly)))))
1286            (and (= (length w) 1)
1287                 (number? (string-contains (car w)
1288                                           "expected 2, got 0")))))
1289
1290        (pass-if "escapes with selector"
1291          (let ((w (call-with-warnings
1292                    (lambda ()
1293                      (compile '(format #f "~1[chbouib~;~a~]")
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 "escapes, range"
1301          (let ((w (call-with-warnings
1302                    (lambda ()
1303                      (compile '(format #f "~[chbouib~;~a~;~2*~a~]")
1304                               #:opts %opts-w-format
1305                               #:to 'assembly)))))
1306            (and (= (length w) 1)
1307                 (number? (string-contains (car w)
1308                                           "expected 1 to 4, got 0")))))
1309
1310        (pass-if "@"
1311          (let ((w (call-with-warnings
1312                    (lambda ()
1313                      (compile '(format #f "~@[temperature=~d~]")
1314                               #:opts %opts-w-format
1315                               #:to 'assembly)))))
1316            (and (= (length w) 1)
1317                 (number? (string-contains (car w)
1318                                           "expected 1, got 0")))))
1319
1320        (pass-if "nested"
1321          (let ((w (call-with-warnings
1322                    (lambda ()
1323                      (compile '(format #f "~:[~[hey~;~a~;~va~]~;~3*~]")
1324                               #:opts %opts-w-format
1325                               #:to 'assembly)))))
1326            (and (= (length w) 1)
1327                 (number? (string-contains (car w)
1328                                           "expected 2 to 4, got 0")))))
1329
1330        (pass-if "unterminated"
1331          (let ((w (call-with-warnings
1332                    (lambda ()
1333                      (compile '(format #f "~[unterminated")
1334                               #:opts %opts-w-format
1335                               #:to 'assembly)))))
1336            (and (= (length w) 1)
1337                 (number? (string-contains (car w)
1338                                           "unterminated conditional")))))
1339
1340        (pass-if "unexpected ~;"
1341          (let ((w (call-with-warnings
1342                    (lambda ()
1343                      (compile '(format #f "foo~;bar")
1344                               #:opts %opts-w-format
1345                               #:to 'assembly)))))
1346            (and (= (length w) 1)
1347                 (number? (string-contains (car w)
1348                                           "unexpected")))))
1349
1350        (pass-if "unexpected ~]"
1351          (let ((w (call-with-warnings
1352                    (lambda ()
1353                      (compile '(format #f "foo~]")
1354                               #:opts %opts-w-format
1355                               #:to 'assembly)))))
1356            (and (= (length w) 1)
1357                 (number? (string-contains (car w)
1358                                           "unexpected"))))))
1359
1360      (pass-if "~{...~}"
1361        (null? (call-with-warnings
1362                (lambda ()
1363                  (compile '(format #f "~A ~{~S~} ~A"
1364                                    'hello '("ladies" "and")
1365                                    'gentlemen)
1366                           #:opts %opts-w-format
1367                           #:to 'assembly)))))
1368
1369      (pass-if "~{...~}, too many args"
1370        (let ((w (call-with-warnings
1371                  (lambda ()
1372                    (compile '(format #f "~{~S~}" 1 2 3)
1373                             #:opts %opts-w-format
1374                             #:to 'assembly)))))
1375          (and (= (length w) 1)
1376               (number? (string-contains (car w)
1377                                         "expected 1, got 3")))))
1378
1379      (pass-if "~@{...~}"
1380        (null? (call-with-warnings
1381                (lambda ()
1382                  (compile '(format #f "~@{~S~}" 1 2 3)
1383                           #:opts %opts-w-format
1384                           #:to 'assembly)))))
1385
1386      (pass-if "~@{...~}, too few args"
1387        (let ((w (call-with-warnings
1388                  (lambda ()
1389                    (compile '(format #f "~A ~@{~S~}")
1390                             #:opts %opts-w-format
1391                             #:to 'assembly)))))
1392          (and (= (length w) 1)
1393               (number? (string-contains (car w)
1394                                         "expected at least 1, got 0")))))
1395
1396      (pass-if "unterminated ~{...~}"
1397        (let ((w (call-with-warnings
1398                  (lambda ()
1399                    (compile '(format #f "~{")
1400                             #:opts %opts-w-format
1401                             #:to 'assembly)))))
1402          (and (= (length w) 1)
1403               (number? (string-contains (car w)
1404                                         "unterminated")))))
1405
1406      (pass-if "~(...~)"
1407        (null? (call-with-warnings
1408                (lambda ()
1409                  (compile '(format #f "~:@(~A ~A~)" 'foo 'bar)
1410                           #:opts %opts-w-format
1411                           #:to 'assembly)))))
1412
1413      (pass-if "~v"
1414        (let ((w (call-with-warnings
1415                  (lambda ()
1416                    (compile '(format #f "~v_foo")
1417                             #:opts %opts-w-format
1418                             #:to 'assembly)))))
1419          (and (= (length w) 1)
1420               (number? (string-contains (car w)
1421                                         "expected 1, got 0")))))
1422      (pass-if "~v:@y"
1423        (null? (call-with-warnings
1424                (lambda ()
1425                  (compile '(format #f "~v:@y" 1 123)
1426                           #:opts %opts-w-format
1427                           #:to 'assembly)))))
1428
1429
1430      (pass-if "~*"
1431        (let ((w (call-with-warnings
1432                  (lambda ()
1433                    (compile '(format #f "~2*~a" 'a 'b)
1434                             #:opts %opts-w-format
1435                             #:to 'assembly)))))
1436          (and (= (length w) 1)
1437               (number? (string-contains (car w)
1438                                         "expected 3, got 2")))))
1439
1440      (pass-if "~?"
1441        (null? (call-with-warnings
1442                (lambda ()
1443                  (compile '(format #f "~?" "~d ~d" '(1 2))
1444                           #:opts %opts-w-format
1445                           #:to 'assembly)))))
1446
1447      (pass-if "complex 1"
1448        (let ((w (call-with-warnings
1449                  (lambda ()
1450                    (compile '(format #f
1451                                      "~4@S    ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n"
1452                                      1 2 3 4 5 6)
1453                             #:opts %opts-w-format
1454                             #:to 'assembly)))))
1455          (and (= (length w) 1)
1456               (number? (string-contains (car w)
1457                                         "expected 4, got 6")))))
1458
1459      (pass-if "complex 2"
1460        (let ((w (call-with-warnings
1461                  (lambda ()
1462                    (compile '(format #f
1463                                      "~:(~A~) Commands~:[~; [abbrev]~]:~2%"
1464                                      1 2 3 4)
1465                             #:opts %opts-w-format
1466                             #:to 'assembly)))))
1467          (and (= (length w) 1)
1468               (number? (string-contains (car w)
1469                                         "expected 2, got 4")))))
1470
1471      (pass-if "complex 3"
1472        (let ((w (call-with-warnings
1473                  (lambda ()
1474                    (compile '(format #f "~9@a~:[~*~3_~;~3d~] ~v:@y~%")
1475                             #:opts %opts-w-format
1476                             #:to 'assembly)))))
1477          (and (= (length w) 1)
1478               (number? (string-contains (car w)
1479                                         "expected 5, got 0")))))
1480
1481      (pass-if "ice-9 format"
1482        (let ((w (call-with-warnings
1483                  (lambda ()
1484                    (let ((in (open-input-string
1485                               "(use-modules ((ice-9 format)
1486                                  #:renamer (symbol-prefix-proc 'i9-)))
1487                                (i9-format #t \"yo! ~A\" 1 2)")))
1488                      (read-and-compile in
1489                                        #:opts %opts-w-format
1490                                        #:to 'assembly))))))
1491          (and (= (length w) 1)
1492               (number? (string-contains (car w)
1493                                         "expected 1, got 2")))))
1494
1495      (pass-if "not format"
1496        (null? (call-with-warnings
1497                (lambda ()
1498                  (compile '(let ((format chbouib))
1499                              (format #t "not ~A a format string"))
1500                           #:opts %opts-w-format
1501                           #:to 'assembly)))))))