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