test-suite/tests/tree-il.test

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