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