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 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         (primcall eqv? (toplevel x) (const #f))
  93       (primcall eq? (const #f) (toplevel x)))
  94
  95     (pass-if-primitives-resolved
  96         (primcall eqv? (toplevel x) (const ()))
  97       (primcall eq? (const ()) (toplevel x)))
  98
  99     (pass-if-primitives-resolved
 100         (primcall eqv? (const #t) (lexical x y))
 101       (primcall eq? (const #t) (lexical x y)))
 102
 103     (pass-if-primitives-resolved
 104         (primcall eqv? (const this-is-a-symbol) (toplevel x))
 105       (primcall eq? (const this-is-a-symbol) (toplevel x)))
 106
 107     (pass-if-primitives-resolved
 108         (primcall eqv? (const 42) (toplevel x))
 109       (primcall eq? (const 42) (toplevel x)))
 110
 111     (pass-if-primitives-resolved
 112         (primcall eqv? (const 42.0) (toplevel x))
 113       (primcall eqv? (const 42.0) (toplevel x)))
 114
 115     (pass-if-primitives-resolved
 116         (primcall eqv? (const #nil) (toplevel x))
 117       (primcall eq? (const #nil) (toplevel x))))
 118
 119   (with-test-prefix "equal?"
 120
 121     (pass-if-primitives-resolved
 122         (primcall equal? (toplevel x) (const #f))
 123       (primcall eq? (const #f) (toplevel x)))
 124
 125     (pass-if-primitives-resolved
 126         (primcall equal? (toplevel x) (const ()))
 127       (primcall eq? (const ()) (toplevel x)))
 128
 129     (pass-if-primitives-resolved
 130         (primcall equal? (const #t) (lexical x y))
 131       (primcall eq? (const #t) (lexical x y)))
 132
 133     (pass-if-primitives-resolved
 134         (primcall equal? (const this-is-a-symbol) (toplevel x))
 135       (primcall eq? (const this-is-a-symbol) (toplevel x)))
 136
 137     (pass-if-primitives-resolved
 138         (primcall equal? (const 42) (toplevel x))
 139       (primcall eq? (const 42) (toplevel x)))
 140
 141     (pass-if-primitives-resolved
 142         (primcall equal? (const 42.0) (toplevel x))
 143       (primcall equal? (const 42.0) (toplevel x)))
 144
 145     (pass-if-primitives-resolved
 146         (primcall equal? (const #nil) (toplevel x))
 147       (primcall 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    (primcall + (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    (call (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 (call (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    (call (toplevel foo) (call (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    (primcall 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    (primcall 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)) (primcall 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) (primcall 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) (primcall 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      (primcall null?
 266            (set! (lexical x y) (primcall 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    (primcall 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    (primcall 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    (primcall 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    (primcall 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    (primcall 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    (primcall 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    (primcall 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    (primcall 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            (call (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) ((call (toplevel foo)) (call (toplevel bar)))
 438            (primcall + (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) ((call (toplevel foo)) (call (toplevel bar)))
 456             (primcall + (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    (primcall 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    (primcall values
 582              (primcall 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    (primcall values
 588              (primcall 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    (primcall +
 595              (primcall 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    (primcall cdr
 602              (letrec (lp) (#{lp ~V9KrhVD4PFEL6oCTrLg3A}#)
 603                      ((lambda ((name . lp))
 604                         (lambda-case ((() #f #f #f () ())
 605                                       (primcall values (const (one two)))))))
 606                      (call (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    (primcall @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 (primcall @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    (call (toplevel foo) (call (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    (primcall @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 (primcall @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    (call (toplevel foo)
 685           (call (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 (with-test-prefix "tree-il-fold"
 706
 707   (pass-if "empty tree"
 708     (let ((leaf? #f) (up? #f) (down? #f) (mark (list 'mark)))
 709       (and (eq? mark
 710                 (tree-il-fold (lambda (x y) (set! leaf? #t) y)
 711                               (lambda (x y) (set! down? #t) y)
 712                               (lambda (x y) (set! up? #t) y)
 713                               mark
 714                               '()))
 715            (not leaf?)
 716            (not up?)
 717            (not down?))))
 718
 719   (pass-if "lambda and application"
 720     (let* ((leaves '()) (ups '()) (downs '())
 721            (result (tree-il-fold (lambda (x y)
 722                                    (set! leaves (cons x leaves))
 723                                    (1+ y))
 724                                  (lambda (x y)
 725                                    (set! downs (cons x downs))
 726                                    (1+ y))
 727                                  (lambda (x y)
 728                                    (set! ups (cons x ups))
 729                                    (1+ y))
 730                                  0
 731                                  (parse-tree-il
 732                                   '(lambda ()
 733                                      (lambda-case
 734                                       (((x y) #f #f #f () (x1 y1))
 735                                        (call (toplevel +)
 736                                              (lexical x x1)
 737                                              (lexical y y1)))
 738                                       #f))))))
 739       (and (equal? (map strip-source leaves)
 740                    (list (make-lexical-ref #f 'y 'y1)
 741                          (make-lexical-ref #f 'x 'x1)
 742                          (make-toplevel-ref #f '+)))
 743            (= (length downs) 3)
 744            (equal? (reverse (map strip-source ups))
 745                    (map strip-source downs))))))
 746
 747 \f
 748 ;;;
 749 ;;; Warnings.
 750 ;;;
 751
 752 ;; Make sure we get English messages.
 753 (setlocale LC_ALL "C")
 754
 755 (define (call-with-warnings thunk)
 756   (let ((port (open-output-string)))
 757     (with-fluids ((*current-warning-port*   port)
 758                   (*current-warning-prefix* ""))
 759       (thunk))
 760     (let ((warnings (get-output-string port)))
 761       (string-tokenize warnings
 762                        (char-set-complement (char-set #\newline))))))
 763
 764 (define %opts-w-unused
 765   '(#:warnings (unused-variable)))
 766
 767 (define %opts-w-unused-toplevel
 768   '(#:warnings (unused-toplevel)))
 769
 770 (define %opts-w-unbound
 771   '(#:warnings (unbound-variable)))
 772
 773 (define %opts-w-arity
 774   '(#:warnings (arity-mismatch)))
 775
 776 (define %opts-w-format
 777   '(#:warnings (format)))
 778
 779 (define %opts-w-duplicate-case-datum
 780   '(#:warnings (duplicate-case-datum)))
 781
 782 (define %opts-w-bad-case-datum
 783   '(#:warnings (bad-case-datum)))
 784
 785
 786 (with-test-prefix "warnings"
 787
 788    (pass-if "unknown warning type"
 789      (let ((w (call-with-warnings
 790                 (lambda ()
 791                   (compile #t #:opts '(#:warnings (does-not-exist)))))))
 792        (and (= (length w) 1)
 793             (number? (string-contains (car w) "unknown warning")))))
 794
 795    (with-test-prefix "unused-variable"
 796
 797      (pass-if "quiet"
 798        (null? (call-with-warnings
 799                 (lambda ()
 800                   (compile '(lambda (x y) (+ x y))
 801                            #:opts %opts-w-unused)))))
 802
 803      (pass-if "let/unused"
 804        (let ((w (call-with-warnings
 805                   (lambda ()
 806                     (compile '(lambda (x)
 807                                 (let ((y (+ x 2)))
 808                                   x))
 809                              #:opts %opts-w-unused)))))
 810          (and (= (length w) 1)
 811               (number? (string-contains (car w) "unused variable `y'")))))
 812
 813      (pass-if "shadowed variable"
 814        (let ((w (call-with-warnings
 815                   (lambda ()
 816                     (compile '(lambda (x)
 817                                 (let ((y x))
 818                                   (let ((y (+ x 2)))
 819                                     (+ x y))))
 820                              #:opts %opts-w-unused)))))
 821          (and (= (length w) 1)
 822               (number? (string-contains (car w) "unused variable `y'")))))
 823
 824      (pass-if "letrec"
 825        (null? (call-with-warnings
 826                 (lambda ()
 827                   (compile '(lambda ()
 828                               (letrec ((x (lambda () (y)))
 829                                        (y (lambda () (x))))
 830                                 y))
 831                            #:opts %opts-w-unused)))))
 832
 833      (pass-if "unused argument"
 834        ;; Unused arguments should not be reported.
 835        (null? (call-with-warnings
 836                 (lambda ()
 837                   (compile '(lambda (x y z) #t)
 838                            #:opts %opts-w-unused)))))
 839
 840      (pass-if "special variable names"
 841        (null? (call-with-warnings
 842                 (lambda ()
 843                   (compile '(lambda ()
 844                               (let ((_ 'underscore)
 845                                     (#{gensym name}# 'ignore-me))
 846                                 #t))
 847                            #:to 'assembly
 848                            #:opts %opts-w-unused))))))
 849
 850    (with-test-prefix "unused-toplevel"
 851
 852      (pass-if "used after definition"
 853        (null? (call-with-warnings
 854                 (lambda ()
 855                   (let ((in (open-input-string
 856                              "(define foo 2) foo")))
 857                     (read-and-compile in
 858                                       #:to 'assembly
 859                                       #:opts %opts-w-unused-toplevel))))))
 860
 861      (pass-if "used before definition"
 862        (null? (call-with-warnings
 863                 (lambda ()
 864                   (let ((in (open-input-string
 865                              "(define (bar) foo) (define foo 2) (bar)")))
 866                     (read-and-compile in
 867                                       #:to 'assembly
 868                                       #:opts %opts-w-unused-toplevel))))))
 869
 870      (pass-if "unused but public"
 871        (let ((in (open-input-string
 872                   "(define-module (test-suite tree-il x) #:export (bar))
 873                    (define (bar) #t)")))
 874          (null? (call-with-warnings
 875                   (lambda ()
 876                     (read-and-compile in
 877                                       #:to 'assembly
 878                                       #:opts %opts-w-unused-toplevel))))))
 879
 880      (pass-if "unused but public (more)"
 881        (let ((in (open-input-string
 882                   "(define-module (test-suite tree-il x) #:export (bar))
 883                    (define (bar) (baz))
 884                    (define (baz) (foo))
 885                    (define (foo) #t)")))
 886          (null? (call-with-warnings
 887                   (lambda ()
 888                     (read-and-compile in
 889                                       #:to 'assembly
 890                                       #:opts %opts-w-unused-toplevel))))))
 891
 892      (pass-if "unused but define-public"
 893        (null? (call-with-warnings
 894                 (lambda ()
 895                   (compile '(define-public foo 2)
 896                            #:to 'assembly
 897                            #:opts %opts-w-unused-toplevel)))))
 898
 899      (pass-if "used by macro"
 900        ;; FIXME: See comment about macros at `unused-toplevel-analysis'.
 901        (throw 'unresolved)
 902
 903        (null? (call-with-warnings
 904                 (lambda ()
 905                   (let ((in (open-input-string
 906                              "(define (bar) 'foo)
 907                               (define-syntax baz
 908                                 (syntax-rules () ((_) (bar))))")))
 909                     (read-and-compile in
 910                                       #:to 'assembly
 911                                       #:opts %opts-w-unused-toplevel))))))
 912
 913      (pass-if "unused"
 914        (let ((w (call-with-warnings
 915                   (lambda ()
 916                     (compile '(define foo 2)
 917                              #:to 'assembly
 918                              #:opts %opts-w-unused-toplevel)))))
 919          (and (= (length w) 1)
 920               (number? (string-contains (car w)
 921                                         (format #f "top-level variable `~A'"
 922                                                 'foo))))))
 923
 924      (pass-if "unused recursive"
 925        (let ((w (call-with-warnings
 926                   (lambda ()
 927                     (compile '(define (foo) (foo))
 928                              #:to 'assembly
 929                              #:opts %opts-w-unused-toplevel)))))
 930          (and (= (length w) 1)
 931               (number? (string-contains (car w)
 932                                         (format #f "top-level variable `~A'"
 933                                                 'foo))))))
 934
 935      (pass-if "unused mutually recursive"
 936        (let* ((in (open-input-string
 937                    "(define (foo) (bar)) (define (bar) (foo))"))
 938               (w  (call-with-warnings
 939                     (lambda ()
 940                       (read-and-compile in
 941                                         #:to 'assembly
 942                                         #:opts %opts-w-unused-toplevel)))))
 943          (and (= (length w) 2)
 944               (number? (string-contains (car w)
 945                                         (format #f "top-level variable `~A'"
 946                                                 'foo)))
 947               (number? (string-contains (cadr w)
 948                                         (format #f "top-level variable `~A'"
 949                                                 'bar))))))
 950
 951      (pass-if "special variable names"
 952        (null? (call-with-warnings
 953                 (lambda ()
 954                   (compile '(define #{gensym name}# 'ignore-me)
 955                            #:to 'assembly
 956                            #:opts %opts-w-unused-toplevel))))))
 957
 958    (with-test-prefix "unbound variable"
 959
 960      (pass-if "quiet"
 961        (null? (call-with-warnings
 962                 (lambda ()
 963                   (compile '+ #:opts %opts-w-unbound)))))
 964
 965      (pass-if "ref"
 966        (let* ((v (gensym))
 967               (w (call-with-warnings
 968                    (lambda ()
 969                      (compile v
 970                               #:to 'assembly
 971                               #:opts %opts-w-unbound)))))
 972          (and (= (length w) 1)
 973               (number? (string-contains (car w)
 974                                         (format #f "unbound variable `~A'"
 975                                                 v))))))
 976
 977      (pass-if "set!"
 978        (let* ((v (gensym))
 979               (w (call-with-warnings
 980                    (lambda ()
 981                      (compile `(set! ,v 7)
 982                               #:to 'assembly
 983                               #:opts %opts-w-unbound)))))
 984          (and (= (length w) 1)
 985               (number? (string-contains (car w)
 986                                         (format #f "unbound variable `~A'"
 987                                                 v))))))
 988
 989      (pass-if "module-local top-level is visible"
 990        (let ((m (make-module))
 991              (v (gensym)))
 992          (beautify-user-module! m)
 993          (compile `(define ,v 123)
 994                   #:env m #:opts %opts-w-unbound)
 995          (null? (call-with-warnings
 996                   (lambda ()
 997                     (compile v
 998                              #:env m
 999                              #:to 'assembly
1000                              #:opts %opts-w-unbound))))))
1001
1002      (pass-if "module-local top-level is visible after"
1003        (let ((m (make-module))
1004              (v (gensym)))
1005          (beautify-user-module! m)
1006          (null? (call-with-warnings
1007                   (lambda ()
1008                     (let ((in (open-input-string
1009                                "(define (f)
1010                                   (set! chbouib 3))
1011                                 (define chbouib 5)")))
1012                       (read-and-compile in
1013                                         #:env m
1014                                         #:opts %opts-w-unbound)))))))
1015
1016      (pass-if "optional arguments are visible"
1017        (null? (call-with-warnings
1018                 (lambda ()
1019                   (compile '(lambda* (x #:optional y z) (list x y z))
1020                            #:opts %opts-w-unbound
1021                            #:to 'assembly)))))
1022
1023      (pass-if "keyword arguments are visible"
1024        (null? (call-with-warnings
1025                 (lambda ()
1026                   (compile '(lambda* (x #:key y z) (list x y z))
1027                            #:opts %opts-w-unbound
1028                            #:to 'assembly)))))
1029
1030      (pass-if "GOOPS definitions are visible"
1031        (let ((m (make-module))
1032              (v (gensym)))
1033          (beautify-user-module! m)
1034          (module-use! m (resolve-interface '(oop goops)))
1035          (null? (call-with-warnings
1036                   (lambda ()
1037                     (let ((in (open-input-string
1038                                "(define-class <foo> ()
1039                                   (bar #:getter foo-bar))
1040                                 (define z (foo-bar (make <foo>)))")))
1041                       (read-and-compile in
1042                                         #:env m
1043                                         #:opts %opts-w-unbound))))))))
1044
1045    (with-test-prefix "arity mismatch"
1046
1047      (pass-if "quiet"
1048        (null? (call-with-warnings
1049                 (lambda ()
1050                   (compile '(cons 'a 'b) #:opts %opts-w-arity)))))
1051
1052      (pass-if "direct application"
1053        (let ((w (call-with-warnings
1054                   (lambda ()
1055                     (compile '((lambda (x y) (or x y)) 1 2 3 4 5)
1056                              #:opts %opts-w-arity
1057                              #:to 'assembly)))))
1058          (and (= (length w) 1)
1059               (number? (string-contains (car w)
1060                                         "wrong number of arguments to")))))
1061      (pass-if "local"
1062        (let ((w (call-with-warnings
1063                   (lambda ()
1064                     (compile '(let ((f (lambda (x y) (+ x y))))
1065                                 (f 2))
1066                              #:opts %opts-w-arity
1067                              #:to 'assembly)))))
1068          (and (= (length w) 1)
1069               (number? (string-contains (car w)
1070                                         "wrong number of arguments to")))))
1071
1072      (pass-if "global"
1073        (let ((w (call-with-warnings
1074                   (lambda ()
1075                     (compile '(cons 1 2 3 4)
1076                              #:opts %opts-w-arity
1077                              #:to 'assembly)))))
1078          (and (= (length w) 1)
1079               (number? (string-contains (car w)
1080                                         "wrong number of arguments to")))))
1081
1082      (pass-if "alias to global"
1083        (let ((w (call-with-warnings
1084                   (lambda ()
1085                     (compile '(let ((f cons)) (f 1 2 3 4))
1086                              #:opts %opts-w-arity
1087                              #:to 'assembly)))))
1088          (and (= (length w) 1)
1089               (number? (string-contains (car w)
1090                                         "wrong number of arguments to")))))
1091
1092      (pass-if "alias to lexical to global"
1093        (let ((w (call-with-warnings
1094                   (lambda ()
1095                     (compile '(let ((f number?))
1096                                 (let ((g f))
1097                                   (f 1 2 3 4)))
1098                              #:opts %opts-w-arity
1099                              #:to 'assembly)))))
1100          (and (= (length w) 1)
1101               (number? (string-contains (car w)
1102                                         "wrong number of arguments to")))))
1103
1104      (pass-if "alias to lexical"
1105        (let ((w (call-with-warnings
1106                   (lambda ()
1107                     (compile '(let ((f (lambda (x y z) (+ x y z))))
1108                                 (let ((g f))
1109                                   (g 1)))
1110                              #:opts %opts-w-arity
1111                              #:to 'assembly)))))
1112          (and (= (length w) 1)
1113               (number? (string-contains (car w)
1114                                         "wrong number of arguments to")))))
1115
1116      (pass-if "letrec"
1117        (let ((w (call-with-warnings
1118                   (lambda ()
1119                     (compile '(letrec ((odd?  (lambda (x) (even? (1- x))))
1120                                        (even? (lambda (x)
1121                                                 (or (= 0 x)
1122                                                     (odd?)))))
1123                                 (odd? 1))
1124                              #:opts %opts-w-arity
1125                              #:to 'assembly)))))
1126          (and (= (length w) 1)
1127               (number? (string-contains (car w)
1128                                         "wrong number of arguments to")))))
1129
1130      (pass-if "case-lambda"
1131        (null? (call-with-warnings
1132                 (lambda ()
1133                   (compile '(let ((f (case-lambda
1134                                        ((x)     1)
1135                                        ((x y)   2)
1136                                        ((x y z) 3))))
1137                               (list (f 1)
1138                                     (f 1 2)
1139                                     (f 1 2 3)))
1140                            #:opts %opts-w-arity
1141                            #:to 'assembly)))))
1142
1143      (pass-if "case-lambda with wrong number of arguments"
1144        (let ((w (call-with-warnings
1145                   (lambda ()
1146                     (compile '(let ((f (case-lambda
1147                                          ((x)     1)
1148                                          ((x y)   2))))
1149                                 (f 1 2 3))
1150                              #:opts %opts-w-arity
1151                              #:to 'assembly)))))
1152          (and (= (length w) 1)
1153               (number? (string-contains (car w)
1154                                         "wrong number of arguments to")))))
1155
1156      (pass-if "case-lambda*"
1157        (null? (call-with-warnings
1158                 (lambda ()
1159                   (compile '(let ((f (case-lambda*
1160                                        ((x #:optional y) 1)
1161                                        ((x #:key y)      2)
1162                                        ((x y #:key z)    3))))
1163                               (list (f 1)
1164                                     (f 1 2)
1165                                     (f #:y 2)
1166                                     (f 1 2 #:z 3)))
1167                            #:opts %opts-w-arity
1168                            #:to 'assembly)))))
1169
1170      (pass-if "case-lambda* with wrong arguments"
1171        (let ((w (call-with-warnings
1172                   (lambda ()
1173                     (compile '(let ((f (case-lambda*
1174                                          ((x #:optional y) 1)
1175                                          ((x #:key y)      2)
1176                                          ((x y #:key z)    3))))
1177                                 (list (f)
1178                                       (f 1 #:z 3)))
1179                              #:opts %opts-w-arity
1180                              #:to 'assembly)))))
1181          (and (= (length w) 2)
1182               (null? (filter (lambda (w)
1183                                (not
1184                                 (number?
1185                                  (string-contains
1186                                   w "wrong number of arguments to"))))
1187                              w)))))
1188
1189      (pass-if "top-level applicable struct"
1190        (null? (call-with-warnings
1191                (lambda ()
1192                  (compile '(let ((p current-warning-port))
1193                              (p (+ (p) 1))
1194                              (p))
1195                           #:opts %opts-w-arity
1196                           #:to 'assembly)))))
1197
1198      (pass-if "top-level applicable struct with wrong arguments"
1199        (let ((w (call-with-warnings
1200                  (lambda ()
1201                    (compile '(let ((p current-warning-port))
1202                                (p 1 2 3))
1203                             #:opts %opts-w-arity
1204                             #:to 'assembly)))))
1205          (and (= (length w) 1)
1206               (number? (string-contains (car w)
1207                                         "wrong number of arguments to")))))
1208
1209      (pass-if "local toplevel-defines"
1210        (let ((w (call-with-warnings
1211                   (lambda ()
1212                     (let ((in (open-input-string "
1213                                 (define (g x) (f x))
1214                                 (define (f) 1)")))
1215                       (read-and-compile in
1216                                         #:opts %opts-w-arity
1217                                         #:to 'assembly))))))
1218          (and (= (length w) 1)
1219               (number? (string-contains (car w)
1220                                         "wrong number of arguments to")))))
1221
1222      (pass-if "global toplevel alias"
1223        (let ((w (call-with-warnings
1224                   (lambda ()
1225                     (let ((in (open-input-string "
1226                                 (define f cons)
1227                                 (define (g) (f))")))
1228                       (read-and-compile in
1229                                         #:opts %opts-w-arity
1230                                         #:to 'assembly))))))
1231          (and (= (length w) 1)
1232               (number? (string-contains (car w)
1233                                         "wrong number of arguments to")))))
1234
1235      (pass-if "local toplevel overrides global"
1236        (null? (call-with-warnings
1237                 (lambda ()
1238                   (let ((in (open-input-string "
1239                               (define (cons) 0)
1240                               (define (foo x) (cons))")))
1241                     (read-and-compile in
1242                                       #:opts %opts-w-arity
1243                                       #:to 'assembly))))))
1244
1245      (pass-if "keyword not passed and quiet"
1246        (null? (call-with-warnings
1247                 (lambda ()
1248                   (compile '(let ((f (lambda* (x #:key y) y)))
1249                               (f 2))
1250                            #:opts %opts-w-arity
1251                            #:to 'assembly)))))
1252
1253      (pass-if "keyword passed and quiet"
1254        (null? (call-with-warnings
1255                 (lambda ()
1256                   (compile '(let ((f (lambda* (x #:key y) y)))
1257                               (f 2 #:y 3))
1258                            #:opts %opts-w-arity
1259                            #:to 'assembly)))))
1260
1261      (pass-if "keyword passed to global and quiet"
1262        (null? (call-with-warnings
1263                 (lambda ()
1264                   (let ((in (open-input-string "
1265                               (use-modules (system base compile))
1266                               (compile '(+ 2 3) #:env (current-module))")))
1267                     (read-and-compile in
1268                                       #:opts %opts-w-arity
1269                                       #:to 'assembly))))))
1270
1271      (pass-if "extra keyword"
1272        (let ((w (call-with-warnings
1273                   (lambda ()
1274                     (compile '(let ((f (lambda* (x #:key y) y)))
1275                                 (f 2 #:Z 3))
1276                              #:opts %opts-w-arity
1277                              #:to 'assembly)))))
1278          (and (= (length w) 1)
1279               (number? (string-contains (car w)
1280                                         "wrong number of arguments to")))))
1281
1282      (pass-if "extra keywords allowed"
1283        (null? (call-with-warnings
1284                 (lambda ()
1285                   (compile '(let ((f (lambda* (x #:key y #:allow-other-keys)
1286                                        y)))
1287                               (f 2 #:Z 3))
1288                            #:opts %opts-w-arity
1289                            #:to 'assembly))))))
1290
1291    (with-test-prefix "format"
1292
1293      (pass-if "quiet (no args)"
1294        (null? (call-with-warnings
1295                (lambda ()
1296                  (compile '(format #t "hey!")
1297                           #:opts %opts-w-format
1298                           #:to 'assembly)))))
1299
1300      (pass-if "quiet (1 arg)"
1301        (null? (call-with-warnings
1302                (lambda ()
1303                  (compile '(format #t "hey ~A!" "you")
1304                           #:opts %opts-w-format
1305                           #:to 'assembly)))))
1306
1307      (pass-if "quiet (2 args)"
1308        (null? (call-with-warnings
1309                (lambda ()
1310                  (compile '(format #t "~A ~A!" "hello" "world")
1311                           #:opts %opts-w-format
1312                           #:to 'assembly)))))
1313
1314      (pass-if "wrong port arg"
1315        (let ((w (call-with-warnings
1316                  (lambda ()
1317                    (compile '(format 10 "foo")
1318                             #:opts %opts-w-format
1319                             #:to 'assembly)))))
1320          (and (= (length w) 1)
1321               (number? (string-contains (car w)
1322                                         "wrong port argument")))))
1323
1324      (pass-if "non-literal format string"
1325        (let ((w (call-with-warnings
1326                  (lambda ()
1327                    (compile '(format #f fmt)
1328                             #:opts %opts-w-format
1329                             #:to 'assembly)))))
1330          (and (= (length w) 1)
1331               (number? (string-contains (car w)
1332                                         "non-literal format string")))))
1333
1334      (pass-if "non-literal format string using gettext"
1335        (null? (call-with-warnings
1336                (lambda ()
1337                  (compile '(format #t (gettext "~A ~A!") "hello" "world")
1338                           #:opts %opts-w-format
1339                           #:to 'assembly)))))
1340
1341      (pass-if "non-literal format string using gettext as _"
1342        (null? (call-with-warnings
1343                (lambda ()
1344                  (compile '(format #t (_ "~A ~A!") "hello" "world")
1345                           #:opts %opts-w-format
1346                           #:to 'assembly)))))
1347
1348      (pass-if "non-literal format string using gettext as top-level _"
1349        (null? (call-with-warnings
1350                (lambda ()
1351                  (compile '(begin
1352                              (define (_ s) (gettext s "my-domain"))
1353                              (format #t (_ "~A ~A!") "hello" "world"))
1354                           #:opts %opts-w-format
1355                           #:to 'assembly)))))
1356
1357      (pass-if "non-literal format string using gettext as module-ref _"
1358        (null? (call-with-warnings
1359                (lambda ()
1360                  (compile '(format #t ((@@ (foo) _) "~A ~A!") "hello" "world")
1361                           #:opts %opts-w-format
1362                           #:to 'assembly)))))
1363
1364      (pass-if "non-literal format string using gettext as lexical _"
1365        (null? (call-with-warnings
1366                (lambda ()
1367                  (compile '(let ((_ (lambda (s)
1368                                       (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 ngettext"
1374        (null? (call-with-warnings
1375                (lambda ()
1376                  (compile '(format #t
1377                                    (ngettext "~a thing" "~a things" n "dom") n)
1378                           #:opts %opts-w-format
1379                           #:to 'assembly)))))
1380
1381      (pass-if "non-literal format string using ngettext as N_"
1382        (null? (call-with-warnings
1383                (lambda ()
1384                  (compile '(format #t (N_ "~a thing" "~a things" n) n)
1385                           #:opts %opts-w-format
1386                           #:to 'assembly)))))
1387
1388      (pass-if "non-literal format string with (define _ gettext)"
1389        (null? (call-with-warnings
1390                (lambda ()
1391                  (compile '(begin
1392                              (define _ gettext)
1393                              (define (foo)
1394                                (format #t (_ "~A ~A!") "hello" "world")))
1395                           #:opts %opts-w-format
1396                           #:to 'assembly)))))
1397
1398      (pass-if "wrong format string"
1399        (let ((w (call-with-warnings
1400                  (lambda ()
1401                    (compile '(format #f 'not-a-string)
1402                             #:opts %opts-w-format
1403                             #:to 'assembly)))))
1404          (and (= (length w) 1)
1405               (number? (string-contains (car w)
1406                                         "wrong format string")))))
1407
1408      (pass-if "wrong number of args"
1409        (let ((w (call-with-warnings
1410                  (lambda ()
1411                    (compile '(format "shbweeb")
1412                             #:opts %opts-w-format
1413                             #:to 'assembly)))))
1414          (and (= (length w) 1)
1415               (number? (string-contains (car w)
1416                                         "wrong number of arguments")))))
1417
1418      (pass-if "~%, ~~, ~&, ~t, ~_, ~!, ~|, ~/, ~q and ~\\n"
1419        (null? (call-with-warnings
1420                (lambda ()
1421                  (compile '((@ (ice-9 format) format) some-port
1422                             "~&~3_~~ ~\n~12they~% ~!~|~/~q")
1423                           #:opts %opts-w-format
1424                           #:to 'assembly)))))
1425
1426      (pass-if "one missing argument"
1427        (let ((w (call-with-warnings
1428                  (lambda ()
1429                    (compile '(format some-port "foo ~A~%")
1430                             #:opts %opts-w-format
1431                             #:to 'assembly)))))
1432          (and (= (length w) 1)
1433               (number? (string-contains (car w)
1434                                         "expected 1, got 0")))))
1435
1436      (pass-if "one missing argument, gettext"
1437        (let ((w (call-with-warnings
1438                  (lambda ()
1439                    (compile '(format some-port (gettext "foo ~A~%"))
1440                             #:opts %opts-w-format
1441                             #:to 'assembly)))))
1442          (and (= (length w) 1)
1443               (number? (string-contains (car w)
1444                                         "expected 1, got 0")))))
1445
1446      (pass-if "two missing arguments"
1447        (let ((w (call-with-warnings
1448                  (lambda ()
1449                    (compile '((@ (ice-9 format) format) #f
1450                               "foo ~10,2f and bar ~S~%")
1451                             #:opts %opts-w-format
1452                             #:to 'assembly)))))
1453          (and (= (length w) 1)
1454               (number? (string-contains (car w)
1455                                         "expected 2, got 0")))))
1456
1457      (pass-if "one given, one missing argument"
1458        (let ((w (call-with-warnings
1459                  (lambda ()
1460                    (compile '(format #t "foo ~A and ~S~%" hey)
1461                             #:opts %opts-w-format
1462                             #:to 'assembly)))))
1463          (and (= (length w) 1)
1464               (number? (string-contains (car w)
1465                                         "expected 2, got 1")))))
1466
1467      (pass-if "too many arguments"
1468        (let ((w (call-with-warnings
1469                  (lambda ()
1470                    (compile '(format #t "foo ~A~%" 1 2)
1471                             #:opts %opts-w-format
1472                             #:to 'assembly)))))
1473          (and (= (length w) 1)
1474               (number? (string-contains (car w)
1475                                         "expected 1, got 2")))))
1476
1477      (pass-if "~h"
1478        (null? (call-with-warnings
1479                  (lambda ()
1480                    (compile '((@ (ice-9 format) format) #t
1481                               "foo ~h ~a~%" 123.4 'bar)
1482                             #:opts %opts-w-format
1483                             #:to 'assembly)))))
1484
1485      (pass-if "~:h with locale object"
1486        (null? (call-with-warnings
1487                  (lambda ()
1488                    (compile '((@ (ice-9 format) format) #t
1489                               "foo ~:h~%" 123.4 %global-locale)
1490                             #:opts %opts-w-format
1491                             #:to 'assembly)))))
1492
1493      (pass-if "~:h without locale object"
1494        (let ((w (call-with-warnings
1495                  (lambda ()
1496                    (compile '((@ (ice-9 format) format) #t "foo ~,2:h" 123.4)
1497                             #:opts %opts-w-format
1498                             #:to 'assembly)))))
1499          (and (= (length w) 1)
1500               (number? (string-contains (car w)
1501                                         "expected 2, got 1")))))
1502
1503      (with-test-prefix "conditionals"
1504        (pass-if "literals"
1505         (null? (call-with-warnings
1506                 (lambda ()
1507                   (compile '((@ (ice-9 format) format) #f "~A ~[foo~;bar~;baz~;~] ~10,2f"
1508                                     'a 1 3.14)
1509                            #:opts %opts-w-format
1510                            #:to 'assembly)))))
1511
1512        (pass-if "literals with selector"
1513          (let ((w (call-with-warnings
1514                    (lambda ()
1515                      (compile '((@ (ice-9 format) format) #f "~2[foo~;bar~;baz~;~] ~A"
1516                                        1 'dont-ignore-me)
1517                               #:opts %opts-w-format
1518                               #:to 'assembly)))))
1519            (and (= (length w) 1)
1520                 (number? (string-contains (car w)
1521                                           "expected 1, got 2")))))
1522
1523        (pass-if "escapes (exact count)"
1524          (let ((w (call-with-warnings
1525                    (lambda ()
1526                      (compile '((@ (ice-9 format) format) #f "~[~a~;~a~]")
1527                               #:opts %opts-w-format
1528                               #:to 'assembly)))))
1529            (and (= (length w) 1)
1530                 (number? (string-contains (car w)
1531                                           "expected 2, got 0")))))
1532
1533        (pass-if "escapes with selector"
1534          (let ((w (call-with-warnings
1535                    (lambda ()
1536                      (compile '((@ (ice-9 format) format) #f "~1[chbouib~;~a~]")
1537                               #:opts %opts-w-format
1538                               #:to 'assembly)))))
1539            (and (= (length w) 1)
1540                 (number? (string-contains (car w)
1541                                           "expected 1, got 0")))))
1542
1543        (pass-if "escapes, range"
1544          (let ((w (call-with-warnings
1545                    (lambda ()
1546                      (compile '((@ (ice-9 format) format) #f "~[chbouib~;~a~;~2*~a~]")
1547                               #:opts %opts-w-format
1548                               #:to 'assembly)))))
1549            (and (= (length w) 1)
1550                 (number? (string-contains (car w)
1551                                           "expected 1 to 4, got 0")))))
1552
1553        (pass-if "@"
1554          (let ((w (call-with-warnings
1555                    (lambda ()
1556                      (compile '((@ (ice-9 format) format) #f "~@[temperature=~d~]")
1557                               #:opts %opts-w-format
1558                               #:to 'assembly)))))
1559            (and (= (length w) 1)
1560                 (number? (string-contains (car w)
1561                                           "expected 1, got 0")))))
1562
1563        (pass-if "nested"
1564          (let ((w (call-with-warnings
1565                    (lambda ()
1566                      (compile '((@ (ice-9 format) format) #f "~:[~[hey~;~a~;~va~]~;~3*~]")
1567                               #:opts %opts-w-format
1568                               #:to 'assembly)))))
1569            (and (= (length w) 1)
1570                 (number? (string-contains (car w)
1571                                           "expected 2 to 4, got 0")))))
1572
1573        (pass-if "unterminated"
1574          (let ((w (call-with-warnings
1575                    (lambda ()
1576                      (compile '((@ (ice-9 format) format) #f "~[unterminated")
1577                               #:opts %opts-w-format
1578                               #:to 'assembly)))))
1579            (and (= (length w) 1)
1580                 (number? (string-contains (car w)
1581                                           "unterminated conditional")))))
1582
1583        (pass-if "unexpected ~;"
1584          (let ((w (call-with-warnings
1585                    (lambda ()
1586                      (compile '((@ (ice-9 format) format) #f "foo~;bar")
1587                               #:opts %opts-w-format
1588                               #:to 'assembly)))))
1589            (and (= (length w) 1)
1590                 (number? (string-contains (car w)
1591                                           "unexpected")))))
1592
1593        (pass-if "unexpected ~]"
1594          (let ((w (call-with-warnings
1595                    (lambda ()
1596                      (compile '((@ (ice-9 format) format) #f "foo~]")
1597                               #:opts %opts-w-format
1598                               #:to 'assembly)))))
1599            (and (= (length w) 1)
1600                 (number? (string-contains (car w)
1601                                           "unexpected"))))))
1602
1603      (pass-if "~{...~}"
1604        (null? (call-with-warnings
1605                (lambda ()
1606                  (compile '((@ (ice-9 format) format) #f "~A ~{~S~} ~A"
1607                                    'hello '("ladies" "and")
1608                                    'gentlemen)
1609                           #:opts %opts-w-format
1610                           #:to 'assembly)))))
1611
1612      (pass-if "~{...~}, too many args"
1613        (let ((w (call-with-warnings
1614                  (lambda ()
1615                    (compile '((@ (ice-9 format) format) #f "~{~S~}" 1 2 3)
1616                             #:opts %opts-w-format
1617                             #:to 'assembly)))))
1618          (and (= (length w) 1)
1619               (number? (string-contains (car w)
1620                                         "expected 1, got 3")))))
1621
1622      (pass-if "~@{...~}"
1623        (null? (call-with-warnings
1624                (lambda ()
1625                  (compile '((@ (ice-9 format) format) #f "~@{~S~}" 1 2 3)
1626                           #:opts %opts-w-format
1627                           #:to 'assembly)))))
1628
1629      (pass-if "~@{...~}, too few args"
1630        (let ((w (call-with-warnings
1631                  (lambda ()
1632                    (compile '((@ (ice-9 format) format) #f "~A ~@{~S~}")
1633                             #:opts %opts-w-format
1634                             #:to 'assembly)))))
1635          (and (= (length w) 1)
1636               (number? (string-contains (car w)
1637                                         "expected at least 1, got 0")))))
1638
1639      (pass-if "unterminated ~{...~}"
1640        (let ((w (call-with-warnings
1641                  (lambda ()
1642                    (compile '((@ (ice-9 format) format) #f "~{")
1643                             #:opts %opts-w-format
1644                             #:to 'assembly)))))
1645          (and (= (length w) 1)
1646               (number? (string-contains (car w)
1647                                         "unterminated")))))
1648
1649      (pass-if "~(...~)"
1650        (null? (call-with-warnings
1651                (lambda ()
1652                  (compile '((@ (ice-9 format) format) #f "~:@(~A ~A~)" 'foo 'bar)
1653                           #:opts %opts-w-format
1654                           #:to 'assembly)))))
1655
1656      (pass-if "~v"
1657        (let ((w (call-with-warnings
1658                  (lambda ()
1659                    (compile '((@ (ice-9 format) format) #f "~v_foo")
1660                             #:opts %opts-w-format
1661                             #:to 'assembly)))))
1662          (and (= (length w) 1)
1663               (number? (string-contains (car w)
1664                                         "expected 1, got 0")))))
1665      (pass-if "~v:@y"
1666        (null? (call-with-warnings
1667                (lambda ()
1668                  (compile '((@ (ice-9 format) format) #f "~v:@y" 1 123)
1669                           #:opts %opts-w-format
1670                           #:to 'assembly)))))
1671
1672
1673      (pass-if "~*"
1674        (let ((w (call-with-warnings
1675                  (lambda ()
1676                    (compile '((@ (ice-9 format) format) #f "~2*~a" 'a 'b)
1677                             #:opts %opts-w-format
1678                             #:to 'assembly)))))
1679          (and (= (length w) 1)
1680               (number? (string-contains (car w)
1681                                         "expected 3, got 2")))))
1682
1683      (pass-if "~?"
1684        (null? (call-with-warnings
1685                (lambda ()
1686                  (compile '((@ (ice-9 format) format) #f "~?" "~d ~d" '(1 2))
1687                           #:opts %opts-w-format
1688                           #:to 'assembly)))))
1689
1690      (pass-if "~^"
1691        (null? (call-with-warnings
1692                (lambda ()
1693                  (compile '((@ (ice-9 format) format) #f "~a ~^ ~a" 0 1)
1694                           #:opts %opts-w-format
1695                           #:to 'assembly)))))
1696
1697      (pass-if "~^, too few args"
1698        (let ((w (call-with-warnings
1699                  (lambda ()
1700                    (compile '((@ (ice-9 format) format) #f "~a ~^ ~a")
1701                             #:opts %opts-w-format
1702                             #:to 'assembly)))))
1703          (and (= (length w) 1)
1704               (number? (string-contains (car w)
1705                                         "expected at least 1, got 0")))))
1706
1707      (pass-if "parameters: +,-,#, and '"
1708        (null? (call-with-warnings
1709                (lambda ()
1710                  (compile '((@ (ice-9 format) format) some-port
1711                             "~#~ ~,,-2f ~,,+2f ~'A~" 1234 1234)
1712                           #:opts %opts-w-format
1713                           #:to 'assembly)))))
1714
1715      (pass-if "complex 1"
1716        (let ((w (call-with-warnings
1717                  (lambda ()
1718                    (compile '((@ (ice-9 format) format) #f
1719                                      "~4@S    ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n"
1720                                      1 2 3 4 5 6)
1721                             #:opts %opts-w-format
1722                             #:to 'assembly)))))
1723          (and (= (length w) 1)
1724               (number? (string-contains (car w)
1725                                         "expected 4, got 6")))))
1726
1727      (pass-if "complex 2"
1728        (let ((w (call-with-warnings
1729                  (lambda ()
1730                    (compile '((@ (ice-9 format) format) #f
1731                                      "~:(~A~) Commands~:[~; [abbrev]~]:~2%"
1732                                      1 2 3 4)
1733                             #:opts %opts-w-format
1734                             #:to 'assembly)))))
1735          (and (= (length w) 1)
1736               (number? (string-contains (car w)
1737                                         "expected 2, got 4")))))
1738
1739      (pass-if "complex 3"
1740        (let ((w (call-with-warnings
1741                  (lambda ()
1742                    (compile '((@ (ice-9 format) format) #f "~9@a~:[~*~3_~;~3d~] ~v:@y~%")
1743                             #:opts %opts-w-format
1744                             #:to 'assembly)))))
1745          (and (= (length w) 1)
1746               (number? (string-contains (car w)
1747                                         "expected 5, got 0")))))
1748
1749      (pass-if "ice-9 format"
1750        (let ((w (call-with-warnings
1751                  (lambda ()
1752                    (let ((in (open-input-string
1753                               "(use-modules ((ice-9 format)
1754                                  #:renamer (symbol-prefix-proc 'i9-)))
1755                                (i9-format #t \"yo! ~A\" 1 2)")))
1756                      (read-and-compile in
1757                                        #:opts %opts-w-format
1758                                        #:to 'assembly))))))
1759          (and (= (length w) 1)
1760               (number? (string-contains (car w)
1761                                         "expected 1, got 2")))))
1762
1763      (pass-if "not format"
1764        (null? (call-with-warnings
1765                (lambda ()
1766                  (compile '(let ((format chbouib))
1767                              (format #t "not ~A a format string"))
1768                           #:opts %opts-w-format
1769                           #:to 'assembly)))))
1770
1771      (with-test-prefix "simple-format"
1772
1773        (pass-if "good"
1774          (null? (call-with-warnings
1775                  (lambda ()
1776                    (compile '(simple-format #t "foo ~a bar ~s ~%~~" 1 2)
1777                             #:opts %opts-w-format
1778                             #:to 'assembly)))))
1779
1780        (pass-if "wrong number of args"
1781          (let ((w (call-with-warnings
1782                    (lambda ()
1783                      (compile '(simple-format #t "foo ~a ~s~%" 'one-missing)
1784                               #:opts %opts-w-format
1785                               #:to 'assembly)))))
1786            (and (= (length w) 1)
1787                 (number? (string-contains (car w) "wrong number")))))
1788
1789        (pass-if "unsupported"
1790          (let ((w (call-with-warnings
1791                    (lambda ()
1792                      (compile '(simple-format #t "foo ~x~%" 16)
1793                               #:opts %opts-w-format
1794                               #:to 'assembly)))))
1795            (and (= (length w) 1)
1796                 (number? (string-contains (car w) "unsupported format option")))))
1797
1798        (pass-if "unsupported, gettext"
1799          (let ((w (call-with-warnings
1800                    (lambda ()
1801                      (compile '(simple-format #t (gettext "foo ~2f~%") 3.14)
1802                               #:opts %opts-w-format
1803                               #:to 'assembly)))))
1804            (and (= (length w) 1)
1805                 (number? (string-contains (car w) "unsupported format option")))))
1806
1807        (pass-if "unsupported, ngettext"
1808          (let ((w (call-with-warnings
1809                    (lambda ()
1810                      (compile '(simple-format #t (ngettext "s ~x" "p ~x" x) x)
1811                               #:opts %opts-w-format
1812                               #:to 'assembly)))))
1813            (and (= (length w) 1)
1814                 (number? (string-contains (car w) "unsupported format option")))))))
1815
1816    (with-test-prefix "duplicate-case-datum"
1817
1818      (pass-if "quiet"
1819        (null? (call-with-warnings
1820                 (lambda ()
1821                   (compile '(case x ((1) 'one) ((2) 'two))
1822                            #:opts %opts-w-duplicate-case-datum
1823                            #:to 'assembly)))))
1824
1825      (pass-if "one duplicate"
1826        (let ((w (call-with-warnings
1827                   (lambda ()
1828                     (compile '(case x
1829                                 ((1) 'one)
1830                                 ((2) 'two)
1831                                 ((1) 'one-again))
1832                              #:opts %opts-w-duplicate-case-datum
1833                              #:to 'assembly)))))
1834          (and (= (length w) 1)
1835               (number? (string-contains (car w) "duplicate")))))
1836
1837      (pass-if "one duplicate"
1838        (let ((w (call-with-warnings
1839                   (lambda ()
1840                     (compile '(case x
1841                                 ((1 2 3) 'a)
1842                                 ((1)     'one))
1843                              #:opts %opts-w-duplicate-case-datum
1844                              #:to 'assembly)))))
1845          (and (= (length w) 1)
1846               (number? (string-contains (car w) "duplicate"))))))
1847
1848    (with-test-prefix "bad-case-datum"
1849
1850      (pass-if "quiet"
1851        (null? (call-with-warnings
1852                 (lambda ()
1853                   (compile '(case x ((1) 'one) ((2) 'two))
1854                            #:opts %opts-w-bad-case-datum
1855                            #:to 'assembly)))))
1856
1857      (pass-if "not eqv?"
1858        (let ((w (call-with-warnings
1859                   (lambda ()
1860                     (compile '(case x
1861                                 ((1)     'one)
1862                                 (("bad") 'bad))
1863                              #:opts %opts-w-bad-case-datum
1864                              #:to 'assembly)))))
1865          (and (= (length w) 1)
1866               (number? (string-contains (car w)
1867                                         "cannot be meaningfully compared")))))
1868
1869      (pass-if "one clause element not eqv?"
1870        (let ((w (call-with-warnings
1871                   (lambda ()
1872                     (compile '(case x
1873                                 ((1 (2) 3) 'a))
1874                              #:opts %opts-w-duplicate-case-datum
1875                              #:to 'assembly)))))
1876          (and (= (length w) 1)
1877               (number? (string-contains (car w)
1878                                         "cannot be meaningfully compared")))))))
1879
1880 ;; Local Variables:
1881 ;; eval: (put 'pass-if-primitives-resolved 'scheme-indent-function 1)
1882 ;; eval: (put 'pass-if-tree-il->scheme 'scheme-indent-function 1)
1883 ;; End: