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 glil)
  27   #:use-module (srfi srfi-13))
  28
  29 ;; Of course, the GLIL that is emitted depends on the source info of the
  30 ;; input. Here we're not concerned about that, so we strip source
  31 ;; information from the incoming tree-il.
  32
  33 (define (strip-source x)
  34   (post-order! (lambda (x) (set! (tree-il-src x) #f))
  35                x))
  36
  37 (define-syntax assert-tree-il->glil
  38   (syntax-rules (with-partial-evaluation without-partial-evaluation
  39                  with-options)
  40     ((_ with-partial-evaluation in pat test ...)
  41      (assert-tree-il->glil with-options (#:partial-eval? #t)
  42                            in pat test ...))
  43     ((_ without-partial-evaluation in pat test ...)
  44      (assert-tree-il->glil with-options (#:partial-eval? #f)
  45                            in pat test ...))
  46     ((_ with-options opts in pat test ...)
  47      (let ((exp 'in))
  48        (pass-if 'in
  49          (let ((glil (unparse-glil
  50                       (compile (strip-source (parse-tree-il exp))
  51                                #:from 'tree-il #:to 'glil
  52                                #:opts 'opts))))
  53            (pmatch glil
  54              (pat (guard test ...) #t)
  55              (else #f))))))
  56     ((_ in pat test ...)
  57      (assert-tree-il->glil with-partial-evaluation
  58                            in pat test ...))))
  59
  60 (define-syntax pass-if-tree-il->scheme
  61   (syntax-rules ()
  62     ((_ in pat)
  63      (assert-scheme->tree-il->scheme in pat #t))
  64     ((_ in pat guard-exp)
  65      (pass-if 'in
  66        (pmatch (tree-il->scheme
  67                 (compile 'in #:from 'scheme #:to 'tree-il))
  68          (pat (guard guard-exp) #t)
  69          (_ #f))))))
  70
  71 (define peval
  72   ;; The partial evaluator.
  73   (@@ (language tree-il optimize) peval))
  74
  75 (define-syntax pass-if-peval
  76   (syntax-rules ()
  77     ((_ in pat)
  78      (pass-if 'in
  79        (let ((evaled (unparse-tree-il
  80                       (peval (compile 'in #:from 'scheme #:to 'tree-il)))))
  81          (pmatch evaled
  82            (pat #t)
  83            (_   (pk 'peval-mismatch evaled) #f)))))))
  84
  85 \f
  86 (with-test-prefix "tree-il->scheme"
  87   (pass-if-tree-il->scheme
  88    (case-lambda ((a) a) ((b c) (list b c)))
  89    (case-lambda ((,a) ,a1) ((,b ,c) (list ,b1 ,c1)))
  90    (and (eq? a a1) (eq? b b1) (eq? c c1))))
  91
  92 (with-test-prefix "void"
  93   (assert-tree-il->glil
  94    (void)
  95    (program () (std-prelude 0 0 #f) (label _) (void) (call return 1)))
  96   (assert-tree-il->glil
  97    (begin (void) (const 1))
  98    (program () (std-prelude 0 0 #f) (label _) (const 1) (call return 1)))
  99   (assert-tree-il->glil
 100    (apply (primitive +) (void) (const 1))
 101    (program () (std-prelude 0 0 #f) (label _) (void) (call add1 1) (call return 1))))
 102
 103 (with-test-prefix "application"
 104   (assert-tree-il->glil
 105    (apply (toplevel foo) (const 1))
 106    (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (const 1) (call tail-call 1)))
 107   (assert-tree-il->glil
 108    (begin (apply (toplevel foo) (const 1)) (void))
 109    (program () (std-prelude 0 0 #f) (label _) (call new-frame 0) (toplevel ref foo) (const 1) (mv-call 1 ,l1)
 110             (call drop 1) (branch br ,l2)
 111             (label ,l3) (mv-bind 0 #f)
 112             (label ,l4)
 113             (void) (call return 1))
 114    (and (eq? l1 l3) (eq? l2 l4)))
 115   (assert-tree-il->glil
 116    (apply (toplevel foo) (apply (toplevel bar)))
 117    (program ()  (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call new-frame 0) (toplevel ref bar) (call call 0)
 118             (call tail-call 1))))
 119
 120 (with-test-prefix "conditional"
 121   (assert-tree-il->glil
 122    (if (toplevel foo) (const 1) (const 2))
 123    (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1)
 124             (const 1) (call return 1)
 125             (label ,l2) (const 2) (call return 1))
 126    (eq? l1 l2))
 127
 128   (assert-tree-il->glil without-partial-evaluation
 129    (begin (if (toplevel foo) (const 1) (const 2)) (const #f))
 130    (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1) (branch br ,l2)
 131             (label ,l3) (label ,l4) (const #f) (call return 1))
 132    (eq? l1 l3) (eq? l2 l4))
 133
 134   (assert-tree-il->glil
 135    (apply (primitive null?) (if (toplevel foo) (const 1) (const 2)))
 136    (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1)
 137             (const 1) (branch br ,l2)
 138                     (label ,l3) (const 2) (label ,l4)
 139                     (call null? 1) (call return 1))
 140    (eq? l1 l3) (eq? l2 l4)))
 141
 142 (with-test-prefix "primitive-ref"
 143   (assert-tree-il->glil
 144    (primitive +)
 145    (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call return 1)))
 146
 147   (assert-tree-il->glil
 148    (begin (primitive +) (const #f))
 149    (program () (std-prelude 0 0 #f) (label _) (const #f) (call return 1)))
 150
 151   (assert-tree-il->glil
 152    (apply (primitive null?) (primitive +))
 153    (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call null? 1)
 154             (call return 1))))
 155
 156 (with-test-prefix "lexical refs"
 157   (assert-tree-il->glil without-partial-evaluation
 158    (let (x) (y) ((const 1)) (lexical x y))
 159    (program () (std-prelude 0 1 #f) (label _)
 160             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
 161             (lexical #t #f ref 0) (call return 1)
 162             (unbind)))
 163
 164   (assert-tree-il->glil without-partial-evaluation
 165    (let (x) (y) ((const 1)) (begin (lexical x y) (const #f)))
 166    (program () (std-prelude 0 1 #f) (label _)
 167             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
 168             (const #f) (call return 1)
 169             (unbind)))
 170
 171   (assert-tree-il->glil without-partial-evaluation
 172    (let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y)))
 173    (program () (std-prelude 0 1 #f) (label _)
 174             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
 175             (lexical #t #f ref 0) (call null? 1) (call return 1)
 176             (unbind))))
 177
 178 (with-test-prefix "lexical sets"
 179   (assert-tree-il->glil
 180    ;; unreferenced sets may be optimized away -- make sure they are ref'd
 181    (let (x) (y) ((const 1))
 182         (set! (lexical x y) (apply (primitive 1+) (lexical x y))))
 183    (program () (std-prelude 0 1 #f) (label _)
 184             (const 1) (bind (x #t 0)) (lexical #t #t box 0)
 185             (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
 186             (void) (call return 1)
 187             (unbind)))
 188
 189   (assert-tree-il->glil
 190    (let (x) (y) ((const 1))
 191         (begin (set! (lexical x y) (apply (primitive 1+) (lexical x y)))
 192                (lexical x y)))
 193    (program () (std-prelude 0 1 #f) (label _)
 194             (const 1) (bind (x #t 0)) (lexical #t #t box 0)
 195             (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
 196             (lexical #t #t ref 0) (call return 1)
 197             (unbind)))
 198
 199   (assert-tree-il->glil
 200    (let (x) (y) ((const 1))
 201      (apply (primitive null?)
 202             (set! (lexical x y) (apply (primitive 1+) (lexical x y)))))
 203    (program () (std-prelude 0 1 #f) (label _)
 204             (const 1) (bind (x #t 0)) (lexical #t #t box 0)
 205             (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (void)
 206             (call null? 1) (call return 1)
 207             (unbind))))
 208
 209 (with-test-prefix "module refs"
 210   (assert-tree-il->glil
 211    (@ (foo) bar)
 212    (program () (std-prelude 0 0 #f) (label _)
 213             (module public ref (foo) bar)
 214             (call return 1)))
 215
 216   (assert-tree-il->glil
 217    (begin (@ (foo) bar) (const #f))
 218    (program () (std-prelude 0 0 #f) (label _)
 219             (module public ref (foo) bar) (call drop 1)
 220             (const #f) (call return 1)))
 221
 222   (assert-tree-il->glil
 223    (apply (primitive null?) (@ (foo) bar))
 224    (program () (std-prelude 0 0 #f) (label _)
 225             (module public ref (foo) bar)
 226             (call null? 1) (call return 1)))
 227
 228   (assert-tree-il->glil
 229    (@@ (foo) bar)
 230    (program () (std-prelude 0 0 #f) (label _)
 231             (module private ref (foo) bar)
 232             (call return 1)))
 233
 234   (assert-tree-il->glil
 235    (begin (@@ (foo) bar) (const #f))
 236    (program () (std-prelude 0 0 #f) (label _)
 237             (module private ref (foo) bar) (call drop 1)
 238             (const #f) (call return 1)))
 239
 240   (assert-tree-il->glil
 241    (apply (primitive null?) (@@ (foo) bar))
 242    (program () (std-prelude 0 0 #f) (label _)
 243             (module private ref (foo) bar)
 244             (call null? 1) (call return 1))))
 245
 246 (with-test-prefix "module sets"
 247   (assert-tree-il->glil
 248    (set! (@ (foo) bar) (const 2))
 249    (program () (std-prelude 0 0 #f) (label _)
 250             (const 2) (module public set (foo) bar)
 251             (void) (call return 1)))
 252
 253   (assert-tree-il->glil
 254    (begin (set! (@ (foo) bar) (const 2)) (const #f))
 255    (program () (std-prelude 0 0 #f) (label _)
 256             (const 2) (module public set (foo) bar)
 257             (const #f) (call return 1)))
 258
 259   (assert-tree-il->glil
 260    (apply (primitive null?) (set! (@ (foo) bar) (const 2)))
 261    (program () (std-prelude 0 0 #f) (label _)
 262             (const 2) (module public set (foo) bar)
 263             (void) (call null? 1) (call return 1)))
 264
 265   (assert-tree-il->glil
 266    (set! (@@ (foo) bar) (const 2))
 267    (program () (std-prelude 0 0 #f) (label _)
 268             (const 2) (module private set (foo) bar)
 269             (void) (call return 1)))
 270
 271   (assert-tree-il->glil
 272    (begin (set! (@@ (foo) bar) (const 2)) (const #f))
 273    (program () (std-prelude 0 0 #f) (label _)
 274             (const 2) (module private set (foo) bar)
 275             (const #f) (call return 1)))
 276
 277   (assert-tree-il->glil
 278    (apply (primitive null?) (set! (@@ (foo) bar) (const 2)))
 279    (program () (std-prelude 0 0 #f) (label _)
 280             (const 2) (module private set (foo) bar)
 281             (void) (call null? 1) (call return 1))))
 282
 283 (with-test-prefix "toplevel refs"
 284   (assert-tree-il->glil
 285    (toplevel bar)
 286    (program () (std-prelude 0 0 #f) (label _)
 287             (toplevel ref bar)
 288             (call return 1)))
 289
 290   (assert-tree-il->glil without-partial-evaluation
 291    (begin (toplevel bar) (const #f))
 292    (program () (std-prelude 0 0 #f) (label _)
 293             (toplevel ref bar) (call drop 1)
 294             (const #f) (call return 1)))
 295
 296   (assert-tree-il->glil
 297    (apply (primitive null?) (toplevel bar))
 298    (program () (std-prelude 0 0 #f) (label _)
 299             (toplevel ref bar)
 300             (call null? 1) (call return 1))))
 301
 302 (with-test-prefix "toplevel sets"
 303   (assert-tree-il->glil
 304    (set! (toplevel bar) (const 2))
 305    (program () (std-prelude 0 0 #f) (label _)
 306             (const 2) (toplevel set bar)
 307             (void) (call return 1)))
 308
 309   (assert-tree-il->glil
 310    (begin (set! (toplevel bar) (const 2)) (const #f))
 311    (program () (std-prelude 0 0 #f) (label _)
 312             (const 2) (toplevel set bar)
 313             (const #f) (call return 1)))
 314
 315   (assert-tree-il->glil
 316    (apply (primitive null?) (set! (toplevel bar) (const 2)))
 317    (program () (std-prelude 0 0 #f) (label _)
 318             (const 2) (toplevel set bar)
 319             (void) (call null? 1) (call return 1))))
 320
 321 (with-test-prefix "toplevel defines"
 322   (assert-tree-il->glil
 323    (define bar (const 2))
 324    (program () (std-prelude 0 0 #f) (label _)
 325             (const 2) (toplevel define bar)
 326             (void) (call return 1)))
 327
 328   (assert-tree-il->glil
 329    (begin (define bar (const 2)) (const #f))
 330    (program () (std-prelude 0 0 #f) (label _)
 331             (const 2) (toplevel define bar)
 332             (const #f) (call return 1)))
 333
 334   (assert-tree-il->glil
 335    (apply (primitive null?) (define bar (const 2)))
 336    (program () (std-prelude 0 0 #f) (label _)
 337             (const 2) (toplevel define bar)
 338             (void) (call null? 1) (call return 1))))
 339
 340 (with-test-prefix "constants"
 341   (assert-tree-il->glil
 342    (const 2)
 343    (program () (std-prelude 0 0 #f) (label _)
 344             (const 2) (call return 1)))
 345
 346   (assert-tree-il->glil
 347    (begin (const 2) (const #f))
 348    (program () (std-prelude 0 0 #f) (label _)
 349             (const #f) (call return 1)))
 350
 351   (assert-tree-il->glil
 352    ;; This gets simplified by `peval'.
 353    (apply (primitive null?) (const 2))
 354    (program () (std-prelude 0 0 #f) (label _)
 355             (const #f) (call return 1))))
 356
 357 (with-test-prefix "letrec"
 358   ;; simple bindings -> let
 359   (assert-tree-il->glil without-partial-evaluation
 360    (letrec (x y) (x1 y1) ((const 10) (const 20))
 361            (apply (toplevel foo) (lexical x x1) (lexical y y1)))
 362    (program () (std-prelude 0 2 #f) (label _)
 363             (const 10) (const 20)
 364             (bind (x #f 0) (y #f 1))
 365             (lexical #t #f set 1) (lexical #t #f set 0)
 366             (toplevel ref foo)
 367             (lexical #t #f ref 0) (lexical #t #f ref 1)
 368             (call tail-call 2)
 369             (unbind)))
 370
 371   ;; complex bindings -> box and set! within let
 372   (assert-tree-il->glil without-partial-evaluation
 373    (letrec (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar)))
 374            (apply (primitive +) (lexical x x1) (lexical y y1)))
 375    (program () (std-prelude 0 4 #f) (label _)
 376             (void) (void) ;; what are these?
 377             (bind (x #t 0) (y #t 1))
 378             (lexical #t #t box 1) (lexical #t #t box 0)
 379             (call new-frame 0) (toplevel ref foo) (call call 0)
 380             (call new-frame 0) (toplevel ref bar) (call call 0)
 381             (bind (x #f 2) (y #f 3)) (lexical #t #f set 3) (lexical #t #f set 2)
 382             (lexical #t #f ref 2) (lexical #t #t set 0)
 383             (lexical #t #f ref 3) (lexical #t #t set 1) (unbind)
 384             (lexical #t #t ref 0) (lexical #t #t ref 1)
 385             (call add 2) (call return 1) (unbind)))
 386
 387   ;; complex bindings in letrec* -> box and set! in order
 388   (assert-tree-il->glil without-partial-evaluation
 389    (letrec* (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar)))
 390             (apply (primitive +) (lexical x x1) (lexical y y1)))
 391    (program () (std-prelude 0 2 #f) (label _)
 392             (void) (void) ;; what are these?
 393             (bind (x #t 0) (y #t 1))
 394             (lexical #t #t box 1) (lexical #t #t box 0)
 395             (call new-frame 0) (toplevel ref foo) (call call 0)
 396             (lexical #t #t set 0)
 397             (call new-frame 0) (toplevel ref bar) (call call 0)
 398             (lexical #t #t set 1)
 399             (lexical #t #t ref 0)
 400             (lexical #t #t ref 1)
 401             (call add 2) (call return 1) (unbind)))
 402
 403   ;; simple bindings in letrec* -> equivalent to letrec
 404   (assert-tree-il->glil without-partial-evaluation
 405    (letrec* (x y) (xx yy) ((const 1) (const 2))
 406             (lexical y yy))
 407    (program () (std-prelude 0 1 #f) (label _)
 408             (const 2)
 409             (bind (y #f 0)) ;; X is removed, and Y is unboxed
 410             (lexical #t #f set 0)
 411             (lexical #t #f ref 0)
 412             (call return 1) (unbind))))
 413
 414 (with-test-prefix "lambda"
 415   (assert-tree-il->glil
 416    (lambda ()
 417      (lambda-case (((x) #f #f #f () (y)) (const 2)) #f))
 418    (program ()  (std-prelude 0 0 #f) (label _)
 419             (program () (std-prelude 1 1 #f)
 420                      (bind (x #f 0)) (label _)
 421                      (const 2) (call return 1) (unbind))
 422             (call return 1)))
 423
 424   (assert-tree-il->glil
 425    (lambda ()
 426      (lambda-case (((x y) #f #f #f () (x1 y1))
 427                    (const 2))
 428                   #f))
 429    (program () (std-prelude 0 0 #f) (label _)
 430             (program () (std-prelude 2 2 #f)
 431                      (bind (x #f 0) (y #f 1)) (label _)
 432                      (const 2) (call return 1)
 433                      (unbind))
 434             (call return 1)))
 435
 436   (assert-tree-il->glil
 437    (lambda ()
 438      (lambda-case ((() #f x #f () (y)) (const 2))
 439                   #f))
 440    (program () (std-prelude 0 0 #f) (label _)
 441             (program () (opt-prelude 0 0 0 1 #f)
 442                      (bind (x #f 0)) (label _)
 443                      (const 2) (call return 1)
 444                      (unbind))
 445             (call return 1)))
 446
 447   (assert-tree-il->glil
 448    (lambda ()
 449      (lambda-case (((x) #f x1 #f () (y y1)) (const 2))
 450                   #f))
 451    (program () (std-prelude 0 0 #f) (label _)
 452             (program () (opt-prelude 1 0 1 2 #f)
 453                      (bind (x #f 0) (x1 #f 1)) (label _)
 454                      (const 2) (call return 1)
 455                      (unbind))
 456             (call return 1)))
 457
 458   (assert-tree-il->glil
 459    (lambda ()
 460      (lambda-case (((x) #f x1 #f () (y y1)) (lexical x y))
 461                   #f))
 462    (program () (std-prelude 0 0 #f) (label _)
 463             (program () (opt-prelude 1 0 1 2 #f)
 464                      (bind (x #f 0) (x1 #f 1)) (label _)
 465                      (lexical #t #f ref 0) (call return 1)
 466                      (unbind))
 467             (call return 1)))
 468
 469   (assert-tree-il->glil
 470    (lambda ()
 471      (lambda-case (((x) #f x1 #f () (y y1)) (lexical x1 y1))
 472                   #f))
 473    (program () (std-prelude 0 0 #f) (label _)
 474             (program () (opt-prelude 1 0 1 2 #f)
 475                      (bind (x #f 0) (x1 #f 1)) (label _)
 476                      (lexical #t #f ref 1) (call return 1)
 477                      (unbind))
 478             (call return 1)))
 479
 480   (assert-tree-il->glil
 481    (lambda ()
 482      (lambda-case (((x) #f #f #f () (x1))
 483                    (lambda ()
 484                      (lambda-case (((y) #f #f #f () (y1))
 485                                    (lexical x x1))
 486                                   #f)))
 487                   #f))
 488    (program () (std-prelude 0 0 #f) (label _)
 489             (program () (std-prelude 1 1 #f)
 490                      (bind (x #f 0)) (label _)
 491                      (program () (std-prelude 1 1 #f)
 492                               (bind (y #f 0)) (label _)
 493                               (lexical #f #f ref 0) (call return 1)
 494                               (unbind))
 495                      (lexical #t #f ref 0)
 496                      (call make-closure 1)
 497                      (call return 1)
 498                      (unbind))
 499             (call return 1))))
 500
 501 (with-test-prefix "sequence"
 502   (assert-tree-il->glil
 503    (begin (begin (const 2) (const #f)) (const #t))
 504    (program () (std-prelude 0 0 #f) (label _)
 505             (const #t) (call return 1)))
 506
 507   (assert-tree-il->glil
 508    ;; This gets simplified by `peval'.
 509    (apply (primitive null?) (begin (const #f) (const 2)))
 510    (program () (std-prelude 0 0 #f) (label _)
 511             (const #f) (call return 1))))
 512
 513 (with-test-prefix "values"
 514   (assert-tree-il->glil
 515    (apply (primitive values)
 516           (apply (primitive values) (const 1) (const 2)))
 517    (program () (std-prelude 0 0 #f) (label _)
 518             (const 1) (call return 1)))
 519
 520   (assert-tree-il->glil
 521    (apply (primitive values)
 522           (apply (primitive values) (const 1) (const 2))
 523           (const 3))
 524    (program () (std-prelude 0 0 #f) (label _)
 525             (const 1) (const 3) (call return/values 2)))
 526
 527   (assert-tree-il->glil
 528    (apply (primitive +)
 529           (apply (primitive values) (const 1) (const 2)))
 530    (program () (std-prelude 0 0 #f) (label _)
 531             (const 1) (call return 1))))
 532
 533 ;; FIXME: binding info for or-hacked locals might bork the disassembler,
 534 ;; and could be tightened in any case
 535 (with-test-prefix "the or hack"
 536   (assert-tree-il->glil without-partial-evaluation
 537    (let (x) (y) ((const 1))
 538         (if (lexical x y)
 539             (lexical x y)
 540             (let (a) (b) ((const 2))
 541                  (lexical a b))))
 542    (program () (std-prelude 0 1 #f) (label _)
 543             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
 544             (lexical #t #f ref 0) (branch br-if-not ,l1)
 545             (lexical #t #f ref 0) (call return 1)
 546             (label ,l2)
 547             (const 2) (bind (a #f 0)) (lexical #t #f set 0)
 548             (lexical #t #f ref 0) (call return 1)
 549             (unbind)
 550             (unbind))
 551    (eq? l1 l2))
 552
 553   ;; second bound var is unreferenced
 554   (assert-tree-il->glil without-partial-evaluation
 555    (let (x) (y) ((const 1))
 556         (if (lexical x y)
 557             (lexical x y)
 558             (let (a) (b) ((const 2))
 559                  (lexical x y))))
 560    (program () (std-prelude 0 1 #f) (label _)
 561             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
 562             (lexical #t #f ref 0) (branch br-if-not ,l1)
 563             (lexical #t #f ref 0) (call return 1)
 564             (label ,l2)
 565             (lexical #t #f ref 0) (call return 1)
 566             (unbind))
 567    (eq? l1 l2)))
 568
 569 (with-test-prefix "apply"
 570   (assert-tree-il->glil
 571    (apply (primitive @apply) (toplevel foo) (toplevel bar))
 572    (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (toplevel ref bar) (call tail-apply 2)))
 573   (assert-tree-il->glil
 574    (begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void))
 575    (program () (std-prelude 0 0 #f) (label _)
 576             (call new-frame 0) (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1)
 577             (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
 578             (label ,l4)
 579             (void) (call return 1))
 580    (and (eq? l1 l3) (eq? l2 l4)))
 581   (assert-tree-il->glil
 582    (apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz)))
 583    (program () (std-prelude 0 0 #f) (label _)
 584             (toplevel ref foo)
 585             (call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call apply 2)
 586             (call tail-call 1))))
 587
 588 (with-test-prefix "call/cc"
 589   (assert-tree-il->glil
 590    (apply (primitive @call-with-current-continuation) (toplevel foo))
 591    (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call tail-call/cc 1)))
 592   (assert-tree-il->glil
 593    (begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void))
 594    (program () (std-prelude 0 0 #f) (label _)
 595             (call new-frame 0) (toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1)
 596             (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
 597             (label ,l4)
 598             (void) (call return 1))
 599    (and (eq? l1 l3) (eq? l2 l4)))
 600   (assert-tree-il->glil
 601    (apply (toplevel foo)
 602           (apply (toplevel @call-with-current-continuation) (toplevel bar)))
 603    (program () (std-prelude 0 0 #f) (label _)
 604             (toplevel ref foo)
 605             (toplevel ref bar) (call call/cc 1)
 606             (call tail-call 1))))
 607
 608 \f
 609 (with-test-prefix "partial evaluation"
 610
 611   (pass-if-peval
 612     ;; First order, primitive.
 613     (let ((x 1) (y 2)) (+ x y))
 614     (const 3))
 615
 616   (pass-if-peval
 617     ;; First order, coalesced.
 618     (cons 0 (cons 1 (cons 2 (list 3 4 5))))
 619     (const (0 1 2 3 4 5)))
 620
 621   (pass-if-peval
 622     ;; First order, coalesced, mutability preserved.
 623     (define mutable
 624       (cons 0 (cons 1 (cons 2 (list 3 4 5)))))
 625     (define mutable
 626       ;; This must not be a constant.
 627       (apply (primitive list)
 628              (const 0) (const 1) (const 2) (const 3) (const 4) (const 5))))
 629
 630   (pass-if-peval
 631     ;; First order, mutability preserved.
 632     (define mutable
 633       (let loop ((i 3) (r '()))
 634         (if (zero? i)
 635             r
 636             (loop (1- i) (cons (cons i i) r)))))
 637     (define mutable
 638       (apply (primitive list)
 639              (apply (primitive cons) (const 1) (const 1))
 640              (apply (primitive cons) (const 2) (const 2))
 641              (apply (primitive cons) (const 3) (const 3)))))
 642
 643   ;; FIXME: The test below fails.
 644   ;; (pass-if-peval
 645   ;;   ;; Mutability preserved.
 646   ;;   ((lambda (x y z) (list x y z)) 1 2 3)
 647   ;;   (apply (primitive list) (const 1) (const 2) (const 3)))
 648
 649   (pass-if-peval
 650     ;; First order, evaluated.
 651     (define one
 652       (let loop ((i 7)
 653                  (r '()))
 654         (if (<= i 0)
 655             (car r)
 656             (loop (1- i) (cons i r)))))
 657     (define one (const 1)))
 658
 659   (pass-if-peval
 660     ;; First order, aliased primitive.
 661     (let* ((x *) (y (x 1 2))) y)
 662     (const 2))
 663
 664   (pass-if-peval
 665     ;; First order, shadowed primitive.
 666     (begin
 667       (define (+ x y) (pk x y))
 668       (+ 1 2))
 669     (begin
 670       (define +
 671         (lambda (_)
 672           (lambda-case
 673            (((x y) #f #f #f () (_ _))
 674             (apply (toplevel pk) (lexical x _) (lexical y _))))))
 675       (apply (toplevel +) (const 1) (const 2))))
 676
 677   (pass-if-peval
 678     ;; First-order, effects preserved.
 679     (let ((x 2))
 680       (do-something!)
 681       x)
 682     (begin
 683       (apply (toplevel do-something!))
 684       (const 2)))
 685
 686   (pass-if-peval
 687     ;; First order, residual bindings removed.
 688     (let ((x 2) (y 3))
 689       (* (+ x y) z))
 690     (apply (primitive *) (const 5) (toplevel z)))
 691
 692   (pass-if-peval
 693     ;; First order, with lambda.
 694     (define (foo x)
 695       (define (bar z) (* z z))
 696       (+ x (bar 3)))
 697     (define foo
 698       (lambda (_)
 699         (lambda-case
 700          (((x) #f #f #f () (_))
 701           (letrec* (bar) (_) ((lambda (_) . _))
 702                    (apply (primitive +) (lexical x _) (const 9))))))))
 703
 704   (pass-if-peval
 705     ;; First order, with lambda inlined & specialized twice.
 706     (let ((f (lambda (x y)
 707                (+ (* x top) y)))
 708           (x 2)
 709           (y 3))
 710       (+ (* x (f x y))
 711          (f something x)))
 712     (let (f) (_) ((lambda (_)
 713                     (lambda-case
 714                      (((x y) #f #f #f () (_ _))
 715                       (apply (primitive +)
 716                              (apply (primitive *)
 717                                     (lexical x _)
 718                                     (toplevel top))
 719                              (lexical y _))))))
 720          (apply (primitive +)
 721                 (apply (primitive *)
 722                        (const 2)
 723                        (apply (primitive +)       ; (f 2 3)
 724                               (apply (primitive *)
 725                                      (const 2)
 726                                      (toplevel top))
 727                               (const 3)))
 728                 (apply (primitive +)              ; (f something 2)
 729                        (apply (primitive *)
 730                               (toplevel something)
 731                               (toplevel top))
 732                        (const 2)))))
 733
 734   (pass-if-peval
 735     ;; First order, with lambda inlined & specialized 3 times.
 736     (let ((f (lambda (x y) (if (> x 0) y x))))
 737       (+ (f -1 x) (f 2 y) (f z y)))
 738     (let (f) (_)
 739          ((lambda (_)
 740             (lambda-case
 741              (((x y) #f #f #f () (_ _))
 742               (if (apply (primitive >) (lexical x _) (const 0))
 743                   (lexical y _)
 744                   (lexical x _))))))
 745          (apply (primitive +)
 746                 (const -1)                        ; (f -1 x)
 747                 (toplevel y)                      ; (f 2 y)
 748                 (apply (lexical f _)              ; (f z y)
 749                        (toplevel z) (toplevel y)))))
 750
 751   (pass-if-peval
 752     ;; First order, conditional.
 753     (let ((y 2))
 754       (lambda (x)
 755         (if (> y 0)
 756             (display x)
 757             'never-reached)))
 758     (lambda ()
 759       (lambda-case
 760        (((x) #f #f #f () (_))
 761         (apply (toplevel display) (lexical x _))))))
 762
 763   (pass-if-peval
 764     ;; First order, recursive procedure.
 765     (letrec ((fibo (lambda (n)
 766                      (if (<= n 1)
 767                          n
 768                          (+ (fibo (- n 1))
 769                             (fibo (- n 2)))))))
 770       (fibo 7))
 771     (const 13))
 772
 773   (pass-if-peval
 774     ;; Higher order.
 775     ((lambda (f x)
 776        (f (* (car x) (cadr x))))
 777      (lambda (x)
 778        (+ x 1))
 779      '(2 3))
 780     (const 7))
 781
 782   (pass-if-peval
 783     ;; Higher order with optional argument (default value).
 784     ((lambda* (f x #:optional (y 0))
 785        (+ y (f (* (car x) (cadr x)))))
 786      (lambda (x)
 787        (+ x 1))
 788      '(2 3))
 789     (const 7))
 790
 791   (pass-if-peval
 792     ;; Higher order with optional argument (caller-supplied value).
 793     ((lambda* (f x #:optional (y 0))
 794        (+ y (f (* (car x) (cadr x)))))
 795      (lambda (x)
 796        (+ x 1))
 797      '(2 3)
 798      35)
 799     (const 42))
 800
 801   (pass-if-peval
 802     ;; Higher order, mutually recursive procedures.
 803     (letrec ((even? (lambda (x)
 804                       (or (= 0 x)
 805                           (odd? (- x 1)))))
 806              (odd?  (lambda (x)
 807                       (not (even? (- x 1))))))
 808       (and (even? 4) (odd? 7)))
 809     (const #t))
 810
 811   ;;
 812   ;; Below are cases where constant propagation should bail out.
 813   ;;
 814
 815   (pass-if-peval
 816     ;; Non-constant lexical is not propagated.
 817     (let ((v (make-vector 6 #f)))
 818       (lambda (n)
 819         (vector-set! v n n)))
 820     (let (v) (_)
 821          ((apply (toplevel make-vector) (const 6) (const #f)))
 822          (lambda ()
 823            (lambda-case
 824             (((n) #f #f #f () (_))
 825              (apply (toplevel vector-set!)
 826                     (lexical v _) (lexical n _) (lexical n _)))))))
 827
 828   (pass-if-peval
 829     ;; Mutable lexical is not propagated.
 830     (let ((v (vector 1 2 3)))
 831       (lambda ()
 832         v))
 833     (let (v) (_)
 834          ((apply (primitive vector) (const 1) (const 2) (const 3)))
 835          (lambda ()
 836            (lambda-case
 837             ((() #f #f #f () ())
 838              (lexical v _))))))
 839
 840   (pass-if-peval
 841     ;; Lexical that is not provably pure is not inlined nor propagated.
 842     (let* ((x (if (> p q) (frob!) (display 'chbouib)))
 843            (y (* x 2)))
 844       (+ x x y))
 845     (let (x) (_) ((if (apply (primitive >) (toplevel p) (toplevel q))
 846                       (apply (toplevel frob!))
 847                       (apply (toplevel display) (const chbouib))))
 848          (let (y) (_) ((apply (primitive *) (lexical x _) (const 2)))
 849               (apply (primitive +) (lexical x _) (lexical x _)
 850                      (apply (primitive *) (lexical x _) (const 2))))))
 851
 852   (pass-if-peval
 853     ;; Procedure only called with non-constant args is not inlined.
 854     (let* ((g (lambda (x y) (+ x y)))
 855            (f (lambda (g x) (g x x))))
 856       (+ (f g foo) (f g bar)))
 857     (let (g) (_)
 858          ((lambda _                              ; g
 859              (lambda-case
 860               (((x y) #f #f #f () (_ _))
 861                (apply (primitive +) (lexical x _) (lexical y _))))))
 862          (let (f) (_)
 863               ((lambda _                         ; f
 864                  (lambda-case
 865                   (((g x) #f #f #f () (_ _))
 866                    (apply (lexical g _) (lexical x _) (lexical x _))))))
 867               (apply (primitive +)
 868                      (apply (lexical g _) (toplevel foo) (toplevel foo))
 869                      (apply (lexical g _) (toplevel bar) (toplevel bar))))))
 870
 871   (pass-if-peval
 872     ;; Fresh objects are not turned into constants.
 873     (let* ((c '(2 3))
 874            (x (cons 1 c))
 875            (y (cons 0 x)))
 876       y)
 877     (let (x) (_) ((apply (primitive list) (const 1) (const 2) (const 3)))
 878          (let (y) (_) ((apply (primitive cons) (const 0) (lexical x _)))
 879               (lexical y _))))
 880
 881   (pass-if-peval
 882     ;; Bindings mutated.
 883     (let ((x 2))
 884       (set! x 3)
 885       x)
 886     (let (x) (_) ((const 2))
 887          (begin
 888            (set! (lexical x _) (const 3))
 889            (lexical x _))))
 890
 891   (pass-if-peval
 892     ;; Bindings mutated.
 893     (letrec ((x 0)
 894              (f (lambda ()
 895                   (set! x (+ 1 x))
 896                   x)))
 897       (frob f) ; may mutate `x'
 898       x)
 899     (letrec (x f) (_ _) ((const 0) _)
 900             (begin
 901              (apply (toplevel frob) (lexical f _))
 902              (lexical x _))))
 903
 904   (pass-if-peval
 905     ;; Bindings mutated.
 906     (letrec ((f (lambda (x)
 907                   (set! f (lambda (_) x))
 908                   x)))
 909       (f 2))
 910     (letrec _ . _))
 911
 912   (pass-if-peval
 913     ;; Bindings possibly mutated.
 914     (let ((x (make-foo)))
 915       (frob! x) ; may mutate `x'
 916       x)
 917     (let (x) (_) ((apply (toplevel make-foo)))
 918          (begin
 919            (apply (toplevel frob!) (lexical x _))
 920            (lexical x _))))
 921
 922   (pass-if-peval
 923     ;; Infinite recursion: `peval' gives up and leaves it as is.
 924     (letrec ((f (lambda (x) (g (1- x))))
 925              (g (lambda (x) (h (1+ x))))
 926              (h (lambda (x) (f x))))
 927       (f 0))
 928     (letrec _ . _)))
 929
 930 \f
 931 (with-test-prefix "tree-il-fold"
 932
 933   (pass-if "empty tree"
 934     (let ((leaf? #f) (up? #f) (down? #f) (mark (list 'mark)))
 935       (and (eq? mark
 936                 (tree-il-fold (lambda (x y) (set! leaf? #t) y)
 937                               (lambda (x y) (set! down? #t) y)
 938                               (lambda (x y) (set! up? #t) y)
 939                               mark
 940                               '()))
 941            (not leaf?)
 942            (not up?)
 943            (not down?))))
 944
 945   (pass-if "lambda and application"
 946     (let* ((leaves '()) (ups '()) (downs '())
 947            (result (tree-il-fold (lambda (x y)
 948                                    (set! leaves (cons x leaves))
 949                                    (1+ y))
 950                                  (lambda (x y)
 951                                    (set! downs (cons x downs))
 952                                    (1+ y))
 953                                  (lambda (x y)
 954                                    (set! ups (cons x ups))
 955                                    (1+ y))
 956                                  0
 957                                  (parse-tree-il
 958                                   '(lambda ()
 959                                      (lambda-case
 960                                       (((x y) #f #f #f () (x1 y1))
 961                                        (apply (toplevel +)
 962                                               (lexical x x1)
 963                                               (lexical y y1)))
 964                                       #f))))))
 965       (and (equal? (map strip-source leaves)
 966                    (list (make-lexical-ref #f 'y 'y1)
 967                          (make-lexical-ref #f 'x 'x1)
 968                          (make-toplevel-ref #f '+)))
 969            (= (length downs) 3)
 970            (equal? (reverse (map strip-source ups))
 971                    (map strip-source downs))))))
 972
 973 \f
 974 ;;;
 975 ;;; Warnings.
 976 ;;;
 977
 978 ;; Make sure we get English messages.
 979 (setlocale LC_ALL "C")
 980
 981 (define (call-with-warnings thunk)
 982   (let ((port (open-output-string)))
 983     (with-fluids ((*current-warning-port*   port)
 984                   (*current-warning-prefix* ""))
 985       (thunk))
 986     (let ((warnings (get-output-string port)))
 987       (string-tokenize warnings
 988                        (char-set-complement (char-set #\newline))))))
 989
 990 (define %opts-w-unused
 991   '(#:warnings (unused-variable)))
 992
 993 (define %opts-w-unused-toplevel
 994   '(#:warnings (unused-toplevel)))
 995
 996 (define %opts-w-unbound
 997   '(#:warnings (unbound-variable)))
 998
 999 (define %opts-w-arity
1000   '(#:warnings (arity-mismatch)))
1001
1002 (define %opts-w-format
1003   '(#:warnings (format)))
1004
1005
1006 (with-test-prefix "warnings"
1007
1008    (pass-if "unknown warning type"
1009      (let ((w (call-with-warnings
1010                 (lambda ()
1011                   (compile #t #:opts '(#:warnings (does-not-exist)))))))
1012        (and (= (length w) 1)
1013             (number? (string-contains (car w) "unknown warning")))))
1014
1015    (with-test-prefix "unused-variable"
1016
1017      (pass-if "quiet"
1018        (null? (call-with-warnings
1019                 (lambda ()
1020                   (compile '(lambda (x y) (+ x y))
1021                            #:opts %opts-w-unused)))))
1022
1023      (pass-if "let/unused"
1024        (let ((w (call-with-warnings
1025                   (lambda ()
1026                     (compile '(lambda (x)
1027                                 (let ((y (+ x 2)))
1028                                   x))
1029                              #:opts %opts-w-unused)))))
1030          (and (= (length w) 1)
1031               (number? (string-contains (car w) "unused variable `y'")))))
1032
1033      (pass-if "shadowed variable"
1034        (let ((w (call-with-warnings
1035                   (lambda ()
1036                     (compile '(lambda (x)
1037                                 (let ((y x))
1038                                   (let ((y (+ x 2)))
1039                                     (+ x y))))
1040                              #:opts %opts-w-unused)))))
1041          (and (= (length w) 1)
1042               (number? (string-contains (car w) "unused variable `y'")))))
1043
1044      (pass-if "letrec"
1045        (null? (call-with-warnings
1046                 (lambda ()
1047                   (compile '(lambda ()
1048                               (letrec ((x (lambda () (y)))
1049                                        (y (lambda () (x))))
1050                                 y))
1051                            #:opts %opts-w-unused)))))
1052
1053      (pass-if "unused argument"
1054        ;; Unused arguments should not be reported.
1055        (null? (call-with-warnings
1056                 (lambda ()
1057                   (compile '(lambda (x y z) #t)
1058                            #:opts %opts-w-unused)))))
1059
1060      (pass-if "special variable names"
1061        (null? (call-with-warnings
1062                 (lambda ()
1063                   (compile '(lambda ()
1064                               (let ((_ 'underscore)
1065                                     (#{gensym name}# 'ignore-me))
1066                                 #t))
1067                            #:to 'assembly
1068                            #:opts %opts-w-unused))))))
1069
1070    (with-test-prefix "unused-toplevel"
1071
1072      (pass-if "used after definition"
1073        (null? (call-with-warnings
1074                 (lambda ()
1075                   (let ((in (open-input-string
1076                              "(define foo 2) foo")))
1077                     (read-and-compile in
1078                                       #:to 'assembly
1079                                       #:opts %opts-w-unused-toplevel))))))
1080
1081      (pass-if "used before definition"
1082        (null? (call-with-warnings
1083                 (lambda ()
1084                   (let ((in (open-input-string
1085                              "(define (bar) foo) (define foo 2) (bar)")))
1086                     (read-and-compile in
1087                                       #:to 'assembly
1088                                       #:opts %opts-w-unused-toplevel))))))
1089
1090      (pass-if "unused but public"
1091        (let ((in (open-input-string
1092                   "(define-module (test-suite tree-il x) #:export (bar))
1093                    (define (bar) #t)")))
1094          (null? (call-with-warnings
1095                   (lambda ()
1096                     (read-and-compile in
1097                                       #:to 'assembly
1098                                       #:opts %opts-w-unused-toplevel))))))
1099
1100      (pass-if "unused but public (more)"
1101        (let ((in (open-input-string
1102                   "(define-module (test-suite tree-il x) #:export (bar))
1103                    (define (bar) (baz))
1104                    (define (baz) (foo))
1105                    (define (foo) #t)")))
1106          (null? (call-with-warnings
1107                   (lambda ()
1108                     (read-and-compile in
1109                                       #:to 'assembly
1110                                       #:opts %opts-w-unused-toplevel))))))
1111
1112      (pass-if "unused but define-public"
1113        (null? (call-with-warnings
1114                 (lambda ()
1115                   (compile '(define-public foo 2)
1116                            #:to 'assembly
1117                            #:opts %opts-w-unused-toplevel)))))
1118
1119      (pass-if "used by macro"
1120        ;; FIXME: See comment about macros at `unused-toplevel-analysis'.
1121        (throw 'unresolved)
1122
1123        (null? (call-with-warnings
1124                 (lambda ()
1125                   (let ((in (open-input-string
1126                              "(define (bar) 'foo)
1127                               (define-syntax baz
1128                                 (syntax-rules () ((_) (bar))))")))
1129                     (read-and-compile in
1130                                       #:to 'assembly
1131                                       #:opts %opts-w-unused-toplevel))))))
1132
1133      (pass-if "unused"
1134        (let ((w (call-with-warnings
1135                   (lambda ()
1136                     (compile '(define foo 2)
1137                              #:to 'assembly
1138                              #:opts %opts-w-unused-toplevel)))))
1139          (and (= (length w) 1)
1140               (number? (string-contains (car w)
1141                                         (format #f "top-level variable `~A'"
1142                                                 'foo))))))
1143
1144      (pass-if "unused recursive"
1145        (let ((w (call-with-warnings
1146                   (lambda ()
1147                     (compile '(define (foo) (foo))
1148                              #:to 'assembly
1149                              #:opts %opts-w-unused-toplevel)))))
1150          (and (= (length w) 1)
1151               (number? (string-contains (car w)
1152                                         (format #f "top-level variable `~A'"
1153                                                 'foo))))))
1154
1155      (pass-if "unused mutually recursive"
1156        (let* ((in (open-input-string
1157                    "(define (foo) (bar)) (define (bar) (foo))"))
1158               (w  (call-with-warnings
1159                     (lambda ()
1160                       (read-and-compile in
1161                                         #:to 'assembly
1162                                         #:opts %opts-w-unused-toplevel)))))
1163          (and (= (length w) 2)
1164               (number? (string-contains (car w)
1165                                         (format #f "top-level variable `~A'"
1166                                                 'foo)))
1167               (number? (string-contains (cadr w)
1168                                         (format #f "top-level variable `~A'"
1169                                                 'bar))))))
1170
1171      (pass-if "special variable names"
1172        (null? (call-with-warnings
1173                 (lambda ()
1174                   (compile '(define #{gensym name}# 'ignore-me)
1175                            #:to 'assembly
1176                            #:opts %opts-w-unused-toplevel))))))
1177
1178    (with-test-prefix "unbound variable"
1179
1180      (pass-if "quiet"
1181        (null? (call-with-warnings
1182                 (lambda ()
1183                   (compile '+ #:opts %opts-w-unbound)))))
1184
1185      (pass-if "ref"
1186        (let* ((v (gensym))
1187               (w (call-with-warnings
1188                    (lambda ()
1189                      (compile v
1190                               #:to 'assembly
1191                               #:opts %opts-w-unbound)))))
1192          (and (= (length w) 1)
1193               (number? (string-contains (car w)
1194                                         (format #f "unbound variable `~A'"
1195                                                 v))))))
1196
1197      (pass-if "set!"
1198        (let* ((v (gensym))
1199               (w (call-with-warnings
1200                    (lambda ()
1201                      (compile `(set! ,v 7)
1202                               #:to 'assembly
1203                               #:opts %opts-w-unbound)))))
1204          (and (= (length w) 1)
1205               (number? (string-contains (car w)
1206                                         (format #f "unbound variable `~A'"
1207                                                 v))))))
1208
1209      (pass-if "module-local top-level is visible"
1210        (let ((m (make-module))
1211              (v (gensym)))
1212          (beautify-user-module! m)
1213          (compile `(define ,v 123)
1214                   #:env m #:opts %opts-w-unbound)
1215          (null? (call-with-warnings
1216                   (lambda ()
1217                     (compile v
1218                              #:env m
1219                              #:to 'assembly
1220                              #:opts %opts-w-unbound))))))
1221
1222      (pass-if "module-local top-level is visible after"
1223        (let ((m (make-module))
1224              (v (gensym)))
1225          (beautify-user-module! m)
1226          (null? (call-with-warnings
1227                   (lambda ()
1228                     (let ((in (open-input-string
1229                                "(define (f)
1230                                   (set! chbouib 3))
1231                                 (define chbouib 5)")))
1232                       (read-and-compile in
1233                                         #:env m
1234                                         #:opts %opts-w-unbound)))))))
1235
1236      (pass-if "optional arguments are visible"
1237        (null? (call-with-warnings
1238                 (lambda ()
1239                   (compile '(lambda* (x #:optional y z) (list x y z))
1240                            #:opts %opts-w-unbound
1241                            #:to 'assembly)))))
1242
1243      (pass-if "keyword arguments are visible"
1244        (null? (call-with-warnings
1245                 (lambda ()
1246                   (compile '(lambda* (x #:key y z) (list x y z))
1247                            #:opts %opts-w-unbound
1248                            #:to 'assembly)))))
1249
1250      (pass-if "GOOPS definitions are visible"
1251        (let ((m (make-module))
1252              (v (gensym)))
1253          (beautify-user-module! m)
1254          (module-use! m (resolve-interface '(oop goops)))
1255          (null? (call-with-warnings
1256                   (lambda ()
1257                     (let ((in (open-input-string
1258                                "(define-class <foo> ()
1259                                   (bar #:getter foo-bar))
1260                                 (define z (foo-bar (make <foo>)))")))
1261                       (read-and-compile in
1262                                         #:env m
1263                                         #:opts %opts-w-unbound))))))))
1264
1265    (with-test-prefix "arity mismatch"
1266
1267      (pass-if "quiet"
1268        (null? (call-with-warnings
1269                 (lambda ()
1270                   (compile '(cons 'a 'b) #:opts %opts-w-arity)))))
1271
1272      (pass-if "direct application"
1273        (let ((w (call-with-warnings
1274                   (lambda ()
1275                     (compile '((lambda (x y) (or x y)) 1 2 3 4 5)
1276                              #:opts %opts-w-arity
1277                              #:to 'assembly)))))
1278          (and (= (length w) 1)
1279               (number? (string-contains (car w)
1280                                         "wrong number of arguments to")))))
1281      (pass-if "local"
1282        (let ((w (call-with-warnings
1283                   (lambda ()
1284                     (compile '(let ((f (lambda (x y) (+ x y))))
1285                                 (f 2))
1286                              #:opts %opts-w-arity
1287                              #:to 'assembly)))))
1288          (and (= (length w) 1)
1289               (number? (string-contains (car w)
1290                                         "wrong number of arguments to")))))
1291
1292      (pass-if "global"
1293        (let ((w (call-with-warnings
1294                   (lambda ()
1295                     (compile '(cons 1 2 3 4)
1296                              #:opts %opts-w-arity
1297                              #:to 'assembly)))))
1298          (and (= (length w) 1)
1299               (number? (string-contains (car w)
1300                                         "wrong number of arguments to")))))
1301
1302      (pass-if "alias to global"
1303        (let ((w (call-with-warnings
1304                   (lambda ()
1305                     (compile '(let ((f cons)) (f 1 2 3 4))
1306                              #:opts %opts-w-arity
1307                              #:to 'assembly)))))
1308          (and (= (length w) 1)
1309               (number? (string-contains (car w)
1310                                         "wrong number of arguments to")))))
1311
1312      (pass-if "alias to lexical to global"
1313        (let ((w (call-with-warnings
1314                   (lambda ()
1315                     (compile '(let ((f number?))
1316                                 (let ((g f))
1317                                   (f 1 2 3 4)))
1318                              #:opts %opts-w-arity
1319                              #:to 'assembly)))))
1320          (and (= (length w) 1)
1321               (number? (string-contains (car w)
1322                                         "wrong number of arguments to")))))
1323
1324      (pass-if "alias to lexical"
1325        (let ((w (call-with-warnings
1326                   (lambda ()
1327                     (compile '(let ((f (lambda (x y z) (+ x y z))))
1328                                 (let ((g f))
1329                                   (g 1)))
1330                              #:opts %opts-w-arity
1331                              #:to 'assembly)))))
1332          (and (= (length w) 1)
1333               (number? (string-contains (car w)
1334                                         "wrong number of arguments to")))))
1335
1336      (pass-if "letrec"
1337        (let ((w (call-with-warnings
1338                   (lambda ()
1339                     (compile '(letrec ((odd?  (lambda (x) (even? (1- x))))
1340                                        (even? (lambda (x)
1341                                                 (or (= 0 x)
1342                                                     (odd?)))))
1343                                 (odd? 1))
1344                              #:opts %opts-w-arity
1345                              #:to 'assembly)))))
1346          (and (= (length w) 1)
1347               (number? (string-contains (car w)
1348                                         "wrong number of arguments to")))))
1349
1350      (pass-if "case-lambda"
1351        (null? (call-with-warnings
1352                 (lambda ()
1353                   (compile '(let ((f (case-lambda
1354                                        ((x)     1)
1355                                        ((x y)   2)
1356                                        ((x y z) 3))))
1357                               (list (f 1)
1358                                     (f 1 2)
1359                                     (f 1 2 3)))
1360                            #:opts %opts-w-arity
1361                            #:to 'assembly)))))
1362
1363      (pass-if "case-lambda with wrong number of arguments"
1364        (let ((w (call-with-warnings
1365                   (lambda ()
1366                     (compile '(let ((f (case-lambda
1367                                          ((x)     1)
1368                                          ((x y)   2))))
1369                                 (f 1 2 3))
1370                              #:opts %opts-w-arity
1371                              #:to 'assembly)))))
1372          (and (= (length w) 1)
1373               (number? (string-contains (car w)
1374                                         "wrong number of arguments to")))))
1375
1376      (pass-if "case-lambda*"
1377        (null? (call-with-warnings
1378                 (lambda ()
1379                   (compile '(let ((f (case-lambda*
1380                                        ((x #:optional y) 1)
1381                                        ((x #:key y)      2)
1382                                        ((x y #:key z)    3))))
1383                               (list (f 1)
1384                                     (f 1 2)
1385                                     (f #:y 2)
1386                                     (f 1 2 #:z 3)))
1387                            #:opts %opts-w-arity
1388                            #:to 'assembly)))))
1389
1390      (pass-if "case-lambda* with wrong arguments"
1391        (let ((w (call-with-warnings
1392                   (lambda ()
1393                     (compile '(let ((f (case-lambda*
1394                                          ((x #:optional y) 1)
1395                                          ((x #:key y)      2)
1396                                          ((x y #:key z)    3))))
1397                                 (list (f)
1398                                       (f 1 #:z 3)))
1399                              #:opts %opts-w-arity
1400                              #:to 'assembly)))))
1401          (and (= (length w) 2)
1402               (null? (filter (lambda (w)
1403                                (not
1404                                 (number?
1405                                  (string-contains
1406                                   w "wrong number of arguments to"))))
1407                              w)))))
1408
1409      (pass-if "local toplevel-defines"
1410        (let ((w (call-with-warnings
1411                   (lambda ()
1412                     (let ((in (open-input-string "
1413                                 (define (g x) (f x))
1414                                 (define (f) 1)")))
1415                       (read-and-compile in
1416                                         #:opts %opts-w-arity
1417                                         #:to 'assembly))))))
1418          (and (= (length w) 1)
1419               (number? (string-contains (car w)
1420                                         "wrong number of arguments to")))))
1421
1422      (pass-if "global toplevel alias"
1423        (let ((w (call-with-warnings
1424                   (lambda ()
1425                     (let ((in (open-input-string "
1426                                 (define f cons)
1427                                 (define (g) (f))")))
1428                       (read-and-compile in
1429                                         #:opts %opts-w-arity
1430                                         #:to 'assembly))))))
1431          (and (= (length w) 1)
1432               (number? (string-contains (car w)
1433                                         "wrong number of arguments to")))))
1434
1435      (pass-if "local toplevel overrides global"
1436        (null? (call-with-warnings
1437                 (lambda ()
1438                   (let ((in (open-input-string "
1439                               (define (cons) 0)
1440                               (define (foo x) (cons))")))
1441                     (read-and-compile in
1442                                       #:opts %opts-w-arity
1443                                       #:to 'assembly))))))
1444
1445      (pass-if "keyword not passed and quiet"
1446        (null? (call-with-warnings
1447                 (lambda ()
1448                   (compile '(let ((f (lambda* (x #:key y) y)))
1449                               (f 2))
1450                            #:opts %opts-w-arity
1451                            #:to 'assembly)))))
1452
1453      (pass-if "keyword passed and quiet"
1454        (null? (call-with-warnings
1455                 (lambda ()
1456                   (compile '(let ((f (lambda* (x #:key y) y)))
1457                               (f 2 #:y 3))
1458                            #:opts %opts-w-arity
1459                            #:to 'assembly)))))
1460
1461      (pass-if "keyword passed to global and quiet"
1462        (null? (call-with-warnings
1463                 (lambda ()
1464                   (let ((in (open-input-string "
1465                               (use-modules (system base compile))
1466                               (compile '(+ 2 3) #:env (current-module))")))
1467                     (read-and-compile in
1468                                       #:opts %opts-w-arity
1469                                       #:to 'assembly))))))
1470
1471      (pass-if "extra keyword"
1472        (let ((w (call-with-warnings
1473                   (lambda ()
1474                     (compile '(let ((f (lambda* (x #:key y) y)))
1475                                 (f 2 #:Z 3))
1476                              #:opts %opts-w-arity
1477                              #:to 'assembly)))))
1478          (and (= (length w) 1)
1479               (number? (string-contains (car w)
1480                                         "wrong number of arguments to")))))
1481
1482      (pass-if "extra keywords allowed"
1483        (null? (call-with-warnings
1484                 (lambda ()
1485                   (compile '(let ((f (lambda* (x #:key y #:allow-other-keys)
1486                                        y)))
1487                               (f 2 #:Z 3))
1488                            #:opts %opts-w-arity
1489                            #:to 'assembly))))))
1490
1491    (with-test-prefix "format"
1492
1493      (pass-if "quiet (no args)"
1494        (null? (call-with-warnings
1495                (lambda ()
1496                  (compile '(format #t "hey!")
1497                           #:opts %opts-w-format
1498                           #:to 'assembly)))))
1499
1500      (pass-if "quiet (1 arg)"
1501        (null? (call-with-warnings
1502                (lambda ()
1503                  (compile '(format #t "hey ~A!" "you")
1504                           #:opts %opts-w-format
1505                           #:to 'assembly)))))
1506
1507      (pass-if "quiet (2 args)"
1508        (null? (call-with-warnings
1509                (lambda ()
1510                  (compile '(format #t "~A ~A!" "hello" "world")
1511                           #:opts %opts-w-format
1512                           #:to 'assembly)))))
1513
1514      (pass-if "wrong port arg"
1515        (let ((w (call-with-warnings
1516                  (lambda ()
1517                    (compile '(format 10 "foo")
1518                             #:opts %opts-w-format
1519                             #:to 'assembly)))))
1520          (and (= (length w) 1)
1521               (number? (string-contains (car w)
1522                                         "wrong port argument")))))
1523
1524      (pass-if "non-literal format string"
1525        (let ((w (call-with-warnings
1526                  (lambda ()
1527                    (compile '(format #f fmt)
1528                             #:opts %opts-w-format
1529                             #:to 'assembly)))))
1530          (and (= (length w) 1)
1531               (number? (string-contains (car w)
1532                                         "non-literal format string")))))
1533
1534      (pass-if "non-literal format string using gettext"
1535        (null? (call-with-warnings
1536                (lambda ()
1537                  (compile '(format #t (_ "~A ~A!") "hello" "world")
1538                           #:opts %opts-w-format
1539                           #:to 'assembly)))))
1540
1541      (pass-if "wrong format string"
1542        (let ((w (call-with-warnings
1543                  (lambda ()
1544                    (compile '(format #f 'not-a-string)
1545                             #:opts %opts-w-format
1546                             #:to 'assembly)))))
1547          (and (= (length w) 1)
1548               (number? (string-contains (car w)
1549                                         "wrong format string")))))
1550
1551      (pass-if "wrong number of args"
1552        (let ((w (call-with-warnings
1553                  (lambda ()
1554                    (compile '(format "shbweeb")
1555                             #:opts %opts-w-format
1556                             #:to 'assembly)))))
1557          (and (= (length w) 1)
1558               (number? (string-contains (car w)
1559                                         "wrong number of arguments")))))
1560
1561      (pass-if "~%, ~~, ~&, ~t, ~_, and ~\\n"
1562        (null? (call-with-warnings
1563                (lambda ()
1564                  (compile '(format some-port "~&~3_~~ ~\n~12they~%")
1565                           #:opts %opts-w-format
1566                           #:to 'assembly)))))
1567
1568      (pass-if "one missing argument"
1569        (let ((w (call-with-warnings
1570                  (lambda ()
1571                    (compile '(format some-port "foo ~A~%")
1572                             #:opts %opts-w-format
1573                             #:to 'assembly)))))
1574          (and (= (length w) 1)
1575               (number? (string-contains (car w)
1576                                         "expected 1, got 0")))))
1577
1578      (pass-if "one missing argument, gettext"
1579        (let ((w (call-with-warnings
1580                  (lambda ()
1581                    (compile '(format some-port (_ "foo ~A~%"))
1582                             #:opts %opts-w-format
1583                             #:to 'assembly)))))
1584          (and (= (length w) 1)
1585               (number? (string-contains (car w)
1586                                         "expected 1, got 0")))))
1587
1588      (pass-if "two missing arguments"
1589        (let ((w (call-with-warnings
1590                  (lambda ()
1591                    (compile '(format #f "foo ~10,2f and bar ~S~%")
1592                             #:opts %opts-w-format
1593                             #:to 'assembly)))))
1594          (and (= (length w) 1)
1595               (number? (string-contains (car w)
1596                                         "expected 2, got 0")))))
1597
1598      (pass-if "one given, one missing argument"
1599        (let ((w (call-with-warnings
1600                  (lambda ()
1601                    (compile '(format #t "foo ~A and ~S~%" hey)
1602                             #:opts %opts-w-format
1603                             #:to 'assembly)))))
1604          (and (= (length w) 1)
1605               (number? (string-contains (car w)
1606                                         "expected 2, got 1")))))
1607
1608      (pass-if "too many arguments"
1609        (let ((w (call-with-warnings
1610                  (lambda ()
1611                    (compile '(format #t "foo ~A~%" 1 2)
1612                             #:opts %opts-w-format
1613                             #:to 'assembly)))))
1614          (and (= (length w) 1)
1615               (number? (string-contains (car w)
1616                                         "expected 1, got 2")))))
1617
1618      (with-test-prefix "conditionals"
1619        (pass-if "literals"
1620         (null? (call-with-warnings
1621                 (lambda ()
1622                   (compile '(format #f "~A ~[foo~;bar~;baz~;~] ~10,2f"
1623                                     'a 1 3.14)
1624                            #:opts %opts-w-format
1625                            #:to 'assembly)))))
1626
1627        (pass-if "literals with selector"
1628          (let ((w (call-with-warnings
1629                    (lambda ()
1630                      (compile '(format #f "~2[foo~;bar~;baz~;~] ~A"
1631                                        1 'dont-ignore-me)
1632                               #:opts %opts-w-format
1633                               #:to 'assembly)))))
1634            (and (= (length w) 1)
1635                 (number? (string-contains (car w)
1636                                           "expected 1, got 2")))))
1637
1638        (pass-if "escapes (exact count)"
1639          (let ((w (call-with-warnings
1640                    (lambda ()
1641                      (compile '(format #f "~[~a~;~a~]")
1642                               #:opts %opts-w-format
1643                               #:to 'assembly)))))
1644            (and (= (length w) 1)
1645                 (number? (string-contains (car w)
1646                                           "expected 2, got 0")))))
1647
1648        (pass-if "escapes with selector"
1649          (let ((w (call-with-warnings
1650                    (lambda ()
1651                      (compile '(format #f "~1[chbouib~;~a~]")
1652                               #:opts %opts-w-format
1653                               #:to 'assembly)))))
1654            (and (= (length w) 1)
1655                 (number? (string-contains (car w)
1656                                           "expected 1, got 0")))))
1657
1658        (pass-if "escapes, range"
1659          (let ((w (call-with-warnings
1660                    (lambda ()
1661                      (compile '(format #f "~[chbouib~;~a~;~2*~a~]")
1662                               #:opts %opts-w-format
1663                               #:to 'assembly)))))
1664            (and (= (length w) 1)
1665                 (number? (string-contains (car w)
1666                                           "expected 1 to 4, got 0")))))
1667
1668        (pass-if "@"
1669          (let ((w (call-with-warnings
1670                    (lambda ()
1671                      (compile '(format #f "~@[temperature=~d~]")
1672                               #:opts %opts-w-format
1673                               #:to 'assembly)))))
1674            (and (= (length w) 1)
1675                 (number? (string-contains (car w)
1676                                           "expected 1, got 0")))))
1677
1678        (pass-if "nested"
1679          (let ((w (call-with-warnings
1680                    (lambda ()
1681                      (compile '(format #f "~:[~[hey~;~a~;~va~]~;~3*~]")
1682                               #:opts %opts-w-format
1683                               #:to 'assembly)))))
1684            (and (= (length w) 1)
1685                 (number? (string-contains (car w)
1686                                           "expected 2 to 4, got 0")))))
1687
1688        (pass-if "unterminated"
1689          (let ((w (call-with-warnings
1690                    (lambda ()
1691                      (compile '(format #f "~[unterminated")
1692                               #:opts %opts-w-format
1693                               #:to 'assembly)))))
1694            (and (= (length w) 1)
1695                 (number? (string-contains (car w)
1696                                           "unterminated conditional")))))
1697
1698        (pass-if "unexpected ~;"
1699          (let ((w (call-with-warnings
1700                    (lambda ()
1701                      (compile '(format #f "foo~;bar")
1702                               #:opts %opts-w-format
1703                               #:to 'assembly)))))
1704            (and (= (length w) 1)
1705                 (number? (string-contains (car w)
1706                                           "unexpected")))))
1707
1708        (pass-if "unexpected ~]"
1709          (let ((w (call-with-warnings
1710                    (lambda ()
1711                      (compile '(format #f "foo~]")
1712                               #:opts %opts-w-format
1713                               #:to 'assembly)))))
1714            (and (= (length w) 1)
1715                 (number? (string-contains (car w)
1716                                           "unexpected"))))))
1717
1718      (pass-if "~{...~}"
1719        (null? (call-with-warnings
1720                (lambda ()
1721                  (compile '(format #f "~A ~{~S~} ~A"
1722                                    'hello '("ladies" "and")
1723                                    'gentlemen)
1724                           #:opts %opts-w-format
1725                           #:to 'assembly)))))
1726
1727      (pass-if "~{...~}, too many args"
1728        (let ((w (call-with-warnings
1729                  (lambda ()
1730                    (compile '(format #f "~{~S~}" 1 2 3)
1731                             #:opts %opts-w-format
1732                             #:to 'assembly)))))
1733          (and (= (length w) 1)
1734               (number? (string-contains (car w)
1735                                         "expected 1, got 3")))))
1736
1737      (pass-if "~@{...~}"
1738        (null? (call-with-warnings
1739                (lambda ()
1740                  (compile '(format #f "~@{~S~}" 1 2 3)
1741                           #:opts %opts-w-format
1742                           #:to 'assembly)))))
1743
1744      (pass-if "~@{...~}, too few args"
1745        (let ((w (call-with-warnings
1746                  (lambda ()
1747                    (compile '(format #f "~A ~@{~S~}")
1748                             #:opts %opts-w-format
1749                             #:to 'assembly)))))
1750          (and (= (length w) 1)
1751               (number? (string-contains (car w)
1752                                         "expected at least 1, got 0")))))
1753
1754      (pass-if "unterminated ~{...~}"
1755        (let ((w (call-with-warnings
1756                  (lambda ()
1757                    (compile '(format #f "~{")
1758                             #:opts %opts-w-format
1759                             #:to 'assembly)))))
1760          (and (= (length w) 1)
1761               (number? (string-contains (car w)
1762                                         "unterminated")))))
1763
1764      (pass-if "~(...~)"
1765        (null? (call-with-warnings
1766                (lambda ()
1767                  (compile '(format #f "~:@(~A ~A~)" 'foo 'bar)
1768                           #:opts %opts-w-format
1769                           #:to 'assembly)))))
1770
1771      (pass-if "~v"
1772        (let ((w (call-with-warnings
1773                  (lambda ()
1774                    (compile '(format #f "~v_foo")
1775                             #:opts %opts-w-format
1776                             #:to 'assembly)))))
1777          (and (= (length w) 1)
1778               (number? (string-contains (car w)
1779                                         "expected 1, got 0")))))
1780      (pass-if "~v:@y"
1781        (null? (call-with-warnings
1782                (lambda ()
1783                  (compile '(format #f "~v:@y" 1 123)
1784                           #:opts %opts-w-format
1785                           #:to 'assembly)))))
1786
1787
1788      (pass-if "~*"
1789        (let ((w (call-with-warnings
1790                  (lambda ()
1791                    (compile '(format #f "~2*~a" 'a 'b)
1792                             #:opts %opts-w-format
1793                             #:to 'assembly)))))
1794          (and (= (length w) 1)
1795               (number? (string-contains (car w)
1796                                         "expected 3, got 2")))))
1797
1798      (pass-if "~?"
1799        (null? (call-with-warnings
1800                (lambda ()
1801                  (compile '(format #f "~?" "~d ~d" '(1 2))
1802                           #:opts %opts-w-format
1803                           #:to 'assembly)))))
1804
1805      (pass-if "complex 1"
1806        (let ((w (call-with-warnings
1807                  (lambda ()
1808                    (compile '(format #f
1809                                      "~4@S    ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n"
1810                                      1 2 3 4 5 6)
1811                             #:opts %opts-w-format
1812                             #:to 'assembly)))))
1813          (and (= (length w) 1)
1814               (number? (string-contains (car w)
1815                                         "expected 4, got 6")))))
1816
1817      (pass-if "complex 2"
1818        (let ((w (call-with-warnings
1819                  (lambda ()
1820                    (compile '(format #f
1821                                      "~:(~A~) Commands~:[~; [abbrev]~]:~2%"
1822                                      1 2 3 4)
1823                             #:opts %opts-w-format
1824                             #:to 'assembly)))))
1825          (and (= (length w) 1)
1826               (number? (string-contains (car w)
1827                                         "expected 2, got 4")))))
1828
1829      (pass-if "complex 3"
1830        (let ((w (call-with-warnings
1831                  (lambda ()
1832                    (compile '(format #f "~9@a~:[~*~3_~;~3d~] ~v:@y~%")
1833                             #:opts %opts-w-format
1834                             #:to 'assembly)))))
1835          (and (= (length w) 1)
1836               (number? (string-contains (car w)
1837                                         "expected 5, got 0")))))
1838
1839      (pass-if "ice-9 format"
1840        (let ((w (call-with-warnings
1841                  (lambda ()
1842                    (let ((in (open-input-string
1843                               "(use-modules ((ice-9 format)
1844                                  #:renamer (symbol-prefix-proc 'i9-)))
1845                                (i9-format #t \"yo! ~A\" 1 2)")))
1846                      (read-and-compile in
1847                                        #:opts %opts-w-format
1848                                        #:to 'assembly))))))
1849          (and (= (length w) 1)
1850               (number? (string-contains (car w)
1851                                         "expected 1, got 2")))))
1852
1853      (pass-if "not format"
1854        (null? (call-with-warnings
1855                (lambda ()
1856                  (compile '(let ((format chbouib))
1857                              (format #t "not ~A a format string"))
1858                           #:opts %opts-w-format
1859                           #:to 'assembly)))))))