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