test-suite/tests/tree-il.test

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