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 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) (unbind)
 403             (lexical #t #t ref 0) (lexical #t #t ref 1)
 404             (call add 2) (call return 1) (unbind)))
 405
 406   ;; complex bindings in letrec* -> box and set! in order
 407   (assert-tree-il->glil without-partial-evaluation
 408    (letrec* (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar)))
 409             (apply (primitive +) (lexical x x1) (lexical y y1)))
 410    (program () (std-prelude 0 2 #f) (label _)
 411             (void) (void) ;; what are these?
 412             (bind (x #t 0) (y #t 1))
 413             (lexical #t #t box 1) (lexical #t #t box 0)
 414             (call new-frame 0) (toplevel ref foo) (call call 0)
 415             (lexical #t #t set 0)
 416             (call new-frame 0) (toplevel ref bar) (call call 0)
 417             (lexical #t #t set 1)
 418             (lexical #t #t ref 0)
 419             (lexical #t #t ref 1)
 420             (call add 2) (call return 1) (unbind)))
 421
 422   ;; simple bindings in letrec* -> equivalent to letrec
 423   (assert-tree-il->glil without-partial-evaluation
 424    (letrec* (x y) (xx yy) ((const 1) (const 2))
 425             (lexical y yy))
 426    (program () (std-prelude 0 1 #f) (label _)
 427             (const 2)
 428             (bind (y #f 0)) ;; X is removed, and Y is unboxed
 429             (lexical #t #f set 0)
 430             (lexical #t #f ref 0)
 431             (call return 1) (unbind))))
 432
 433 (with-test-prefix "lambda"
 434   (assert-tree-il->glil
 435    (lambda ()
 436      (lambda-case (((x) #f #f #f () (y)) (const 2)) #f))
 437    (program ()  (std-prelude 0 0 #f) (label _)
 438             (program () (std-prelude 1 1 #f)
 439                      (bind (x #f 0)) (label _)
 440                      (const 2) (call return 1) (unbind))
 441             (call return 1)))
 442
 443   (assert-tree-il->glil
 444    (lambda ()
 445      (lambda-case (((x y) #f #f #f () (x1 y1))
 446                    (const 2))
 447                   #f))
 448    (program () (std-prelude 0 0 #f) (label _)
 449             (program () (std-prelude 2 2 #f)
 450                      (bind (x #f 0) (y #f 1)) (label _)
 451                      (const 2) (call return 1)
 452                      (unbind))
 453             (call return 1)))
 454
 455   (assert-tree-il->glil
 456    (lambda ()
 457      (lambda-case ((() #f x #f () (y)) (const 2))
 458                   #f))
 459    (program () (std-prelude 0 0 #f) (label _)
 460             (program () (opt-prelude 0 0 0 1 #f)
 461                      (bind (x #f 0)) (label _)
 462                      (const 2) (call return 1)
 463                      (unbind))
 464             (call return 1)))
 465
 466   (assert-tree-il->glil
 467    (lambda ()
 468      (lambda-case (((x) #f x1 #f () (y y1)) (const 2))
 469                   #f))
 470    (program () (std-prelude 0 0 #f) (label _)
 471             (program () (opt-prelude 1 0 1 2 #f)
 472                      (bind (x #f 0) (x1 #f 1)) (label _)
 473                      (const 2) (call return 1)
 474                      (unbind))
 475             (call return 1)))
 476
 477   (assert-tree-il->glil
 478    (lambda ()
 479      (lambda-case (((x) #f x1 #f () (y y1)) (lexical x y))
 480                   #f))
 481    (program () (std-prelude 0 0 #f) (label _)
 482             (program () (opt-prelude 1 0 1 2 #f)
 483                      (bind (x #f 0) (x1 #f 1)) (label _)
 484                      (lexical #t #f ref 0) (call return 1)
 485                      (unbind))
 486             (call return 1)))
 487
 488   (assert-tree-il->glil
 489    (lambda ()
 490      (lambda-case (((x) #f x1 #f () (y y1)) (lexical x1 y1))
 491                   #f))
 492    (program () (std-prelude 0 0 #f) (label _)
 493             (program () (opt-prelude 1 0 1 2 #f)
 494                      (bind (x #f 0) (x1 #f 1)) (label _)
 495                      (lexical #t #f ref 1) (call return 1)
 496                      (unbind))
 497             (call return 1)))
 498
 499   (assert-tree-il->glil
 500    (lambda ()
 501      (lambda-case (((x) #f #f #f () (x1))
 502                    (lambda ()
 503                      (lambda-case (((y) #f #f #f () (y1))
 504                                    (lexical x x1))
 505                                   #f)))
 506                   #f))
 507    (program () (std-prelude 0 0 #f) (label _)
 508             (program () (std-prelude 1 1 #f)
 509                      (bind (x #f 0)) (label _)
 510                      (program () (std-prelude 1 1 #f)
 511                               (bind (y #f 0)) (label _)
 512                               (lexical #f #f ref 0) (call return 1)
 513                               (unbind))
 514                      (lexical #t #f ref 0)
 515                      (call make-closure 1)
 516                      (call return 1)
 517                      (unbind))
 518             (call return 1))))
 519
 520 (with-test-prefix "sequence"
 521   (assert-tree-il->glil
 522    (begin (begin (const 2) (const #f)) (const #t))
 523    (program () (std-prelude 0 0 #f) (label _)
 524             (const #t) (call return 1)))
 525
 526   (assert-tree-il->glil
 527    ;; This gets simplified by `peval'.
 528    (apply (primitive null?) (begin (const #f) (const 2)))
 529    (program () (std-prelude 0 0 #f) (label _)
 530             (const #f) (call return 1))))
 531
 532 (with-test-prefix "values"
 533   (assert-tree-il->glil
 534    (apply (primitive values)
 535           (apply (primitive values) (const 1) (const 2)))
 536    (program () (std-prelude 0 0 #f) (label _)
 537             (const 1) (call return 1)))
 538
 539   (assert-tree-il->glil
 540    (apply (primitive values)
 541           (apply (primitive values) (const 1) (const 2))
 542           (const 3))
 543    (program () (std-prelude 0 0 #f) (label _)
 544             (const 1) (const 3) (call return/values 2)))
 545
 546   (assert-tree-il->glil
 547    (apply (primitive +)
 548           (apply (primitive values) (const 1) (const 2)))
 549    (program () (std-prelude 0 0 #f) (label _)
 550             (const 1) (call return 1))))
 551
 552 ;; FIXME: binding info for or-hacked locals might bork the disassembler,
 553 ;; and could be tightened in any case
 554 (with-test-prefix "the or hack"
 555   (assert-tree-il->glil without-partial-evaluation
 556    (let (x) (y) ((const 1))
 557         (if (lexical x y)
 558             (lexical x y)
 559             (let (a) (b) ((const 2))
 560                  (lexical a b))))
 561    (program () (std-prelude 0 1 #f) (label _)
 562             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
 563             (lexical #t #f ref 0) (branch br-if-not ,l1)
 564             (lexical #t #f ref 0) (call return 1)
 565             (label ,l2)
 566             (const 2) (bind (a #f 0)) (lexical #t #f set 0)
 567             (lexical #t #f ref 0) (call return 1)
 568             (unbind)
 569             (unbind))
 570    (eq? l1 l2))
 571
 572   ;; second bound var is unreferenced
 573   (assert-tree-il->glil without-partial-evaluation
 574    (let (x) (y) ((const 1))
 575         (if (lexical x y)
 576             (lexical x y)
 577             (let (a) (b) ((const 2))
 578                  (lexical x y))))
 579    (program () (std-prelude 0 1 #f) (label _)
 580             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
 581             (lexical #t #f ref 0) (branch br-if-not ,l1)
 582             (lexical #t #f ref 0) (call return 1)
 583             (label ,l2)
 584             (lexical #t #f ref 0) (call return 1)
 585             (unbind))
 586    (eq? l1 l2)))
 587
 588 (with-test-prefix "apply"
 589   (assert-tree-il->glil
 590    (apply (primitive @apply) (toplevel foo) (toplevel bar))
 591    (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (toplevel ref bar) (call tail-apply 2)))
 592   (assert-tree-il->glil
 593    (begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void))
 594    (program () (std-prelude 0 0 #f) (label _)
 595             (call new-frame 0) (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1)
 596             (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
 597             (label ,l4)
 598             (void) (call return 1))
 599    (and (eq? l1 l3) (eq? l2 l4)))
 600   (assert-tree-il->glil
 601    (apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz)))
 602    (program () (std-prelude 0 0 #f) (label _)
 603             (toplevel ref foo)
 604             (call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call apply 2)
 605             (call tail-call 1))))
 606
 607 (with-test-prefix "call/cc"
 608   (assert-tree-il->glil
 609    (apply (primitive @call-with-current-continuation) (toplevel foo))
 610    (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call tail-call/cc 1)))
 611   (assert-tree-il->glil
 612    (begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void))
 613    (program () (std-prelude 0 0 #f) (label _)
 614             (call new-frame 0) (toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,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)
 621           (apply (toplevel @call-with-current-continuation) (toplevel bar)))
 622    (program () (std-prelude 0 0 #f) (label _)
 623             (toplevel ref foo)
 624             (toplevel ref bar) (call call/cc 1)
 625             (call tail-call 1))))
 626
 627 \f
 628 (with-test-prefix "partial evaluation"
 629
 630   (pass-if-peval
 631     ;; First order, primitive.
 632     (let ((x 1) (y 2)) (+ x y))
 633     (const 3))
 634
 635   (pass-if-peval
 636     ;; First order, thunk.
 637     (let ((x 1) (y 2))
 638       (let ((f (lambda () (+ x y))))
 639         (f)))
 640     (const 3))
 641
 642   (pass-if-peval resolve-primitives
 643     ;; First order, let-values (requires primitive expansion for
 644     ;; `call-with-values'.)
 645     (let ((x 0))
 646       (call-with-values
 647           (lambda () (if (zero? x) (values 1 2) (values 3 4)))
 648         (lambda (a b)
 649           (+ a b))))
 650     (const 3))
 651
 652   (pass-if-peval
 653     ;; First order, coalesced, mutability preserved.
 654     (cons 0 (cons 1 (cons 2 (list 3 4 5))))
 655     (apply (primitive list)
 656            (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
 657
 658   (pass-if-peval
 659    ;; First order, coalesced, mutability preserved.
 660    (cons 0 (cons 1 (cons 2 (list 3 4 5))))
 661    ;; This must not be a constant.
 662    (apply (primitive list)
 663           (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
 664
 665   (pass-if-peval
 666     ;; First order, coalesced, immutability preserved.
 667     (cons 0 (cons 1 (cons 2 '(3 4 5))))
 668     (apply (primitive cons) (const 0)
 669            (apply (primitive cons) (const 1)
 670                   (apply (primitive cons) (const 2)
 671                          (const (3 4 5))))))
 672
 673   ;; These two tests doesn't work any more because we changed the way we
 674   ;; deal with constants -- now the algorithm will see a construction as
 675   ;; being bound to the lexical, so it won't propagate it.  It can't
 676   ;; even propagate it in the case that it is only referenced once,
 677   ;; because:
 678   ;;
 679   ;;   (let ((x (cons 1 2))) (lambda () x))
 680   ;;
 681   ;; is not the same as
 682   ;;
 683   ;;   (lambda () (cons 1 2))
 684   ;;
 685   ;; Perhaps if we determined that not only was it only referenced once,
 686   ;; it was not closed over by a lambda, then we could propagate it, and
 687   ;; re-enable these two tests.
 688   ;;
 689   #;
 690   (pass-if-peval
 691    ;; First order, mutability preserved.
 692    (let loop ((i 3) (r '()))
 693      (if (zero? i)
 694          r
 695          (loop (1- i) (cons (cons i i) r))))
 696    (apply (primitive list)
 697           (apply (primitive cons) (const 1) (const 1))
 698           (apply (primitive cons) (const 2) (const 2))
 699           (apply (primitive cons) (const 3) (const 3))))
 700   ;;
 701   ;; See above.
 702   #;
 703   (pass-if-peval
 704    ;; First order, evaluated.
 705    (let loop ((i 7)
 706               (r '()))
 707      (if (<= i 0)
 708          (car r)
 709          (loop (1- i) (cons i r))))
 710    (const 1))
 711
 712   ;; Instead here are tests for what happens for the above cases: they
 713   ;; unroll but they don't fold.
 714   (pass-if-peval
 715    (let loop ((i 3) (r '()))
 716      (if (zero? i)
 717          r
 718          (loop (1- i) (cons (cons i i) r))))
 719    (letrec (loop) (_) (_)
 720            (let (r) (_)
 721                 ((apply (primitive list)
 722                         (apply (primitive cons) (const 3) (const 3))))
 723                 (let (r) (_)
 724                      ((apply (primitive cons)
 725                              (apply (primitive cons) (const 2) (const 2))
 726                              (lexical r _)))
 727                      (apply (primitive cons)
 728                             (apply (primitive cons) (const 1) (const 1))
 729                             (lexical r _))))))
 730
 731   ;; See above.
 732   (pass-if-peval
 733    (let loop ((i 4)
 734               (r '()))
 735      (if (<= i 0)
 736          (car r)
 737          (loop (1- i) (cons i r))))
 738    (letrec (loop) (_) (_)
 739            (let (r) (_)
 740                 ((apply (primitive list) (const 4)))
 741                 (let (r) (_)
 742                      ((apply (primitive cons)
 743                              (const 3)
 744                              (lexical r _)))
 745                      (let (r) (_)
 746                           ((apply (primitive cons)
 747                                   (const 2)
 748                                   (lexical r _)))
 749                           (let (r) (_)
 750                                ((apply (primitive cons)
 751                                        (const 1)
 752                                        (lexical r _)))
 753                                (apply (primitive car)
 754                                       (lexical r _))))))))
 755
 756    ;; Static sums.
 757   (pass-if-peval
 758    (let loop ((l '(1 2 3 4)) (sum 0))
 759      (if (null? l)
 760          sum
 761          (loop (cdr l) (+ sum (car l)))))
 762    (const 10))
 763
 764   (pass-if-peval
 765    ;; Mutability preserved.
 766    ((lambda (x y z) (list x y z)) 1 2 3)
 767    (apply (primitive list) (const 1) (const 2) (const 3)))
 768
 769   (pass-if-peval
 770    ;; Don't propagate effect-free expressions that operate on mutable
 771    ;; objects.
 772    (let* ((x (list 1))
 773           (y (car x)))
 774      (set-car! x 0)
 775      y)
 776    (let (x) (_) ((apply (primitive list) (const 1)))
 777         (let (y) (_) ((apply (primitive car) (lexical x _)))
 778              (begin
 779                (apply (toplevel set-car!) (lexical x _) (const 0))
 780                (lexical y _)))))
 781
 782   (pass-if-peval
 783    ;; Don't propagate effect-free expressions that operate on objects we
 784    ;; don't know about.
 785    (let ((y (car x)))
 786      (set-car! x 0)
 787      y)
 788    (let (y) (_) ((apply (primitive car) (toplevel x)))
 789         (begin
 790           (apply (toplevel set-car!) (toplevel x) (const 0))
 791           (lexical y _))))
 792
 793   (pass-if-peval
 794    ;; Infinite recursion
 795    ((lambda (x) (x x)) (lambda (x) (x x)))
 796    (apply (lambda _
 797            (lambda-case
 798             (((x) _ _ _ _ _)
 799              (apply (lexical x _) (lexical x _)))))
 800           (lambda _
 801            (lambda-case
 802             (((x) _ _ _ _ _)
 803              (apply (lexical x _) (lexical x _)))))))
 804
 805   (pass-if-peval
 806     ;; First order, aliased primitive.
 807     (let* ((x *) (y (x 1 2))) y)
 808     (const 2))
 809
 810   (pass-if-peval
 811     ;; First order, shadowed primitive.
 812     (begin
 813       (define (+ x y) (pk x y))
 814       (+ 1 2))
 815     (begin
 816       (define +
 817         (lambda (_)
 818           (lambda-case
 819            (((x y) #f #f #f () (_ _))
 820             (apply (toplevel pk) (lexical x _) (lexical y _))))))
 821       (apply (toplevel +) (const 1) (const 2))))
 822
 823   (pass-if-peval
 824     ;; First-order, effects preserved.
 825     (let ((x 2))
 826       (do-something!)
 827       x)
 828     (begin
 829       (apply (toplevel do-something!))
 830       (const 2)))
 831
 832   (pass-if-peval
 833     ;; First order, residual bindings removed.
 834     (let ((x 2) (y 3))
 835       (* (+ x y) z))
 836     (apply (primitive *) (const 5) (toplevel z)))
 837
 838   (pass-if-peval
 839     ;; First order, with lambda.
 840     (define (foo x)
 841       (define (bar z) (* z z))
 842       (+ x (bar 3)))
 843     (define foo
 844       (lambda (_)
 845         (lambda-case
 846          (((x) #f #f #f () (_))
 847           (apply (primitive +) (lexical x _) (const 9)))))))
 848
 849   (pass-if-peval
 850     ;; First order, with lambda inlined & specialized twice.
 851     (let ((f (lambda (x y)
 852                (+ (* x top) y)))
 853           (x 2)
 854           (y 3))
 855       (+ (* x (f x y))
 856          (f something x)))
 857     (apply (primitive +)
 858            (apply (primitive *)
 859                   (const 2)
 860                   (apply (primitive +)  ; (f 2 3)
 861                          (apply (primitive *)
 862                                 (const 2)
 863                                 (toplevel top))
 864                          (const 3)))
 865            (let (x) (_) ((toplevel something))                    ; (f something 2)
 866                 ;; `something' is not const, so preserve order of
 867                 ;; effects with a lexical binding.
 868                 (apply (primitive +)
 869                        (apply (primitive *)
 870                               (lexical x _)
 871                               (toplevel top))
 872                        (const 2)))))
 873
 874   (pass-if-peval
 875    ;; First order, with lambda inlined & specialized 3 times.
 876    (let ((f (lambda (x y) (if (> x 0) y x))))
 877      (+ (f -1 0)
 878         (f 1 0)
 879         (f -1 y)
 880         (f 2 y)
 881         (f z y)))
 882    (apply (primitive +)
 883           (const -1)                      ; (f -1 0)
 884           (const 0)                       ; (f 1 0)
 885           (begin (toplevel y) (const -1)) ; (f -1 y)
 886           (toplevel y)                    ; (f 2 y)
 887           (let (x y) (_ _) ((toplevel z) (toplevel y)) ; (f z y)
 888                (if (apply (primitive >) (lexical x _) (const 0))
 889                    (lexical y _)
 890                    (lexical x _)))))
 891
 892   (pass-if-peval
 893     ;; First order, conditional.
 894     (let ((y 2))
 895       (lambda (x)
 896         (if (> y 0)
 897             (display x)
 898             'never-reached)))
 899     (lambda ()
 900       (lambda-case
 901        (((x) #f #f #f () (_))
 902         (apply (toplevel display) (lexical x _))))))
 903
 904   (pass-if-peval
 905     ;; First order, recursive procedure.
 906     (letrec ((fibo (lambda (n)
 907                      (if (<= n 1)
 908                          n
 909                          (+ (fibo (- n 1))
 910                             (fibo (- n 2)))))))
 911       (fibo 4))
 912     (const 3))
 913
 914   (pass-if-peval
 915    ;; Don't propagate toplevel references, as intervening expressions
 916    ;; could alter their bindings.
 917    (let ((x top))
 918      (foo)
 919      x)
 920    (let (x) (_) ((toplevel top))
 921         (begin
 922           (apply (toplevel foo))
 923           (lexical x _))))
 924
 925   (pass-if-peval
 926     ;; Higher order.
 927     ((lambda (f x)
 928        (f (* (car x) (cadr x))))
 929      (lambda (x)
 930        (+ x 1))
 931      '(2 3))
 932     (const 7))
 933
 934   (pass-if-peval
 935     ;; Higher order with optional argument (default value).
 936     ((lambda* (f x #:optional (y 0))
 937        (+ y (f (* (car x) (cadr x)))))
 938      (lambda (x)
 939        (+ x 1))
 940      '(2 3))
 941     (const 7))
 942
 943   (pass-if-peval
 944     ;; Higher order with optional argument (caller-supplied value).
 945     ((lambda* (f x #:optional (y 0))
 946        (+ y (f (* (car x) (cadr x)))))
 947      (lambda (x)
 948        (+ x 1))
 949      '(2 3)
 950      35)
 951     (const 42))
 952
 953   (pass-if-peval
 954     ;; Higher order with optional argument (side-effecting default
 955     ;; value).
 956     ((lambda* (f x #:optional (y (foo)))
 957        (+ y (f (* (car x) (cadr x)))))
 958      (lambda (x)
 959        (+ x 1))
 960      '(2 3))
 961     (let (y) (_) ((apply (toplevel foo)))
 962          (apply (primitive +) (lexical y _) (const 7))))
 963
 964   (pass-if-peval
 965     ;; Higher order with optional argument (caller-supplied value).
 966     ((lambda* (f x #:optional (y (foo)))
 967        (+ y (f (* (car x) (cadr x)))))
 968      (lambda (x)
 969        (+ x 1))
 970      '(2 3)
 971      35)
 972     (const 42))
 973
 974   (pass-if-peval
 975     ;; Higher order.
 976     ((lambda (f) (f x)) (lambda (x) x))
 977     (toplevel x))
 978
 979   (pass-if-peval
 980     ;; Bug reported at
 981     ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>.
 982     (let ((fold (lambda (f g) (f (g top)))))
 983       (fold 1+ (lambda (x) x)))
 984     (apply (primitive 1+) (toplevel top)))
 985
 986   (pass-if-peval
 987     ;; Procedure not inlined when residual code contains recursive calls.
 988     ;; <http://debbugs.gnu.org/9542>
 989     (letrec ((fold (lambda (f x3 b null? car cdr)
 990                      (if (null? x3)
 991                          b
 992                          (f (car x3) (fold f (cdr x3) b null? car cdr))))))
 993       (fold * x 1 zero? (lambda (x1) x1) (lambda (x2) (- x2 1))))
 994     (letrec (fold) (_) (_)
 995             (apply (lexical fold _)
 996                    (primitive *)
 997                    (toplevel x)
 998                    (const 1)
 999                    (primitive zero?)
1000                    (lambda ()
1001                      (lambda-case
1002                       (((x1) #f #f #f () (_))
1003                        (lexical x1 _))))
1004                    (lambda ()
1005                      (lambda-case
1006                       (((x2) #f #f #f () (_))
1007                        (apply (primitive -) (lexical x2 _) (const 1))))))))
1008
1009   (pass-if "inlined lambdas are alpha-renamed"
1010     ;; In this example, `make-adder' is inlined more than once; thus,
1011     ;; they should use different gensyms for their arguments, because
1012     ;; the various optimization passes assume uniquely-named variables.
1013     ;;
1014     ;; Bug reported at
1015     ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html> and
1016     ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00029.html>.
1017     (pmatch (unparse-tree-il
1018              (peval (compile
1019                      '(let ((make-adder
1020                              (lambda (x) (lambda (y) (+ x y)))))
1021                         (cons (make-adder 1) (make-adder 2)))
1022                      #:to 'tree-il)))
1023       ((apply (primitive cons)
1024               (lambda ()
1025                 (lambda-case
1026                  (((y) #f #f #f () (,gensym1))
1027                   (apply (primitive +)
1028                          (const 1)
1029                          (lexical y ,ref1)))))
1030               (lambda ()
1031                 (lambda-case
1032                  (((y) #f #f #f () (,gensym2))
1033                   (apply (primitive +)
1034                          (const 2)
1035                          (lexical y ,ref2))))))
1036        (and (eq? gensym1 ref1)
1037             (eq? gensym2 ref2)
1038             (not (eq? gensym1 gensym2))))
1039       (_ #f)))
1040
1041   (pass-if-peval
1042     ;; Higher order, mutually recursive procedures.
1043     (letrec ((even? (lambda (x)
1044                       (or (= 0 x)
1045                           (odd? (- x 1)))))
1046              (odd?  (lambda (x)
1047                       (not (even? (- x 1))))))
1048       (and (even? 4) (odd? 7)))
1049     (const #t))
1050
1051   ;;
1052   ;; Below are cases where constant propagation should bail out.
1053   ;;
1054
1055   (pass-if-peval
1056     ;; Non-constant lexical is not propagated.
1057     (let ((v (make-vector 6 #f)))
1058       (lambda (n)
1059         (vector-set! v n n)))
1060     (let (v) (_)
1061          ((apply (toplevel make-vector) (const 6) (const #f)))
1062          (lambda ()
1063            (lambda-case
1064             (((n) #f #f #f () (_))
1065              (apply (toplevel vector-set!)
1066                     (lexical v _) (lexical n _) (lexical n _)))))))
1067
1068   (pass-if-peval
1069     ;; Mutable lexical is not propagated.
1070     (let ((v (vector 1 2 3)))
1071       (lambda ()
1072         v))
1073     (let (v) (_)
1074          ((apply (primitive vector) (const 1) (const 2) (const 3)))
1075          (lambda ()
1076            (lambda-case
1077             ((() #f #f #f () ())
1078              (lexical v _))))))
1079
1080   (pass-if-peval
1081     ;; Lexical that is not provably pure is not inlined nor propagated.
1082     (let* ((x (if (> p q) (frob!) (display 'chbouib)))
1083            (y (* x 2)))
1084       (+ x x y))
1085     (let (x) (_) ((if (apply (primitive >) (toplevel p) (toplevel q))
1086                       (apply (toplevel frob!))
1087                       (apply (toplevel display) (const chbouib))))
1088          (let (y) (_) ((apply (primitive *) (lexical x _) (const 2)))
1089               (apply (primitive +)
1090                      (lexical x _) (lexical x _) (lexical y _)))))
1091
1092   (pass-if-peval
1093     ;; Non-constant arguments not propagated to lambdas.
1094     ((lambda (x y z)
1095        (vector-set! x 0 0)
1096        (set-car! y 0)
1097        (set-cdr! z '()))
1098      (vector 1 2 3)
1099      (make-list 10)
1100      (list 1 2 3))
1101     (let (x y z) (_ _ _)
1102          ((apply (primitive vector) (const 1) (const 2) (const 3))
1103           (apply (toplevel make-list) (const 10))
1104           (apply (primitive list) (const 1) (const 2) (const 3)))
1105          (begin
1106            (apply (toplevel vector-set!)
1107                   (lexical x _) (const 0) (const 0))
1108            (apply (toplevel set-car!)
1109                   (lexical y _) (const 0))
1110            (apply (toplevel set-cdr!)
1111                   (lexical z _) (const ())))))
1112
1113   (pass-if-peval
1114    (let ((foo top-foo) (bar top-bar))
1115      (let* ((g (lambda (x y) (+ x y)))
1116             (f (lambda (g x) (g x x))))
1117        (+ (f g foo) (f g bar))))
1118    (let (foo bar) (_ _) ((toplevel top-foo) (toplevel top-bar))
1119         (apply (primitive +)
1120                (apply (primitive +) (lexical foo _) (lexical foo _))
1121                (apply (primitive +) (lexical bar _) (lexical bar _)))))
1122
1123   (pass-if-peval
1124     ;; Fresh objects are not turned into constants, nor are constants
1125     ;; turned into fresh objects.
1126     (let* ((c '(2 3))
1127            (x (cons 1 c))
1128            (y (cons 0 x)))
1129       y)
1130     (let (x) (_) ((apply (primitive cons) (const 1) (const (2 3))))
1131          (apply (primitive cons) (const 0) (lexical x _))))
1132
1133   (pass-if-peval
1134     ;; Bindings mutated.
1135     (let ((x 2))
1136       (set! x 3)
1137       x)
1138     (let (x) (_) ((const 2))
1139          (begin
1140            (set! (lexical x _) (const 3))
1141            (lexical x _))))
1142
1143   (pass-if-peval
1144     ;; Bindings mutated.
1145     (letrec ((x 0)
1146              (f (lambda ()
1147                   (set! x (+ 1 x))
1148                   x)))
1149       (frob f) ; may mutate `x'
1150       x)
1151     (letrec (x) (_) ((const 0))
1152             (begin
1153               (apply (toplevel frob) (lambda _ _))
1154               (lexical x _))))
1155
1156   (pass-if-peval
1157     ;; Bindings mutated.
1158     (letrec ((f (lambda (x)
1159                   (set! f (lambda (_) x))
1160                   x)))
1161       (f 2))
1162     (letrec _ . _))
1163
1164   (pass-if-peval
1165     ;; Bindings possibly mutated.
1166     (let ((x (make-foo)))
1167       (frob! x) ; may mutate `x'
1168       x)
1169     (let (x) (_) ((apply (toplevel make-foo)))
1170          (begin
1171            (apply (toplevel frob!) (lexical x _))
1172            (lexical x _))))
1173
1174   (pass-if-peval
1175     ;; Inlining stops at recursive calls with dynamic arguments.
1176     (let loop ((x x))
1177       (if (< x 0) x (loop (1- x))))
1178     (letrec (loop) (_) ((lambda (_)
1179                           (lambda-case
1180                            (((x) #f #f #f () (_))
1181                             (if _ _
1182                                 (apply (lexical loop _)
1183                                        (apply (primitive 1-)
1184                                               (lexical x _))))))))
1185             (apply (lexical loop _) (toplevel x))))
1186
1187   (pass-if-peval
1188     ;; Recursion on the 2nd argument is fully evaluated.
1189     (let ((x (top)))
1190       (let loop ((x x) (y 10))
1191         (if (> y 0)
1192             (loop x (1- y))
1193             (foo x y))))
1194     (let (x) (_) ((apply (toplevel top)))
1195          (letrec (loop) (_) (_)
1196                  (apply (toplevel foo) (lexical x _) (const 0)))))
1197
1198   (pass-if-peval
1199     ;; Inlining aborted when residual code contains recursive calls.
1200     ;;
1201     ;; <http://debbugs.gnu.org/9542>
1202     (let loop ((x x) (y 0))
1203       (if (> y 0)
1204           (loop (1- x) (1- y))
1205           (if (< x 0)
1206               x
1207               (loop (1+ x) (1+ y)))))
1208     (letrec (loop) (_) ((lambda (_)
1209                           (lambda-case
1210                            (((x y) #f #f #f () (_ _))
1211                             (if (apply (primitive >)
1212                                        (lexical y _) (const 0))
1213                                 _ _)))))
1214             (apply (lexical loop _) (toplevel x) (const 0))))
1215
1216   (pass-if-peval
1217     ;; Infinite recursion: `peval' gives up and leaves it as is.
1218     (letrec ((f (lambda (x) (g (1- x))))
1219              (g (lambda (x) (h (1+ x))))
1220              (h (lambda (x) (f x))))
1221       (f 0))
1222     (letrec _ . _))
1223
1224   (pass-if-peval
1225     ;; Constant folding: cons
1226    (begin (cons 1 2) #f)
1227    (const #f))
1228
1229   (pass-if-peval
1230     ;; Constant folding: cons
1231    (begin (cons (foo) 2) #f)
1232    (begin (apply (toplevel foo)) (const #f)))
1233
1234   (pass-if-peval
1235     ;; Constant folding: cons
1236    (if (cons 0 0) 1 2)
1237    (const 1))
1238
1239   (pass-if-peval
1240    ;; Constant folding: car+cons
1241    (car (cons 1 0))
1242    (const 1))
1243
1244   (pass-if-peval
1245    ;; Constant folding: cdr+cons
1246    (cdr (cons 1 0))
1247    (const 0))
1248
1249   (pass-if-peval
1250    ;; Constant folding: car+cons, impure
1251    (car (cons 1 (bar)))
1252    (begin (apply (toplevel bar)) (const 1)))
1253
1254   (pass-if-peval
1255    ;; Constant folding: cdr+cons, impure
1256    (cdr (cons (bar) 0))
1257    (begin (apply (toplevel bar)) (const 0)))
1258
1259   (pass-if-peval
1260    ;; Constant folding: car+list
1261    (car (list 1 0))
1262    (const 1))
1263
1264   (pass-if-peval
1265    ;; Constant folding: cdr+list
1266    (cdr (list 1 0))
1267    (apply (primitive list) (const 0)))
1268
1269   (pass-if-peval
1270    ;; Constant folding: car+list, impure
1271    (car (list 1 (bar)))
1272    (begin (apply (toplevel bar)) (const 1)))
1273
1274   (pass-if-peval
1275    ;; Constant folding: cdr+list, impure
1276    (cdr (list (bar) 0))
1277    (begin (apply (toplevel bar)) (apply (primitive list) (const 0))))
1278
1279   (pass-if-peval
1280    resolve-primitives
1281    ;; Prompt is removed if tag is unreferenced
1282    (let ((tag (make-prompt-tag)))
1283      (call-with-prompt tag
1284                        (lambda () 1)
1285                        (lambda args args)))
1286    (const 1))
1287
1288   (pass-if-peval
1289    resolve-primitives
1290    ;; Prompt is removed if tag is unreferenced, with explicit stem
1291    (let ((tag (make-prompt-tag "foo")))
1292      (call-with-prompt tag
1293                        (lambda () 1)
1294                        (lambda args args)))
1295    (const 1))
1296
1297   (pass-if-peval
1298    resolve-primitives
1299    ;; `while' without `break' or `continue' has no prompts and gets its
1300    ;; condition folded.  Unfortunately the outer `lp' does not yet get
1301    ;; elided.
1302    (while #t #t)
1303    (letrec (lp) (_)
1304            ((lambda _
1305               (lambda-case
1306                ((() #f #f #f () ())
1307                 (letrec (loop) (_)
1308                         ((lambda _
1309                            (lambda-case
1310                             ((() #f #f #f () ())
1311                              (apply (lexical loop _))))))
1312                         (apply (lexical loop _)))))))
1313            (apply (lexical lp _)))))
1314
1315
1316 \f
1317 (with-test-prefix "tree-il-fold"
1318
1319   (pass-if "empty tree"
1320     (let ((leaf? #f) (up? #f) (down? #f) (mark (list 'mark)))
1321       (and (eq? mark
1322                 (tree-il-fold (lambda (x y) (set! leaf? #t) y)
1323                               (lambda (x y) (set! down? #t) y)
1324                               (lambda (x y) (set! up? #t) y)
1325                               mark
1326                               '()))
1327            (not leaf?)
1328            (not up?)
1329            (not down?))))
1330
1331   (pass-if "lambda and application"
1332     (let* ((leaves '()) (ups '()) (downs '())
1333            (result (tree-il-fold (lambda (x y)
1334                                    (set! leaves (cons x leaves))
1335                                    (1+ y))
1336                                  (lambda (x y)
1337                                    (set! downs (cons x downs))
1338                                    (1+ y))
1339                                  (lambda (x y)
1340                                    (set! ups (cons x ups))
1341                                    (1+ y))
1342                                  0
1343                                  (parse-tree-il
1344                                   '(lambda ()
1345                                      (lambda-case
1346                                       (((x y) #f #f #f () (x1 y1))
1347                                        (apply (toplevel +)
1348                                               (lexical x x1)
1349                                               (lexical y y1)))
1350                                       #f))))))
1351       (and (equal? (map strip-source leaves)
1352                    (list (make-lexical-ref #f 'y 'y1)
1353                          (make-lexical-ref #f 'x 'x1)
1354                          (make-toplevel-ref #f '+)))
1355            (= (length downs) 3)
1356            (equal? (reverse (map strip-source ups))
1357                    (map strip-source downs))))))
1358
1359 \f
1360 ;;;
1361 ;;; Warnings.
1362 ;;;
1363
1364 ;; Make sure we get English messages.
1365 (setlocale LC_ALL "C")
1366
1367 (define (call-with-warnings thunk)
1368   (let ((port (open-output-string)))
1369     (with-fluids ((*current-warning-port*   port)
1370                   (*current-warning-prefix* ""))
1371       (thunk))
1372     (let ((warnings (get-output-string port)))
1373       (string-tokenize warnings
1374                        (char-set-complement (char-set #\newline))))))
1375
1376 (define %opts-w-unused
1377   '(#:warnings (unused-variable)))
1378
1379 (define %opts-w-unused-toplevel
1380   '(#:warnings (unused-toplevel)))
1381
1382 (define %opts-w-unbound
1383   '(#:warnings (unbound-variable)))
1384
1385 (define %opts-w-arity
1386   '(#:warnings (arity-mismatch)))
1387
1388 (define %opts-w-format
1389   '(#:warnings (format)))
1390
1391
1392 (with-test-prefix "warnings"
1393
1394    (pass-if "unknown warning type"
1395      (let ((w (call-with-warnings
1396                 (lambda ()
1397                   (compile #t #:opts '(#:warnings (does-not-exist)))))))
1398        (and (= (length w) 1)
1399             (number? (string-contains (car w) "unknown warning")))))
1400
1401    (with-test-prefix "unused-variable"
1402
1403      (pass-if "quiet"
1404        (null? (call-with-warnings
1405                 (lambda ()
1406                   (compile '(lambda (x y) (+ x y))
1407                            #:opts %opts-w-unused)))))
1408
1409      (pass-if "let/unused"
1410        (let ((w (call-with-warnings
1411                   (lambda ()
1412                     (compile '(lambda (x)
1413                                 (let ((y (+ x 2)))
1414                                   x))
1415                              #:opts %opts-w-unused)))))
1416          (and (= (length w) 1)
1417               (number? (string-contains (car w) "unused variable `y'")))))
1418
1419      (pass-if "shadowed variable"
1420        (let ((w (call-with-warnings
1421                   (lambda ()
1422                     (compile '(lambda (x)
1423                                 (let ((y x))
1424                                   (let ((y (+ x 2)))
1425                                     (+ x y))))
1426                              #:opts %opts-w-unused)))))
1427          (and (= (length w) 1)
1428               (number? (string-contains (car w) "unused variable `y'")))))
1429
1430      (pass-if "letrec"
1431        (null? (call-with-warnings
1432                 (lambda ()
1433                   (compile '(lambda ()
1434                               (letrec ((x (lambda () (y)))
1435                                        (y (lambda () (x))))
1436                                 y))
1437                            #:opts %opts-w-unused)))))
1438
1439      (pass-if "unused argument"
1440        ;; Unused arguments should not be reported.
1441        (null? (call-with-warnings
1442                 (lambda ()
1443                   (compile '(lambda (x y z) #t)
1444                            #:opts %opts-w-unused)))))
1445
1446      (pass-if "special variable names"
1447        (null? (call-with-warnings
1448                 (lambda ()
1449                   (compile '(lambda ()
1450                               (let ((_ 'underscore)
1451                                     (#{gensym name}# 'ignore-me))
1452                                 #t))
1453                            #:to 'assembly
1454                            #:opts %opts-w-unused))))))
1455
1456    (with-test-prefix "unused-toplevel"
1457
1458      (pass-if "used after definition"
1459        (null? (call-with-warnings
1460                 (lambda ()
1461                   (let ((in (open-input-string
1462                              "(define foo 2) foo")))
1463                     (read-and-compile in
1464                                       #:to 'assembly
1465                                       #:opts %opts-w-unused-toplevel))))))
1466
1467      (pass-if "used before definition"
1468        (null? (call-with-warnings
1469                 (lambda ()
1470                   (let ((in (open-input-string
1471                              "(define (bar) foo) (define foo 2) (bar)")))
1472                     (read-and-compile in
1473                                       #:to 'assembly
1474                                       #:opts %opts-w-unused-toplevel))))))
1475
1476      (pass-if "unused but public"
1477        (let ((in (open-input-string
1478                   "(define-module (test-suite tree-il x) #:export (bar))
1479                    (define (bar) #t)")))
1480          (null? (call-with-warnings
1481                   (lambda ()
1482                     (read-and-compile in
1483                                       #:to 'assembly
1484                                       #:opts %opts-w-unused-toplevel))))))
1485
1486      (pass-if "unused but public (more)"
1487        (let ((in (open-input-string
1488                   "(define-module (test-suite tree-il x) #:export (bar))
1489                    (define (bar) (baz))
1490                    (define (baz) (foo))
1491                    (define (foo) #t)")))
1492          (null? (call-with-warnings
1493                   (lambda ()
1494                     (read-and-compile in
1495                                       #:to 'assembly
1496                                       #:opts %opts-w-unused-toplevel))))))
1497
1498      (pass-if "unused but define-public"
1499        (null? (call-with-warnings
1500                 (lambda ()
1501                   (compile '(define-public foo 2)
1502                            #:to 'assembly
1503                            #:opts %opts-w-unused-toplevel)))))
1504
1505      (pass-if "used by macro"
1506        ;; FIXME: See comment about macros at `unused-toplevel-analysis'.
1507        (throw 'unresolved)
1508
1509        (null? (call-with-warnings
1510                 (lambda ()
1511                   (let ((in (open-input-string
1512                              "(define (bar) 'foo)
1513                               (define-syntax baz
1514                                 (syntax-rules () ((_) (bar))))")))
1515                     (read-and-compile in
1516                                       #:to 'assembly
1517                                       #:opts %opts-w-unused-toplevel))))))
1518
1519      (pass-if "unused"
1520        (let ((w (call-with-warnings
1521                   (lambda ()
1522                     (compile '(define foo 2)
1523                              #:to 'assembly
1524                              #:opts %opts-w-unused-toplevel)))))
1525          (and (= (length w) 1)
1526               (number? (string-contains (car w)
1527                                         (format #f "top-level variable `~A'"
1528                                                 'foo))))))
1529
1530      (pass-if "unused recursive"
1531        (let ((w (call-with-warnings
1532                   (lambda ()
1533                     (compile '(define (foo) (foo))
1534                              #:to 'assembly
1535                              #:opts %opts-w-unused-toplevel)))))
1536          (and (= (length w) 1)
1537               (number? (string-contains (car w)
1538                                         (format #f "top-level variable `~A'"
1539                                                 'foo))))))
1540
1541      (pass-if "unused mutually recursive"
1542        (let* ((in (open-input-string
1543                    "(define (foo) (bar)) (define (bar) (foo))"))
1544               (w  (call-with-warnings
1545                     (lambda ()
1546                       (read-and-compile in
1547                                         #:to 'assembly
1548                                         #:opts %opts-w-unused-toplevel)))))
1549          (and (= (length w) 2)
1550               (number? (string-contains (car w)
1551                                         (format #f "top-level variable `~A'"
1552                                                 'foo)))
1553               (number? (string-contains (cadr w)
1554                                         (format #f "top-level variable `~A'"
1555                                                 'bar))))))
1556
1557      (pass-if "special variable names"
1558        (null? (call-with-warnings
1559                 (lambda ()
1560                   (compile '(define #{gensym name}# 'ignore-me)
1561                            #:to 'assembly
1562                            #:opts %opts-w-unused-toplevel))))))
1563
1564    (with-test-prefix "unbound variable"
1565
1566      (pass-if "quiet"
1567        (null? (call-with-warnings
1568                 (lambda ()
1569                   (compile '+ #:opts %opts-w-unbound)))))
1570
1571      (pass-if "ref"
1572        (let* ((v (gensym))
1573               (w (call-with-warnings
1574                    (lambda ()
1575                      (compile v
1576                               #:to 'assembly
1577                               #:opts %opts-w-unbound)))))
1578          (and (= (length w) 1)
1579               (number? (string-contains (car w)
1580                                         (format #f "unbound variable `~A'"
1581                                                 v))))))
1582
1583      (pass-if "set!"
1584        (let* ((v (gensym))
1585               (w (call-with-warnings
1586                    (lambda ()
1587                      (compile `(set! ,v 7)
1588                               #:to 'assembly
1589                               #:opts %opts-w-unbound)))))
1590          (and (= (length w) 1)
1591               (number? (string-contains (car w)
1592                                         (format #f "unbound variable `~A'"
1593                                                 v))))))
1594
1595      (pass-if "module-local top-level is visible"
1596        (let ((m (make-module))
1597              (v (gensym)))
1598          (beautify-user-module! m)
1599          (compile `(define ,v 123)
1600                   #:env m #:opts %opts-w-unbound)
1601          (null? (call-with-warnings
1602                   (lambda ()
1603                     (compile v
1604                              #:env m
1605                              #:to 'assembly
1606                              #:opts %opts-w-unbound))))))
1607
1608      (pass-if "module-local top-level is visible after"
1609        (let ((m (make-module))
1610              (v (gensym)))
1611          (beautify-user-module! m)
1612          (null? (call-with-warnings
1613                   (lambda ()
1614                     (let ((in (open-input-string
1615                                "(define (f)
1616                                   (set! chbouib 3))
1617                                 (define chbouib 5)")))
1618                       (read-and-compile in
1619                                         #:env m
1620                                         #:opts %opts-w-unbound)))))))
1621
1622      (pass-if "optional arguments are visible"
1623        (null? (call-with-warnings
1624                 (lambda ()
1625                   (compile '(lambda* (x #:optional y z) (list x y z))
1626                            #:opts %opts-w-unbound
1627                            #:to 'assembly)))))
1628
1629      (pass-if "keyword arguments are visible"
1630        (null? (call-with-warnings
1631                 (lambda ()
1632                   (compile '(lambda* (x #:key y z) (list x y z))
1633                            #:opts %opts-w-unbound
1634                            #:to 'assembly)))))
1635
1636      (pass-if "GOOPS definitions are visible"
1637        (let ((m (make-module))
1638              (v (gensym)))
1639          (beautify-user-module! m)
1640          (module-use! m (resolve-interface '(oop goops)))
1641          (null? (call-with-warnings
1642                   (lambda ()
1643                     (let ((in (open-input-string
1644                                "(define-class <foo> ()
1645                                   (bar #:getter foo-bar))
1646                                 (define z (foo-bar (make <foo>)))")))
1647                       (read-and-compile in
1648                                         #:env m
1649                                         #:opts %opts-w-unbound))))))))
1650
1651    (with-test-prefix "arity mismatch"
1652
1653      (pass-if "quiet"
1654        (null? (call-with-warnings
1655                 (lambda ()
1656                   (compile '(cons 'a 'b) #:opts %opts-w-arity)))))
1657
1658      (pass-if "direct application"
1659        (let ((w (call-with-warnings
1660                   (lambda ()
1661                     (compile '((lambda (x y) (or x y)) 1 2 3 4 5)
1662                              #:opts %opts-w-arity
1663                              #:to 'assembly)))))
1664          (and (= (length w) 1)
1665               (number? (string-contains (car w)
1666                                         "wrong number of arguments to")))))
1667      (pass-if "local"
1668        (let ((w (call-with-warnings
1669                   (lambda ()
1670                     (compile '(let ((f (lambda (x y) (+ x y))))
1671                                 (f 2))
1672                              #:opts %opts-w-arity
1673                              #:to 'assembly)))))
1674          (and (= (length w) 1)
1675               (number? (string-contains (car w)
1676                                         "wrong number of arguments to")))))
1677
1678      (pass-if "global"
1679        (let ((w (call-with-warnings
1680                   (lambda ()
1681                     (compile '(cons 1 2 3 4)
1682                              #:opts %opts-w-arity
1683                              #:to 'assembly)))))
1684          (and (= (length w) 1)
1685               (number? (string-contains (car w)
1686                                         "wrong number of arguments to")))))
1687
1688      (pass-if "alias to global"
1689        (let ((w (call-with-warnings
1690                   (lambda ()
1691                     (compile '(let ((f cons)) (f 1 2 3 4))
1692                              #:opts %opts-w-arity
1693                              #:to 'assembly)))))
1694          (and (= (length w) 1)
1695               (number? (string-contains (car w)
1696                                         "wrong number of arguments to")))))
1697
1698      (pass-if "alias to lexical to global"
1699        (let ((w (call-with-warnings
1700                   (lambda ()
1701                     (compile '(let ((f number?))
1702                                 (let ((g f))
1703                                   (f 1 2 3 4)))
1704                              #:opts %opts-w-arity
1705                              #:to 'assembly)))))
1706          (and (= (length w) 1)
1707               (number? (string-contains (car w)
1708                                         "wrong number of arguments to")))))
1709
1710      (pass-if "alias to lexical"
1711        (let ((w (call-with-warnings
1712                   (lambda ()
1713                     (compile '(let ((f (lambda (x y z) (+ x y z))))
1714                                 (let ((g f))
1715                                   (g 1)))
1716                              #:opts %opts-w-arity
1717                              #:to 'assembly)))))
1718          (and (= (length w) 1)
1719               (number? (string-contains (car w)
1720                                         "wrong number of arguments to")))))
1721
1722      (pass-if "letrec"
1723        (let ((w (call-with-warnings
1724                   (lambda ()
1725                     (compile '(letrec ((odd?  (lambda (x) (even? (1- x))))
1726                                        (even? (lambda (x)
1727                                                 (or (= 0 x)
1728                                                     (odd?)))))
1729                                 (odd? 1))
1730                              #:opts %opts-w-arity
1731                              #:to 'assembly)))))
1732          (and (= (length w) 1)
1733               (number? (string-contains (car w)
1734                                         "wrong number of arguments to")))))
1735
1736      (pass-if "case-lambda"
1737        (null? (call-with-warnings
1738                 (lambda ()
1739                   (compile '(let ((f (case-lambda
1740                                        ((x)     1)
1741                                        ((x y)   2)
1742                                        ((x y z) 3))))
1743                               (list (f 1)
1744                                     (f 1 2)
1745                                     (f 1 2 3)))
1746                            #:opts %opts-w-arity
1747                            #:to 'assembly)))))
1748
1749      (pass-if "case-lambda with wrong number of arguments"
1750        (let ((w (call-with-warnings
1751                   (lambda ()
1752                     (compile '(let ((f (case-lambda
1753                                          ((x)     1)
1754                                          ((x y)   2))))
1755                                 (f 1 2 3))
1756                              #:opts %opts-w-arity
1757                              #:to 'assembly)))))
1758          (and (= (length w) 1)
1759               (number? (string-contains (car w)
1760                                         "wrong number of arguments to")))))
1761
1762      (pass-if "case-lambda*"
1763        (null? (call-with-warnings
1764                 (lambda ()
1765                   (compile '(let ((f (case-lambda*
1766                                        ((x #:optional y) 1)
1767                                        ((x #:key y)      2)
1768                                        ((x y #:key z)    3))))
1769                               (list (f 1)
1770                                     (f 1 2)
1771                                     (f #:y 2)
1772                                     (f 1 2 #:z 3)))
1773                            #:opts %opts-w-arity
1774                            #:to 'assembly)))))
1775
1776      (pass-if "case-lambda* with wrong arguments"
1777        (let ((w (call-with-warnings
1778                   (lambda ()
1779                     (compile '(let ((f (case-lambda*
1780                                          ((x #:optional y) 1)
1781                                          ((x #:key y)      2)
1782                                          ((x y #:key z)    3))))
1783                                 (list (f)
1784                                       (f 1 #:z 3)))
1785                              #:opts %opts-w-arity
1786                              #:to 'assembly)))))
1787          (and (= (length w) 2)
1788               (null? (filter (lambda (w)
1789                                (not
1790                                 (number?
1791                                  (string-contains
1792                                   w "wrong number of arguments to"))))
1793                              w)))))
1794
1795      (pass-if "local toplevel-defines"
1796        (let ((w (call-with-warnings
1797                   (lambda ()
1798                     (let ((in (open-input-string "
1799                                 (define (g x) (f x))
1800                                 (define (f) 1)")))
1801                       (read-and-compile in
1802                                         #:opts %opts-w-arity
1803                                         #:to 'assembly))))))
1804          (and (= (length w) 1)
1805               (number? (string-contains (car w)
1806                                         "wrong number of arguments to")))))
1807
1808      (pass-if "global toplevel alias"
1809        (let ((w (call-with-warnings
1810                   (lambda ()
1811                     (let ((in (open-input-string "
1812                                 (define f cons)
1813                                 (define (g) (f))")))
1814                       (read-and-compile in
1815                                         #:opts %opts-w-arity
1816                                         #:to 'assembly))))))
1817          (and (= (length w) 1)
1818               (number? (string-contains (car w)
1819                                         "wrong number of arguments to")))))
1820
1821      (pass-if "local toplevel overrides global"
1822        (null? (call-with-warnings
1823                 (lambda ()
1824                   (let ((in (open-input-string "
1825                               (define (cons) 0)
1826                               (define (foo x) (cons))")))
1827                     (read-and-compile in
1828                                       #:opts %opts-w-arity
1829                                       #:to 'assembly))))))
1830
1831      (pass-if "keyword not passed and quiet"
1832        (null? (call-with-warnings
1833                 (lambda ()
1834                   (compile '(let ((f (lambda* (x #:key y) y)))
1835                               (f 2))
1836                            #:opts %opts-w-arity
1837                            #:to 'assembly)))))
1838
1839      (pass-if "keyword passed and quiet"
1840        (null? (call-with-warnings
1841                 (lambda ()
1842                   (compile '(let ((f (lambda* (x #:key y) y)))
1843                               (f 2 #:y 3))
1844                            #:opts %opts-w-arity
1845                            #:to 'assembly)))))
1846
1847      (pass-if "keyword passed to global and quiet"
1848        (null? (call-with-warnings
1849                 (lambda ()
1850                   (let ((in (open-input-string "
1851                               (use-modules (system base compile))
1852                               (compile '(+ 2 3) #:env (current-module))")))
1853                     (read-and-compile in
1854                                       #:opts %opts-w-arity
1855                                       #:to 'assembly))))))
1856
1857      (pass-if "extra keyword"
1858        (let ((w (call-with-warnings
1859                   (lambda ()
1860                     (compile '(let ((f (lambda* (x #:key y) y)))
1861                                 (f 2 #:Z 3))
1862                              #:opts %opts-w-arity
1863                              #:to 'assembly)))))
1864          (and (= (length w) 1)
1865               (number? (string-contains (car w)
1866                                         "wrong number of arguments to")))))
1867
1868      (pass-if "extra keywords allowed"
1869        (null? (call-with-warnings
1870                 (lambda ()
1871                   (compile '(let ((f (lambda* (x #:key y #:allow-other-keys)
1872                                        y)))
1873                               (f 2 #:Z 3))
1874                            #:opts %opts-w-arity
1875                            #:to 'assembly))))))
1876
1877    (with-test-prefix "format"
1878
1879      (pass-if "quiet (no args)"
1880        (null? (call-with-warnings
1881                (lambda ()
1882                  (compile '(format #t "hey!")
1883                           #:opts %opts-w-format
1884                           #:to 'assembly)))))
1885
1886      (pass-if "quiet (1 arg)"
1887        (null? (call-with-warnings
1888                (lambda ()
1889                  (compile '(format #t "hey ~A!" "you")
1890                           #:opts %opts-w-format
1891                           #:to 'assembly)))))
1892
1893      (pass-if "quiet (2 args)"
1894        (null? (call-with-warnings
1895                (lambda ()
1896                  (compile '(format #t "~A ~A!" "hello" "world")
1897                           #:opts %opts-w-format
1898                           #:to 'assembly)))))
1899
1900      (pass-if "wrong port arg"
1901        (let ((w (call-with-warnings
1902                  (lambda ()
1903                    (compile '(format 10 "foo")
1904                             #:opts %opts-w-format
1905                             #:to 'assembly)))))
1906          (and (= (length w) 1)
1907               (number? (string-contains (car w)
1908                                         "wrong port argument")))))
1909
1910      (pass-if "non-literal format string"
1911        (let ((w (call-with-warnings
1912                  (lambda ()
1913                    (compile '(format #f fmt)
1914                             #:opts %opts-w-format
1915                             #:to 'assembly)))))
1916          (and (= (length w) 1)
1917               (number? (string-contains (car w)
1918                                         "non-literal format string")))))
1919
1920      (pass-if "non-literal format string using gettext"
1921        (null? (call-with-warnings
1922                (lambda ()
1923                  (compile '(format #t (_ "~A ~A!") "hello" "world")
1924                           #:opts %opts-w-format
1925                           #:to 'assembly)))))
1926
1927      (pass-if "wrong format string"
1928        (let ((w (call-with-warnings
1929                  (lambda ()
1930                    (compile '(format #f 'not-a-string)
1931                             #:opts %opts-w-format
1932                             #:to 'assembly)))))
1933          (and (= (length w) 1)
1934               (number? (string-contains (car w)
1935                                         "wrong format string")))))
1936
1937      (pass-if "wrong number of args"
1938        (let ((w (call-with-warnings
1939                  (lambda ()
1940                    (compile '(format "shbweeb")
1941                             #:opts %opts-w-format
1942                             #:to 'assembly)))))
1943          (and (= (length w) 1)
1944               (number? (string-contains (car w)
1945                                         "wrong number of arguments")))))
1946
1947      (pass-if "~%, ~~, ~&, ~t, ~_, and ~\\n"
1948        (null? (call-with-warnings
1949                (lambda ()
1950                  (compile '(format some-port "~&~3_~~ ~\n~12they~%")
1951                           #:opts %opts-w-format
1952                           #:to 'assembly)))))
1953
1954      (pass-if "one missing argument"
1955        (let ((w (call-with-warnings
1956                  (lambda ()
1957                    (compile '(format some-port "foo ~A~%")
1958                             #:opts %opts-w-format
1959                             #:to 'assembly)))))
1960          (and (= (length w) 1)
1961               (number? (string-contains (car w)
1962                                         "expected 1, got 0")))))
1963
1964      (pass-if "one missing argument, gettext"
1965        (let ((w (call-with-warnings
1966                  (lambda ()
1967                    (compile '(format some-port (_ "foo ~A~%"))
1968                             #:opts %opts-w-format
1969                             #:to 'assembly)))))
1970          (and (= (length w) 1)
1971               (number? (string-contains (car w)
1972                                         "expected 1, got 0")))))
1973
1974      (pass-if "two missing arguments"
1975        (let ((w (call-with-warnings
1976                  (lambda ()
1977                    (compile '(format #f "foo ~10,2f and bar ~S~%")
1978                             #:opts %opts-w-format
1979                             #:to 'assembly)))))
1980          (and (= (length w) 1)
1981               (number? (string-contains (car w)
1982                                         "expected 2, got 0")))))
1983
1984      (pass-if "one given, one missing argument"
1985        (let ((w (call-with-warnings
1986                  (lambda ()
1987                    (compile '(format #t "foo ~A and ~S~%" hey)
1988                             #:opts %opts-w-format
1989                             #:to 'assembly)))))
1990          (and (= (length w) 1)
1991               (number? (string-contains (car w)
1992                                         "expected 2, got 1")))))
1993
1994      (pass-if "too many arguments"
1995        (let ((w (call-with-warnings
1996                  (lambda ()
1997                    (compile '(format #t "foo ~A~%" 1 2)
1998                             #:opts %opts-w-format
1999                             #:to 'assembly)))))
2000          (and (= (length w) 1)
2001               (number? (string-contains (car w)
2002                                         "expected 1, got 2")))))
2003
2004      (with-test-prefix "conditionals"
2005        (pass-if "literals"
2006         (null? (call-with-warnings
2007                 (lambda ()
2008                   (compile '(format #f "~A ~[foo~;bar~;baz~;~] ~10,2f"
2009                                     'a 1 3.14)
2010                            #:opts %opts-w-format
2011                            #:to 'assembly)))))
2012
2013        (pass-if "literals with selector"
2014          (let ((w (call-with-warnings
2015                    (lambda ()
2016                      (compile '(format #f "~2[foo~;bar~;baz~;~] ~A"
2017                                        1 'dont-ignore-me)
2018                               #:opts %opts-w-format
2019                               #:to 'assembly)))))
2020            (and (= (length w) 1)
2021                 (number? (string-contains (car w)
2022                                           "expected 1, got 2")))))
2023
2024        (pass-if "escapes (exact count)"
2025          (let ((w (call-with-warnings
2026                    (lambda ()
2027                      (compile '(format #f "~[~a~;~a~]")
2028                               #:opts %opts-w-format
2029                               #:to 'assembly)))))
2030            (and (= (length w) 1)
2031                 (number? (string-contains (car w)
2032                                           "expected 2, got 0")))))
2033
2034        (pass-if "escapes with selector"
2035          (let ((w (call-with-warnings
2036                    (lambda ()
2037                      (compile '(format #f "~1[chbouib~;~a~]")
2038                               #:opts %opts-w-format
2039                               #:to 'assembly)))))
2040            (and (= (length w) 1)
2041                 (number? (string-contains (car w)
2042                                           "expected 1, got 0")))))
2043
2044        (pass-if "escapes, range"
2045          (let ((w (call-with-warnings
2046                    (lambda ()
2047                      (compile '(format #f "~[chbouib~;~a~;~2*~a~]")
2048                               #:opts %opts-w-format
2049                               #:to 'assembly)))))
2050            (and (= (length w) 1)
2051                 (number? (string-contains (car w)
2052                                           "expected 1 to 4, got 0")))))
2053
2054        (pass-if "@"
2055          (let ((w (call-with-warnings
2056                    (lambda ()
2057                      (compile '(format #f "~@[temperature=~d~]")
2058                               #:opts %opts-w-format
2059                               #:to 'assembly)))))
2060            (and (= (length w) 1)
2061                 (number? (string-contains (car w)
2062                                           "expected 1, got 0")))))
2063
2064        (pass-if "nested"
2065          (let ((w (call-with-warnings
2066                    (lambda ()
2067                      (compile '(format #f "~:[~[hey~;~a~;~va~]~;~3*~]")
2068                               #:opts %opts-w-format
2069                               #:to 'assembly)))))
2070            (and (= (length w) 1)
2071                 (number? (string-contains (car w)
2072                                           "expected 2 to 4, got 0")))))
2073
2074        (pass-if "unterminated"
2075          (let ((w (call-with-warnings
2076                    (lambda ()
2077                      (compile '(format #f "~[unterminated")
2078                               #:opts %opts-w-format
2079                               #:to 'assembly)))))
2080            (and (= (length w) 1)
2081                 (number? (string-contains (car w)
2082                                           "unterminated conditional")))))
2083
2084        (pass-if "unexpected ~;"
2085          (let ((w (call-with-warnings
2086                    (lambda ()
2087                      (compile '(format #f "foo~;bar")
2088                               #:opts %opts-w-format
2089                               #:to 'assembly)))))
2090            (and (= (length w) 1)
2091                 (number? (string-contains (car w)
2092                                           "unexpected")))))
2093
2094        (pass-if "unexpected ~]"
2095          (let ((w (call-with-warnings
2096                    (lambda ()
2097                      (compile '(format #f "foo~]")
2098                               #:opts %opts-w-format
2099                               #:to 'assembly)))))
2100            (and (= (length w) 1)
2101                 (number? (string-contains (car w)
2102                                           "unexpected"))))))
2103
2104      (pass-if "~{...~}"
2105        (null? (call-with-warnings
2106                (lambda ()
2107                  (compile '(format #f "~A ~{~S~} ~A"
2108                                    'hello '("ladies" "and")
2109                                    'gentlemen)
2110                           #:opts %opts-w-format
2111                           #:to 'assembly)))))
2112
2113      (pass-if "~{...~}, too many args"
2114        (let ((w (call-with-warnings
2115                  (lambda ()
2116                    (compile '(format #f "~{~S~}" 1 2 3)
2117                             #:opts %opts-w-format
2118                             #:to 'assembly)))))
2119          (and (= (length w) 1)
2120               (number? (string-contains (car w)
2121                                         "expected 1, got 3")))))
2122
2123      (pass-if "~@{...~}"
2124        (null? (call-with-warnings
2125                (lambda ()
2126                  (compile '(format #f "~@{~S~}" 1 2 3)
2127                           #:opts %opts-w-format
2128                           #:to 'assembly)))))
2129
2130      (pass-if "~@{...~}, too few args"
2131        (let ((w (call-with-warnings
2132                  (lambda ()
2133                    (compile '(format #f "~A ~@{~S~}")
2134                             #:opts %opts-w-format
2135                             #:to 'assembly)))))
2136          (and (= (length w) 1)
2137               (number? (string-contains (car w)
2138                                         "expected at least 1, got 0")))))
2139
2140      (pass-if "unterminated ~{...~}"
2141        (let ((w (call-with-warnings
2142                  (lambda ()
2143                    (compile '(format #f "~{")
2144                             #:opts %opts-w-format
2145                             #:to 'assembly)))))
2146          (and (= (length w) 1)
2147               (number? (string-contains (car w)
2148                                         "unterminated")))))
2149
2150      (pass-if "~(...~)"
2151        (null? (call-with-warnings
2152                (lambda ()
2153                  (compile '(format #f "~:@(~A ~A~)" 'foo 'bar)
2154                           #:opts %opts-w-format
2155                           #:to 'assembly)))))
2156
2157      (pass-if "~v"
2158        (let ((w (call-with-warnings
2159                  (lambda ()
2160                    (compile '(format #f "~v_foo")
2161                             #:opts %opts-w-format
2162                             #:to 'assembly)))))
2163          (and (= (length w) 1)
2164               (number? (string-contains (car w)
2165                                         "expected 1, got 0")))))
2166      (pass-if "~v:@y"
2167        (null? (call-with-warnings
2168                (lambda ()
2169                  (compile '(format #f "~v:@y" 1 123)
2170                           #:opts %opts-w-format
2171                           #:to 'assembly)))))
2172
2173
2174      (pass-if "~*"
2175        (let ((w (call-with-warnings
2176                  (lambda ()
2177                    (compile '(format #f "~2*~a" 'a 'b)
2178                             #:opts %opts-w-format
2179                             #:to 'assembly)))))
2180          (and (= (length w) 1)
2181               (number? (string-contains (car w)
2182                                         "expected 3, got 2")))))
2183
2184      (pass-if "~?"
2185        (null? (call-with-warnings
2186                (lambda ()
2187                  (compile '(format #f "~?" "~d ~d" '(1 2))
2188                           #:opts %opts-w-format
2189                           #:to 'assembly)))))
2190
2191      (pass-if "complex 1"
2192        (let ((w (call-with-warnings
2193                  (lambda ()
2194                    (compile '(format #f
2195                                      "~4@S    ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n"
2196                                      1 2 3 4 5 6)
2197                             #:opts %opts-w-format
2198                             #:to 'assembly)))))
2199          (and (= (length w) 1)
2200               (number? (string-contains (car w)
2201                                         "expected 4, got 6")))))
2202
2203      (pass-if "complex 2"
2204        (let ((w (call-with-warnings
2205                  (lambda ()
2206                    (compile '(format #f
2207                                      "~:(~A~) Commands~:[~; [abbrev]~]:~2%"
2208                                      1 2 3 4)
2209                             #:opts %opts-w-format
2210                             #:to 'assembly)))))
2211          (and (= (length w) 1)
2212               (number? (string-contains (car w)
2213                                         "expected 2, got 4")))))
2214
2215      (pass-if "complex 3"
2216        (let ((w (call-with-warnings
2217                  (lambda ()
2218                    (compile '(format #f "~9@a~:[~*~3_~;~3d~] ~v:@y~%")
2219                             #:opts %opts-w-format
2220                             #:to 'assembly)))))
2221          (and (= (length w) 1)
2222               (number? (string-contains (car w)
2223                                         "expected 5, got 0")))))
2224
2225      (pass-if "ice-9 format"
2226        (let ((w (call-with-warnings
2227                  (lambda ()
2228                    (let ((in (open-input-string
2229                               "(use-modules ((ice-9 format)
2230                                  #:renamer (symbol-prefix-proc 'i9-)))
2231                                (i9-format #t \"yo! ~A\" 1 2)")))
2232                      (read-and-compile in
2233                                        #:opts %opts-w-format
2234                                        #:to 'assembly))))))
2235          (and (= (length w) 1)
2236               (number? (string-contains (car w)
2237                                         "expected 1, got 2")))))
2238
2239      (pass-if "not format"
2240        (null? (call-with-warnings
2241                (lambda ()
2242                  (compile '(let ((format chbouib))
2243                              (format #t "not ~A a format string"))
2244                           #:opts %opts-w-format
2245                           #:to 'assembly)))))))