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