test-suite/tests/tree-il.test

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