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, immutability preserved.
 709     (cons 0 (cons 1 (cons 2 '(3 4 5))))
 710     (apply (primitive cons) (const 0)
 711            (apply (primitive cons) (const 1)
 712                   (apply (primitive cons) (const 2)
 713                          (const (3 4 5))))))
 714
 715   ;; These two tests doesn't work any more because we changed the way we
 716   ;; deal with constants -- now the algorithm will see a construction as
 717   ;; being bound to the lexical, so it won't propagate it.  It can't
 718   ;; even propagate it in the case that it is only referenced once,
 719   ;; because:
 720   ;;
 721   ;;   (let ((x (cons 1 2))) (lambda () x))
 722   ;;
 723   ;; is not the same as
 724   ;;
 725   ;;   (lambda () (cons 1 2))
 726   ;;
 727   ;; Perhaps if we determined that not only was it only referenced once,
 728   ;; it was not closed over by a lambda, then we could propagate it, and
 729   ;; re-enable these two tests.
 730   ;;
 731   #;
 732   (pass-if-peval
 733    ;; First order, mutability preserved.
 734    (let loop ((i 3) (r '()))
 735      (if (zero? i)
 736          r
 737          (loop (1- i) (cons (cons i i) r))))
 738    (apply (primitive list)
 739           (apply (primitive cons) (const 1) (const 1))
 740           (apply (primitive cons) (const 2) (const 2))
 741           (apply (primitive cons) (const 3) (const 3))))
 742   ;;
 743   ;; See above.
 744   #;
 745   (pass-if-peval
 746    ;; First order, evaluated.
 747    (let loop ((i 7)
 748               (r '()))
 749      (if (<= i 0)
 750          (car r)
 751          (loop (1- i) (cons i r))))
 752    (const 1))
 753
 754   ;; Instead here are tests for what happens for the above cases: they
 755   ;; unroll but they don't fold.
 756   (pass-if-peval
 757    (let loop ((i 3) (r '()))
 758      (if (zero? i)
 759          r
 760          (loop (1- i) (cons (cons i i) r))))
 761    (let (r) (_)
 762         ((apply (primitive list)
 763                 (apply (primitive cons) (const 3) (const 3))))
 764         (let (r) (_)
 765              ((apply (primitive cons)
 766                      (apply (primitive cons) (const 2) (const 2))
 767                      (lexical r _)))
 768              (apply (primitive cons)
 769                     (apply (primitive cons) (const 1) (const 1))
 770                     (lexical r _)))))
 771
 772   ;; See above.
 773   (pass-if-peval
 774    (let loop ((i 4)
 775               (r '()))
 776      (if (<= i 0)
 777          (car r)
 778          (loop (1- i) (cons i r))))
 779    (let (r) (_)
 780         ((apply (primitive list) (const 4)))
 781         (let (r) (_)
 782              ((apply (primitive cons)
 783                      (const 3)
 784                      (lexical r _)))
 785              (let (r) (_)
 786                   ((apply (primitive cons)
 787                           (const 2)
 788                           (lexical r _)))
 789                   (let (r) (_)
 790                        ((apply (primitive cons)
 791                                (const 1)
 792                                (lexical r _)))
 793                        (apply (primitive car)
 794                               (lexical r _)))))))
 795
 796    ;; Static sums.
 797   (pass-if-peval
 798    (let loop ((l '(1 2 3 4)) (sum 0))
 799      (if (null? l)
 800          sum
 801          (loop (cdr l) (+ sum (car l)))))
 802    (const 10))
 803
 804   (pass-if-peval resolve-primitives
 805    (let ((string->chars
 806           (lambda (s)
 807             (define (char-at n)
 808               (string-ref s n))
 809             (define (len)
 810               (string-length s))
 811             (let loop ((i 0))
 812               (if (< i (len))
 813                   (cons (char-at i)
 814                         (loop (1+ i)))
 815                   '())))))
 816      (string->chars "yo"))
 817    (apply (primitive list) (const #\y) (const #\o)))
 818
 819   (pass-if-peval
 820     ;; Primitives in module-refs are resolved (the expansion of `pmatch'
 821     ;; below leads to calls to (@@ (system base pmatch) car) and
 822     ;; similar, which is what we want to be inlined.)
 823     (begin
 824       (use-modules (system base pmatch))
 825       (pmatch '(a b c d)
 826         ((a b . _)
 827          #t)))
 828     (begin
 829       (apply . _)
 830       (const #t)))
 831
 832   (pass-if-peval
 833    ;; Mutability preserved.
 834    ((lambda (x y z) (list x y z)) 1 2 3)
 835    (apply (primitive list) (const 1) (const 2) (const 3)))
 836
 837   (pass-if-peval
 838    ;; Don't propagate effect-free expressions that operate on mutable
 839    ;; objects.
 840    (let* ((x (list 1))
 841           (y (car x)))
 842      (set-car! x 0)
 843      y)
 844    (let (x) (_) ((apply (primitive list) (const 1)))
 845         (let (y) (_) ((apply (primitive car) (lexical x _)))
 846              (begin
 847                (apply (toplevel set-car!) (lexical x _) (const 0))
 848                (lexical y _)))))
 849
 850   (pass-if-peval
 851    ;; Don't propagate effect-free expressions that operate on objects we
 852    ;; don't know about.
 853    (let ((y (car x)))
 854      (set-car! x 0)
 855      y)
 856    (let (y) (_) ((apply (primitive car) (toplevel x)))
 857         (begin
 858           (apply (toplevel set-car!) (toplevel x) (const 0))
 859           (lexical y _))))
 860
 861   (pass-if-peval
 862    ;; Infinite recursion
 863    ((lambda (x) (x x)) (lambda (x) (x x)))
 864    (let (x) (_)
 865         ((lambda _
 866            (lambda-case
 867             (((x) _ _ _ _ _)
 868              (apply (lexical x _) (lexical x _))))))
 869         (apply (lexical x _) (lexical x _))))
 870
 871   (pass-if-peval
 872     ;; First order, aliased primitive.
 873     (let* ((x *) (y (x 1 2))) y)
 874     (const 2))
 875
 876   (pass-if-peval
 877     ;; First order, shadowed primitive.
 878     (begin
 879       (define (+ x y) (pk x y))
 880       (+ 1 2))
 881     (begin
 882       (define +
 883         (lambda (_)
 884           (lambda-case
 885            (((x y) #f #f #f () (_ _))
 886             (apply (toplevel pk) (lexical x _) (lexical y _))))))
 887       (apply (toplevel +) (const 1) (const 2))))
 888
 889   (pass-if-peval
 890     ;; First-order, effects preserved.
 891     (let ((x 2))
 892       (do-something!)
 893       x)
 894     (begin
 895       (apply (toplevel do-something!))
 896       (const 2)))
 897
 898   (pass-if-peval
 899     ;; First order, residual bindings removed.
 900     (let ((x 2) (y 3))
 901       (* (+ x y) z))
 902     (apply (primitive *) (const 5) (toplevel z)))
 903
 904   (pass-if-peval
 905     ;; First order, with lambda.
 906     (define (foo x)
 907       (define (bar z) (* z z))
 908       (+ x (bar 3)))
 909     (define foo
 910       (lambda (_)
 911         (lambda-case
 912          (((x) #f #f #f () (_))
 913           (apply (primitive +) (lexical x _) (const 9)))))))
 914
 915   (pass-if-peval
 916     ;; First order, with lambda inlined & specialized twice.
 917     (let ((f (lambda (x y)
 918                (+ (* x top) y)))
 919           (x 2)
 920           (y 3))
 921       (+ (* x (f x y))
 922          (f something x)))
 923     (apply (primitive +)
 924            (apply (primitive *)
 925                   (const 2)
 926                   (apply (primitive +)  ; (f 2 3)
 927                          (apply (primitive *)
 928                                 (const 2)
 929                                 (toplevel top))
 930                          (const 3)))
 931            (let (x) (_) ((toplevel something))                    ; (f something 2)
 932                 ;; `something' is not const, so preserve order of
 933                 ;; effects with a lexical binding.
 934                 (apply (primitive +)
 935                        (apply (primitive *)
 936                               (lexical x _)
 937                               (toplevel top))
 938                        (const 2)))))
 939
 940   (pass-if-peval
 941    ;; First order, with lambda inlined & specialized 3 times.
 942    (let ((f (lambda (x y) (if (> x 0) y x))))
 943      (+ (f -1 0)
 944         (f 1 0)
 945         (f -1 y)
 946         (f 2 y)
 947         (f z y)))
 948    (apply (primitive +)
 949           (const -1)                      ; (f -1 0)
 950           (const 0)                       ; (f 1 0)
 951           (begin (toplevel y) (const -1)) ; (f -1 y)
 952           (toplevel y)                    ; (f 2 y)
 953           (let (x y) (_ _) ((toplevel z) (toplevel y)) ; (f z y)
 954                (if (apply (primitive >) (lexical x _) (const 0))
 955                    (lexical y _)
 956                    (lexical x _)))))
 957
 958   (pass-if-peval
 959     ;; First order, conditional.
 960     (let ((y 2))
 961       (lambda (x)
 962         (if (> y 0)
 963             (display x)
 964             'never-reached)))
 965     (lambda ()
 966       (lambda-case
 967        (((x) #f #f #f () (_))
 968         (apply (toplevel display) (lexical x _))))))
 969
 970   (pass-if-peval
 971     ;; First order, recursive procedure.
 972     (letrec ((fibo (lambda (n)
 973                      (if (<= n 1)
 974                          n
 975                          (+ (fibo (- n 1))
 976                             (fibo (- n 2)))))))
 977       (fibo 4))
 978     (const 3))
 979
 980   (pass-if-peval
 981    ;; Don't propagate toplevel references, as intervening expressions
 982    ;; could alter their bindings.
 983    (let ((x top))
 984      (foo)
 985      x)
 986    (let (x) (_) ((toplevel top))
 987         (begin
 988           (apply (toplevel foo))
 989           (lexical x _))))
 990
 991   (pass-if-peval
 992     ;; Higher order.
 993     ((lambda (f x)
 994        (f (* (car x) (cadr x))))
 995      (lambda (x)
 996        (+ x 1))
 997      '(2 3))
 998     (const 7))
 999
1000   (pass-if-peval
1001     ;; Higher order with optional argument (default value).
1002     ((lambda* (f x #:optional (y 0))
1003        (+ y (f (* (car x) (cadr x)))))
1004      (lambda (x)
1005        (+ x 1))
1006      '(2 3))
1007     (const 7))
1008
1009   (pass-if-peval
1010     ;; Higher order with optional argument (caller-supplied value).
1011     ((lambda* (f x #:optional (y 0))
1012        (+ y (f (* (car x) (cadr x)))))
1013      (lambda (x)
1014        (+ x 1))
1015      '(2 3)
1016      35)
1017     (const 42))
1018
1019   (pass-if-peval
1020     ;; Higher order with optional argument (side-effecting default
1021     ;; value).
1022     ((lambda* (f x #:optional (y (foo)))
1023        (+ y (f (* (car x) (cadr x)))))
1024      (lambda (x)
1025        (+ x 1))
1026      '(2 3))
1027     (let (y) (_) ((apply (toplevel foo)))
1028          (apply (primitive +) (lexical y _) (const 7))))
1029
1030   (pass-if-peval
1031     ;; Higher order with optional argument (caller-supplied value).
1032     ((lambda* (f x #:optional (y (foo)))
1033        (+ y (f (* (car x) (cadr x)))))
1034      (lambda (x)
1035        (+ x 1))
1036      '(2 3)
1037      35)
1038     (const 42))
1039
1040   (pass-if-peval
1041     ;; Higher order.
1042     ((lambda (f) (f x)) (lambda (x) x))
1043     (toplevel x))
1044
1045   (pass-if-peval
1046     ;; Bug reported at
1047     ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>.
1048     (let ((fold (lambda (f g) (f (g top)))))
1049       (fold 1+ (lambda (x) x)))
1050     (apply (primitive 1+) (toplevel top)))
1051
1052   (pass-if-peval
1053     ;; Procedure not inlined when residual code contains recursive calls.
1054     ;; <http://debbugs.gnu.org/9542>
1055     (letrec ((fold (lambda (f x3 b null? car cdr)
1056                      (if (null? x3)
1057                          b
1058                          (f (car x3) (fold f (cdr x3) b null? car cdr))))))
1059       (fold * x 1 zero? (lambda (x1) x1) (lambda (x2) (- x2 1))))
1060     (letrec (fold) (_) (_)
1061             (apply (lexical fold _)
1062                    (primitive *)
1063                    (toplevel x)
1064                    (const 1)
1065                    (primitive zero?)
1066                    (lambda ()
1067                      (lambda-case
1068                       (((x1) #f #f #f () (_))
1069                        (lexical x1 _))))
1070                    (lambda ()
1071                      (lambda-case
1072                       (((x2) #f #f #f () (_))
1073                        (apply (primitive -) (lexical x2 _) (const 1))))))))
1074
1075   (pass-if "inlined lambdas are alpha-renamed"
1076     ;; In this example, `make-adder' is inlined more than once; thus,
1077     ;; they should use different gensyms for their arguments, because
1078     ;; the various optimization passes assume uniquely-named variables.
1079     ;;
1080     ;; Bug reported at
1081     ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html> and
1082     ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00029.html>.
1083     (pmatch (unparse-tree-il
1084              (peval (compile
1085                      '(let ((make-adder
1086                              (lambda (x) (lambda (y) (+ x y)))))
1087                         (cons (make-adder 1) (make-adder 2)))
1088                      #:to 'tree-il)))
1089       ((apply (primitive cons)
1090               (lambda ()
1091                 (lambda-case
1092                  (((y) #f #f #f () (,gensym1))
1093                   (apply (primitive +)
1094                          (const 1)
1095                          (lexical y ,ref1)))))
1096               (lambda ()
1097                 (lambda-case
1098                  (((y) #f #f #f () (,gensym2))
1099                   (apply (primitive +)
1100                          (const 2)
1101                          (lexical y ,ref2))))))
1102        (and (eq? gensym1 ref1)
1103             (eq? gensym2 ref2)
1104             (not (eq? gensym1 gensym2))))
1105       (_ #f)))
1106
1107   (pass-if-peval
1108    ;; Unused letrec bindings are pruned.
1109    (letrec ((a (lambda () (b)))
1110             (b (lambda () (a)))
1111             (c (lambda (x) x)))
1112      (c 10))
1113    (const 10))
1114
1115   (pass-if-peval
1116    ;; Unused letrec bindings are pruned.
1117    (letrec ((a (foo!))
1118             (b (lambda () (a)))
1119             (c (lambda (x) x)))
1120      (c 10))
1121    (begin (apply (toplevel foo!))
1122           (const 10)))
1123
1124   (pass-if-peval
1125     ;; Higher order, mutually recursive procedures.
1126     (letrec ((even? (lambda (x)
1127                       (or (= 0 x)
1128                           (odd? (- x 1)))))
1129              (odd?  (lambda (x)
1130                       (not (even? x)))))
1131       (and (even? 4) (odd? 7)))
1132     (const #t))
1133
1134   (pass-if-peval
1135     ;; Memv with constants.
1136     (memv 1 '(3 2 1))
1137     (const '(1)))
1138
1139   (pass-if-peval
1140     ;; Memv with non-constant list.  It could fold but doesn't
1141     ;; currently.
1142     (memv 1 (list 3 2 1))
1143     (apply (primitive memv)
1144            (const 1)
1145            (apply (primitive list) (const 3) (const 2) (const 1))))
1146
1147   (pass-if-peval
1148     ;; Memv with non-constant key, constant list, test context
1149     (case foo
1150       ((3 2 1) 'a)
1151       (else 'b))
1152     (let (key) (_) ((toplevel foo))
1153          (if (if (apply (primitive eqv?) (lexical key _) (const 3))
1154                  (const #t)
1155                  (if (apply (primitive eqv?) (lexical key _) (const 2))
1156                      (const #t)
1157                      (apply (primitive eqv?) (lexical key _) (const 1))))
1158              (const a)
1159              (const b))))
1160
1161   (pass-if-peval
1162     ;; Memv with non-constant key, empty list, test context.  Currently
1163     ;; doesn't fold entirely.
1164     (case foo
1165       (() 'a)
1166       (else 'b))
1167     (begin (toplevel foo) (const b)))
1168
1169   ;;
1170   ;; Below are cases where constant propagation should bail out.
1171   ;;
1172
1173   (pass-if-peval
1174     ;; Non-constant lexical is not propagated.
1175     (let ((v (make-vector 6 #f)))
1176       (lambda (n)
1177         (vector-set! v n n)))
1178     (let (v) (_)
1179          ((apply (toplevel make-vector) (const 6) (const #f)))
1180          (lambda ()
1181            (lambda-case
1182             (((n) #f #f #f () (_))
1183              (apply (toplevel vector-set!)
1184                     (lexical v _) (lexical n _) (lexical n _)))))))
1185
1186   (pass-if-peval
1187     ;; Mutable lexical is not propagated.
1188     (let ((v (vector 1 2 3)))
1189       (lambda ()
1190         v))
1191     (let (v) (_)
1192          ((apply (primitive vector) (const 1) (const 2) (const 3)))
1193          (lambda ()
1194            (lambda-case
1195             ((() #f #f #f () ())
1196              (lexical v _))))))
1197
1198   (pass-if-peval
1199     ;; Lexical that is not provably pure is not inlined nor propagated.
1200     (let* ((x (if (> p q) (frob!) (display 'chbouib)))
1201            (y (* x 2)))
1202       (+ x x y))
1203     (let (x) (_) ((if (apply (primitive >) (toplevel p) (toplevel q))
1204                       (apply (toplevel frob!))
1205                       (apply (toplevel display) (const chbouib))))
1206          (let (y) (_) ((apply (primitive *) (lexical x _) (const 2)))
1207               (apply (primitive +)
1208                      (lexical x _) (lexical x _) (lexical y _)))))
1209
1210   (pass-if-peval
1211     ;; Non-constant arguments not propagated to lambdas.
1212     ((lambda (x y z)
1213        (vector-set! x 0 0)
1214        (set-car! y 0)
1215        (set-cdr! z '()))
1216      (vector 1 2 3)
1217      (make-list 10)
1218      (list 1 2 3))
1219     (let (x y z) (_ _ _)
1220          ((apply (primitive vector) (const 1) (const 2) (const 3))
1221           (apply (toplevel make-list) (const 10))
1222           (apply (primitive list) (const 1) (const 2) (const 3)))
1223          (begin
1224            (apply (toplevel vector-set!)
1225                   (lexical x _) (const 0) (const 0))
1226            (apply (toplevel set-car!)
1227                   (lexical y _) (const 0))
1228            (apply (toplevel set-cdr!)
1229                   (lexical z _) (const ())))))
1230
1231   (pass-if-peval
1232    (let ((foo top-foo) (bar top-bar))
1233      (let* ((g (lambda (x y) (+ x y)))
1234             (f (lambda (g x) (g x x))))
1235        (+ (f g foo) (f g bar))))
1236    (let (foo bar) (_ _) ((toplevel top-foo) (toplevel top-bar))
1237         (apply (primitive +)
1238                (apply (primitive +) (lexical foo _) (lexical foo _))
1239                (apply (primitive +) (lexical bar _) (lexical bar _)))))
1240
1241   (pass-if-peval
1242     ;; Fresh objects are not turned into constants, nor are constants
1243     ;; turned into fresh objects.
1244     (let* ((c '(2 3))
1245            (x (cons 1 c))
1246            (y (cons 0 x)))
1247       y)
1248     (let (x) (_) ((apply (primitive cons) (const 1) (const (2 3))))
1249          (apply (primitive cons) (const 0) (lexical x _))))
1250
1251   (pass-if-peval
1252     ;; Bindings mutated.
1253     (let ((x 2))
1254       (set! x 3)
1255       x)
1256     (let (x) (_) ((const 2))
1257          (begin
1258            (set! (lexical x _) (const 3))
1259            (lexical x _))))
1260
1261   (pass-if-peval
1262     ;; Bindings mutated.
1263     (letrec ((x 0)
1264              (f (lambda ()
1265                   (set! x (+ 1 x))
1266                   x)))
1267       (frob f) ; may mutate `x'
1268       x)
1269     (letrec (x) (_) ((const 0))
1270             (begin
1271               (apply (toplevel frob) (lambda _ _))
1272               (lexical x _))))
1273
1274   (pass-if-peval
1275     ;; Bindings mutated.
1276     (letrec ((f (lambda (x)
1277                   (set! f (lambda (_) x))
1278                   x)))
1279       (f 2))
1280     (letrec _ . _))
1281
1282   (pass-if-peval
1283     ;; Bindings possibly mutated.
1284     (let ((x (make-foo)))
1285       (frob! x) ; may mutate `x'
1286       x)
1287     (let (x) (_) ((apply (toplevel make-foo)))
1288          (begin
1289            (apply (toplevel frob!) (lexical x _))
1290            (lexical x _))))
1291
1292   (pass-if-peval
1293     ;; Inlining stops at recursive calls with dynamic arguments.
1294     (let loop ((x x))
1295       (if (< x 0) x (loop (1- x))))
1296     (letrec (loop) (_) ((lambda (_)
1297                           (lambda-case
1298                            (((x) #f #f #f () (_))
1299                             (if _ _
1300                                 (apply (lexical loop _)
1301                                        (apply (primitive 1-)
1302                                               (lexical x _))))))))
1303             (apply (lexical loop _) (toplevel x))))
1304
1305   (pass-if-peval
1306     ;; Recursion on the 2nd argument is fully evaluated.
1307     (let ((x (top)))
1308       (let loop ((x x) (y 10))
1309         (if (> y 0)
1310             (loop x (1- y))
1311             (foo x y))))
1312     (let (x) (_) ((apply (toplevel top)))
1313          (apply (toplevel foo) (lexical x _) (const 0))))
1314
1315   (pass-if-peval
1316     ;; Inlining aborted when residual code contains recursive calls.
1317     ;;
1318     ;; <http://debbugs.gnu.org/9542>
1319     (let loop ((x x) (y 0))
1320       (if (> y 0)
1321           (loop (1- x) (1- y))
1322           (if (< x 0)
1323               x
1324               (loop (1+ x) (1+ y)))))
1325     (letrec (loop) (_) ((lambda (_)
1326                           (lambda-case
1327                            (((x y) #f #f #f () (_ _))
1328                             (if (apply (primitive >)
1329                                        (lexical y _) (const 0))
1330                                 _ _)))))
1331             (apply (lexical loop _) (toplevel x) (const 0))))
1332
1333   (pass-if-peval
1334     ;; Infinite recursion: `peval' gives up and leaves it as is.
1335     (letrec ((f (lambda (x) (g (1- x))))
1336              (g (lambda (x) (h (1+ x))))
1337              (h (lambda (x) (f x))))
1338       (f 0))
1339     (letrec _ . _))
1340
1341   (pass-if-peval
1342     ;; Infinite recursion: all the arguments to `loop' are static, but
1343     ;; unrolling it would lead `peval' to enter an infinite loop.
1344     (let loop ((x 0))
1345       (and (< x top)
1346            (loop (1+ x))))
1347     (letrec (loop) (_) ((lambda . _))
1348             (apply (lexical loop _) (const 0))))
1349
1350   (pass-if-peval
1351     ;; This test checks that the `start' binding is indeed residualized.
1352     ;; See the `referenced?' procedure in peval's `prune-bindings'.
1353     (let ((pos 0))
1354       (set! pos 1) ;; Cause references to `pos' to residualize.
1355       (let ((here (let ((start pos)) (lambda () start))))
1356         (here)))
1357     (let (pos) (_) ((const 0))
1358          (begin
1359            (set! (lexical pos _) (const 1))
1360            (let (here) (_) (_)
1361                 (apply (lexical here _))))))
1362
1363   (pass-if-peval
1364    ;; FIXME: should this one residualize the binding?
1365    (letrec ((a a))
1366      1)
1367    (const 1))
1368
1369   (pass-if-peval
1370    ;; This is a fun one for peval to handle.
1371    (letrec ((a a))
1372      a)
1373    (letrec (a) (_) ((lexical a _))
1374            (lexical a _)))
1375
1376   (pass-if-peval
1377    ;; Another interesting recursive case.
1378    (letrec ((a b) (b a))
1379      a)
1380    (letrec (a) (_) ((lexical a _))
1381            (lexical a _)))
1382
1383   (pass-if-peval
1384    ;; Another pruning case, that `a' is residualized.
1385    (letrec ((a (lambda () (a)))
1386             (b (lambda () (a)))
1387             (c (lambda (x) x)))
1388      (let ((d (foo b)))
1389        (c d)))
1390
1391    ;; "b c a" is the current order that we get with unordered letrec,
1392    ;; but it's not important to this test, so if it changes, just adapt
1393    ;; the test.
1394    (letrec (b c a) (_ _ _)
1395      ((lambda _
1396         (lambda-case
1397          ((() #f #f #f () ())
1398           (apply (lexical a _)))))
1399       (lambda _
1400         (lambda-case
1401          (((x) #f #f #f () (_))
1402           (lexical x _))))
1403       (lambda _
1404         (lambda-case
1405          ((() #f #f #f () ())
1406           (apply (lexical a _))))))
1407      (let (d)
1408        (_)
1409        ((apply (toplevel foo) (lexical b _)))
1410        (apply (lexical c _)
1411               (lexical d _)))))
1412
1413   (pass-if-peval
1414    ;; In this case, we can prune the bindings.  `a' ends up being copied
1415    ;; because it is only referenced once in the source program.  Oh
1416    ;; well.
1417    (letrec* ((a (lambda (x) (top x)))
1418              (b (lambda () a)))
1419      (foo (b) (b)))
1420    (apply (toplevel foo)
1421           (lambda _
1422             (lambda-case
1423              (((x) #f #f #f () (_))
1424               (apply (toplevel top) (lexical x _)))))
1425           (lambda _
1426             (lambda-case
1427              (((x) #f #f #f () (_))
1428               (apply (toplevel top) (lexical x _)))))))
1429
1430   (pass-if-peval
1431    ;; Constant folding: cons of #nil does not make list
1432    (cons 1 #nil)
1433    (apply (primitive cons) (const 1) (const '#nil)))
1434
1435   (pass-if-peval
1436     ;; Constant folding: cons
1437    (begin (cons 1 2) #f)
1438    (const #f))
1439
1440   (pass-if-peval
1441     ;; Constant folding: cons
1442    (begin (cons (foo) 2) #f)
1443    (begin (apply (toplevel foo)) (const #f)))
1444
1445   (pass-if-peval
1446     ;; Constant folding: cons
1447    (if (cons 0 0) 1 2)
1448    (const 1))
1449
1450   (pass-if-peval
1451    ;; Constant folding: car+cons
1452    (car (cons 1 0))
1453    (const 1))
1454
1455   (pass-if-peval
1456    ;; Constant folding: cdr+cons
1457    (cdr (cons 1 0))
1458    (const 0))
1459
1460   (pass-if-peval
1461    ;; Constant folding: car+cons, impure
1462    (car (cons 1 (bar)))
1463    (begin (apply (toplevel bar)) (const 1)))
1464
1465   (pass-if-peval
1466    ;; Constant folding: cdr+cons, impure
1467    (cdr (cons (bar) 0))
1468    (begin (apply (toplevel bar)) (const 0)))
1469
1470   (pass-if-peval
1471    ;; Constant folding: car+list
1472    (car (list 1 0))
1473    (const 1))
1474
1475   (pass-if-peval
1476    ;; Constant folding: cdr+list
1477    (cdr (list 1 0))
1478    (apply (primitive list) (const 0)))
1479
1480   (pass-if-peval
1481    ;; Constant folding: car+list, impure
1482    (car (list 1 (bar)))
1483    (begin (apply (toplevel bar)) (const 1)))
1484
1485   (pass-if-peval
1486    ;; Constant folding: cdr+list, impure
1487    (cdr (list (bar) 0))
1488    (begin (apply (toplevel bar)) (apply (primitive list) (const 0))))
1489
1490   (pass-if-peval
1491    resolve-primitives
1492    ;; Non-constant guards get lexical bindings.
1493    (dynamic-wind foo (lambda () bar) baz)
1494    (let (pre post) (_ _) ((toplevel foo) (toplevel baz))
1495         (dynwind (lexical pre _) (toplevel bar) (lexical post _))))
1496
1497   (pass-if-peval
1498    resolve-primitives
1499    ;; Constant guards don't need lexical bindings.
1500    (dynamic-wind (lambda () foo) (lambda () bar) (lambda () baz))
1501    (dynwind
1502     (lambda ()
1503       (lambda-case
1504        ((() #f #f #f () ()) (toplevel foo))))
1505     (toplevel bar)
1506     (lambda ()
1507       (lambda-case
1508        ((() #f #f #f () ()) (toplevel baz))))))
1509
1510   (pass-if-peval
1511    resolve-primitives
1512    ;; Prompt is removed if tag is unreferenced
1513    (let ((tag (make-prompt-tag)))
1514      (call-with-prompt tag
1515                        (lambda () 1)
1516                        (lambda args args)))
1517    (const 1))
1518
1519   (pass-if-peval
1520    resolve-primitives
1521    ;; Prompt is removed if tag is unreferenced, with explicit stem
1522    (let ((tag (make-prompt-tag "foo")))
1523      (call-with-prompt tag
1524                        (lambda () 1)
1525                        (lambda args args)))
1526    (const 1))
1527
1528   ;; Handler lambda inlined
1529   (pass-if-peval
1530    resolve-primitives
1531    (call-with-prompt tag
1532                      (lambda () 1)
1533                      (lambda (k x) x))
1534    (prompt (toplevel tag)
1535            (const 1)
1536            (lambda-case
1537             (((k x) #f #f #f () (_ _))
1538              (lexical x _)))))
1539
1540   ;; Handler toplevel not inlined
1541   (pass-if-peval
1542    resolve-primitives
1543    (call-with-prompt tag
1544                      (lambda () 1)
1545                      handler)
1546    (let (handler) (_) ((toplevel handler))
1547         (prompt (toplevel tag)
1548                 (const 1)
1549                 (lambda-case
1550                  ((() #f args #f () (_))
1551                   (apply (primitive @apply)
1552                          (lexical handler _)
1553                          (lexical args _)))))))
1554
1555   (pass-if-peval
1556    resolve-primitives
1557    ;; `while' without `break' or `continue' has no prompts and gets its
1558    ;; condition folded.  Unfortunately the outer `lp' does not yet get
1559    ;; elided.
1560    (while #t #t)
1561    (letrec (lp) (_)
1562            ((lambda _
1563               (lambda-case
1564                ((() #f #f #f () ())
1565                 (letrec (loop) (_)
1566                         ((lambda _
1567                            (lambda-case
1568                             ((() #f #f #f () ())
1569                              (apply (lexical loop _))))))
1570                         (apply (lexical loop _)))))))
1571            (apply (lexical lp _))))
1572
1573   (pass-if-peval
1574    resolve-primitives
1575    (lambda (a . rest)
1576      (apply (lambda (x y) (+ x y))
1577             a rest))
1578    (lambda _
1579      (lambda-case
1580       (((x y) #f #f #f () (_ _))
1581        _))))
1582
1583   (pass-if-peval resolve-primitives
1584    ((@ (guile) car) '(1 2))
1585    (const 1))
1586
1587   (pass-if-peval resolve-primitives
1588    ((@@ (guile) car) '(1 2))
1589    (const 1)))
1590
1591
1592 \f
1593 (with-test-prefix "tree-il-fold"
1594
1595   (pass-if "empty tree"
1596     (let ((leaf? #f) (up? #f) (down? #f) (mark (list 'mark)))
1597       (and (eq? mark
1598                 (tree-il-fold (lambda (x y) (set! leaf? #t) y)
1599                               (lambda (x y) (set! down? #t) y)
1600                               (lambda (x y) (set! up? #t) y)
1601                               mark
1602                               '()))
1603            (not leaf?)
1604            (not up?)
1605            (not down?))))
1606
1607   (pass-if "lambda and application"
1608     (let* ((leaves '()) (ups '()) (downs '())
1609            (result (tree-il-fold (lambda (x y)
1610                                    (set! leaves (cons x leaves))
1611                                    (1+ y))
1612                                  (lambda (x y)
1613                                    (set! downs (cons x downs))
1614                                    (1+ y))
1615                                  (lambda (x y)
1616                                    (set! ups (cons x ups))
1617                                    (1+ y))
1618                                  0
1619                                  (parse-tree-il
1620                                   '(lambda ()
1621                                      (lambda-case
1622                                       (((x y) #f #f #f () (x1 y1))
1623                                        (apply (toplevel +)
1624                                               (lexical x x1)
1625                                               (lexical y y1)))
1626                                       #f))))))
1627       (and (equal? (map strip-source leaves)
1628                    (list (make-lexical-ref #f 'y 'y1)
1629                          (make-lexical-ref #f 'x 'x1)
1630                          (make-toplevel-ref #f '+)))
1631            (= (length downs) 3)
1632            (equal? (reverse (map strip-source ups))
1633                    (map strip-source downs))))))
1634
1635 \f
1636 ;;;
1637 ;;; Warnings.
1638 ;;;
1639
1640 ;; Make sure we get English messages.
1641 (setlocale LC_ALL "C")
1642
1643 (define (call-with-warnings thunk)
1644   (let ((port (open-output-string)))
1645     (with-fluids ((*current-warning-port*   port)
1646                   (*current-warning-prefix* ""))
1647       (thunk))
1648     (let ((warnings (get-output-string port)))
1649       (string-tokenize warnings
1650                        (char-set-complement (char-set #\newline))))))
1651
1652 (define %opts-w-unused
1653   '(#:warnings (unused-variable)))
1654
1655 (define %opts-w-unused-toplevel
1656   '(#:warnings (unused-toplevel)))
1657
1658 (define %opts-w-unbound
1659   '(#:warnings (unbound-variable)))
1660
1661 (define %opts-w-arity
1662   '(#:warnings (arity-mismatch)))
1663
1664 (define %opts-w-format
1665   '(#:warnings (format)))
1666
1667
1668 (with-test-prefix "warnings"
1669
1670    (pass-if "unknown warning type"
1671      (let ((w (call-with-warnings
1672                 (lambda ()
1673                   (compile #t #:opts '(#:warnings (does-not-exist)))))))
1674        (and (= (length w) 1)
1675             (number? (string-contains (car w) "unknown warning")))))
1676
1677    (with-test-prefix "unused-variable"
1678
1679      (pass-if "quiet"
1680        (null? (call-with-warnings
1681                 (lambda ()
1682                   (compile '(lambda (x y) (+ x y))
1683                            #:opts %opts-w-unused)))))
1684
1685      (pass-if "let/unused"
1686        (let ((w (call-with-warnings
1687                   (lambda ()
1688                     (compile '(lambda (x)
1689                                 (let ((y (+ x 2)))
1690                                   x))
1691                              #:opts %opts-w-unused)))))
1692          (and (= (length w) 1)
1693               (number? (string-contains (car w) "unused variable `y'")))))
1694
1695      (pass-if "shadowed variable"
1696        (let ((w (call-with-warnings
1697                   (lambda ()
1698                     (compile '(lambda (x)
1699                                 (let ((y x))
1700                                   (let ((y (+ x 2)))
1701                                     (+ x y))))
1702                              #:opts %opts-w-unused)))))
1703          (and (= (length w) 1)
1704               (number? (string-contains (car w) "unused variable `y'")))))
1705
1706      (pass-if "letrec"
1707        (null? (call-with-warnings
1708                 (lambda ()
1709                   (compile '(lambda ()
1710                               (letrec ((x (lambda () (y)))
1711                                        (y (lambda () (x))))
1712                                 y))
1713                            #:opts %opts-w-unused)))))
1714
1715      (pass-if "unused argument"
1716        ;; Unused arguments should not be reported.
1717        (null? (call-with-warnings
1718                 (lambda ()
1719                   (compile '(lambda (x y z) #t)
1720                            #:opts %opts-w-unused)))))
1721
1722      (pass-if "special variable names"
1723        (null? (call-with-warnings
1724                 (lambda ()
1725                   (compile '(lambda ()
1726                               (let ((_ 'underscore)
1727                                     (#{gensym name}# 'ignore-me))
1728                                 #t))
1729                            #:to 'assembly
1730                            #:opts %opts-w-unused))))))
1731
1732    (with-test-prefix "unused-toplevel"
1733
1734      (pass-if "used after definition"
1735        (null? (call-with-warnings
1736                 (lambda ()
1737                   (let ((in (open-input-string
1738                              "(define foo 2) foo")))
1739                     (read-and-compile in
1740                                       #:to 'assembly
1741                                       #:opts %opts-w-unused-toplevel))))))
1742
1743      (pass-if "used before definition"
1744        (null? (call-with-warnings
1745                 (lambda ()
1746                   (let ((in (open-input-string
1747                              "(define (bar) foo) (define foo 2) (bar)")))
1748                     (read-and-compile in
1749                                       #:to 'assembly
1750                                       #:opts %opts-w-unused-toplevel))))))
1751
1752      (pass-if "unused but public"
1753        (let ((in (open-input-string
1754                   "(define-module (test-suite tree-il x) #:export (bar))
1755                    (define (bar) #t)")))
1756          (null? (call-with-warnings
1757                   (lambda ()
1758                     (read-and-compile in
1759                                       #:to 'assembly
1760                                       #:opts %opts-w-unused-toplevel))))))
1761
1762      (pass-if "unused but public (more)"
1763        (let ((in (open-input-string
1764                   "(define-module (test-suite tree-il x) #:export (bar))
1765                    (define (bar) (baz))
1766                    (define (baz) (foo))
1767                    (define (foo) #t)")))
1768          (null? (call-with-warnings
1769                   (lambda ()
1770                     (read-and-compile in
1771                                       #:to 'assembly
1772                                       #:opts %opts-w-unused-toplevel))))))
1773
1774      (pass-if "unused but define-public"
1775        (null? (call-with-warnings
1776                 (lambda ()
1777                   (compile '(define-public foo 2)
1778                            #:to 'assembly
1779                            #:opts %opts-w-unused-toplevel)))))
1780
1781      (pass-if "used by macro"
1782        ;; FIXME: See comment about macros at `unused-toplevel-analysis'.
1783        (throw 'unresolved)
1784
1785        (null? (call-with-warnings
1786                 (lambda ()
1787                   (let ((in (open-input-string
1788                              "(define (bar) 'foo)
1789                               (define-syntax baz
1790                                 (syntax-rules () ((_) (bar))))")))
1791                     (read-and-compile in
1792                                       #:to 'assembly
1793                                       #:opts %opts-w-unused-toplevel))))))
1794
1795      (pass-if "unused"
1796        (let ((w (call-with-warnings
1797                   (lambda ()
1798                     (compile '(define foo 2)
1799                              #:to 'assembly
1800                              #:opts %opts-w-unused-toplevel)))))
1801          (and (= (length w) 1)
1802               (number? (string-contains (car w)
1803                                         (format #f "top-level variable `~A'"
1804                                                 'foo))))))
1805
1806      (pass-if "unused recursive"
1807        (let ((w (call-with-warnings
1808                   (lambda ()
1809                     (compile '(define (foo) (foo))
1810                              #:to 'assembly
1811                              #:opts %opts-w-unused-toplevel)))))
1812          (and (= (length w) 1)
1813               (number? (string-contains (car w)
1814                                         (format #f "top-level variable `~A'"
1815                                                 'foo))))))
1816
1817      (pass-if "unused mutually recursive"
1818        (let* ((in (open-input-string
1819                    "(define (foo) (bar)) (define (bar) (foo))"))
1820               (w  (call-with-warnings
1821                     (lambda ()
1822                       (read-and-compile in
1823                                         #:to 'assembly
1824                                         #:opts %opts-w-unused-toplevel)))))
1825          (and (= (length w) 2)
1826               (number? (string-contains (car w)
1827                                         (format #f "top-level variable `~A'"
1828                                                 'foo)))
1829               (number? (string-contains (cadr w)
1830                                         (format #f "top-level variable `~A'"
1831                                                 'bar))))))
1832
1833      (pass-if "special variable names"
1834        (null? (call-with-warnings
1835                 (lambda ()
1836                   (compile '(define #{gensym name}# 'ignore-me)
1837                            #:to 'assembly
1838                            #:opts %opts-w-unused-toplevel))))))
1839
1840    (with-test-prefix "unbound variable"
1841
1842      (pass-if "quiet"
1843        (null? (call-with-warnings
1844                 (lambda ()
1845                   (compile '+ #:opts %opts-w-unbound)))))
1846
1847      (pass-if "ref"
1848        (let* ((v (gensym))
1849               (w (call-with-warnings
1850                    (lambda ()
1851                      (compile v
1852                               #:to 'assembly
1853                               #:opts %opts-w-unbound)))))
1854          (and (= (length w) 1)
1855               (number? (string-contains (car w)
1856                                         (format #f "unbound variable `~A'"
1857                                                 v))))))
1858
1859      (pass-if "set!"
1860        (let* ((v (gensym))
1861               (w (call-with-warnings
1862                    (lambda ()
1863                      (compile `(set! ,v 7)
1864                               #:to 'assembly
1865                               #:opts %opts-w-unbound)))))
1866          (and (= (length w) 1)
1867               (number? (string-contains (car w)
1868                                         (format #f "unbound variable `~A'"
1869                                                 v))))))
1870
1871      (pass-if "module-local top-level is visible"
1872        (let ((m (make-module))
1873              (v (gensym)))
1874          (beautify-user-module! m)
1875          (compile `(define ,v 123)
1876                   #:env m #:opts %opts-w-unbound)
1877          (null? (call-with-warnings
1878                   (lambda ()
1879                     (compile v
1880                              #:env m
1881                              #:to 'assembly
1882                              #:opts %opts-w-unbound))))))
1883
1884      (pass-if "module-local top-level is visible after"
1885        (let ((m (make-module))
1886              (v (gensym)))
1887          (beautify-user-module! m)
1888          (null? (call-with-warnings
1889                   (lambda ()
1890                     (let ((in (open-input-string
1891                                "(define (f)
1892                                   (set! chbouib 3))
1893                                 (define chbouib 5)")))
1894                       (read-and-compile in
1895                                         #:env m
1896                                         #:opts %opts-w-unbound)))))))
1897
1898      (pass-if "optional arguments are visible"
1899        (null? (call-with-warnings
1900                 (lambda ()
1901                   (compile '(lambda* (x #:optional y z) (list x y z))
1902                            #:opts %opts-w-unbound
1903                            #:to 'assembly)))))
1904
1905      (pass-if "keyword arguments are visible"
1906        (null? (call-with-warnings
1907                 (lambda ()
1908                   (compile '(lambda* (x #:key y z) (list x y z))
1909                            #:opts %opts-w-unbound
1910                            #:to 'assembly)))))
1911
1912      (pass-if "GOOPS definitions are visible"
1913        (let ((m (make-module))
1914              (v (gensym)))
1915          (beautify-user-module! m)
1916          (module-use! m (resolve-interface '(oop goops)))
1917          (null? (call-with-warnings
1918                   (lambda ()
1919                     (let ((in (open-input-string
1920                                "(define-class <foo> ()
1921                                   (bar #:getter foo-bar))
1922                                 (define z (foo-bar (make <foo>)))")))
1923                       (read-and-compile in
1924                                         #:env m
1925                                         #:opts %opts-w-unbound))))))))
1926
1927    (with-test-prefix "arity mismatch"
1928
1929      (pass-if "quiet"
1930        (null? (call-with-warnings
1931                 (lambda ()
1932                   (compile '(cons 'a 'b) #:opts %opts-w-arity)))))
1933
1934      (pass-if "direct application"
1935        (let ((w (call-with-warnings
1936                   (lambda ()
1937                     (compile '((lambda (x y) (or x y)) 1 2 3 4 5)
1938                              #:opts %opts-w-arity
1939                              #:to 'assembly)))))
1940          (and (= (length w) 1)
1941               (number? (string-contains (car w)
1942                                         "wrong number of arguments to")))))
1943      (pass-if "local"
1944        (let ((w (call-with-warnings
1945                   (lambda ()
1946                     (compile '(let ((f (lambda (x y) (+ x y))))
1947                                 (f 2))
1948                              #:opts %opts-w-arity
1949                              #:to 'assembly)))))
1950          (and (= (length w) 1)
1951               (number? (string-contains (car w)
1952                                         "wrong number of arguments to")))))
1953
1954      (pass-if "global"
1955        (let ((w (call-with-warnings
1956                   (lambda ()
1957                     (compile '(cons 1 2 3 4)
1958                              #:opts %opts-w-arity
1959                              #:to 'assembly)))))
1960          (and (= (length w) 1)
1961               (number? (string-contains (car w)
1962                                         "wrong number of arguments to")))))
1963
1964      (pass-if "alias to global"
1965        (let ((w (call-with-warnings
1966                   (lambda ()
1967                     (compile '(let ((f cons)) (f 1 2 3 4))
1968                              #:opts %opts-w-arity
1969                              #:to 'assembly)))))
1970          (and (= (length w) 1)
1971               (number? (string-contains (car w)
1972                                         "wrong number of arguments to")))))
1973
1974      (pass-if "alias to lexical to global"
1975        (let ((w (call-with-warnings
1976                   (lambda ()
1977                     (compile '(let ((f number?))
1978                                 (let ((g f))
1979                                   (f 1 2 3 4)))
1980                              #:opts %opts-w-arity
1981                              #:to 'assembly)))))
1982          (and (= (length w) 1)
1983               (number? (string-contains (car w)
1984                                         "wrong number of arguments to")))))
1985
1986      (pass-if "alias to lexical"
1987        (let ((w (call-with-warnings
1988                   (lambda ()
1989                     (compile '(let ((f (lambda (x y z) (+ x y z))))
1990                                 (let ((g f))
1991                                   (g 1)))
1992                              #:opts %opts-w-arity
1993                              #:to 'assembly)))))
1994          (and (= (length w) 1)
1995               (number? (string-contains (car w)
1996                                         "wrong number of arguments to")))))
1997
1998      (pass-if "letrec"
1999        (let ((w (call-with-warnings
2000                   (lambda ()
2001                     (compile '(letrec ((odd?  (lambda (x) (even? (1- x))))
2002                                        (even? (lambda (x)
2003                                                 (or (= 0 x)
2004                                                     (odd?)))))
2005                                 (odd? 1))
2006                              #:opts %opts-w-arity
2007                              #:to 'assembly)))))
2008          (and (= (length w) 1)
2009               (number? (string-contains (car w)
2010                                         "wrong number of arguments to")))))
2011
2012      (pass-if "case-lambda"
2013        (null? (call-with-warnings
2014                 (lambda ()
2015                   (compile '(let ((f (case-lambda
2016                                        ((x)     1)
2017                                        ((x y)   2)
2018                                        ((x y z) 3))))
2019                               (list (f 1)
2020                                     (f 1 2)
2021                                     (f 1 2 3)))
2022                            #:opts %opts-w-arity
2023                            #:to 'assembly)))))
2024
2025      (pass-if "case-lambda with wrong number of arguments"
2026        (let ((w (call-with-warnings
2027                   (lambda ()
2028                     (compile '(let ((f (case-lambda
2029                                          ((x)     1)
2030                                          ((x y)   2))))
2031                                 (f 1 2 3))
2032                              #:opts %opts-w-arity
2033                              #:to 'assembly)))))
2034          (and (= (length w) 1)
2035               (number? (string-contains (car w)
2036                                         "wrong number of arguments to")))))
2037
2038      (pass-if "case-lambda*"
2039        (null? (call-with-warnings
2040                 (lambda ()
2041                   (compile '(let ((f (case-lambda*
2042                                        ((x #:optional y) 1)
2043                                        ((x #:key y)      2)
2044                                        ((x y #:key z)    3))))
2045                               (list (f 1)
2046                                     (f 1 2)
2047                                     (f #:y 2)
2048                                     (f 1 2 #:z 3)))
2049                            #:opts %opts-w-arity
2050                            #:to 'assembly)))))
2051
2052      (pass-if "case-lambda* with wrong arguments"
2053        (let ((w (call-with-warnings
2054                   (lambda ()
2055                     (compile '(let ((f (case-lambda*
2056                                          ((x #:optional y) 1)
2057                                          ((x #:key y)      2)
2058                                          ((x y #:key z)    3))))
2059                                 (list (f)
2060                                       (f 1 #:z 3)))
2061                              #:opts %opts-w-arity
2062                              #:to 'assembly)))))
2063          (and (= (length w) 2)
2064               (null? (filter (lambda (w)
2065                                (not
2066                                 (number?
2067                                  (string-contains
2068                                   w "wrong number of arguments to"))))
2069                              w)))))
2070
2071      (pass-if "local toplevel-defines"
2072        (let ((w (call-with-warnings
2073                   (lambda ()
2074                     (let ((in (open-input-string "
2075                                 (define (g x) (f x))
2076                                 (define (f) 1)")))
2077                       (read-and-compile in
2078                                         #:opts %opts-w-arity
2079                                         #:to 'assembly))))))
2080          (and (= (length w) 1)
2081               (number? (string-contains (car w)
2082                                         "wrong number of arguments to")))))
2083
2084      (pass-if "global toplevel alias"
2085        (let ((w (call-with-warnings
2086                   (lambda ()
2087                     (let ((in (open-input-string "
2088                                 (define f cons)
2089                                 (define (g) (f))")))
2090                       (read-and-compile in
2091                                         #:opts %opts-w-arity
2092                                         #:to 'assembly))))))
2093          (and (= (length w) 1)
2094               (number? (string-contains (car w)
2095                                         "wrong number of arguments to")))))
2096
2097      (pass-if "local toplevel overrides global"
2098        (null? (call-with-warnings
2099                 (lambda ()
2100                   (let ((in (open-input-string "
2101                               (define (cons) 0)
2102                               (define (foo x) (cons))")))
2103                     (read-and-compile in
2104                                       #:opts %opts-w-arity
2105                                       #:to 'assembly))))))
2106
2107      (pass-if "keyword not passed and quiet"
2108        (null? (call-with-warnings
2109                 (lambda ()
2110                   (compile '(let ((f (lambda* (x #:key y) y)))
2111                               (f 2))
2112                            #:opts %opts-w-arity
2113                            #:to 'assembly)))))
2114
2115      (pass-if "keyword passed and quiet"
2116        (null? (call-with-warnings
2117                 (lambda ()
2118                   (compile '(let ((f (lambda* (x #:key y) y)))
2119                               (f 2 #:y 3))
2120                            #:opts %opts-w-arity
2121                            #:to 'assembly)))))
2122
2123      (pass-if "keyword passed to global and quiet"
2124        (null? (call-with-warnings
2125                 (lambda ()
2126                   (let ((in (open-input-string "
2127                               (use-modules (system base compile))
2128                               (compile '(+ 2 3) #:env (current-module))")))
2129                     (read-and-compile in
2130                                       #:opts %opts-w-arity
2131                                       #:to 'assembly))))))
2132
2133      (pass-if "extra keyword"
2134        (let ((w (call-with-warnings
2135                   (lambda ()
2136                     (compile '(let ((f (lambda* (x #:key y) y)))
2137                                 (f 2 #:Z 3))
2138                              #:opts %opts-w-arity
2139                              #:to 'assembly)))))
2140          (and (= (length w) 1)
2141               (number? (string-contains (car w)
2142                                         "wrong number of arguments to")))))
2143
2144      (pass-if "extra keywords allowed"
2145        (null? (call-with-warnings
2146                 (lambda ()
2147                   (compile '(let ((f (lambda* (x #:key y #:allow-other-keys)
2148                                        y)))
2149                               (f 2 #:Z 3))
2150                            #:opts %opts-w-arity
2151                            #:to 'assembly))))))
2152
2153    (with-test-prefix "format"
2154
2155      (pass-if "quiet (no args)"
2156        (null? (call-with-warnings
2157                (lambda ()
2158                  (compile '(format #t "hey!")
2159                           #:opts %opts-w-format
2160                           #:to 'assembly)))))
2161
2162      (pass-if "quiet (1 arg)"
2163        (null? (call-with-warnings
2164                (lambda ()
2165                  (compile '(format #t "hey ~A!" "you")
2166                           #:opts %opts-w-format
2167                           #:to 'assembly)))))
2168
2169      (pass-if "quiet (2 args)"
2170        (null? (call-with-warnings
2171                (lambda ()
2172                  (compile '(format #t "~A ~A!" "hello" "world")
2173                           #:opts %opts-w-format
2174                           #:to 'assembly)))))
2175
2176      (pass-if "wrong port arg"
2177        (let ((w (call-with-warnings
2178                  (lambda ()
2179                    (compile '(format 10 "foo")
2180                             #:opts %opts-w-format
2181                             #:to 'assembly)))))
2182          (and (= (length w) 1)
2183               (number? (string-contains (car w)
2184                                         "wrong port argument")))))
2185
2186      (pass-if "non-literal format string"
2187        (let ((w (call-with-warnings
2188                  (lambda ()
2189                    (compile '(format #f fmt)
2190                             #:opts %opts-w-format
2191                             #:to 'assembly)))))
2192          (and (= (length w) 1)
2193               (number? (string-contains (car w)
2194                                         "non-literal format string")))))
2195
2196      (pass-if "non-literal format string using gettext"
2197        (null? (call-with-warnings
2198                (lambda ()
2199                  (compile '(format #t (gettext "~A ~A!") "hello" "world")
2200                           #:opts %opts-w-format
2201                           #:to 'assembly)))))
2202
2203      (pass-if "non-literal format string using gettext as _"
2204        (null? (call-with-warnings
2205                (lambda ()
2206                  (compile '(format #t (_ "~A ~A!") "hello" "world")
2207                           #:opts %opts-w-format
2208                           #:to 'assembly)))))
2209
2210      (pass-if "non-literal format string using ngettext"
2211        (null? (call-with-warnings
2212                (lambda ()
2213                  (compile '(format #t
2214                                    (ngettext "~a thing" "~a things" n "dom") n)
2215                           #:opts %opts-w-format
2216                           #:to 'assembly)))))
2217
2218      (pass-if "non-literal format string using ngettext as N_"
2219        (null? (call-with-warnings
2220                (lambda ()
2221                  (compile '(format #t (N_ "~a thing" "~a things" n) n)
2222                           #:opts %opts-w-format
2223                           #:to 'assembly)))))
2224
2225      (pass-if "non-literal format string with (define _ gettext)"
2226        (null? (call-with-warnings
2227                (lambda ()
2228                  (compile '(begin
2229                              (define _ gettext)
2230                              (define (foo)
2231                                (format #t (_ "~A ~A!") "hello" "world")))
2232                           #:opts %opts-w-format
2233                           #:to 'assembly)))))
2234
2235      (pass-if "wrong format string"
2236        (let ((w (call-with-warnings
2237                  (lambda ()
2238                    (compile '(format #f 'not-a-string)
2239                             #:opts %opts-w-format
2240                             #:to 'assembly)))))
2241          (and (= (length w) 1)
2242               (number? (string-contains (car w)
2243                                         "wrong format string")))))
2244
2245      (pass-if "wrong number of args"
2246        (let ((w (call-with-warnings
2247                  (lambda ()
2248                    (compile '(format "shbweeb")
2249                             #:opts %opts-w-format
2250                             #:to 'assembly)))))
2251          (and (= (length w) 1)
2252               (number? (string-contains (car w)
2253                                         "wrong number of arguments")))))
2254
2255      (pass-if "~%, ~~, ~&, ~t, ~_, and ~\\n"
2256        (null? (call-with-warnings
2257                (lambda ()
2258                  (compile '((@ (ice-9 format) format) some-port
2259                             "~&~3_~~ ~\n~12they~%")
2260                           #:opts %opts-w-format
2261                           #:to 'assembly)))))
2262
2263      (pass-if "one missing argument"
2264        (let ((w (call-with-warnings
2265                  (lambda ()
2266                    (compile '(format some-port "foo ~A~%")
2267                             #:opts %opts-w-format
2268                             #:to 'assembly)))))
2269          (and (= (length w) 1)
2270               (number? (string-contains (car w)
2271                                         "expected 1, got 0")))))
2272
2273      (pass-if "one missing argument, gettext"
2274        (let ((w (call-with-warnings
2275                  (lambda ()
2276                    (compile '(format some-port (gettext "foo ~A~%"))
2277                             #:opts %opts-w-format
2278                             #:to 'assembly)))))
2279          (and (= (length w) 1)
2280               (number? (string-contains (car w)
2281                                         "expected 1, got 0")))))
2282
2283      (pass-if "two missing arguments"
2284        (let ((w (call-with-warnings
2285                  (lambda ()
2286                    (compile '((@ (ice-9 format) format) #f
2287                               "foo ~10,2f and bar ~S~%")
2288                             #:opts %opts-w-format
2289                             #:to 'assembly)))))
2290          (and (= (length w) 1)
2291               (number? (string-contains (car w)
2292                                         "expected 2, got 0")))))
2293
2294      (pass-if "one given, one missing argument"
2295        (let ((w (call-with-warnings
2296                  (lambda ()
2297                    (compile '(format #t "foo ~A and ~S~%" hey)
2298                             #:opts %opts-w-format
2299                             #:to 'assembly)))))
2300          (and (= (length w) 1)
2301               (number? (string-contains (car w)
2302                                         "expected 2, got 1")))))
2303
2304      (pass-if "too many arguments"
2305        (let ((w (call-with-warnings
2306                  (lambda ()
2307                    (compile '(format #t "foo ~A~%" 1 2)
2308                             #:opts %opts-w-format
2309                             #:to 'assembly)))))
2310          (and (= (length w) 1)
2311               (number? (string-contains (car w)
2312                                         "expected 1, got 2")))))
2313
2314      (pass-if "~h"
2315        (null? (call-with-warnings
2316                  (lambda ()
2317                    (compile '((@ (ice-9 format) format) #t
2318                               "foo ~h ~a~%" 123.4 'bar)
2319                             #:opts %opts-w-format
2320                             #:to 'assembly)))))
2321
2322      (pass-if "~:h with locale object"
2323        (null? (call-with-warnings
2324                  (lambda ()
2325                    (compile '((@ (ice-9 format) format) #t
2326                               "foo ~:h~%" 123.4 %global-locale)
2327                             #:opts %opts-w-format
2328                             #:to 'assembly)))))
2329
2330      (pass-if "~:h without locale object"
2331        (let ((w (call-with-warnings
2332                  (lambda ()
2333                    (compile '((@ (ice-9 format) format) #t "foo ~,2:h" 123.4)
2334                             #:opts %opts-w-format
2335                             #:to 'assembly)))))
2336          (and (= (length w) 1)
2337               (number? (string-contains (car w)
2338                                         "expected 2, got 1")))))
2339
2340      (with-test-prefix "conditionals"
2341        (pass-if "literals"
2342         (null? (call-with-warnings
2343                 (lambda ()
2344                   (compile '((@ (ice-9 format) format) #f "~A ~[foo~;bar~;baz~;~] ~10,2f"
2345                                     'a 1 3.14)
2346                            #:opts %opts-w-format
2347                            #:to 'assembly)))))
2348
2349        (pass-if "literals with selector"
2350          (let ((w (call-with-warnings
2351                    (lambda ()
2352                      (compile '((@ (ice-9 format) format) #f "~2[foo~;bar~;baz~;~] ~A"
2353                                        1 'dont-ignore-me)
2354                               #:opts %opts-w-format
2355                               #:to 'assembly)))))
2356            (and (= (length w) 1)
2357                 (number? (string-contains (car w)
2358                                           "expected 1, got 2")))))
2359
2360        (pass-if "escapes (exact count)"
2361          (let ((w (call-with-warnings
2362                    (lambda ()
2363                      (compile '((@ (ice-9 format) format) #f "~[~a~;~a~]")
2364                               #:opts %opts-w-format
2365                               #:to 'assembly)))))
2366            (and (= (length w) 1)
2367                 (number? (string-contains (car w)
2368                                           "expected 2, got 0")))))
2369
2370        (pass-if "escapes with selector"
2371          (let ((w (call-with-warnings
2372                    (lambda ()
2373                      (compile '((@ (ice-9 format) format) #f "~1[chbouib~;~a~]")
2374                               #:opts %opts-w-format
2375                               #:to 'assembly)))))
2376            (and (= (length w) 1)
2377                 (number? (string-contains (car w)
2378                                           "expected 1, got 0")))))
2379
2380        (pass-if "escapes, range"
2381          (let ((w (call-with-warnings
2382                    (lambda ()
2383                      (compile '((@ (ice-9 format) format) #f "~[chbouib~;~a~;~2*~a~]")
2384                               #:opts %opts-w-format
2385                               #:to 'assembly)))))
2386            (and (= (length w) 1)
2387                 (number? (string-contains (car w)
2388                                           "expected 1 to 4, got 0")))))
2389
2390        (pass-if "@"
2391          (let ((w (call-with-warnings
2392                    (lambda ()
2393                      (compile '((@ (ice-9 format) format) #f "~@[temperature=~d~]")
2394                               #:opts %opts-w-format
2395                               #:to 'assembly)))))
2396            (and (= (length w) 1)
2397                 (number? (string-contains (car w)
2398                                           "expected 1, got 0")))))
2399
2400        (pass-if "nested"
2401          (let ((w (call-with-warnings
2402                    (lambda ()
2403                      (compile '((@ (ice-9 format) format) #f "~:[~[hey~;~a~;~va~]~;~3*~]")
2404                               #:opts %opts-w-format
2405                               #:to 'assembly)))))
2406            (and (= (length w) 1)
2407                 (number? (string-contains (car w)
2408                                           "expected 2 to 4, got 0")))))
2409
2410        (pass-if "unterminated"
2411          (let ((w (call-with-warnings
2412                    (lambda ()
2413                      (compile '((@ (ice-9 format) format) #f "~[unterminated")
2414                               #:opts %opts-w-format
2415                               #:to 'assembly)))))
2416            (and (= (length w) 1)
2417                 (number? (string-contains (car w)
2418                                           "unterminated conditional")))))
2419
2420        (pass-if "unexpected ~;"
2421          (let ((w (call-with-warnings
2422                    (lambda ()
2423                      (compile '((@ (ice-9 format) format) #f "foo~;bar")
2424                               #:opts %opts-w-format
2425                               #:to 'assembly)))))
2426            (and (= (length w) 1)
2427                 (number? (string-contains (car w)
2428                                           "unexpected")))))
2429
2430        (pass-if "unexpected ~]"
2431          (let ((w (call-with-warnings
2432                    (lambda ()
2433                      (compile '((@ (ice-9 format) format) #f "foo~]")
2434                               #:opts %opts-w-format
2435                               #:to 'assembly)))))
2436            (and (= (length w) 1)
2437                 (number? (string-contains (car w)
2438                                           "unexpected"))))))
2439
2440      (pass-if "~{...~}"
2441        (null? (call-with-warnings
2442                (lambda ()
2443                  (compile '((@ (ice-9 format) format) #f "~A ~{~S~} ~A"
2444                                    'hello '("ladies" "and")
2445                                    'gentlemen)
2446                           #:opts %opts-w-format
2447                           #:to 'assembly)))))
2448
2449      (pass-if "~{...~}, too many args"
2450        (let ((w (call-with-warnings
2451                  (lambda ()
2452                    (compile '((@ (ice-9 format) format) #f "~{~S~}" 1 2 3)
2453                             #:opts %opts-w-format
2454                             #:to 'assembly)))))
2455          (and (= (length w) 1)
2456               (number? (string-contains (car w)
2457                                         "expected 1, got 3")))))
2458
2459      (pass-if "~@{...~}"
2460        (null? (call-with-warnings
2461                (lambda ()
2462                  (compile '((@ (ice-9 format) format) #f "~@{~S~}" 1 2 3)
2463                           #:opts %opts-w-format
2464                           #:to 'assembly)))))
2465
2466      (pass-if "~@{...~}, too few args"
2467        (let ((w (call-with-warnings
2468                  (lambda ()
2469                    (compile '((@ (ice-9 format) format) #f "~A ~@{~S~}")
2470                             #:opts %opts-w-format
2471                             #:to 'assembly)))))
2472          (and (= (length w) 1)
2473               (number? (string-contains (car w)
2474                                         "expected at least 1, got 0")))))
2475
2476      (pass-if "unterminated ~{...~}"
2477        (let ((w (call-with-warnings
2478                  (lambda ()
2479                    (compile '((@ (ice-9 format) format) #f "~{")
2480                             #:opts %opts-w-format
2481                             #:to 'assembly)))))
2482          (and (= (length w) 1)
2483               (number? (string-contains (car w)
2484                                         "unterminated")))))
2485
2486      (pass-if "~(...~)"
2487        (null? (call-with-warnings
2488                (lambda ()
2489                  (compile '((@ (ice-9 format) format) #f "~:@(~A ~A~)" 'foo 'bar)
2490                           #:opts %opts-w-format
2491                           #:to 'assembly)))))
2492
2493      (pass-if "~v"
2494        (let ((w (call-with-warnings
2495                  (lambda ()
2496                    (compile '((@ (ice-9 format) format) #f "~v_foo")
2497                             #:opts %opts-w-format
2498                             #:to 'assembly)))))
2499          (and (= (length w) 1)
2500               (number? (string-contains (car w)
2501                                         "expected 1, got 0")))))
2502      (pass-if "~v:@y"
2503        (null? (call-with-warnings
2504                (lambda ()
2505                  (compile '((@ (ice-9 format) format) #f "~v:@y" 1 123)
2506                           #:opts %opts-w-format
2507                           #:to 'assembly)))))
2508
2509
2510      (pass-if "~*"
2511        (let ((w (call-with-warnings
2512                  (lambda ()
2513                    (compile '((@ (ice-9 format) format) #f "~2*~a" 'a 'b)
2514                             #:opts %opts-w-format
2515                             #:to 'assembly)))))
2516          (and (= (length w) 1)
2517               (number? (string-contains (car w)
2518                                         "expected 3, got 2")))))
2519
2520      (pass-if "~?"
2521        (null? (call-with-warnings
2522                (lambda ()
2523                  (compile '((@ (ice-9 format) format) #f "~?" "~d ~d" '(1 2))
2524                           #:opts %opts-w-format
2525                           #:to 'assembly)))))
2526
2527      (pass-if "complex 1"
2528        (let ((w (call-with-warnings
2529                  (lambda ()
2530                    (compile '((@ (ice-9 format) format) #f
2531                                      "~4@S    ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n"
2532                                      1 2 3 4 5 6)
2533                             #:opts %opts-w-format
2534                             #:to 'assembly)))))
2535          (and (= (length w) 1)
2536               (number? (string-contains (car w)
2537                                         "expected 4, got 6")))))
2538
2539      (pass-if "complex 2"
2540        (let ((w (call-with-warnings
2541                  (lambda ()
2542                    (compile '((@ (ice-9 format) format) #f
2543                                      "~:(~A~) Commands~:[~; [abbrev]~]:~2%"
2544                                      1 2 3 4)
2545                             #:opts %opts-w-format
2546                             #:to 'assembly)))))
2547          (and (= (length w) 1)
2548               (number? (string-contains (car w)
2549                                         "expected 2, got 4")))))
2550
2551      (pass-if "complex 3"
2552        (let ((w (call-with-warnings
2553                  (lambda ()
2554                    (compile '((@ (ice-9 format) format) #f "~9@a~:[~*~3_~;~3d~] ~v:@y~%")
2555                             #:opts %opts-w-format
2556                             #:to 'assembly)))))
2557          (and (= (length w) 1)
2558               (number? (string-contains (car w)
2559                                         "expected 5, got 0")))))
2560
2561      (pass-if "ice-9 format"
2562        (let ((w (call-with-warnings
2563                  (lambda ()
2564                    (let ((in (open-input-string
2565                               "(use-modules ((ice-9 format)
2566                                  #:renamer (symbol-prefix-proc 'i9-)))
2567                                (i9-format #t \"yo! ~A\" 1 2)")))
2568                      (read-and-compile in
2569                                        #:opts %opts-w-format
2570                                        #:to 'assembly))))))
2571          (and (= (length w) 1)
2572               (number? (string-contains (car w)
2573                                         "expected 1, got 2")))))
2574
2575      (pass-if "not format"
2576        (null? (call-with-warnings
2577                (lambda ()
2578                  (compile '(let ((format chbouib))
2579                              (format #t "not ~A a format string"))
2580                           #:opts %opts-w-format
2581                           #:to 'assembly)))))
2582
2583      (with-test-prefix "simple-format"
2584
2585        (pass-if "good"
2586          (null? (call-with-warnings
2587                  (lambda ()
2588                    (compile '(simple-format #t "foo ~a bar ~s ~%~~" 1 2)
2589                             #:opts %opts-w-format
2590                             #:to 'assembly)))))
2591
2592        (pass-if "wrong number of args"
2593          (let ((w (call-with-warnings
2594                    (lambda ()
2595                      (compile '(simple-format #t "foo ~a ~s~%" 'one-missing)
2596                               #:opts %opts-w-format
2597                               #:to 'assembly)))))
2598            (and (= (length w) 1)
2599                 (number? (string-contains (car w) "wrong number")))))
2600
2601        (pass-if "unsupported"
2602          (let ((w (call-with-warnings
2603                    (lambda ()
2604                      (compile '(simple-format #t "foo ~x~%" 16)
2605                               #:opts %opts-w-format
2606                               #:to 'assembly)))))
2607            (and (= (length w) 1)
2608                 (number? (string-contains (car w) "unsupported format option")))))
2609
2610        (pass-if "unsupported, gettext"
2611          (let ((w (call-with-warnings
2612                    (lambda ()
2613                      (compile '(simple-format #t (gettext "foo ~2f~%") 3.14)
2614                               #:opts %opts-w-format
2615                               #:to 'assembly)))))
2616            (and (= (length w) 1)
2617                 (number? (string-contains (car w) "unsupported format option")))))
2618
2619        (pass-if "unsupported, ngettext"
2620          (let ((w (call-with-warnings
2621                    (lambda ()
2622                      (compile '(simple-format #t (ngettext "s ~x" "p ~x" x) x)
2623                               #:opts %opts-w-format
2624                               #:to 'assembly)))))
2625            (and (= (length w) 1)
2626                 (number? (string-contains (car w) "unsupported format option"))))))))