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