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 pass-if-tree-il->scheme
  62   (syntax-rules ()
  63     ((_ in pat)
  64      (assert-scheme->tree-il->scheme in pat #t))
  65     ((_ in pat guard-exp)
  66      (pass-if 'in
  67        (pmatch (tree-il->scheme
  68                 (compile 'in #:from 'scheme #:to 'tree-il))
  69          (pat (guard guard-exp) #t)
  70          (_ #f))))))
  71
  72 (define peval
  73   ;; The partial evaluator.
  74   (@@ (language tree-il optimize) peval))
  75
  76 (define-syntax pass-if-peval
  77   (syntax-rules (resolve-primitives)
  78     ((_ in pat)
  79      (pass-if-peval in pat
  80                     (compile 'in #:from 'scheme #:to 'tree-il)))
  81     ((_ resolve-primitives in pat)
  82      (pass-if-peval in pat
  83                     (expand-primitives!
  84                      (resolve-primitives!
  85                       (compile 'in #:from 'scheme #:to 'tree-il)
  86                       (current-module)))))
  87     ((_ in pat code)
  88      (pass-if 'in
  89        (let ((evaled (unparse-tree-il (peval code))))
  90          (pmatch evaled
  91            (pat #t)
  92            (_   (pk 'peval-mismatch)
  93                 ((@ (ice-9 pretty-print) pretty-print)
  94                     'in)
  95                 (newline)
  96                 ((@ (ice-9 pretty-print) pretty-print)
  97                     evaled)
  98                 (newline)
  99                 ((@ (ice-9 pretty-print) pretty-print)
 100                     'pat)
 101                 (newline)
 102                 #f)))))))
 103
 104 \f
 105 (with-test-prefix "tree-il->scheme"
 106   (pass-if-tree-il->scheme
 107    (case-lambda ((a) a) ((b c) (list b c)))
 108    (case-lambda ((,a) ,a1) ((,b ,c) (list ,b1 ,c1)))
 109    (and (eq? a a1) (eq? b b1) (eq? c c1))))
 110
 111 (with-test-prefix "void"
 112   (assert-tree-il->glil
 113    (void)
 114    (program () (std-prelude 0 0 #f) (label _) (void) (call return 1)))
 115   (assert-tree-il->glil
 116    (begin (void) (const 1))
 117    (program () (std-prelude 0 0 #f) (label _) (const 1) (call return 1)))
 118   (assert-tree-il->glil
 119    (apply (primitive +) (void) (const 1))
 120    (program () (std-prelude 0 0 #f) (label _) (void) (call add1 1) (call return 1))))
 121
 122 (with-test-prefix "application"
 123   (assert-tree-il->glil
 124    (apply (toplevel foo) (const 1))
 125    (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (const 1) (call tail-call 1)))
 126   (assert-tree-il->glil
 127    (begin (apply (toplevel foo) (const 1)) (void))
 128    (program () (std-prelude 0 0 #f) (label _) (call new-frame 0) (toplevel ref foo) (const 1) (mv-call 1 ,l1)
 129             (call drop 1) (branch br ,l2)
 130             (label ,l3) (mv-bind 0 #f)
 131             (label ,l4)
 132             (void) (call return 1))
 133    (and (eq? l1 l3) (eq? l2 l4)))
 134   (assert-tree-il->glil
 135    (apply (toplevel foo) (apply (toplevel bar)))
 136    (program ()  (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call new-frame 0) (toplevel ref bar) (call call 0)
 137             (call tail-call 1))))
 138
 139 (with-test-prefix "conditional"
 140   (assert-tree-il->glil
 141    (if (toplevel foo) (const 1) (const 2))
 142    (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1)
 143             (const 1) (call return 1)
 144             (label ,l2) (const 2) (call return 1))
 145    (eq? l1 l2))
 146
 147   (assert-tree-il->glil without-partial-evaluation
 148    (begin (if (toplevel foo) (const 1) (const 2)) (const #f))
 149    (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1) (branch br ,l2)
 150             (label ,l3) (label ,l4) (const #f) (call return 1))
 151    (eq? l1 l3) (eq? l2 l4))
 152
 153   (assert-tree-il->glil
 154    (apply (primitive null?) (if (toplevel foo) (const 1) (const 2)))
 155    (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1)
 156             (const 1) (branch br ,l2)
 157                     (label ,l3) (const 2) (label ,l4)
 158                     (call null? 1) (call return 1))
 159    (eq? l1 l3) (eq? l2 l4)))
 160
 161 (with-test-prefix "primitive-ref"
 162   (assert-tree-il->glil
 163    (primitive +)
 164    (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call return 1)))
 165
 166   (assert-tree-il->glil
 167    (begin (primitive +) (const #f))
 168    (program () (std-prelude 0 0 #f) (label _) (const #f) (call return 1)))
 169
 170   (assert-tree-il->glil
 171    (apply (primitive null?) (primitive +))
 172    (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call null? 1)
 173             (call return 1))))
 174
 175 (with-test-prefix "lexical refs"
 176   (assert-tree-il->glil without-partial-evaluation
 177    (let (x) (y) ((const 1)) (lexical x y))
 178    (program () (std-prelude 0 1 #f) (label _)
 179             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
 180             (lexical #t #f ref 0) (call return 1)
 181             (unbind)))
 182
 183   (assert-tree-il->glil without-partial-evaluation
 184    (let (x) (y) ((const 1)) (begin (lexical x y) (const #f)))
 185    (program () (std-prelude 0 1 #f) (label _)
 186             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
 187             (const #f) (call return 1)
 188             (unbind)))
 189
 190   (assert-tree-il->glil without-partial-evaluation
 191    (let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y)))
 192    (program () (std-prelude 0 1 #f) (label _)
 193             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
 194             (lexical #t #f ref 0) (call null? 1) (call return 1)
 195             (unbind))))
 196
 197 (with-test-prefix "lexical sets"
 198   (assert-tree-il->glil
 199    ;; unreferenced sets may be optimized away -- make sure they are ref'd
 200    (let (x) (y) ((const 1))
 201         (set! (lexical x y) (apply (primitive 1+) (lexical x y))))
 202    (program () (std-prelude 0 1 #f) (label _)
 203             (const 1) (bind (x #t 0)) (lexical #t #t box 0)
 204             (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
 205             (void) (call return 1)
 206             (unbind)))
 207
 208   (assert-tree-il->glil
 209    (let (x) (y) ((const 1))
 210         (begin (set! (lexical x y) (apply (primitive 1+) (lexical x y)))
 211                (lexical x y)))
 212    (program () (std-prelude 0 1 #f) (label _)
 213             (const 1) (bind (x #t 0)) (lexical #t #t box 0)
 214             (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
 215             (lexical #t #t ref 0) (call return 1)
 216             (unbind)))
 217
 218   (assert-tree-il->glil
 219    (let (x) (y) ((const 1))
 220      (apply (primitive null?)
 221             (set! (lexical x y) (apply (primitive 1+) (lexical x y)))))
 222    (program () (std-prelude 0 1 #f) (label _)
 223             (const 1) (bind (x #t 0)) (lexical #t #t box 0)
 224             (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (void)
 225             (call null? 1) (call return 1)
 226             (unbind))))
 227
 228 (with-test-prefix "module refs"
 229   (assert-tree-il->glil
 230    (@ (foo) bar)
 231    (program () (std-prelude 0 0 #f) (label _)
 232             (module public ref (foo) bar)
 233             (call return 1)))
 234
 235   (assert-tree-il->glil
 236    (begin (@ (foo) bar) (const #f))
 237    (program () (std-prelude 0 0 #f) (label _)
 238             (module public ref (foo) bar) (call drop 1)
 239             (const #f) (call return 1)))
 240
 241   (assert-tree-il->glil
 242    (apply (primitive null?) (@ (foo) bar))
 243    (program () (std-prelude 0 0 #f) (label _)
 244             (module public ref (foo) bar)
 245             (call null? 1) (call return 1)))
 246
 247   (assert-tree-il->glil
 248    (@@ (foo) bar)
 249    (program () (std-prelude 0 0 #f) (label _)
 250             (module private ref (foo) bar)
 251             (call return 1)))
 252
 253   (assert-tree-il->glil
 254    (begin (@@ (foo) bar) (const #f))
 255    (program () (std-prelude 0 0 #f) (label _)
 256             (module private ref (foo) bar) (call drop 1)
 257             (const #f) (call return 1)))
 258
 259   (assert-tree-il->glil
 260    (apply (primitive null?) (@@ (foo) bar))
 261    (program () (std-prelude 0 0 #f) (label _)
 262             (module private ref (foo) bar)
 263             (call null? 1) (call return 1))))
 264
 265 (with-test-prefix "module sets"
 266   (assert-tree-il->glil
 267    (set! (@ (foo) bar) (const 2))
 268    (program () (std-prelude 0 0 #f) (label _)
 269             (const 2) (module public set (foo) bar)
 270             (void) (call return 1)))
 271
 272   (assert-tree-il->glil
 273    (begin (set! (@ (foo) bar) (const 2)) (const #f))
 274    (program () (std-prelude 0 0 #f) (label _)
 275             (const 2) (module public set (foo) bar)
 276             (const #f) (call return 1)))
 277
 278   (assert-tree-il->glil
 279    (apply (primitive null?) (set! (@ (foo) bar) (const 2)))
 280    (program () (std-prelude 0 0 #f) (label _)
 281             (const 2) (module public set (foo) bar)
 282             (void) (call null? 1) (call return 1)))
 283
 284   (assert-tree-il->glil
 285    (set! (@@ (foo) bar) (const 2))
 286    (program () (std-prelude 0 0 #f) (label _)
 287             (const 2) (module private set (foo) bar)
 288             (void) (call return 1)))
 289
 290   (assert-tree-il->glil
 291    (begin (set! (@@ (foo) bar) (const 2)) (const #f))
 292    (program () (std-prelude 0 0 #f) (label _)
 293             (const 2) (module private set (foo) bar)
 294             (const #f) (call return 1)))
 295
 296   (assert-tree-il->glil
 297    (apply (primitive null?) (set! (@@ (foo) bar) (const 2)))
 298    (program () (std-prelude 0 0 #f) (label _)
 299             (const 2) (module private set (foo) bar)
 300             (void) (call null? 1) (call return 1))))
 301
 302 (with-test-prefix "toplevel refs"
 303   (assert-tree-il->glil
 304    (toplevel bar)
 305    (program () (std-prelude 0 0 #f) (label _)
 306             (toplevel ref bar)
 307             (call return 1)))
 308
 309   (assert-tree-il->glil without-partial-evaluation
 310    (begin (toplevel bar) (const #f))
 311    (program () (std-prelude 0 0 #f) (label _)
 312             (toplevel ref bar) (call drop 1)
 313             (const #f) (call return 1)))
 314
 315   (assert-tree-il->glil
 316    (apply (primitive null?) (toplevel bar))
 317    (program () (std-prelude 0 0 #f) (label _)
 318             (toplevel ref bar)
 319             (call null? 1) (call return 1))))
 320
 321 (with-test-prefix "toplevel sets"
 322   (assert-tree-il->glil
 323    (set! (toplevel bar) (const 2))
 324    (program () (std-prelude 0 0 #f) (label _)
 325             (const 2) (toplevel set bar)
 326             (void) (call return 1)))
 327
 328   (assert-tree-il->glil
 329    (begin (set! (toplevel bar) (const 2)) (const #f))
 330    (program () (std-prelude 0 0 #f) (label _)
 331             (const 2) (toplevel set bar)
 332             (const #f) (call return 1)))
 333
 334   (assert-tree-il->glil
 335    (apply (primitive null?) (set! (toplevel bar) (const 2)))
 336    (program () (std-prelude 0 0 #f) (label _)
 337             (const 2) (toplevel set bar)
 338             (void) (call null? 1) (call return 1))))
 339
 340 (with-test-prefix "toplevel defines"
 341   (assert-tree-il->glil
 342    (define bar (const 2))
 343    (program () (std-prelude 0 0 #f) (label _)
 344             (const 2) (toplevel define bar)
 345             (void) (call return 1)))
 346
 347   (assert-tree-il->glil
 348    (begin (define bar (const 2)) (const #f))
 349    (program () (std-prelude 0 0 #f) (label _)
 350             (const 2) (toplevel define bar)
 351             (const #f) (call return 1)))
 352
 353   (assert-tree-il->glil
 354    (apply (primitive null?) (define bar (const 2)))
 355    (program () (std-prelude 0 0 #f) (label _)
 356             (const 2) (toplevel define bar)
 357             (void) (call null? 1) (call return 1))))
 358
 359 (with-test-prefix "constants"
 360   (assert-tree-il->glil
 361    (const 2)
 362    (program () (std-prelude 0 0 #f) (label _)
 363             (const 2) (call return 1)))
 364
 365   (assert-tree-il->glil
 366    (begin (const 2) (const #f))
 367    (program () (std-prelude 0 0 #f) (label _)
 368             (const #f) (call return 1)))
 369
 370   (assert-tree-il->glil
 371    ;; This gets simplified by `peval'.
 372    (apply (primitive null?) (const 2))
 373    (program () (std-prelude 0 0 #f) (label _)
 374             (const #f) (call return 1))))
 375
 376 (with-test-prefix "letrec"
 377   ;; simple bindings -> let
 378   (assert-tree-il->glil without-partial-evaluation
 379    (letrec (x y) (x1 y1) ((const 10) (const 20))
 380            (apply (toplevel foo) (lexical x x1) (lexical y y1)))
 381    (program () (std-prelude 0 2 #f) (label _)
 382             (const 10) (const 20)
 383             (bind (x #f 0) (y #f 1))
 384             (lexical #t #f set 1) (lexical #t #f set 0)
 385             (toplevel ref foo)
 386             (lexical #t #f ref 0) (lexical #t #f ref 1)
 387             (call tail-call 2)
 388             (unbind)))
 389
 390   ;; complex bindings -> box and set! within let
 391   (assert-tree-il->glil without-partial-evaluation
 392    (letrec (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar)))
 393            (apply (primitive +) (lexical x x1) (lexical y y1)))
 394    (program () (std-prelude 0 4 #f) (label _)
 395             (void) (void) ;; what are these?
 396             (bind (x #t 0) (y #t 1))
 397             (lexical #t #t box 1) (lexical #t #t box 0)
 398             (call new-frame 0) (toplevel ref foo) (call call 0)
 399             (call new-frame 0) (toplevel ref bar) (call call 0)
 400             (bind (x #f 2) (y #f 3)) (lexical #t #f set 3) (lexical #t #f set 2)
 401             (lexical #t #f ref 2) (lexical #t #t set 0)
 402             (lexical #t #f ref 3) (lexical #t #t set 1)
 403             (void) (lexical #t #f set 2) (void) (lexical #t #f set 3) ;; clear bindings
 404             (unbind)
 405             (lexical #t #t ref 0) (lexical #t #t ref 1)
 406             (call add 2) (call return 1) (unbind)))
 407
 408   ;; complex bindings in letrec* -> box and set! in order
 409   (assert-tree-il->glil without-partial-evaluation
 410    (letrec* (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar)))
 411             (apply (primitive +) (lexical x x1) (lexical y y1)))
 412    (program () (std-prelude 0 2 #f) (label _)
 413             (void) (void) ;; what are these?
 414             (bind (x #t 0) (y #t 1))
 415             (lexical #t #t box 1) (lexical #t #t box 0)
 416             (call new-frame 0) (toplevel ref foo) (call call 0)
 417             (lexical #t #t set 0)
 418             (call new-frame 0) (toplevel ref bar) (call call 0)
 419             (lexical #t #t set 1)
 420             (lexical #t #t ref 0)
 421             (lexical #t #t ref 1)
 422             (call add 2) (call return 1) (unbind)))
 423
 424   ;; simple bindings in letrec* -> equivalent to letrec
 425   (assert-tree-il->glil without-partial-evaluation
 426    (letrec* (x y) (xx yy) ((const 1) (const 2))
 427             (lexical y yy))
 428    (program () (std-prelude 0 1 #f) (label _)
 429             (const 2)
 430             (bind (y #f 0)) ;; X is removed, and Y is unboxed
 431             (lexical #t #f set 0)
 432             (lexical #t #f ref 0)
 433             (call return 1) (unbind))))
 434
 435 (with-test-prefix "lambda"
 436   (assert-tree-il->glil
 437    (lambda ()
 438      (lambda-case (((x) #f #f #f () (y)) (const 2)) #f))
 439    (program ()  (std-prelude 0 0 #f) (label _)
 440             (program () (std-prelude 1 1 #f)
 441                      (bind (x #f 0)) (label _)
 442                      (const 2) (call return 1) (unbind))
 443             (call return 1)))
 444
 445   (assert-tree-il->glil
 446    (lambda ()
 447      (lambda-case (((x y) #f #f #f () (x1 y1))
 448                    (const 2))
 449                   #f))
 450    (program () (std-prelude 0 0 #f) (label _)
 451             (program () (std-prelude 2 2 #f)
 452                      (bind (x #f 0) (y #f 1)) (label _)
 453                      (const 2) (call return 1)
 454                      (unbind))
 455             (call return 1)))
 456
 457   (assert-tree-il->glil
 458    (lambda ()
 459      (lambda-case ((() #f x #f () (y)) (const 2))
 460                   #f))
 461    (program () (std-prelude 0 0 #f) (label _)
 462             (program () (opt-prelude 0 0 0 1 #f)
 463                      (bind (x #f 0)) (label _)
 464                      (const 2) (call return 1)
 465                      (unbind))
 466             (call return 1)))
 467
 468   (assert-tree-il->glil
 469    (lambda ()
 470      (lambda-case (((x) #f x1 #f () (y y1)) (const 2))
 471                   #f))
 472    (program () (std-prelude 0 0 #f) (label _)
 473             (program () (opt-prelude 1 0 1 2 #f)
 474                      (bind (x #f 0) (x1 #f 1)) (label _)
 475                      (const 2) (call return 1)
 476                      (unbind))
 477             (call return 1)))
 478
 479   (assert-tree-il->glil
 480    (lambda ()
 481      (lambda-case (((x) #f x1 #f () (y y1)) (lexical x y))
 482                   #f))
 483    (program () (std-prelude 0 0 #f) (label _)
 484             (program () (opt-prelude 1 0 1 2 #f)
 485                      (bind (x #f 0) (x1 #f 1)) (label _)
 486                      (lexical #t #f ref 0) (call return 1)
 487                      (unbind))
 488             (call return 1)))
 489
 490   (assert-tree-il->glil
 491    (lambda ()
 492      (lambda-case (((x) #f x1 #f () (y y1)) (lexical x1 y1))
 493                   #f))
 494    (program () (std-prelude 0 0 #f) (label _)
 495             (program () (opt-prelude 1 0 1 2 #f)
 496                      (bind (x #f 0) (x1 #f 1)) (label _)
 497                      (lexical #t #f ref 1) (call return 1)
 498                      (unbind))
 499             (call return 1)))
 500
 501   (assert-tree-il->glil
 502    (lambda ()
 503      (lambda-case (((x) #f #f #f () (x1))
 504                    (lambda ()
 505                      (lambda-case (((y) #f #f #f () (y1))
 506                                    (lexical x x1))
 507                                   #f)))
 508                   #f))
 509    (program () (std-prelude 0 0 #f) (label _)
 510             (program () (std-prelude 1 1 #f)
 511                      (bind (x #f 0)) (label _)
 512                      (program () (std-prelude 1 1 #f)
 513                               (bind (y #f 0)) (label _)
 514                               (lexical #f #f ref 0) (call return 1)
 515                               (unbind))
 516                      (lexical #t #f ref 0)
 517                      (call make-closure 1)
 518                      (call return 1)
 519                      (unbind))
 520             (call return 1))))
 521
 522 (with-test-prefix "sequence"
 523   (assert-tree-il->glil
 524    (begin (begin (const 2) (const #f)) (const #t))
 525    (program () (std-prelude 0 0 #f) (label _)
 526             (const #t) (call return 1)))
 527
 528   (assert-tree-il->glil
 529    ;; This gets simplified by `peval'.
 530    (apply (primitive null?) (begin (const #f) (const 2)))
 531    (program () (std-prelude 0 0 #f) (label _)
 532             (const #f) (call return 1))))
 533
 534 (with-test-prefix "values"
 535   (assert-tree-il->glil
 536    (apply (primitive values)
 537           (apply (primitive values) (const 1) (const 2)))
 538    (program () (std-prelude 0 0 #f) (label _)
 539             (const 1) (call return 1)))
 540
 541   (assert-tree-il->glil
 542    (apply (primitive values)
 543           (apply (primitive values) (const 1) (const 2))
 544           (const 3))
 545    (program () (std-prelude 0 0 #f) (label _)
 546             (const 1) (const 3) (call return/values 2)))
 547
 548   (assert-tree-il->glil
 549    (apply (primitive +)
 550           (apply (primitive values) (const 1) (const 2)))
 551    (program () (std-prelude 0 0 #f) (label _)
 552             (const 1) (call return 1)))
 553
 554   ;; Testing `(values foo)' in push context with RA.
 555   (assert-tree-il->glil without-partial-evaluation
 556    (apply (primitive cdr)
 557           (letrec (lp) (#{lp ~V9KrhVD4PFEL6oCTrLg3A}#)
 558                   ((lambda ((name . lp))
 559                      (lambda-case ((() #f #f #f () ())
 560                                    (apply (toplevel values) (const (one two)))))))
 561                   (apply (lexical lp #{lp ~V9KrhVD4PFEL6oCTrLg3A}#))))
 562    (program () (std-prelude 0 0 #f) (label _)
 563             (branch br _) ;; entering the fix, jump to :2
 564             ;; :1 body of lp, jump to :3
 565             (label _) (bind) (const (one two)) (branch br _) (unbind)
 566             ;; :2 initial call of lp, jump to :1
 567             (label _) (bind) (branch br _) (label _) (unbind)
 568             ;; :3 the push continuation
 569             (call cdr 1) (call return 1))))
 570
 571 ;; FIXME: binding info for or-hacked locals might bork the disassembler,
 572 ;; and could be tightened in any case
 573 (with-test-prefix "the or hack"
 574   (assert-tree-il->glil without-partial-evaluation
 575    (let (x) (y) ((const 1))
 576         (if (lexical x y)
 577             (lexical x y)
 578             (let (a) (b) ((const 2))
 579                  (lexical a b))))
 580    (program () (std-prelude 0 1 #f) (label _)
 581             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
 582             (lexical #t #f ref 0) (branch br-if-not ,l1)
 583             (lexical #t #f ref 0) (call return 1)
 584             (label ,l2)
 585             (const 2) (bind (a #f 0)) (lexical #t #f set 0)
 586             (lexical #t #f ref 0) (call return 1)
 587             (unbind)
 588             (unbind))
 589    (eq? l1 l2))
 590
 591   ;; second bound var is unreferenced
 592   (assert-tree-il->glil without-partial-evaluation
 593    (let (x) (y) ((const 1))
 594         (if (lexical x y)
 595             (lexical x y)
 596             (let (a) (b) ((const 2))
 597                  (lexical x y))))
 598    (program () (std-prelude 0 1 #f) (label _)
 599             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
 600             (lexical #t #f ref 0) (branch br-if-not ,l1)
 601             (lexical #t #f ref 0) (call return 1)
 602             (label ,l2)
 603             (lexical #t #f ref 0) (call return 1)
 604             (unbind))
 605    (eq? l1 l2)))
 606
 607 (with-test-prefix "apply"
 608   (assert-tree-il->glil
 609    (apply (primitive @apply) (toplevel foo) (toplevel bar))
 610    (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (toplevel ref bar) (call tail-apply 2)))
 611   (assert-tree-il->glil
 612    (begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void))
 613    (program () (std-prelude 0 0 #f) (label _)
 614             (call new-frame 0) (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1)
 615             (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
 616             (label ,l4)
 617             (void) (call return 1))
 618    (and (eq? l1 l3) (eq? l2 l4)))
 619   (assert-tree-il->glil
 620    (apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz)))
 621    (program () (std-prelude 0 0 #f) (label _)
 622             (toplevel ref foo)
 623             (call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call apply 2)
 624             (call tail-call 1))))
 625
 626 (with-test-prefix "call/cc"
 627   (assert-tree-il->glil
 628    (apply (primitive @call-with-current-continuation) (toplevel foo))
 629    (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call tail-call/cc 1)))
 630   (assert-tree-il->glil
 631    (begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void))
 632    (program () (std-prelude 0 0 #f) (label _)
 633             (call new-frame 0) (toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1)
 634             (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
 635             (label ,l4)
 636             (void) (call return 1))
 637    (and (eq? l1 l3) (eq? l2 l4)))
 638   (assert-tree-il->glil
 639    (apply (toplevel foo)
 640           (apply (toplevel @call-with-current-continuation) (toplevel bar)))
 641    (program () (std-prelude 0 0 #f) (label _)
 642             (toplevel ref foo)
 643             (toplevel ref bar) (call call/cc 1)
 644             (call tail-call 1))))
 645
 646 \f
 647 (with-test-prefix "labels allocation"
 648   (pass-if "http://debbugs.gnu.org/9769"
 649     ((compile '(lambda ()
 650                  (let ((fail (lambda () #f)))
 651                    (let ((test (lambda () (fail))))
 652                      (test))
 653                    #t))
 654               ;; Prevent inlining.  We're testing analyze.scm's
 655               ;; labels allocator here, and inlining it will
 656               ;; reduce the entire thing to #t.
 657               #:opts '(#:partial-eval? #f)))))
 658
 659 \f
 660 (with-test-prefix "partial evaluation"
 661
 662   (pass-if-peval
 663     ;; First order, primitive.
 664     (let ((x 1) (y 2)) (+ x y))
 665     (const 3))
 666
 667   (pass-if-peval
 668     ;; First order, thunk.
 669     (let ((x 1) (y 2))
 670       (let ((f (lambda () (+ x y))))
 671         (f)))
 672     (const 3))
 673
 674   (pass-if-peval resolve-primitives
 675     ;; First order, let-values (requires primitive expansion for
 676     ;; `call-with-values'.)
 677     (let ((x 0))
 678       (call-with-values
 679           (lambda () (if (zero? x) (values 1 2) (values 3 4)))
 680         (lambda (a b)
 681           (+ a b))))
 682     (const 3))
 683
 684   (pass-if-peval resolve-primitives
 685     ;; First order, multiple values.
 686     (let ((x 1) (y 2))
 687       (values x y))
 688     (apply (primitive values) (const 1) (const 2)))
 689
 690   (pass-if-peval resolve-primitives
 691     ;; First order, multiple values truncated.
 692     (let ((x (values 1 'a)) (y 2))
 693       (values x y))
 694     (apply (primitive values) (const 1) (const 2)))
 695
 696   (pass-if-peval resolve-primitives
 697     ;; First order, multiple values truncated.
 698     (or (values 1 2) 3)
 699     (const 1))
 700
 701   (pass-if-peval
 702     ;; First order, coalesced, mutability preserved.
 703     (cons 0 (cons 1 (cons 2 (list 3 4 5))))
 704     (apply (primitive list)
 705            (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
 706
 707   (pass-if-peval
 708    ;; First order, coalesced, mutability preserved.
 709    (cons 0 (cons 1 (cons 2 (list 3 4 5))))
 710    ;; This must not be a constant.
 711    (apply (primitive list)
 712           (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
 713
 714   (pass-if-peval
 715     ;; First order, coalesced, immutability preserved.
 716     (cons 0 (cons 1 (cons 2 '(3 4 5))))
 717     (apply (primitive cons) (const 0)
 718            (apply (primitive cons) (const 1)
 719                   (apply (primitive cons) (const 2)
 720                          (const (3 4 5))))))
 721
 722   ;; These two tests doesn't work any more because we changed the way we
 723   ;; deal with constants -- now the algorithm will see a construction as
 724   ;; being bound to the lexical, so it won't propagate it.  It can't
 725   ;; even propagate it in the case that it is only referenced once,
 726   ;; because:
 727   ;;
 728   ;;   (let ((x (cons 1 2))) (lambda () x))
 729   ;;
 730   ;; is not the same as
 731   ;;
 732   ;;   (lambda () (cons 1 2))
 733   ;;
 734   ;; Perhaps if we determined that not only was it only referenced once,
 735   ;; it was not closed over by a lambda, then we could propagate it, and
 736   ;; re-enable these two tests.
 737   ;;
 738   #;
 739   (pass-if-peval
 740    ;; First order, mutability preserved.
 741    (let loop ((i 3) (r '()))
 742      (if (zero? i)
 743          r
 744          (loop (1- i) (cons (cons i i) r))))
 745    (apply (primitive list)
 746           (apply (primitive cons) (const 1) (const 1))
 747           (apply (primitive cons) (const 2) (const 2))
 748           (apply (primitive cons) (const 3) (const 3))))
 749   ;;
 750   ;; See above.
 751   #;
 752   (pass-if-peval
 753    ;; First order, evaluated.
 754    (let loop ((i 7)
 755               (r '()))
 756      (if (<= i 0)
 757          (car r)
 758          (loop (1- i) (cons i r))))
 759    (const 1))
 760
 761   ;; Instead here are tests for what happens for the above cases: they
 762   ;; unroll but they don't fold.
 763   (pass-if-peval
 764    (let loop ((i 3) (r '()))
 765      (if (zero? i)
 766          r
 767          (loop (1- i) (cons (cons i i) r))))
 768    (let (r) (_)
 769         ((apply (primitive list)
 770                 (apply (primitive cons) (const 3) (const 3))))
 771         (let (r) (_)
 772              ((apply (primitive cons)
 773                      (apply (primitive cons) (const 2) (const 2))
 774                      (lexical r _)))
 775              (apply (primitive cons)
 776                     (apply (primitive cons) (const 1) (const 1))
 777                     (lexical r _)))))
 778
 779   ;; See above.
 780   (pass-if-peval
 781    (let loop ((i 4)
 782               (r '()))
 783      (if (<= i 0)
 784          (car r)
 785          (loop (1- i) (cons i r))))
 786    (let (r) (_)
 787         ((apply (primitive list) (const 4)))
 788         (let (r) (_)
 789              ((apply (primitive cons)
 790                      (const 3)
 791                      (lexical r _)))
 792              (let (r) (_)
 793                   ((apply (primitive cons)
 794                           (const 2)
 795                           (lexical r _)))
 796                   (let (r) (_)
 797                        ((apply (primitive cons)
 798                                (const 1)
 799                                (lexical r _)))
 800                        (apply (primitive car)
 801                               (lexical r _)))))))
 802
 803    ;; Static sums.
 804   (pass-if-peval
 805    (let loop ((l '(1 2 3 4)) (sum 0))
 806      (if (null? l)
 807          sum
 808          (loop (cdr l) (+ sum (car l)))))
 809    (const 10))
 810
 811   (pass-if-peval resolve-primitives
 812    (let ((string->chars
 813           (lambda (s)
 814             (define (char-at n)
 815               (string-ref s n))
 816             (define (len)
 817               (string-length s))
 818             (let loop ((i 0))
 819               (if (< i (len))
 820                   (cons (char-at i)
 821                         (loop (1+ i)))
 822                   '())))))
 823      (string->chars "yo"))
 824    (apply (primitive list) (const #\y) (const #\o)))
 825
 826   (pass-if-peval
 827     ;; Primitives in module-refs are resolved (the expansion of `pmatch'
 828     ;; below leads to calls to (@@ (system base pmatch) car) and
 829     ;; similar, which is what we want to be inlined.)
 830     (begin
 831       (use-modules (system base pmatch))
 832       (pmatch '(a b c d)
 833         ((a b . _)
 834          #t)))
 835     (begin
 836       (apply . _)
 837       (const #t)))
 838
 839   (pass-if-peval
 840    ;; Mutability preserved.
 841    ((lambda (x y z) (list x y z)) 1 2 3)
 842    (apply (primitive list) (const 1) (const 2) (const 3)))
 843
 844   (pass-if-peval
 845    ;; Don't propagate effect-free expressions that operate on mutable
 846    ;; objects.
 847    (let* ((x (list 1))
 848           (y (car x)))
 849      (set-car! x 0)
 850      y)
 851    (let (x) (_) ((apply (primitive list) (const 1)))
 852         (let (y) (_) ((apply (primitive car) (lexical x _)))
 853              (begin
 854                (apply (toplevel set-car!) (lexical x _) (const 0))
 855                (lexical y _)))))
 856
 857   (pass-if-peval
 858    ;; Don't propagate effect-free expressions that operate on objects we
 859    ;; don't know about.
 860    (let ((y (car x)))
 861      (set-car! x 0)
 862      y)
 863    (let (y) (_) ((apply (primitive car) (toplevel x)))
 864         (begin
 865           (apply (toplevel set-car!) (toplevel x) (const 0))
 866           (lexical y _))))
 867
 868   (pass-if-peval
 869    ;; Infinite recursion
 870    ((lambda (x) (x x)) (lambda (x) (x x)))
 871    (let (x) (_)
 872         ((lambda _
 873            (lambda-case
 874             (((x) _ _ _ _ _)
 875              (apply (lexical x _) (lexical x _))))))
 876         (apply (lexical x _) (lexical x _))))
 877
 878   (pass-if-peval
 879     ;; First order, aliased primitive.
 880     (let* ((x *) (y (x 1 2))) y)
 881     (const 2))
 882
 883   (pass-if-peval
 884     ;; First order, shadowed primitive.
 885     (begin
 886       (define (+ x y) (pk x y))
 887       (+ 1 2))
 888     (begin
 889       (define +
 890         (lambda (_)
 891           (lambda-case
 892            (((x y) #f #f #f () (_ _))
 893             (apply (toplevel pk) (lexical x _) (lexical y _))))))
 894       (apply (toplevel +) (const 1) (const 2))))
 895
 896   (pass-if-peval
 897     ;; First-order, effects preserved.
 898     (let ((x 2))
 899       (do-something!)
 900       x)
 901     (begin
 902       (apply (toplevel do-something!))
 903       (const 2)))
 904
 905   (pass-if-peval
 906     ;; First order, residual bindings removed.
 907     (let ((x 2) (y 3))
 908       (* (+ x y) z))
 909     (apply (primitive *) (const 5) (toplevel z)))
 910
 911   (pass-if-peval
 912     ;; First order, with lambda.
 913     (define (foo x)
 914       (define (bar z) (* z z))
 915       (+ x (bar 3)))
 916     (define foo
 917       (lambda (_)
 918         (lambda-case
 919          (((x) #f #f #f () (_))
 920           (apply (primitive +) (lexical x _) (const 9)))))))
 921
 922   (pass-if-peval
 923     ;; First order, with lambda inlined & specialized twice.
 924     (let ((f (lambda (x y)
 925                (+ (* x top) y)))
 926           (x 2)
 927           (y 3))
 928       (+ (* x (f x y))
 929          (f something x)))
 930     (apply (primitive +)
 931            (apply (primitive *)
 932                   (const 2)
 933                   (apply (primitive +)  ; (f 2 3)
 934                          (apply (primitive *)
 935                                 (const 2)
 936                                 (toplevel top))
 937                          (const 3)))
 938            (let (x) (_) ((toplevel something))                    ; (f something 2)
 939                 ;; `something' is not const, so preserve order of
 940                 ;; effects with a lexical binding.
 941                 (apply (primitive +)
 942                        (apply (primitive *)
 943                               (lexical x _)
 944                               (toplevel top))
 945                        (const 2)))))
 946
 947   (pass-if-peval
 948    ;; First order, with lambda inlined & specialized 3 times.
 949    (let ((f (lambda (x y) (if (> x 0) y x))))
 950      (+ (f -1 0)
 951         (f 1 0)
 952         (f -1 y)
 953         (f 2 y)
 954         (f z y)))
 955    (apply (primitive +)
 956           (const -1)                      ; (f -1 0)
 957           (const 0)                       ; (f 1 0)
 958           (begin (toplevel y) (const -1)) ; (f -1 y)
 959           (toplevel y)                    ; (f 2 y)
 960           (let (x y) (_ _) ((toplevel z) (toplevel y)) ; (f z y)
 961                (if (apply (primitive >) (lexical x _) (const 0))
 962                    (lexical y _)
 963                    (lexical x _)))))
 964
 965   (pass-if-peval
 966     ;; First order, conditional.
 967     (let ((y 2))
 968       (lambda (x)
 969         (if (> y 0)
 970             (display x)
 971             'never-reached)))
 972     (lambda ()
 973       (lambda-case
 974        (((x) #f #f #f () (_))
 975         (apply (toplevel display) (lexical x _))))))
 976
 977   (pass-if-peval
 978     ;; First order, recursive procedure.
 979     (letrec ((fibo (lambda (n)
 980                      (if (<= n 1)
 981                          n
 982                          (+ (fibo (- n 1))
 983                             (fibo (- n 2)))))))
 984       (fibo 4))
 985     (const 3))
 986
 987   (pass-if-peval
 988    ;; Don't propagate toplevel references, as intervening expressions
 989    ;; could alter their bindings.
 990    (let ((x top))
 991      (foo)
 992      x)
 993    (let (x) (_) ((toplevel top))
 994         (begin
 995           (apply (toplevel foo))
 996           (lexical x _))))
 997
 998   (pass-if-peval
 999     ;; Higher order.
1000     ((lambda (f x)
1001        (f (* (car x) (cadr x))))
1002      (lambda (x)
1003        (+ x 1))
1004      '(2 3))
1005     (const 7))
1006
1007   (pass-if-peval
1008     ;; Higher order with optional argument (default value).
1009     ((lambda* (f x #:optional (y 0))
1010        (+ y (f (* (car x) (cadr x)))))
1011      (lambda (x)
1012        (+ x 1))
1013      '(2 3))
1014     (const 7))
1015
1016   (pass-if-peval
1017     ;; Higher order with optional argument (caller-supplied value).
1018     ((lambda* (f x #:optional (y 0))
1019        (+ y (f (* (car x) (cadr x)))))
1020      (lambda (x)
1021        (+ x 1))
1022      '(2 3)
1023      35)
1024     (const 42))
1025
1026   (pass-if-peval
1027     ;; Higher order with optional argument (side-effecting default
1028     ;; value).
1029     ((lambda* (f x #:optional (y (foo)))
1030        (+ y (f (* (car x) (cadr x)))))
1031      (lambda (x)
1032        (+ x 1))
1033      '(2 3))
1034     (let (y) (_) ((apply (toplevel foo)))
1035          (apply (primitive +) (lexical y _) (const 7))))
1036
1037   (pass-if-peval
1038     ;; Higher order with optional argument (caller-supplied value).
1039     ((lambda* (f x #:optional (y (foo)))
1040        (+ y (f (* (car x) (cadr x)))))
1041      (lambda (x)
1042        (+ x 1))
1043      '(2 3)
1044      35)
1045     (const 42))
1046
1047   (pass-if-peval
1048     ;; Higher order.
1049     ((lambda (f) (f x)) (lambda (x) x))
1050     (toplevel x))
1051
1052   (pass-if-peval
1053     ;; Bug reported at
1054     ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>.
1055     (let ((fold (lambda (f g) (f (g top)))))
1056       (fold 1+ (lambda (x) x)))
1057     (apply (primitive 1+) (toplevel top)))
1058
1059   (pass-if-peval
1060     ;; Procedure not inlined when residual code contains recursive calls.
1061     ;; <http://debbugs.gnu.org/9542>
1062     (letrec ((fold (lambda (f x3 b null? car cdr)
1063                      (if (null? x3)
1064                          b
1065                          (f (car x3) (fold f (cdr x3) b null? car cdr))))))
1066       (fold * x 1 zero? (lambda (x1) x1) (lambda (x2) (- x2 1))))
1067     (letrec (fold) (_) (_)
1068             (apply (lexical fold _)
1069                    (primitive *)
1070                    (toplevel x)
1071                    (const 1)
1072                    (primitive zero?)
1073                    (lambda ()
1074                      (lambda-case
1075                       (((x1) #f #f #f () (_))
1076                        (lexical x1 _))))
1077                    (lambda ()
1078                      (lambda-case
1079                       (((x2) #f #f #f () (_))
1080                        (apply (primitive -) (lexical x2 _) (const 1))))))))
1081
1082   (pass-if "inlined lambdas are alpha-renamed"
1083     ;; In this example, `make-adder' is inlined more than once; thus,
1084     ;; they should use different gensyms for their arguments, because
1085     ;; the various optimization passes assume uniquely-named variables.
1086     ;;
1087     ;; Bug reported at
1088     ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html> and
1089     ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00029.html>.
1090     (pmatch (unparse-tree-il
1091              (peval (compile
1092                      '(let ((make-adder
1093                              (lambda (x) (lambda (y) (+ x y)))))
1094                         (cons (make-adder 1) (make-adder 2)))
1095                      #:to 'tree-il)))
1096       ((apply (primitive cons)
1097               (lambda ()
1098                 (lambda-case
1099                  (((y) #f #f #f () (,gensym1))
1100                   (apply (primitive +)
1101                          (const 1)
1102                          (lexical y ,ref1)))))
1103               (lambda ()
1104                 (lambda-case
1105                  (((y) #f #f #f () (,gensym2))
1106                   (apply (primitive +)
1107                          (const 2)
1108                          (lexical y ,ref2))))))
1109        (and (eq? gensym1 ref1)
1110             (eq? gensym2 ref2)
1111             (not (eq? gensym1 gensym2))))
1112       (_ #f)))
1113
1114   (pass-if-peval
1115    ;; Unused letrec bindings are pruned.
1116    (letrec ((a (lambda () (b)))
1117             (b (lambda () (a)))
1118             (c (lambda (x) x)))
1119      (c 10))
1120    (const 10))
1121
1122   (pass-if-peval
1123    ;; Unused letrec bindings are pruned.
1124    (letrec ((a (foo!))
1125             (b (lambda () (a)))
1126             (c (lambda (x) x)))
1127      (c 10))
1128    (begin (apply (toplevel foo!))
1129           (const 10)))
1130
1131   (pass-if-peval
1132     ;; Higher order, mutually recursive procedures.
1133     (letrec ((even? (lambda (x)
1134                       (or (= 0 x)
1135                           (odd? (- x 1)))))
1136              (odd?  (lambda (x)
1137                       (not (even? x)))))
1138       (and (even? 4) (odd? 7)))
1139     (const #t))
1140
1141   (pass-if-peval
1142     ;; Memv with constants.
1143     (memv 1 '(3 2 1))
1144     (const '(1)))
1145
1146   (pass-if-peval
1147     ;; Memv with non-constant list.  It could fold but doesn't
1148     ;; currently.
1149     (memv 1 (list 3 2 1))
1150     (apply (primitive memv)
1151            (const 1)
1152            (apply (primitive list) (const 3) (const 2) (const 1))))
1153
1154   (pass-if-peval
1155     ;; Memv with non-constant key, constant list, test context
1156     (case foo
1157       ((3 2 1) 'a)
1158       (else 'b))
1159     (if (let (t) (_) ((toplevel foo))
1160              (if (apply (primitive eqv?) (lexical t _) (const 3))
1161                  (const #t)
1162                  (if (apply (primitive eqv?) (lexical t _) (const 2))
1163                      (const #t)
1164                      (apply (primitive eqv?) (lexical t _) (const 1)))))
1165         (const a)
1166         (const b)))
1167
1168   (pass-if-peval
1169     ;; Memv with non-constant key, empty list, test context.  Currently
1170     ;; doesn't fold entirely.
1171     (case foo
1172       (() 'a)
1173       (else 'b))
1174     (if (begin (toplevel foo) (const #f))
1175         (const a)
1176         (const b)))
1177
1178   ;;
1179   ;; Below are cases where constant propagation should bail out.
1180   ;;
1181
1182   (pass-if-peval
1183     ;; Non-constant lexical is not propagated.
1184     (let ((v (make-vector 6 #f)))
1185       (lambda (n)
1186         (vector-set! v n n)))
1187     (let (v) (_)
1188          ((apply (toplevel make-vector) (const 6) (const #f)))
1189          (lambda ()
1190            (lambda-case
1191             (((n) #f #f #f () (_))
1192              (apply (toplevel vector-set!)
1193                     (lexical v _) (lexical n _) (lexical n _)))))))
1194
1195   (pass-if-peval
1196     ;; Mutable lexical is not propagated.
1197     (let ((v (vector 1 2 3)))
1198       (lambda ()
1199         v))
1200     (let (v) (_)
1201          ((apply (primitive vector) (const 1) (const 2) (const 3)))
1202          (lambda ()
1203            (lambda-case
1204             ((() #f #f #f () ())
1205              (lexical v _))))))
1206
1207   (pass-if-peval
1208     ;; Lexical that is not provably pure is not inlined nor propagated.
1209     (let* ((x (if (> p q) (frob!) (display 'chbouib)))
1210            (y (* x 2)))
1211       (+ x x y))
1212     (let (x) (_) ((if (apply (primitive >) (toplevel p) (toplevel q))
1213                       (apply (toplevel frob!))
1214                       (apply (toplevel display) (const chbouib))))
1215          (let (y) (_) ((apply (primitive *) (lexical x _) (const 2)))
1216               (apply (primitive +)
1217                      (lexical x _) (lexical x _) (lexical y _)))))
1218
1219   (pass-if-peval
1220     ;; Non-constant arguments not propagated to lambdas.
1221     ((lambda (x y z)
1222        (vector-set! x 0 0)
1223        (set-car! y 0)
1224        (set-cdr! z '()))
1225      (vector 1 2 3)
1226      (make-list 10)
1227      (list 1 2 3))
1228     (let (x y z) (_ _ _)
1229          ((apply (primitive vector) (const 1) (const 2) (const 3))
1230           (apply (toplevel make-list) (const 10))
1231           (apply (primitive list) (const 1) (const 2) (const 3)))
1232          (begin
1233            (apply (toplevel vector-set!)
1234                   (lexical x _) (const 0) (const 0))
1235            (apply (toplevel set-car!)
1236                   (lexical y _) (const 0))
1237            (apply (toplevel set-cdr!)
1238                   (lexical z _) (const ())))))
1239
1240   (pass-if-peval
1241    (let ((foo top-foo) (bar top-bar))
1242      (let* ((g (lambda (x y) (+ x y)))
1243             (f (lambda (g x) (g x x))))
1244        (+ (f g foo) (f g bar))))
1245    (let (foo bar) (_ _) ((toplevel top-foo) (toplevel top-bar))
1246         (apply (primitive +)
1247                (apply (primitive +) (lexical foo _) (lexical foo _))
1248                (apply (primitive +) (lexical bar _) (lexical bar _)))))
1249
1250   (pass-if-peval
1251     ;; Fresh objects are not turned into constants, nor are constants
1252     ;; turned into fresh objects.
1253     (let* ((c '(2 3))
1254            (x (cons 1 c))
1255            (y (cons 0 x)))
1256       y)
1257     (let (x) (_) ((apply (primitive cons) (const 1) (const (2 3))))
1258          (apply (primitive cons) (const 0) (lexical x _))))
1259
1260   (pass-if-peval
1261     ;; Bindings mutated.
1262     (let ((x 2))
1263       (set! x 3)
1264       x)
1265     (let (x) (_) ((const 2))
1266          (begin
1267            (set! (lexical x _) (const 3))
1268            (lexical x _))))
1269
1270   (pass-if-peval
1271     ;; Bindings mutated.
1272     (letrec ((x 0)
1273              (f (lambda ()
1274                   (set! x (+ 1 x))
1275                   x)))
1276       (frob f) ; may mutate `x'
1277       x)
1278     (letrec (x) (_) ((const 0))
1279             (begin
1280               (apply (toplevel frob) (lambda _ _))
1281               (lexical x _))))
1282
1283   (pass-if-peval
1284     ;; Bindings mutated.
1285     (letrec ((f (lambda (x)
1286                   (set! f (lambda (_) x))
1287                   x)))
1288       (f 2))
1289     (letrec _ . _))
1290
1291   (pass-if-peval
1292     ;; Bindings possibly mutated.
1293     (let ((x (make-foo)))
1294       (frob! x) ; may mutate `x'
1295       x)
1296     (let (x) (_) ((apply (toplevel make-foo)))
1297          (begin
1298            (apply (toplevel frob!) (lexical x _))
1299            (lexical x _))))
1300
1301   (pass-if-peval
1302     ;; Inlining stops at recursive calls with dynamic arguments.
1303     (let loop ((x x))
1304       (if (< x 0) x (loop (1- x))))
1305     (letrec (loop) (_) ((lambda (_)
1306                           (lambda-case
1307                            (((x) #f #f #f () (_))
1308                             (if _ _
1309                                 (apply (lexical loop _)
1310                                        (apply (primitive 1-)
1311                                               (lexical x _))))))))
1312             (apply (lexical loop _) (toplevel x))))
1313
1314   (pass-if-peval
1315     ;; Recursion on the 2nd argument is fully evaluated.
1316     (let ((x (top)))
1317       (let loop ((x x) (y 10))
1318         (if (> y 0)
1319             (loop x (1- y))
1320             (foo x y))))
1321     (let (x) (_) ((apply (toplevel top)))
1322          (apply (toplevel foo) (lexical x _) (const 0))))
1323
1324   (pass-if-peval
1325     ;; Inlining aborted when residual code contains recursive calls.
1326     ;;
1327     ;; <http://debbugs.gnu.org/9542>
1328     (let loop ((x x) (y 0))
1329       (if (> y 0)
1330           (loop (1- x) (1- y))
1331           (if (< x 0)
1332               x
1333               (loop (1+ x) (1+ y)))))
1334     (letrec (loop) (_) ((lambda (_)
1335                           (lambda-case
1336                            (((x y) #f #f #f () (_ _))
1337                             (if (apply (primitive >)
1338                                        (lexical y _) (const 0))
1339                                 _ _)))))
1340             (apply (lexical loop _) (toplevel x) (const 0))))
1341
1342   (pass-if-peval
1343     ;; Infinite recursion: `peval' gives up and leaves it as is.
1344     (letrec ((f (lambda (x) (g (1- x))))
1345              (g (lambda (x) (h (1+ x))))
1346              (h (lambda (x) (f x))))
1347       (f 0))
1348     (letrec _ . _))
1349
1350   (pass-if-peval
1351     ;; Infinite recursion: all the arguments to `loop' are static, but
1352     ;; unrolling it would lead `peval' to enter an infinite loop.
1353     (let loop ((x 0))
1354       (and (< x top)
1355            (loop (1+ x))))
1356     (letrec (loop) (_) ((lambda . _))
1357             (apply (lexical loop _) (const 0))))
1358
1359   (pass-if-peval
1360     ;; This test checks that the `start' binding is indeed residualized.
1361     ;; See the `referenced?' procedure in peval's `prune-bindings'.
1362     (let ((pos 0))
1363       (set! pos 1) ;; Cause references to `pos' to residualize.
1364       (let ((here (let ((start pos)) (lambda () start))))
1365         (here)))
1366     (let (pos) (_) ((const 0))
1367          (begin
1368            (set! (lexical pos _) (const 1))
1369            (let (here) (_) (_)
1370                 (apply (lexical here _))))))
1371
1372   (pass-if-peval
1373    ;; FIXME: should this one residualize the binding?
1374    (letrec ((a a))
1375      1)
1376    (const 1))
1377
1378   (pass-if-peval
1379    ;; This is a fun one for peval to handle.
1380    (letrec ((a a))
1381      a)
1382    (letrec (a) (_) ((lexical a _))
1383            (lexical a _)))
1384
1385   (pass-if-peval
1386    ;; Another interesting recursive case.
1387    (letrec ((a b) (b a))
1388      a)
1389    (letrec (a) (_) ((lexical a _))
1390            (lexical a _)))
1391
1392   (pass-if-peval
1393    ;; Another pruning case, that `a' is residualized.
1394    (letrec ((a (lambda () (a)))
1395             (b (lambda () (a)))
1396             (c (lambda (x) x)))
1397      (let ((d (foo b)))
1398        (c d)))
1399
1400    ;; "b c a" is the current order that we get with unordered letrec,
1401    ;; but it's not important to this test, so if it changes, just adapt
1402    ;; the test.
1403    (letrec (b c a) (_ _ _)
1404      ((lambda _
1405         (lambda-case
1406          ((() #f #f #f () ())
1407           (apply (lexical a _)))))
1408       (lambda _
1409         (lambda-case
1410          (((x) #f #f #f () (_))
1411           (lexical x _))))
1412       (lambda _
1413         (lambda-case
1414          ((() #f #f #f () ())
1415           (apply (lexical a _))))))
1416      (let (d)
1417        (_)
1418        ((apply (toplevel foo) (lexical b _)))
1419        (apply (lexical c _)
1420               (lexical d _)))))
1421
1422   (pass-if-peval
1423    ;; In this case, we can prune the bindings.  `a' ends up being copied
1424    ;; because it is only referenced once in the source program.  Oh
1425    ;; well.
1426    (letrec* ((a (lambda (x) (top x)))
1427              (b (lambda () a)))
1428      (foo (b) (b)))
1429    (apply (toplevel foo)
1430           (lambda _
1431             (lambda-case
1432              (((x) #f #f #f () (_))
1433               (apply (toplevel top) (lexical x _)))))
1434           (lambda _
1435             (lambda-case
1436              (((x) #f #f #f () (_))
1437               (apply (toplevel top) (lexical x _)))))))
1438
1439   (pass-if-peval
1440    ;; Constant folding: cons of #nil does not make list
1441    (cons 1 #nil)
1442    (apply (primitive cons) (const 1) (const '#nil)))
1443
1444   (pass-if-peval
1445     ;; Constant folding: cons
1446    (begin (cons 1 2) #f)
1447    (const #f))
1448
1449   (pass-if-peval
1450     ;; Constant folding: cons
1451    (begin (cons (foo) 2) #f)
1452    (begin (apply (toplevel foo)) (const #f)))
1453
1454   (pass-if-peval
1455     ;; Constant folding: cons
1456    (if (cons 0 0) 1 2)
1457    (const 1))
1458
1459   (pass-if-peval
1460    ;; Constant folding: car+cons
1461    (car (cons 1 0))
1462    (const 1))
1463
1464   (pass-if-peval
1465    ;; Constant folding: cdr+cons
1466    (cdr (cons 1 0))
1467    (const 0))
1468
1469   (pass-if-peval
1470    ;; Constant folding: car+cons, impure
1471    (car (cons 1 (bar)))
1472    (begin (apply (toplevel bar)) (const 1)))
1473
1474   (pass-if-peval
1475    ;; Constant folding: cdr+cons, impure
1476    (cdr (cons (bar) 0))
1477    (begin (apply (toplevel bar)) (const 0)))
1478
1479   (pass-if-peval
1480    ;; Constant folding: car+list
1481    (car (list 1 0))
1482    (const 1))
1483
1484   (pass-if-peval
1485    ;; Constant folding: cdr+list
1486    (cdr (list 1 0))
1487    (apply (primitive list) (const 0)))
1488
1489   (pass-if-peval
1490    ;; Constant folding: car+list, impure
1491    (car (list 1 (bar)))
1492    (begin (apply (toplevel bar)) (const 1)))
1493
1494   (pass-if-peval
1495    ;; Constant folding: cdr+list, impure
1496    (cdr (list (bar) 0))
1497    (begin (apply (toplevel bar)) (apply (primitive list) (const 0))))
1498
1499   (pass-if-peval
1500    resolve-primitives
1501    ;; Non-constant guards get lexical bindings.
1502    (dynamic-wind foo (lambda () bar) baz)
1503    (let (pre post) (_ _) ((toplevel foo) (toplevel baz))
1504         (dynwind (lexical pre _) (toplevel bar) (lexical post _))))
1505
1506   (pass-if-peval
1507    resolve-primitives
1508    ;; Constant guards don't need lexical bindings.
1509    (dynamic-wind (lambda () foo) (lambda () bar) (lambda () baz))
1510    (dynwind
1511     (lambda ()
1512       (lambda-case
1513        ((() #f #f #f () ()) (toplevel foo))))
1514     (toplevel bar)
1515     (lambda ()
1516       (lambda-case
1517        ((() #f #f #f () ()) (toplevel baz))))))
1518
1519   (pass-if-peval
1520    resolve-primitives
1521    ;; Prompt is removed if tag is unreferenced
1522    (let ((tag (make-prompt-tag)))
1523      (call-with-prompt tag
1524                        (lambda () 1)
1525                        (lambda args args)))
1526    (const 1))
1527
1528   (pass-if-peval
1529    resolve-primitives
1530    ;; Prompt is removed if tag is unreferenced, with explicit stem
1531    (let ((tag (make-prompt-tag "foo")))
1532      (call-with-prompt tag
1533                        (lambda () 1)
1534                        (lambda args args)))
1535    (const 1))
1536
1537   (pass-if-peval
1538    resolve-primitives
1539    ;; `while' without `break' or `continue' has no prompts and gets its
1540    ;; condition folded.  Unfortunately the outer `lp' does not yet get
1541    ;; elided.
1542    (while #t #t)
1543    (letrec (lp) (_)
1544            ((lambda _
1545               (lambda-case
1546                ((() #f #f #f () ())
1547                 (letrec (loop) (_)
1548                         ((lambda _
1549                            (lambda-case
1550                             ((() #f #f #f () ())
1551                              (apply (lexical loop _))))))
1552                         (apply (lexical loop _)))))))
1553            (apply (lexical lp _)))))
1554
1555
1556 \f
1557 (with-test-prefix "tree-il-fold"
1558
1559   (pass-if "empty tree"
1560     (let ((leaf? #f) (up? #f) (down? #f) (mark (list 'mark)))
1561       (and (eq? mark
1562                 (tree-il-fold (lambda (x y) (set! leaf? #t) y)
1563                               (lambda (x y) (set! down? #t) y)
1564                               (lambda (x y) (set! up? #t) y)
1565                               mark
1566                               '()))
1567            (not leaf?)
1568            (not up?)
1569            (not down?))))
1570
1571   (pass-if "lambda and application"
1572     (let* ((leaves '()) (ups '()) (downs '())
1573            (result (tree-il-fold (lambda (x y)
1574                                    (set! leaves (cons x leaves))
1575                                    (1+ y))
1576                                  (lambda (x y)
1577                                    (set! downs (cons x downs))
1578                                    (1+ y))
1579                                  (lambda (x y)
1580                                    (set! ups (cons x ups))
1581                                    (1+ y))
1582                                  0
1583                                  (parse-tree-il
1584                                   '(lambda ()
1585                                      (lambda-case
1586                                       (((x y) #f #f #f () (x1 y1))
1587                                        (apply (toplevel +)
1588                                               (lexical x x1)
1589                                               (lexical y y1)))
1590                                       #f))))))
1591       (and (equal? (map strip-source leaves)
1592                    (list (make-lexical-ref #f 'y 'y1)
1593                          (make-lexical-ref #f 'x 'x1)
1594                          (make-toplevel-ref #f '+)))
1595            (= (length downs) 3)
1596            (equal? (reverse (map strip-source ups))
1597                    (map strip-source downs))))))
1598
1599 \f
1600 ;;;
1601 ;;; Warnings.
1602 ;;;
1603
1604 ;; Make sure we get English messages.
1605 (setlocale LC_ALL "C")
1606
1607 (define (call-with-warnings thunk)
1608   (let ((port (open-output-string)))
1609     (with-fluids ((*current-warning-port*   port)
1610                   (*current-warning-prefix* ""))
1611       (thunk))
1612     (let ((warnings (get-output-string port)))
1613       (string-tokenize warnings
1614                        (char-set-complement (char-set #\newline))))))
1615
1616 (define %opts-w-unused
1617   '(#:warnings (unused-variable)))
1618
1619 (define %opts-w-unused-toplevel
1620   '(#:warnings (unused-toplevel)))
1621
1622 (define %opts-w-unbound
1623   '(#:warnings (unbound-variable)))
1624
1625 (define %opts-w-arity
1626   '(#:warnings (arity-mismatch)))
1627
1628 (define %opts-w-format
1629   '(#:warnings (format)))
1630
1631
1632 (with-test-prefix "warnings"
1633
1634    (pass-if "unknown warning type"
1635      (let ((w (call-with-warnings
1636                 (lambda ()
1637                   (compile #t #:opts '(#:warnings (does-not-exist)))))))
1638        (and (= (length w) 1)
1639             (number? (string-contains (car w) "unknown warning")))))
1640
1641    (with-test-prefix "unused-variable"
1642
1643      (pass-if "quiet"
1644        (null? (call-with-warnings
1645                 (lambda ()
1646                   (compile '(lambda (x y) (+ x y))
1647                            #:opts %opts-w-unused)))))
1648
1649      (pass-if "let/unused"
1650        (let ((w (call-with-warnings
1651                   (lambda ()
1652                     (compile '(lambda (x)
1653                                 (let ((y (+ x 2)))
1654                                   x))
1655                              #:opts %opts-w-unused)))))
1656          (and (= (length w) 1)
1657               (number? (string-contains (car w) "unused variable `y'")))))
1658
1659      (pass-if "shadowed variable"
1660        (let ((w (call-with-warnings
1661                   (lambda ()
1662                     (compile '(lambda (x)
1663                                 (let ((y x))
1664                                   (let ((y (+ x 2)))
1665                                     (+ x y))))
1666                              #:opts %opts-w-unused)))))
1667          (and (= (length w) 1)
1668               (number? (string-contains (car w) "unused variable `y'")))))
1669
1670      (pass-if "letrec"
1671        (null? (call-with-warnings
1672                 (lambda ()
1673                   (compile '(lambda ()
1674                               (letrec ((x (lambda () (y)))
1675                                        (y (lambda () (x))))
1676                                 y))
1677                            #:opts %opts-w-unused)))))
1678
1679      (pass-if "unused argument"
1680        ;; Unused arguments should not be reported.
1681        (null? (call-with-warnings
1682                 (lambda ()
1683                   (compile '(lambda (x y z) #t)
1684                            #:opts %opts-w-unused)))))
1685
1686      (pass-if "special variable names"
1687        (null? (call-with-warnings
1688                 (lambda ()
1689                   (compile '(lambda ()
1690                               (let ((_ 'underscore)
1691                                     (#{gensym name}# 'ignore-me))
1692                                 #t))
1693                            #:to 'assembly
1694                            #:opts %opts-w-unused))))))
1695
1696    (with-test-prefix "unused-toplevel"
1697
1698      (pass-if "used after definition"
1699        (null? (call-with-warnings
1700                 (lambda ()
1701                   (let ((in (open-input-string
1702                              "(define foo 2) foo")))
1703                     (read-and-compile in
1704                                       #:to 'assembly
1705                                       #:opts %opts-w-unused-toplevel))))))
1706
1707      (pass-if "used before definition"
1708        (null? (call-with-warnings
1709                 (lambda ()
1710                   (let ((in (open-input-string
1711                              "(define (bar) foo) (define foo 2) (bar)")))
1712                     (read-and-compile in
1713                                       #:to 'assembly
1714                                       #:opts %opts-w-unused-toplevel))))))
1715
1716      (pass-if "unused but public"
1717        (let ((in (open-input-string
1718                   "(define-module (test-suite tree-il x) #:export (bar))
1719                    (define (bar) #t)")))
1720          (null? (call-with-warnings
1721                   (lambda ()
1722                     (read-and-compile in
1723                                       #:to 'assembly
1724                                       #:opts %opts-w-unused-toplevel))))))
1725
1726      (pass-if "unused but public (more)"
1727        (let ((in (open-input-string
1728                   "(define-module (test-suite tree-il x) #:export (bar))
1729                    (define (bar) (baz))
1730                    (define (baz) (foo))
1731                    (define (foo) #t)")))
1732          (null? (call-with-warnings
1733                   (lambda ()
1734                     (read-and-compile in
1735                                       #:to 'assembly
1736                                       #:opts %opts-w-unused-toplevel))))))
1737
1738      (pass-if "unused but define-public"
1739        (null? (call-with-warnings
1740                 (lambda ()
1741                   (compile '(define-public foo 2)
1742                            #:to 'assembly
1743                            #:opts %opts-w-unused-toplevel)))))
1744
1745      (pass-if "used by macro"
1746        ;; FIXME: See comment about macros at `unused-toplevel-analysis'.
1747        (throw 'unresolved)
1748
1749        (null? (call-with-warnings
1750                 (lambda ()
1751                   (let ((in (open-input-string
1752                              "(define (bar) 'foo)
1753                               (define-syntax baz
1754                                 (syntax-rules () ((_) (bar))))")))
1755                     (read-and-compile in
1756                                       #:to 'assembly
1757                                       #:opts %opts-w-unused-toplevel))))))
1758
1759      (pass-if "unused"
1760        (let ((w (call-with-warnings
1761                   (lambda ()
1762                     (compile '(define foo 2)
1763                              #:to 'assembly
1764                              #:opts %opts-w-unused-toplevel)))))
1765          (and (= (length w) 1)
1766               (number? (string-contains (car w)
1767                                         (format #f "top-level variable `~A'"
1768                                                 'foo))))))
1769
1770      (pass-if "unused recursive"
1771        (let ((w (call-with-warnings
1772                   (lambda ()
1773                     (compile '(define (foo) (foo))
1774                              #:to 'assembly
1775                              #:opts %opts-w-unused-toplevel)))))
1776          (and (= (length w) 1)
1777               (number? (string-contains (car w)
1778                                         (format #f "top-level variable `~A'"
1779                                                 'foo))))))
1780
1781      (pass-if "unused mutually recursive"
1782        (let* ((in (open-input-string
1783                    "(define (foo) (bar)) (define (bar) (foo))"))
1784               (w  (call-with-warnings
1785                     (lambda ()
1786                       (read-and-compile in
1787                                         #:to 'assembly
1788                                         #:opts %opts-w-unused-toplevel)))))
1789          (and (= (length w) 2)
1790               (number? (string-contains (car w)
1791                                         (format #f "top-level variable `~A'"
1792                                                 'foo)))
1793               (number? (string-contains (cadr w)
1794                                         (format #f "top-level variable `~A'"
1795                                                 'bar))))))
1796
1797      (pass-if "special variable names"
1798        (null? (call-with-warnings
1799                 (lambda ()
1800                   (compile '(define #{gensym name}# 'ignore-me)
1801                            #:to 'assembly
1802                            #:opts %opts-w-unused-toplevel))))))
1803
1804    (with-test-prefix "unbound variable"
1805
1806      (pass-if "quiet"
1807        (null? (call-with-warnings
1808                 (lambda ()
1809                   (compile '+ #:opts %opts-w-unbound)))))
1810
1811      (pass-if "ref"
1812        (let* ((v (gensym))
1813               (w (call-with-warnings
1814                    (lambda ()
1815                      (compile v
1816                               #:to 'assembly
1817                               #:opts %opts-w-unbound)))))
1818          (and (= (length w) 1)
1819               (number? (string-contains (car w)
1820                                         (format #f "unbound variable `~A'"
1821                                                 v))))))
1822
1823      (pass-if "set!"
1824        (let* ((v (gensym))
1825               (w (call-with-warnings
1826                    (lambda ()
1827                      (compile `(set! ,v 7)
1828                               #:to 'assembly
1829                               #:opts %opts-w-unbound)))))
1830          (and (= (length w) 1)
1831               (number? (string-contains (car w)
1832                                         (format #f "unbound variable `~A'"
1833                                                 v))))))
1834
1835      (pass-if "module-local top-level is visible"
1836        (let ((m (make-module))
1837              (v (gensym)))
1838          (beautify-user-module! m)
1839          (compile `(define ,v 123)
1840                   #:env m #:opts %opts-w-unbound)
1841          (null? (call-with-warnings
1842                   (lambda ()
1843                     (compile v
1844                              #:env m
1845                              #:to 'assembly
1846                              #:opts %opts-w-unbound))))))
1847
1848      (pass-if "module-local top-level is visible after"
1849        (let ((m (make-module))
1850              (v (gensym)))
1851          (beautify-user-module! m)
1852          (null? (call-with-warnings
1853                   (lambda ()
1854                     (let ((in (open-input-string
1855                                "(define (f)
1856                                   (set! chbouib 3))
1857                                 (define chbouib 5)")))
1858                       (read-and-compile in
1859                                         #:env m
1860                                         #:opts %opts-w-unbound)))))))
1861
1862      (pass-if "optional arguments are visible"
1863        (null? (call-with-warnings
1864                 (lambda ()
1865                   (compile '(lambda* (x #:optional y z) (list x y z))
1866                            #:opts %opts-w-unbound
1867                            #:to 'assembly)))))
1868
1869      (pass-if "keyword arguments are visible"
1870        (null? (call-with-warnings
1871                 (lambda ()
1872                   (compile '(lambda* (x #:key y z) (list x y z))
1873                            #:opts %opts-w-unbound
1874                            #:to 'assembly)))))
1875
1876      (pass-if "GOOPS definitions are visible"
1877        (let ((m (make-module))
1878              (v (gensym)))
1879          (beautify-user-module! m)
1880          (module-use! m (resolve-interface '(oop goops)))
1881          (null? (call-with-warnings
1882                   (lambda ()
1883                     (let ((in (open-input-string
1884                                "(define-class <foo> ()
1885                                   (bar #:getter foo-bar))
1886                                 (define z (foo-bar (make <foo>)))")))
1887                       (read-and-compile in
1888                                         #:env m
1889                                         #:opts %opts-w-unbound))))))))
1890
1891    (with-test-prefix "arity mismatch"
1892
1893      (pass-if "quiet"
1894        (null? (call-with-warnings
1895                 (lambda ()
1896                   (compile '(cons 'a 'b) #:opts %opts-w-arity)))))
1897
1898      (pass-if "direct application"
1899        (let ((w (call-with-warnings
1900                   (lambda ()
1901                     (compile '((lambda (x y) (or x y)) 1 2 3 4 5)
1902                              #:opts %opts-w-arity
1903                              #:to 'assembly)))))
1904          (and (= (length w) 1)
1905               (number? (string-contains (car w)
1906                                         "wrong number of arguments to")))))
1907      (pass-if "local"
1908        (let ((w (call-with-warnings
1909                   (lambda ()
1910                     (compile '(let ((f (lambda (x y) (+ x y))))
1911                                 (f 2))
1912                              #:opts %opts-w-arity
1913                              #:to 'assembly)))))
1914          (and (= (length w) 1)
1915               (number? (string-contains (car w)
1916                                         "wrong number of arguments to")))))
1917
1918      (pass-if "global"
1919        (let ((w (call-with-warnings
1920                   (lambda ()
1921                     (compile '(cons 1 2 3 4)
1922                              #:opts %opts-w-arity
1923                              #:to 'assembly)))))
1924          (and (= (length w) 1)
1925               (number? (string-contains (car w)
1926                                         "wrong number of arguments to")))))
1927
1928      (pass-if "alias to global"
1929        (let ((w (call-with-warnings
1930                   (lambda ()
1931                     (compile '(let ((f cons)) (f 1 2 3 4))
1932                              #:opts %opts-w-arity
1933                              #:to 'assembly)))))
1934          (and (= (length w) 1)
1935               (number? (string-contains (car w)
1936                                         "wrong number of arguments to")))))
1937
1938      (pass-if "alias to lexical to global"
1939        (let ((w (call-with-warnings
1940                   (lambda ()
1941                     (compile '(let ((f number?))
1942                                 (let ((g f))
1943                                   (f 1 2 3 4)))
1944                              #:opts %opts-w-arity
1945                              #:to 'assembly)))))
1946          (and (= (length w) 1)
1947               (number? (string-contains (car w)
1948                                         "wrong number of arguments to")))))
1949
1950      (pass-if "alias to lexical"
1951        (let ((w (call-with-warnings
1952                   (lambda ()
1953                     (compile '(let ((f (lambda (x y z) (+ x y z))))
1954                                 (let ((g f))
1955                                   (g 1)))
1956                              #:opts %opts-w-arity
1957                              #:to 'assembly)))))
1958          (and (= (length w) 1)
1959               (number? (string-contains (car w)
1960                                         "wrong number of arguments to")))))
1961
1962      (pass-if "letrec"
1963        (let ((w (call-with-warnings
1964                   (lambda ()
1965                     (compile '(letrec ((odd?  (lambda (x) (even? (1- x))))
1966                                        (even? (lambda (x)
1967                                                 (or (= 0 x)
1968                                                     (odd?)))))
1969                                 (odd? 1))
1970                              #:opts %opts-w-arity
1971                              #:to 'assembly)))))
1972          (and (= (length w) 1)
1973               (number? (string-contains (car w)
1974                                         "wrong number of arguments to")))))
1975
1976      (pass-if "case-lambda"
1977        (null? (call-with-warnings
1978                 (lambda ()
1979                   (compile '(let ((f (case-lambda
1980                                        ((x)     1)
1981                                        ((x y)   2)
1982                                        ((x y z) 3))))
1983                               (list (f 1)
1984                                     (f 1 2)
1985                                     (f 1 2 3)))
1986                            #:opts %opts-w-arity
1987                            #:to 'assembly)))))
1988
1989      (pass-if "case-lambda with wrong number of arguments"
1990        (let ((w (call-with-warnings
1991                   (lambda ()
1992                     (compile '(let ((f (case-lambda
1993                                          ((x)     1)
1994                                          ((x y)   2))))
1995                                 (f 1 2 3))
1996                              #:opts %opts-w-arity
1997                              #:to 'assembly)))))
1998          (and (= (length w) 1)
1999               (number? (string-contains (car w)
2000                                         "wrong number of arguments to")))))
2001
2002      (pass-if "case-lambda*"
2003        (null? (call-with-warnings
2004                 (lambda ()
2005                   (compile '(let ((f (case-lambda*
2006                                        ((x #:optional y) 1)
2007                                        ((x #:key y)      2)
2008                                        ((x y #:key z)    3))))
2009                               (list (f 1)
2010                                     (f 1 2)
2011                                     (f #:y 2)
2012                                     (f 1 2 #:z 3)))
2013                            #:opts %opts-w-arity
2014                            #:to 'assembly)))))
2015
2016      (pass-if "case-lambda* with wrong arguments"
2017        (let ((w (call-with-warnings
2018                   (lambda ()
2019                     (compile '(let ((f (case-lambda*
2020                                          ((x #:optional y) 1)
2021                                          ((x #:key y)      2)
2022                                          ((x y #:key z)    3))))
2023                                 (list (f)
2024                                       (f 1 #:z 3)))
2025                              #:opts %opts-w-arity
2026                              #:to 'assembly)))))
2027          (and (= (length w) 2)
2028               (null? (filter (lambda (w)
2029                                (not
2030                                 (number?
2031                                  (string-contains
2032                                   w "wrong number of arguments to"))))
2033                              w)))))
2034
2035      (pass-if "local toplevel-defines"
2036        (let ((w (call-with-warnings
2037                   (lambda ()
2038                     (let ((in (open-input-string "
2039                                 (define (g x) (f x))
2040                                 (define (f) 1)")))
2041                       (read-and-compile in
2042                                         #:opts %opts-w-arity
2043                                         #:to 'assembly))))))
2044          (and (= (length w) 1)
2045               (number? (string-contains (car w)
2046                                         "wrong number of arguments to")))))
2047
2048      (pass-if "global toplevel alias"
2049        (let ((w (call-with-warnings
2050                   (lambda ()
2051                     (let ((in (open-input-string "
2052                                 (define f cons)
2053                                 (define (g) (f))")))
2054                       (read-and-compile in
2055                                         #:opts %opts-w-arity
2056                                         #:to 'assembly))))))
2057          (and (= (length w) 1)
2058               (number? (string-contains (car w)
2059                                         "wrong number of arguments to")))))
2060
2061      (pass-if "local toplevel overrides global"
2062        (null? (call-with-warnings
2063                 (lambda ()
2064                   (let ((in (open-input-string "
2065                               (define (cons) 0)
2066                               (define (foo x) (cons))")))
2067                     (read-and-compile in
2068                                       #:opts %opts-w-arity
2069                                       #:to 'assembly))))))
2070
2071      (pass-if "keyword not passed and quiet"
2072        (null? (call-with-warnings
2073                 (lambda ()
2074                   (compile '(let ((f (lambda* (x #:key y) y)))
2075                               (f 2))
2076                            #:opts %opts-w-arity
2077                            #:to 'assembly)))))
2078
2079      (pass-if "keyword passed and quiet"
2080        (null? (call-with-warnings
2081                 (lambda ()
2082                   (compile '(let ((f (lambda* (x #:key y) y)))
2083                               (f 2 #:y 3))
2084                            #:opts %opts-w-arity
2085                            #:to 'assembly)))))
2086
2087      (pass-if "keyword passed to global and quiet"
2088        (null? (call-with-warnings
2089                 (lambda ()
2090                   (let ((in (open-input-string "
2091                               (use-modules (system base compile))
2092                               (compile '(+ 2 3) #:env (current-module))")))
2093                     (read-and-compile in
2094                                       #:opts %opts-w-arity
2095                                       #:to 'assembly))))))
2096
2097      (pass-if "extra keyword"
2098        (let ((w (call-with-warnings
2099                   (lambda ()
2100                     (compile '(let ((f (lambda* (x #:key y) y)))
2101                                 (f 2 #:Z 3))
2102                              #:opts %opts-w-arity
2103                              #:to 'assembly)))))
2104          (and (= (length w) 1)
2105               (number? (string-contains (car w)
2106                                         "wrong number of arguments to")))))
2107
2108      (pass-if "extra keywords allowed"
2109        (null? (call-with-warnings
2110                 (lambda ()
2111                   (compile '(let ((f (lambda* (x #:key y #:allow-other-keys)
2112                                        y)))
2113                               (f 2 #:Z 3))
2114                            #:opts %opts-w-arity
2115                            #:to 'assembly))))))
2116
2117    (with-test-prefix "format"
2118
2119      (pass-if "quiet (no args)"
2120        (null? (call-with-warnings
2121                (lambda ()
2122                  (compile '(format #t "hey!")
2123                           #:opts %opts-w-format
2124                           #:to 'assembly)))))
2125
2126      (pass-if "quiet (1 arg)"
2127        (null? (call-with-warnings
2128                (lambda ()
2129                  (compile '(format #t "hey ~A!" "you")
2130                           #:opts %opts-w-format
2131                           #:to 'assembly)))))
2132
2133      (pass-if "quiet (2 args)"
2134        (null? (call-with-warnings
2135                (lambda ()
2136                  (compile '(format #t "~A ~A!" "hello" "world")
2137                           #:opts %opts-w-format
2138                           #:to 'assembly)))))
2139
2140      (pass-if "wrong port arg"
2141        (let ((w (call-with-warnings
2142                  (lambda ()
2143                    (compile '(format 10 "foo")
2144                             #:opts %opts-w-format
2145                             #:to 'assembly)))))
2146          (and (= (length w) 1)
2147               (number? (string-contains (car w)
2148                                         "wrong port argument")))))
2149
2150      (pass-if "non-literal format string"
2151        (let ((w (call-with-warnings
2152                  (lambda ()
2153                    (compile '(format #f fmt)
2154                             #:opts %opts-w-format
2155                             #:to 'assembly)))))
2156          (and (= (length w) 1)
2157               (number? (string-contains (car w)
2158                                         "non-literal format string")))))
2159
2160      (pass-if "non-literal format string using gettext"
2161        (null? (call-with-warnings
2162                (lambda ()
2163                  (compile '(format #t (_ "~A ~A!") "hello" "world")
2164                           #:opts %opts-w-format
2165                           #:to 'assembly)))))
2166
2167      (pass-if "wrong format string"
2168        (let ((w (call-with-warnings
2169                  (lambda ()
2170                    (compile '(format #f 'not-a-string)
2171                             #:opts %opts-w-format
2172                             #:to 'assembly)))))
2173          (and (= (length w) 1)
2174               (number? (string-contains (car w)
2175                                         "wrong format string")))))
2176
2177      (pass-if "wrong number of args"
2178        (let ((w (call-with-warnings
2179                  (lambda ()
2180                    (compile '(format "shbweeb")
2181                             #:opts %opts-w-format
2182                             #:to 'assembly)))))
2183          (and (= (length w) 1)
2184               (number? (string-contains (car w)
2185                                         "wrong number of arguments")))))
2186
2187      (pass-if "~%, ~~, ~&, ~t, ~_, and ~\\n"
2188        (null? (call-with-warnings
2189                (lambda ()
2190                  (compile '((@ (ice-9 format) format) some-port
2191                             "~&~3_~~ ~\n~12they~%")
2192                           #:opts %opts-w-format
2193                           #:to 'assembly)))))
2194
2195      (pass-if "one missing argument"
2196        (let ((w (call-with-warnings
2197                  (lambda ()
2198                    (compile '(format some-port "foo ~A~%")
2199                             #:opts %opts-w-format
2200                             #:to 'assembly)))))
2201          (and (= (length w) 1)
2202               (number? (string-contains (car w)
2203                                         "expected 1, got 0")))))
2204
2205      (pass-if "one missing argument, gettext"
2206        (let ((w (call-with-warnings
2207                  (lambda ()
2208                    (compile '(format some-port (_ "foo ~A~%"))
2209                             #:opts %opts-w-format
2210                             #:to 'assembly)))))
2211          (and (= (length w) 1)
2212               (number? (string-contains (car w)
2213                                         "expected 1, got 0")))))
2214
2215      (pass-if "two missing arguments"
2216        (let ((w (call-with-warnings
2217                  (lambda ()
2218                    (compile '((@ (ice-9 format) format) #f
2219                               "foo ~10,2f and bar ~S~%")
2220                             #:opts %opts-w-format
2221                             #:to 'assembly)))))
2222          (and (= (length w) 1)
2223               (number? (string-contains (car w)
2224                                         "expected 2, got 0")))))
2225
2226      (pass-if "one given, one missing argument"
2227        (let ((w (call-with-warnings
2228                  (lambda ()
2229                    (compile '(format #t "foo ~A and ~S~%" hey)
2230                             #:opts %opts-w-format
2231                             #:to 'assembly)))))
2232          (and (= (length w) 1)
2233               (number? (string-contains (car w)
2234                                         "expected 2, got 1")))))
2235
2236      (pass-if "too many arguments"
2237        (let ((w (call-with-warnings
2238                  (lambda ()
2239                    (compile '(format #t "foo ~A~%" 1 2)
2240                             #:opts %opts-w-format
2241                             #:to 'assembly)))))
2242          (and (= (length w) 1)
2243               (number? (string-contains (car w)
2244                                         "expected 1, got 2")))))
2245
2246      (pass-if "~h"
2247        (null? (call-with-warnings
2248                  (lambda ()
2249                    (compile '((@ (ice-9 format) format) #t
2250                               "foo ~h ~a~%" 123.4 'bar)
2251                             #:opts %opts-w-format
2252                             #:to 'assembly)))))
2253
2254      (pass-if "~:h with locale object"
2255        (null? (call-with-warnings
2256                  (lambda ()
2257                    (compile '((@ (ice-9 format) format) #t
2258                               "foo ~:h~%" 123.4 %global-locale)
2259                             #:opts %opts-w-format
2260                             #:to 'assembly)))))
2261
2262      (pass-if "~:h without locale object"
2263        (let ((w (call-with-warnings
2264                  (lambda ()
2265                    (compile '((@ (ice-9 format) format) #t "foo ~,2:h" 123.4)
2266                             #:opts %opts-w-format
2267                             #:to 'assembly)))))
2268          (and (= (length w) 1)
2269               (number? (string-contains (car w)
2270                                         "expected 2, got 1")))))
2271
2272      (with-test-prefix "conditionals"
2273        (pass-if "literals"
2274         (null? (call-with-warnings
2275                 (lambda ()
2276                   (compile '((@ (ice-9 format) format) #f "~A ~[foo~;bar~;baz~;~] ~10,2f"
2277                                     'a 1 3.14)
2278                            #:opts %opts-w-format
2279                            #:to 'assembly)))))
2280
2281        (pass-if "literals with selector"
2282          (let ((w (call-with-warnings
2283                    (lambda ()
2284                      (compile '((@ (ice-9 format) format) #f "~2[foo~;bar~;baz~;~] ~A"
2285                                        1 'dont-ignore-me)
2286                               #:opts %opts-w-format
2287                               #:to 'assembly)))))
2288            (and (= (length w) 1)
2289                 (number? (string-contains (car w)
2290                                           "expected 1, got 2")))))
2291
2292        (pass-if "escapes (exact count)"
2293          (let ((w (call-with-warnings
2294                    (lambda ()
2295                      (compile '((@ (ice-9 format) format) #f "~[~a~;~a~]")
2296                               #:opts %opts-w-format
2297                               #:to 'assembly)))))
2298            (and (= (length w) 1)
2299                 (number? (string-contains (car w)
2300                                           "expected 2, got 0")))))
2301
2302        (pass-if "escapes with selector"
2303          (let ((w (call-with-warnings
2304                    (lambda ()
2305                      (compile '((@ (ice-9 format) format) #f "~1[chbouib~;~a~]")
2306                               #:opts %opts-w-format
2307                               #:to 'assembly)))))
2308            (and (= (length w) 1)
2309                 (number? (string-contains (car w)
2310                                           "expected 1, got 0")))))
2311
2312        (pass-if "escapes, range"
2313          (let ((w (call-with-warnings
2314                    (lambda ()
2315                      (compile '((@ (ice-9 format) format) #f "~[chbouib~;~a~;~2*~a~]")
2316                               #:opts %opts-w-format
2317                               #:to 'assembly)))))
2318            (and (= (length w) 1)
2319                 (number? (string-contains (car w)
2320                                           "expected 1 to 4, got 0")))))
2321
2322        (pass-if "@"
2323          (let ((w (call-with-warnings
2324                    (lambda ()
2325                      (compile '((@ (ice-9 format) format) #f "~@[temperature=~d~]")
2326                               #:opts %opts-w-format
2327                               #:to 'assembly)))))
2328            (and (= (length w) 1)
2329                 (number? (string-contains (car w)
2330                                           "expected 1, got 0")))))
2331
2332        (pass-if "nested"
2333          (let ((w (call-with-warnings
2334                    (lambda ()
2335                      (compile '((@ (ice-9 format) format) #f "~:[~[hey~;~a~;~va~]~;~3*~]")
2336                               #:opts %opts-w-format
2337                               #:to 'assembly)))))
2338            (and (= (length w) 1)
2339                 (number? (string-contains (car w)
2340                                           "expected 2 to 4, got 0")))))
2341
2342        (pass-if "unterminated"
2343          (let ((w (call-with-warnings
2344                    (lambda ()
2345                      (compile '((@ (ice-9 format) format) #f "~[unterminated")
2346                               #:opts %opts-w-format
2347                               #:to 'assembly)))))
2348            (and (= (length w) 1)
2349                 (number? (string-contains (car w)
2350                                           "unterminated conditional")))))
2351
2352        (pass-if "unexpected ~;"
2353          (let ((w (call-with-warnings
2354                    (lambda ()
2355                      (compile '((@ (ice-9 format) format) #f "foo~;bar")
2356                               #:opts %opts-w-format
2357                               #:to 'assembly)))))
2358            (and (= (length w) 1)
2359                 (number? (string-contains (car w)
2360                                           "unexpected")))))
2361
2362        (pass-if "unexpected ~]"
2363          (let ((w (call-with-warnings
2364                    (lambda ()
2365                      (compile '((@ (ice-9 format) format) #f "foo~]")
2366                               #:opts %opts-w-format
2367                               #:to 'assembly)))))
2368            (and (= (length w) 1)
2369                 (number? (string-contains (car w)
2370                                           "unexpected"))))))
2371
2372      (pass-if "~{...~}"
2373        (null? (call-with-warnings
2374                (lambda ()
2375                  (compile '((@ (ice-9 format) format) #f "~A ~{~S~} ~A"
2376                                    'hello '("ladies" "and")
2377                                    'gentlemen)
2378                           #:opts %opts-w-format
2379                           #:to 'assembly)))))
2380
2381      (pass-if "~{...~}, too many args"
2382        (let ((w (call-with-warnings
2383                  (lambda ()
2384                    (compile '((@ (ice-9 format) format) #f "~{~S~}" 1 2 3)
2385                             #:opts %opts-w-format
2386                             #:to 'assembly)))))
2387          (and (= (length w) 1)
2388               (number? (string-contains (car w)
2389                                         "expected 1, got 3")))))
2390
2391      (pass-if "~@{...~}"
2392        (null? (call-with-warnings
2393                (lambda ()
2394                  (compile '((@ (ice-9 format) format) #f "~@{~S~}" 1 2 3)
2395                           #:opts %opts-w-format
2396                           #:to 'assembly)))))
2397
2398      (pass-if "~@{...~}, too few args"
2399        (let ((w (call-with-warnings
2400                  (lambda ()
2401                    (compile '((@ (ice-9 format) format) #f "~A ~@{~S~}")
2402                             #:opts %opts-w-format
2403                             #:to 'assembly)))))
2404          (and (= (length w) 1)
2405               (number? (string-contains (car w)
2406                                         "expected at least 1, got 0")))))
2407
2408      (pass-if "unterminated ~{...~}"
2409        (let ((w (call-with-warnings
2410                  (lambda ()
2411                    (compile '((@ (ice-9 format) format) #f "~{")
2412                             #:opts %opts-w-format
2413                             #:to 'assembly)))))
2414          (and (= (length w) 1)
2415               (number? (string-contains (car w)
2416                                         "unterminated")))))
2417
2418      (pass-if "~(...~)"
2419        (null? (call-with-warnings
2420                (lambda ()
2421                  (compile '((@ (ice-9 format) format) #f "~:@(~A ~A~)" 'foo 'bar)
2422                           #:opts %opts-w-format
2423                           #:to 'assembly)))))
2424
2425      (pass-if "~v"
2426        (let ((w (call-with-warnings
2427                  (lambda ()
2428                    (compile '((@ (ice-9 format) format) #f "~v_foo")
2429                             #:opts %opts-w-format
2430                             #:to 'assembly)))))
2431          (and (= (length w) 1)
2432               (number? (string-contains (car w)
2433                                         "expected 1, got 0")))))
2434      (pass-if "~v:@y"
2435        (null? (call-with-warnings
2436                (lambda ()
2437                  (compile '((@ (ice-9 format) format) #f "~v:@y" 1 123)
2438                           #:opts %opts-w-format
2439                           #:to 'assembly)))))
2440
2441
2442      (pass-if "~*"
2443        (let ((w (call-with-warnings
2444                  (lambda ()
2445                    (compile '((@ (ice-9 format) format) #f "~2*~a" 'a 'b)
2446                             #:opts %opts-w-format
2447                             #:to 'assembly)))))
2448          (and (= (length w) 1)
2449               (number? (string-contains (car w)
2450                                         "expected 3, got 2")))))
2451
2452      (pass-if "~?"
2453        (null? (call-with-warnings
2454                (lambda ()
2455                  (compile '((@ (ice-9 format) format) #f "~?" "~d ~d" '(1 2))
2456                           #:opts %opts-w-format
2457                           #:to 'assembly)))))
2458
2459      (pass-if "complex 1"
2460        (let ((w (call-with-warnings
2461                  (lambda ()
2462                    (compile '((@ (ice-9 format) format) #f
2463                                      "~4@S    ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n"
2464                                      1 2 3 4 5 6)
2465                             #:opts %opts-w-format
2466                             #:to 'assembly)))))
2467          (and (= (length w) 1)
2468               (number? (string-contains (car w)
2469                                         "expected 4, got 6")))))
2470
2471      (pass-if "complex 2"
2472        (let ((w (call-with-warnings
2473                  (lambda ()
2474                    (compile '((@ (ice-9 format) format) #f
2475                                      "~:(~A~) Commands~:[~; [abbrev]~]:~2%"
2476                                      1 2 3 4)
2477                             #:opts %opts-w-format
2478                             #:to 'assembly)))))
2479          (and (= (length w) 1)
2480               (number? (string-contains (car w)
2481                                         "expected 2, got 4")))))
2482
2483      (pass-if "complex 3"
2484        (let ((w (call-with-warnings
2485                  (lambda ()
2486                    (compile '((@ (ice-9 format) format) #f "~9@a~:[~*~3_~;~3d~] ~v:@y~%")
2487                             #:opts %opts-w-format
2488                             #:to 'assembly)))))
2489          (and (= (length w) 1)
2490               (number? (string-contains (car w)
2491                                         "expected 5, got 0")))))
2492
2493      (pass-if "ice-9 format"
2494        (let ((w (call-with-warnings
2495                  (lambda ()
2496                    (let ((in (open-input-string
2497                               "(use-modules ((ice-9 format)
2498                                  #:renamer (symbol-prefix-proc 'i9-)))
2499                                (i9-format #t \"yo! ~A\" 1 2)")))
2500                      (read-and-compile in
2501                                        #:opts %opts-w-format
2502                                        #:to 'assembly))))))
2503          (and (= (length w) 1)
2504               (number? (string-contains (car w)
2505                                         "expected 1, got 2")))))
2506
2507      (pass-if "not format"
2508        (null? (call-with-warnings
2509                (lambda ()
2510                  (compile '(let ((format chbouib))
2511                              (format #t "not ~A a format string"))
2512                           #:opts %opts-w-format
2513                           #:to 'assembly)))))
2514
2515      (with-test-prefix "simple-format"
2516
2517        (pass-if "good"
2518          (null? (call-with-warnings
2519                  (lambda ()
2520                    (compile '(simple-format #t "foo ~a bar ~s ~%~~" 1 2)
2521                             #:opts %opts-w-format
2522                             #:to 'assembly)))))
2523
2524        (pass-if "wrong number of args"
2525          (let ((w (call-with-warnings
2526                    (lambda ()
2527                      (compile '(simple-format #t "foo ~a ~s~%" 'one-missing)
2528                               #:opts %opts-w-format
2529                               #:to 'assembly)))))
2530            (and (= (length w) 1)
2531                 (number? (string-contains (car w) "wrong number")))))
2532
2533        (pass-if "unsupported"
2534          (let ((w (call-with-warnings
2535                    (lambda ()
2536                      (compile '(simple-format #t "foo ~x~%" 16)
2537                               #:opts %opts-w-format
2538                               #:to 'assembly)))))
2539            (and (= (length w) 1)
2540                 (number? (string-contains (car w) "unsupported format option"))))))))