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