test-suite/tests/tree-il.test

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