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-rule (pass-if-primitives-resolved in expected)
  62   (pass-if (format #f "primitives-resolved in ~s" 'in)
  63     (let* ((module   (let ((m (make-module)))
  64                        (beautify-user-module! m)
  65                        m))
  66            (orig     (parse-tree-il 'in))
  67            (resolved (expand-primitives! (resolve-primitives! orig module))))
  68       (or (equal? (unparse-tree-il resolved) 'expected)
  69           (begin
  70             (format (current-error-port)
  71                     "primitive test failed: got ~s, expected ~s"
  72                     resolved 'expected)
  73             #f)))))
  74
  75 (define-syntax pass-if-tree-il->scheme
  76   (syntax-rules ()
  77     ((_ in pat)
  78      (assert-scheme->tree-il->scheme in pat #t))
  79     ((_ in pat guard-exp)
  80      (pass-if 'in
  81        (pmatch (tree-il->scheme
  82                 (compile 'in #:from 'scheme #:to 'tree-il))
  83          (pat (guard guard-exp) #t)
  84          (_ #f))))))
  85
  86 \f
  87 (with-test-prefix "primitives"
  88
  89   (with-test-prefix "eqv?"
  90
  91     (pass-if-primitives-resolved
  92         (primcall eqv? (toplevel x) (const #f))
  93       (primcall eq? (const #f) (toplevel x)))
  94
  95     (pass-if-primitives-resolved
  96         (primcall eqv? (toplevel x) (const ()))
  97       (primcall eq? (const ()) (toplevel x)))
  98
  99     (pass-if-primitives-resolved
 100         (primcall eqv? (const #t) (lexical x y))
 101       (primcall eq? (const #t) (lexical x y)))
 102
 103     (pass-if-primitives-resolved
 104         (primcall eqv? (const this-is-a-symbol) (toplevel x))
 105       (primcall eq? (const this-is-a-symbol) (toplevel x)))
 106
 107     (pass-if-primitives-resolved
 108         (primcall eqv? (const 42) (toplevel x))
 109       (primcall eq? (const 42) (toplevel x)))
 110
 111     (pass-if-primitives-resolved
 112         (primcall eqv? (const 42.0) (toplevel x))
 113       (primcall eqv? (const 42.0) (toplevel x)))
 114
 115     (pass-if-primitives-resolved
 116         (primcall eqv? (const #nil) (toplevel x))
 117       (primcall eq? (const #nil) (toplevel x))))
 118
 119   (with-test-prefix "equal?"
 120
 121     (pass-if-primitives-resolved
 122         (primcall equal? (toplevel x) (const #f))
 123       (primcall eq? (const #f) (toplevel x)))
 124
 125     (pass-if-primitives-resolved
 126         (primcall equal? (toplevel x) (const ()))
 127       (primcall eq? (const ()) (toplevel x)))
 128
 129     (pass-if-primitives-resolved
 130         (primcall equal? (const #t) (lexical x y))
 131       (primcall eq? (const #t) (lexical x y)))
 132
 133     (pass-if-primitives-resolved
 134         (primcall equal? (const this-is-a-symbol) (toplevel x))
 135       (primcall eq? (const this-is-a-symbol) (toplevel x)))
 136
 137     (pass-if-primitives-resolved
 138         (primcall equal? (const 42) (toplevel x))
 139       (primcall eq? (const 42) (toplevel x)))
 140
 141     (pass-if-primitives-resolved
 142         (primcall equal? (const 42.0) (toplevel x))
 143       (primcall equal? (const 42.0) (toplevel x)))
 144
 145     (pass-if-primitives-resolved
 146         (primcall equal? (const #nil) (toplevel x))
 147       (primcall eq? (const #nil) (toplevel x)))))
 148
 149 \f
 150 (with-test-prefix "tree-il->scheme"
 151   (pass-if-tree-il->scheme
 152    (case-lambda ((a) a) ((b c) (list b c)))
 153    (case-lambda ((,a) ,a1) ((,b ,c) (list ,b1 ,c1)))
 154    (and (eq? a a1) (eq? b b1) (eq? c c1))))
 155
 156 (with-test-prefix "void"
 157   (assert-tree-il->glil
 158    (void)
 159    (program () (std-prelude 0 0 #f) (label _) (void) (call return 1)))
 160   (assert-tree-il->glil
 161    (begin (void) (const 1))
 162    (program () (std-prelude 0 0 #f) (label _) (const 1) (call return 1)))
 163   (assert-tree-il->glil
 164    (primcall + (void) (const 1))
 165    (program () (std-prelude 0 0 #f) (label _) (void) (call add1 1) (call return 1))))
 166
 167 (with-test-prefix "application"
 168   (assert-tree-il->glil
 169    (call (toplevel foo) (const 1))
 170    (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (const 1) (call tail-call 1)))
 171   (assert-tree-il->glil
 172    (begin (call (toplevel foo) (const 1)) (void))
 173    (program () (std-prelude 0 0 #f) (label _) (call new-frame 0) (toplevel ref foo) (const 1) (mv-call 1 ,l1)
 174             (call drop 1) (branch br ,l2)
 175             (label ,l3) (mv-bind 0 #f)
 176             (label ,l4)
 177             (void) (call return 1))
 178    (and (eq? l1 l3) (eq? l2 l4)))
 179   (assert-tree-il->glil
 180    (call (toplevel foo) (call (toplevel bar)))
 181    (program ()  (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call new-frame 0) (toplevel ref bar) (call call 0)
 182             (call tail-call 1))))
 183
 184 (with-test-prefix "conditional"
 185   (assert-tree-il->glil
 186    (if (toplevel foo) (const 1) (const 2))
 187    (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1)
 188             (const 1) (call return 1)
 189             (label ,l2) (const 2) (call return 1))
 190    (eq? l1 l2))
 191
 192   (assert-tree-il->glil without-partial-evaluation
 193    (begin (if (toplevel foo) (const 1) (const 2)) (const #f))
 194    (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1) (branch br ,l2)
 195             (label ,l3) (label ,l4) (const #f) (call return 1))
 196    (eq? l1 l3) (eq? l2 l4))
 197
 198   (assert-tree-il->glil
 199    (primcall null? (if (toplevel foo) (const 1) (const 2)))
 200    (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1)
 201             (const 1) (branch br ,l2)
 202                     (label ,l3) (const 2) (label ,l4)
 203                     (call null? 1) (call return 1))
 204    (eq? l1 l3) (eq? l2 l4)))
 205
 206 (with-test-prefix "primitive-ref"
 207   (assert-tree-il->glil
 208    (primitive +)
 209    (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call return 1)))
 210
 211   (assert-tree-il->glil
 212    (begin (primitive +) (const #f))
 213    (program () (std-prelude 0 0 #f) (label _) (const #f) (call return 1)))
 214
 215   (assert-tree-il->glil
 216    (primcall null? (primitive +))
 217    (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call null? 1)
 218             (call return 1))))
 219
 220 (with-test-prefix "lexical refs"
 221   (assert-tree-il->glil without-partial-evaluation
 222    (let (x) (y) ((const 1)) (lexical x y))
 223    (program () (std-prelude 0 1 #f) (label _)
 224             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
 225             (lexical #t #f ref 0) (call return 1)
 226             (unbind)))
 227
 228   (assert-tree-il->glil with-options (#:partial-eval? #f #:cse? #f)
 229    (let (x) (y) ((const 1)) (begin (lexical x y) (const #f)))
 230    (program () (std-prelude 0 1 #f) (label _)
 231             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
 232             (const #f) (call return 1)
 233             (unbind)))
 234
 235   (assert-tree-il->glil without-partial-evaluation
 236    (let (x) (y) ((const 1)) (primcall null? (lexical x y)))
 237    (program () (std-prelude 0 1 #f) (label _)
 238             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
 239             (lexical #t #f ref 0) (call null? 1) (call return 1)
 240             (unbind))))
 241
 242 (with-test-prefix "lexical sets"
 243   (assert-tree-il->glil
 244    ;; unreferenced sets may be optimized away -- make sure they are ref'd
 245    (let (x) (y) ((const 1))
 246         (set! (lexical x y) (primcall 1+ (lexical x y))))
 247    (program () (std-prelude 0 1 #f) (label _)
 248             (const 1) (bind (x #t 0)) (lexical #t #t box 0)
 249             (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
 250             (void) (call return 1)
 251             (unbind)))
 252
 253   (assert-tree-il->glil
 254    (let (x) (y) ((const 1))
 255         (begin (set! (lexical x y) (primcall 1+ (lexical x y)))
 256                (lexical x y)))
 257    (program () (std-prelude 0 1 #f) (label _)
 258             (const 1) (bind (x #t 0)) (lexical #t #t box 0)
 259             (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
 260             (lexical #t #t ref 0) (call return 1)
 261             (unbind)))
 262
 263   (assert-tree-il->glil
 264    (let (x) (y) ((const 1))
 265      (primcall null?
 266            (set! (lexical x y) (primcall 1+ (lexical x y)))))
 267    (program () (std-prelude 0 1 #f) (label _)
 268             (const 1) (bind (x #t 0)) (lexical #t #t box 0)
 269             (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (void)
 270             (call null? 1) (call return 1)
 271             (unbind))))
 272
 273 (with-test-prefix "module refs"
 274   (assert-tree-il->glil
 275    (@ (foo) bar)
 276    (program () (std-prelude 0 0 #f) (label _)
 277             (module public ref (foo) bar)
 278             (call return 1)))
 279
 280   (assert-tree-il->glil
 281    (begin (@ (foo) bar) (const #f))
 282    (program () (std-prelude 0 0 #f) (label _)
 283             (module public ref (foo) bar) (call drop 1)
 284             (const #f) (call return 1)))
 285
 286   (assert-tree-il->glil
 287    (primcall null? (@ (foo) bar))
 288    (program () (std-prelude 0 0 #f) (label _)
 289             (module public ref (foo) bar)
 290             (call null? 1) (call return 1)))
 291
 292   (assert-tree-il->glil
 293    (@@ (foo) bar)
 294    (program () (std-prelude 0 0 #f) (label _)
 295             (module private ref (foo) bar)
 296             (call return 1)))
 297
 298   (assert-tree-il->glil
 299    (begin (@@ (foo) bar) (const #f))
 300    (program () (std-prelude 0 0 #f) (label _)
 301             (module private ref (foo) bar) (call drop 1)
 302             (const #f) (call return 1)))
 303
 304   (assert-tree-il->glil
 305    (primcall null? (@@ (foo) bar))
 306    (program () (std-prelude 0 0 #f) (label _)
 307             (module private ref (foo) bar)
 308             (call null? 1) (call return 1))))
 309
 310 (with-test-prefix "module sets"
 311   (assert-tree-il->glil
 312    (set! (@ (foo) bar) (const 2))
 313    (program () (std-prelude 0 0 #f) (label _)
 314             (const 2) (module public set (foo) bar)
 315             (void) (call return 1)))
 316
 317   (assert-tree-il->glil
 318    (begin (set! (@ (foo) bar) (const 2)) (const #f))
 319    (program () (std-prelude 0 0 #f) (label _)
 320             (const 2) (module public set (foo) bar)
 321             (const #f) (call return 1)))
 322
 323   (assert-tree-il->glil
 324    (primcall null? (set! (@ (foo) bar) (const 2)))
 325    (program () (std-prelude 0 0 #f) (label _)
 326             (const 2) (module public set (foo) bar)
 327             (void) (call null? 1) (call return 1)))
 328
 329   (assert-tree-il->glil
 330    (set! (@@ (foo) bar) (const 2))
 331    (program () (std-prelude 0 0 #f) (label _)
 332             (const 2) (module private set (foo) bar)
 333             (void) (call return 1)))
 334
 335   (assert-tree-il->glil
 336    (begin (set! (@@ (foo) bar) (const 2)) (const #f))
 337    (program () (std-prelude 0 0 #f) (label _)
 338             (const 2) (module private set (foo) bar)
 339             (const #f) (call return 1)))
 340
 341   (assert-tree-il->glil
 342    (primcall null? (set! (@@ (foo) bar) (const 2)))
 343    (program () (std-prelude 0 0 #f) (label _)
 344             (const 2) (module private set (foo) bar)
 345             (void) (call null? 1) (call return 1))))
 346
 347 (with-test-prefix "toplevel refs"
 348   (assert-tree-il->glil
 349    (toplevel bar)
 350    (program () (std-prelude 0 0 #f) (label _)
 351             (toplevel ref bar)
 352             (call return 1)))
 353
 354   (assert-tree-il->glil without-partial-evaluation
 355    (begin (toplevel bar) (const #f))
 356    (program () (std-prelude 0 0 #f) (label _)
 357             (toplevel ref bar) (call drop 1)
 358             (const #f) (call return 1)))
 359
 360   (assert-tree-il->glil
 361    (primcall null? (toplevel bar))
 362    (program () (std-prelude 0 0 #f) (label _)
 363             (toplevel ref bar)
 364             (call null? 1) (call return 1))))
 365
 366 (with-test-prefix "toplevel sets"
 367   (assert-tree-il->glil
 368    (set! (toplevel bar) (const 2))
 369    (program () (std-prelude 0 0 #f) (label _)
 370             (const 2) (toplevel set bar)
 371             (void) (call return 1)))
 372
 373   (assert-tree-il->glil
 374    (begin (set! (toplevel bar) (const 2)) (const #f))
 375    (program () (std-prelude 0 0 #f) (label _)
 376             (const 2) (toplevel set bar)
 377             (const #f) (call return 1)))
 378
 379   (assert-tree-il->glil
 380    (primcall null? (set! (toplevel bar) (const 2)))
 381    (program () (std-prelude 0 0 #f) (label _)
 382             (const 2) (toplevel set bar)
 383             (void) (call null? 1) (call return 1))))
 384
 385 (with-test-prefix "toplevel defines"
 386   (assert-tree-il->glil
 387    (define bar (const 2))
 388    (program () (std-prelude 0 0 #f) (label _)
 389             (const 2) (toplevel define bar)
 390             (void) (call return 1)))
 391
 392   (assert-tree-il->glil
 393    (begin (define bar (const 2)) (const #f))
 394    (program () (std-prelude 0 0 #f) (label _)
 395             (const 2) (toplevel define bar)
 396             (const #f) (call return 1)))
 397
 398   (assert-tree-il->glil
 399    (primcall null? (define bar (const 2)))
 400    (program () (std-prelude 0 0 #f) (label _)
 401             (const 2) (toplevel define bar)
 402             (void) (call null? 1) (call return 1))))
 403
 404 (with-test-prefix "constants"
 405   (assert-tree-il->glil
 406    (const 2)
 407    (program () (std-prelude 0 0 #f) (label _)
 408             (const 2) (call return 1)))
 409
 410   (assert-tree-il->glil
 411    (begin (const 2) (const #f))
 412    (program () (std-prelude 0 0 #f) (label _)
 413             (const #f) (call return 1)))
 414
 415   (assert-tree-il->glil
 416    ;; This gets simplified by `peval'.
 417    (primcall null? (const 2))
 418    (program () (std-prelude 0 0 #f) (label _)
 419             (const #f) (call return 1))))
 420
 421 (with-test-prefix "letrec"
 422   ;; simple bindings -> let
 423   (assert-tree-il->glil without-partial-evaluation
 424    (letrec (x y) (x1 y1) ((const 10) (const 20))
 425            (call (toplevel foo) (lexical x x1) (lexical y y1)))
 426    (program () (std-prelude 0 2 #f) (label _)
 427             (const 10) (const 20)
 428             (bind (x #f 0) (y #f 1))
 429             (lexical #t #f set 1) (lexical #t #f set 0)
 430             (toplevel ref foo)
 431             (lexical #t #f ref 0) (lexical #t #f ref 1)
 432             (call tail-call 2)
 433             (unbind)))
 434
 435   ;; complex bindings -> box and set! within let
 436   (assert-tree-il->glil without-partial-evaluation
 437    (letrec (x y) (x1 y1) ((call (toplevel foo)) (call (toplevel bar)))
 438            (primcall + (lexical x x1) (lexical y y1)))
 439    (program () (std-prelude 0 4 #f) (label _)
 440             (void) (void) ;; what are these?
 441             (bind (x #t 0) (y #t 1))
 442             (lexical #t #t box 1) (lexical #t #t box 0)
 443             (call new-frame 0) (toplevel ref foo) (call call 0)
 444             (call new-frame 0) (toplevel ref bar) (call call 0)
 445             (bind (x #f 2) (y #f 3)) (lexical #t #f set 3) (lexical #t #f set 2)
 446             (lexical #t #f ref 2) (lexical #t #t set 0)
 447             (lexical #t #f ref 3) (lexical #t #t set 1)
 448             (void) (lexical #t #f set 2) (void) (lexical #t #f set 3) ;; clear bindings
 449             (unbind)
 450             (lexical #t #t ref 0) (lexical #t #t ref 1)
 451             (call add 2) (call return 1) (unbind)))
 452
 453   ;; complex bindings in letrec* -> box and set! in order
 454   (assert-tree-il->glil without-partial-evaluation
 455    (letrec* (x y) (x1 y1) ((call (toplevel foo)) (call (toplevel bar)))
 456             (primcall + (lexical x x1) (lexical y y1)))
 457    (program () (std-prelude 0 2 #f) (label _)
 458             (void) (void) ;; what are these?
 459             (bind (x #t 0) (y #t 1))
 460             (lexical #t #t box 1) (lexical #t #t box 0)
 461             (call new-frame 0) (toplevel ref foo) (call call 0)
 462             (lexical #t #t set 0)
 463             (call new-frame 0) (toplevel ref bar) (call call 0)
 464             (lexical #t #t set 1)
 465             (lexical #t #t ref 0)
 466             (lexical #t #t ref 1)
 467             (call add 2) (call return 1) (unbind)))
 468
 469   ;; simple bindings in letrec* -> equivalent to letrec
 470   (assert-tree-il->glil without-partial-evaluation
 471    (letrec* (x y) (xx yy) ((const 1) (const 2))
 472             (lexical y yy))
 473    (program () (std-prelude 0 1 #f) (label _)
 474             (const 2)
 475             (bind (y #f 0)) ;; X is removed, and Y is unboxed
 476             (lexical #t #f set 0)
 477             (lexical #t #f ref 0)
 478             (call return 1) (unbind))))
 479
 480 (with-test-prefix "lambda"
 481   (assert-tree-il->glil
 482    (lambda ()
 483      (lambda-case (((x) #f #f #f () (y)) (const 2)) #f))
 484    (program ()  (std-prelude 0 0 #f) (label _)
 485             (program () (std-prelude 1 1 #f)
 486                      (bind (x #f 0)) (label _)
 487                      (const 2) (call return 1) (unbind))
 488             (call return 1)))
 489
 490   (assert-tree-il->glil
 491    (lambda ()
 492      (lambda-case (((x y) #f #f #f () (x1 y1))
 493                    (const 2))
 494                   #f))
 495    (program () (std-prelude 0 0 #f) (label _)
 496             (program () (std-prelude 2 2 #f)
 497                      (bind (x #f 0) (y #f 1)) (label _)
 498                      (const 2) (call return 1)
 499                      (unbind))
 500             (call return 1)))
 501
 502   (assert-tree-il->glil
 503    (lambda ()
 504      (lambda-case ((() #f x #f () (y)) (const 2))
 505                   #f))
 506    (program () (std-prelude 0 0 #f) (label _)
 507             (program () (opt-prelude 0 0 0 1 #f)
 508                      (bind (x #f 0)) (label _)
 509                      (const 2) (call return 1)
 510                      (unbind))
 511             (call return 1)))
 512
 513   (assert-tree-il->glil
 514    (lambda ()
 515      (lambda-case (((x) #f x1 #f () (y y1)) (const 2))
 516                   #f))
 517    (program () (std-prelude 0 0 #f) (label _)
 518             (program () (opt-prelude 1 0 1 2 #f)
 519                      (bind (x #f 0) (x1 #f 1)) (label _)
 520                      (const 2) (call return 1)
 521                      (unbind))
 522             (call return 1)))
 523
 524   (assert-tree-il->glil
 525    (lambda ()
 526      (lambda-case (((x) #f x1 #f () (y y1)) (lexical x y))
 527                   #f))
 528    (program () (std-prelude 0 0 #f) (label _)
 529             (program () (opt-prelude 1 0 1 2 #f)
 530                      (bind (x #f 0) (x1 #f 1)) (label _)
 531                      (lexical #t #f ref 0) (call return 1)
 532                      (unbind))
 533             (call return 1)))
 534
 535   (assert-tree-il->glil
 536    (lambda ()
 537      (lambda-case (((x) #f x1 #f () (y y1)) (lexical x1 y1))
 538                   #f))
 539    (program () (std-prelude 0 0 #f) (label _)
 540             (program () (opt-prelude 1 0 1 2 #f)
 541                      (bind (x #f 0) (x1 #f 1)) (label _)
 542                      (lexical #t #f ref 1) (call return 1)
 543                      (unbind))
 544             (call return 1)))
 545
 546   (assert-tree-il->glil
 547    (lambda ()
 548      (lambda-case (((x) #f #f #f () (x1))
 549                    (lambda ()
 550                      (lambda-case (((y) #f #f #f () (y1))
 551                                    (lexical x x1))
 552                                   #f)))
 553                   #f))
 554    (program () (std-prelude 0 0 #f) (label _)
 555             (program () (std-prelude 1 1 #f)
 556                      (bind (x #f 0)) (label _)
 557                      (program () (std-prelude 1 1 #f)
 558                               (bind (y #f 0)) (label _)
 559                               (lexical #f #f ref 0) (call return 1)
 560                               (unbind))
 561                      (lexical #t #f ref 0)
 562                      (call make-closure 1)
 563                      (call return 1)
 564                      (unbind))
 565             (call return 1))))
 566
 567 (with-test-prefix "sequence"
 568   (assert-tree-il->glil
 569    (begin (begin (const 2) (const #f)) (const #t))
 570    (program () (std-prelude 0 0 #f) (label _)
 571             (const #t) (call return 1)))
 572
 573   (assert-tree-il->glil
 574    ;; This gets simplified by `peval'.
 575    (primcall null? (begin (const #f) (const 2)))
 576    (program () (std-prelude 0 0 #f) (label _)
 577             (const #f) (call return 1))))
 578
 579 (with-test-prefix "values"
 580   (assert-tree-il->glil
 581    (primcall values
 582              (primcall values (const 1) (const 2)))
 583    (program () (std-prelude 0 0 #f) (label _)
 584             (const 1) (call return 1)))
 585
 586   (assert-tree-il->glil
 587    (primcall values
 588              (primcall values (const 1) (const 2))
 589              (const 3))
 590    (program () (std-prelude 0 0 #f) (label _)
 591             (const 1) (const 3) (call return/values 2)))
 592
 593   (assert-tree-il->glil
 594    (primcall +
 595              (primcall values (const 1) (const 2)))
 596    (program () (std-prelude 0 0 #f) (label _)
 597             (const 1) (call return 1)))
 598
 599   ;; Testing `(values foo)' in push context with RA.
 600   (assert-tree-il->glil without-partial-evaluation
 601    (primcall cdr
 602              (letrec (lp) (#{lp ~V9KrhVD4PFEL6oCTrLg3A}#)
 603                      ((lambda ((name . lp))
 604                         (lambda-case ((() #f #f #f () ())
 605                                       (primcall values (const (one two)))))))
 606                      (call (lexical lp #{lp ~V9KrhVD4PFEL6oCTrLg3A}#))))
 607    (program () (std-prelude 0 0 #f) (label _)
 608             (branch br _) ;; entering the fix, jump to :2
 609             ;; :1 body of lp, jump to :3
 610             (label _) (bind) (const (one two)) (branch br _) (unbind)
 611             ;; :2 initial call of lp, jump to :1
 612             (label _) (bind) (branch br _) (label _) (unbind)
 613             ;; :3 the push continuation
 614             (call cdr 1) (call return 1))))
 615
 616 ;; FIXME: binding info for or-hacked locals might bork the disassembler,
 617 ;; and could be tightened in any case
 618 (with-test-prefix "the or hack"
 619   (assert-tree-il->glil without-partial-evaluation
 620    (let (x) (y) ((const 1))
 621         (if (lexical x y)
 622             (lexical x y)
 623             (let (a) (b) ((const 2))
 624                  (lexical a b))))
 625    (program () (std-prelude 0 1 #f) (label _)
 626             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
 627             (lexical #t #f ref 0) (branch br-if-not ,l1)
 628             (lexical #t #f ref 0) (call return 1)
 629             (label ,l2)
 630             (const 2) (bind (a #f 0)) (lexical #t #f set 0)
 631             (lexical #t #f ref 0) (call return 1)
 632             (unbind)
 633             (unbind))
 634    (eq? l1 l2))
 635
 636   ;; second bound var is unreferenced
 637   (assert-tree-il->glil without-partial-evaluation
 638    (let (x) (y) ((const 1))
 639         (if (lexical x y)
 640             (lexical x y)
 641             (let (a) (b) ((const 2))
 642                  (lexical x y))))
 643    (program () (std-prelude 0 1 #f) (label _)
 644             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
 645             (lexical #t #f ref 0) (branch br-if-not ,l1)
 646             (lexical #t #f ref 0) (call return 1)
 647             (label ,l2)
 648             (lexical #t #f ref 0) (call return 1)
 649             (unbind))
 650    (eq? l1 l2)))
 651
 652 (with-test-prefix "apply"
 653   (assert-tree-il->glil
 654    (primcall @apply (toplevel foo) (toplevel bar))
 655    (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (toplevel ref bar) (call tail-apply 2)))
 656   (assert-tree-il->glil
 657    (begin (primcall @apply (toplevel foo) (toplevel bar)) (void))
 658    (program () (std-prelude 0 0 #f) (label _)
 659             (call new-frame 0) (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1)
 660             (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
 661             (label ,l4)
 662             (void) (call return 1))
 663    (and (eq? l1 l3) (eq? l2 l4)))
 664   (assert-tree-il->glil
 665    (call (toplevel foo) (call (toplevel @apply) (toplevel bar) (toplevel baz)))
 666    (program () (std-prelude 0 0 #f) (label _)
 667             (toplevel ref foo)
 668             (call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call apply 2)
 669             (call tail-call 1))))
 670
 671 (with-test-prefix "call/cc"
 672   (assert-tree-il->glil
 673    (primcall @call-with-current-continuation (toplevel foo))
 674    (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call tail-call/cc 1)))
 675   (assert-tree-il->glil
 676    (begin (primcall @call-with-current-continuation (toplevel foo)) (void))
 677    (program () (std-prelude 0 0 #f) (label _)
 678             (call new-frame 0) (toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1)
 679             (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
 680             (label ,l4)
 681             (void) (call return 1))
 682    (and (eq? l1 l3) (eq? l2 l4)))
 683   (assert-tree-il->glil
 684    (call (toplevel foo)
 685           (call (toplevel @call-with-current-continuation) (toplevel bar)))
 686    (program () (std-prelude 0 0 #f) (label _)
 687             (toplevel ref foo)
 688             (toplevel ref bar) (call call/cc 1)
 689             (call tail-call 1))))
 690
 691 \f
 692 (with-test-prefix "labels allocation"
 693   (pass-if "http://debbugs.gnu.org/9769"
 694     ((compile '(lambda ()
 695                  (let ((fail (lambda () #f)))
 696                    (let ((test (lambda () (fail))))
 697                      (test))
 698                    #t))
 699               ;; Prevent inlining.  We're testing analyze.scm's
 700               ;; labels allocator here, and inlining it will
 701               ;; reduce the entire thing to #t.
 702               #:opts '(#:partial-eval? #f)))))
 703
 704 \f
 705 (with-test-prefix "tree-il-fold"
 706
 707   (pass-if "empty tree"
 708     (let ((leaf? #f) (up? #f) (down? #f) (mark (list 'mark)))
 709       (and (eq? mark
 710                 (tree-il-fold (lambda (x y) (set! leaf? #t) y)
 711                               (lambda (x y) (set! down? #t) y)
 712                               (lambda (x y) (set! up? #t) y)
 713                               mark
 714                               '()))
 715            (not leaf?)
 716            (not up?)
 717            (not down?))))
 718
 719   (pass-if "lambda and application"
 720     (let* ((leaves '()) (ups '()) (downs '())
 721            (result (tree-il-fold (lambda (x y)
 722                                    (set! leaves (cons x leaves))
 723                                    (1+ y))
 724                                  (lambda (x y)
 725                                    (set! downs (cons x downs))
 726                                    (1+ y))
 727                                  (lambda (x y)
 728                                    (set! ups (cons x ups))
 729                                    (1+ y))
 730                                  0
 731                                  (parse-tree-il
 732                                   '(lambda ()
 733                                      (lambda-case
 734                                       (((x y) #f #f #f () (x1 y1))
 735                                        (call (toplevel +)
 736                                              (lexical x x1)
 737                                              (lexical y y1)))
 738                                       #f))))))
 739       (and (equal? (map strip-source leaves)
 740                    (list (make-lexical-ref #f 'y 'y1)
 741                          (make-lexical-ref #f 'x 'x1)
 742                          (make-toplevel-ref #f '+)))
 743            (= (length downs) 3)
 744            (equal? (reverse (map strip-source ups))
 745                    (map strip-source downs))))))
 746
 747 \f
 748 ;;;
 749 ;;; Warnings.
 750 ;;;
 751
 752 ;; Make sure we get English messages.
 753 (setlocale LC_ALL "C")
 754
 755 (define (call-with-warnings thunk)
 756   (let ((port (open-output-string)))
 757     (with-fluids ((*current-warning-port*   port)
 758                   (*current-warning-prefix* ""))
 759       (thunk))
 760     (let ((warnings (get-output-string port)))
 761       (string-tokenize warnings
 762                        (char-set-complement (char-set #\newline))))))
 763
 764 (define %opts-w-unused
 765   '(#:warnings (unused-variable)))
 766
 767 (define %opts-w-unused-toplevel
 768   '(#:warnings (unused-toplevel)))
 769
 770 (define %opts-w-unbound
 771   '(#:warnings (unbound-variable)))
 772
 773 (define %opts-w-arity
 774   '(#:warnings (arity-mismatch)))
 775
 776 (define %opts-w-format
 777   '(#:warnings (format)))
 778
 779
 780 (with-test-prefix "warnings"
 781
 782    (pass-if "unknown warning type"
 783      (let ((w (call-with-warnings
 784                 (lambda ()
 785                   (compile #t #:opts '(#:warnings (does-not-exist)))))))
 786        (and (= (length w) 1)
 787             (number? (string-contains (car w) "unknown warning")))))
 788
 789    (with-test-prefix "unused-variable"
 790
 791      (pass-if "quiet"
 792        (null? (call-with-warnings
 793                 (lambda ()
 794                   (compile '(lambda (x y) (+ x y))
 795                            #:opts %opts-w-unused)))))
 796
 797      (pass-if "let/unused"
 798        (let ((w (call-with-warnings
 799                   (lambda ()
 800                     (compile '(lambda (x)
 801                                 (let ((y (+ x 2)))
 802                                   x))
 803                              #:opts %opts-w-unused)))))
 804          (and (= (length w) 1)
 805               (number? (string-contains (car w) "unused variable `y'")))))
 806
 807      (pass-if "shadowed variable"
 808        (let ((w (call-with-warnings
 809                   (lambda ()
 810                     (compile '(lambda (x)
 811                                 (let ((y x))
 812                                   (let ((y (+ x 2)))
 813                                     (+ x y))))
 814                              #:opts %opts-w-unused)))))
 815          (and (= (length w) 1)
 816               (number? (string-contains (car w) "unused variable `y'")))))
 817
 818      (pass-if "letrec"
 819        (null? (call-with-warnings
 820                 (lambda ()
 821                   (compile '(lambda ()
 822                               (letrec ((x (lambda () (y)))
 823                                        (y (lambda () (x))))
 824                                 y))
 825                            #:opts %opts-w-unused)))))
 826
 827      (pass-if "unused argument"
 828        ;; Unused arguments should not be reported.
 829        (null? (call-with-warnings
 830                 (lambda ()
 831                   (compile '(lambda (x y z) #t)
 832                            #:opts %opts-w-unused)))))
 833
 834      (pass-if "special variable names"
 835        (null? (call-with-warnings
 836                 (lambda ()
 837                   (compile '(lambda ()
 838                               (let ((_ 'underscore)
 839                                     (#{gensym name}# 'ignore-me))
 840                                 #t))
 841                            #:to 'assembly
 842                            #:opts %opts-w-unused))))))
 843
 844    (with-test-prefix "unused-toplevel"
 845
 846      (pass-if "used after definition"
 847        (null? (call-with-warnings
 848                 (lambda ()
 849                   (let ((in (open-input-string
 850                              "(define foo 2) foo")))
 851                     (read-and-compile in
 852                                       #:to 'assembly
 853                                       #:opts %opts-w-unused-toplevel))))))
 854
 855      (pass-if "used before definition"
 856        (null? (call-with-warnings
 857                 (lambda ()
 858                   (let ((in (open-input-string
 859                              "(define (bar) foo) (define foo 2) (bar)")))
 860                     (read-and-compile in
 861                                       #:to 'assembly
 862                                       #:opts %opts-w-unused-toplevel))))))
 863
 864      (pass-if "unused but public"
 865        (let ((in (open-input-string
 866                   "(define-module (test-suite tree-il x) #:export (bar))
 867                    (define (bar) #t)")))
 868          (null? (call-with-warnings
 869                   (lambda ()
 870                     (read-and-compile in
 871                                       #:to 'assembly
 872                                       #:opts %opts-w-unused-toplevel))))))
 873
 874      (pass-if "unused but public (more)"
 875        (let ((in (open-input-string
 876                   "(define-module (test-suite tree-il x) #:export (bar))
 877                    (define (bar) (baz))
 878                    (define (baz) (foo))
 879                    (define (foo) #t)")))
 880          (null? (call-with-warnings
 881                   (lambda ()
 882                     (read-and-compile in
 883                                       #:to 'assembly
 884                                       #:opts %opts-w-unused-toplevel))))))
 885
 886      (pass-if "unused but define-public"
 887        (null? (call-with-warnings
 888                 (lambda ()
 889                   (compile '(define-public foo 2)
 890                            #:to 'assembly
 891                            #:opts %opts-w-unused-toplevel)))))
 892
 893      (pass-if "used by macro"
 894        ;; FIXME: See comment about macros at `unused-toplevel-analysis'.
 895        (throw 'unresolved)
 896
 897        (null? (call-with-warnings
 898                 (lambda ()
 899                   (let ((in (open-input-string
 900                              "(define (bar) 'foo)
 901                               (define-syntax baz
 902                                 (syntax-rules () ((_) (bar))))")))
 903                     (read-and-compile in
 904                                       #:to 'assembly
 905                                       #:opts %opts-w-unused-toplevel))))))
 906
 907      (pass-if "unused"
 908        (let ((w (call-with-warnings
 909                   (lambda ()
 910                     (compile '(define foo 2)
 911                              #:to 'assembly
 912                              #:opts %opts-w-unused-toplevel)))))
 913          (and (= (length w) 1)
 914               (number? (string-contains (car w)
 915                                         (format #f "top-level variable `~A'"
 916                                                 'foo))))))
 917
 918      (pass-if "unused recursive"
 919        (let ((w (call-with-warnings
 920                   (lambda ()
 921                     (compile '(define (foo) (foo))
 922                              #:to 'assembly
 923                              #:opts %opts-w-unused-toplevel)))))
 924          (and (= (length w) 1)
 925               (number? (string-contains (car w)
 926                                         (format #f "top-level variable `~A'"
 927                                                 'foo))))))
 928
 929      (pass-if "unused mutually recursive"
 930        (let* ((in (open-input-string
 931                    "(define (foo) (bar)) (define (bar) (foo))"))
 932               (w  (call-with-warnings
 933                     (lambda ()
 934                       (read-and-compile in
 935                                         #:to 'assembly
 936                                         #:opts %opts-w-unused-toplevel)))))
 937          (and (= (length w) 2)
 938               (number? (string-contains (car w)
 939                                         (format #f "top-level variable `~A'"
 940                                                 'foo)))
 941               (number? (string-contains (cadr w)
 942                                         (format #f "top-level variable `~A'"
 943                                                 'bar))))))
 944
 945      (pass-if "special variable names"
 946        (null? (call-with-warnings
 947                 (lambda ()
 948                   (compile '(define #{gensym name}# 'ignore-me)
 949                            #:to 'assembly
 950                            #:opts %opts-w-unused-toplevel))))))
 951
 952    (with-test-prefix "unbound variable"
 953
 954      (pass-if "quiet"
 955        (null? (call-with-warnings
 956                 (lambda ()
 957                   (compile '+ #:opts %opts-w-unbound)))))
 958
 959      (pass-if "ref"
 960        (let* ((v (gensym))
 961               (w (call-with-warnings
 962                    (lambda ()
 963                      (compile v
 964                               #:to 'assembly
 965                               #:opts %opts-w-unbound)))))
 966          (and (= (length w) 1)
 967               (number? (string-contains (car w)
 968                                         (format #f "unbound variable `~A'"
 969                                                 v))))))
 970
 971      (pass-if "set!"
 972        (let* ((v (gensym))
 973               (w (call-with-warnings
 974                    (lambda ()
 975                      (compile `(set! ,v 7)
 976                               #:to 'assembly
 977                               #:opts %opts-w-unbound)))))
 978          (and (= (length w) 1)
 979               (number? (string-contains (car w)
 980                                         (format #f "unbound variable `~A'"
 981                                                 v))))))
 982
 983      (pass-if "module-local top-level is visible"
 984        (let ((m (make-module))
 985              (v (gensym)))
 986          (beautify-user-module! m)
 987          (compile `(define ,v 123)
 988                   #:env m #:opts %opts-w-unbound)
 989          (null? (call-with-warnings
 990                   (lambda ()
 991                     (compile v
 992                              #:env m
 993                              #:to 'assembly
 994                              #:opts %opts-w-unbound))))))
 995
 996      (pass-if "module-local top-level is visible after"
 997        (let ((m (make-module))
 998              (v (gensym)))
 999          (beautify-user-module! m)
1000          (null? (call-with-warnings
1001                   (lambda ()
1002                     (let ((in (open-input-string
1003                                "(define (f)
1004                                   (set! chbouib 3))
1005                                 (define chbouib 5)")))
1006                       (read-and-compile in
1007                                         #:env m
1008                                         #:opts %opts-w-unbound)))))))
1009
1010      (pass-if "optional arguments are visible"
1011        (null? (call-with-warnings
1012                 (lambda ()
1013                   (compile '(lambda* (x #:optional y z) (list x y z))
1014                            #:opts %opts-w-unbound
1015                            #:to 'assembly)))))
1016
1017      (pass-if "keyword arguments are visible"
1018        (null? (call-with-warnings
1019                 (lambda ()
1020                   (compile '(lambda* (x #:key y z) (list x y z))
1021                            #:opts %opts-w-unbound
1022                            #:to 'assembly)))))
1023
1024      (pass-if "GOOPS definitions are visible"
1025        (let ((m (make-module))
1026              (v (gensym)))
1027          (beautify-user-module! m)
1028          (module-use! m (resolve-interface '(oop goops)))
1029          (null? (call-with-warnings
1030                   (lambda ()
1031                     (let ((in (open-input-string
1032                                "(define-class <foo> ()
1033                                   (bar #:getter foo-bar))
1034                                 (define z (foo-bar (make <foo>)))")))
1035                       (read-and-compile in
1036                                         #:env m
1037                                         #:opts %opts-w-unbound))))))))
1038
1039    (with-test-prefix "arity mismatch"
1040
1041      (pass-if "quiet"
1042        (null? (call-with-warnings
1043                 (lambda ()
1044                   (compile '(cons 'a 'b) #:opts %opts-w-arity)))))
1045
1046      (pass-if "direct application"
1047        (let ((w (call-with-warnings
1048                   (lambda ()
1049                     (compile '((lambda (x y) (or x y)) 1 2 3 4 5)
1050                              #:opts %opts-w-arity
1051                              #:to 'assembly)))))
1052          (and (= (length w) 1)
1053               (number? (string-contains (car w)
1054                                         "wrong number of arguments to")))))
1055      (pass-if "local"
1056        (let ((w (call-with-warnings
1057                   (lambda ()
1058                     (compile '(let ((f (lambda (x y) (+ x y))))
1059                                 (f 2))
1060                              #:opts %opts-w-arity
1061                              #:to 'assembly)))))
1062          (and (= (length w) 1)
1063               (number? (string-contains (car w)
1064                                         "wrong number of arguments to")))))
1065
1066      (pass-if "global"
1067        (let ((w (call-with-warnings
1068                   (lambda ()
1069                     (compile '(cons 1 2 3 4)
1070                              #:opts %opts-w-arity
1071                              #:to 'assembly)))))
1072          (and (= (length w) 1)
1073               (number? (string-contains (car w)
1074                                         "wrong number of arguments to")))))
1075
1076      (pass-if "alias to global"
1077        (let ((w (call-with-warnings
1078                   (lambda ()
1079                     (compile '(let ((f cons)) (f 1 2 3 4))
1080                              #:opts %opts-w-arity
1081                              #:to 'assembly)))))
1082          (and (= (length w) 1)
1083               (number? (string-contains (car w)
1084                                         "wrong number of arguments to")))))
1085
1086      (pass-if "alias to lexical to global"
1087        (let ((w (call-with-warnings
1088                   (lambda ()
1089                     (compile '(let ((f number?))
1090                                 (let ((g f))
1091                                   (f 1 2 3 4)))
1092                              #:opts %opts-w-arity
1093                              #:to 'assembly)))))
1094          (and (= (length w) 1)
1095               (number? (string-contains (car w)
1096                                         "wrong number of arguments to")))))
1097
1098      (pass-if "alias to lexical"
1099        (let ((w (call-with-warnings
1100                   (lambda ()
1101                     (compile '(let ((f (lambda (x y z) (+ x y z))))
1102                                 (let ((g f))
1103                                   (g 1)))
1104                              #:opts %opts-w-arity
1105                              #:to 'assembly)))))
1106          (and (= (length w) 1)
1107               (number? (string-contains (car w)
1108                                         "wrong number of arguments to")))))
1109
1110      (pass-if "letrec"
1111        (let ((w (call-with-warnings
1112                   (lambda ()
1113                     (compile '(letrec ((odd?  (lambda (x) (even? (1- x))))
1114                                        (even? (lambda (x)
1115                                                 (or (= 0 x)
1116                                                     (odd?)))))
1117                                 (odd? 1))
1118                              #:opts %opts-w-arity
1119                              #:to 'assembly)))))
1120          (and (= (length w) 1)
1121               (number? (string-contains (car w)
1122                                         "wrong number of arguments to")))))
1123
1124      (pass-if "case-lambda"
1125        (null? (call-with-warnings
1126                 (lambda ()
1127                   (compile '(let ((f (case-lambda
1128                                        ((x)     1)
1129                                        ((x y)   2)
1130                                        ((x y z) 3))))
1131                               (list (f 1)
1132                                     (f 1 2)
1133                                     (f 1 2 3)))
1134                            #:opts %opts-w-arity
1135                            #:to 'assembly)))))
1136
1137      (pass-if "case-lambda with wrong number of arguments"
1138        (let ((w (call-with-warnings
1139                   (lambda ()
1140                     (compile '(let ((f (case-lambda
1141                                          ((x)     1)
1142                                          ((x y)   2))))
1143                                 (f 1 2 3))
1144                              #:opts %opts-w-arity
1145                              #:to 'assembly)))))
1146          (and (= (length w) 1)
1147               (number? (string-contains (car w)
1148                                         "wrong number of arguments to")))))
1149
1150      (pass-if "case-lambda*"
1151        (null? (call-with-warnings
1152                 (lambda ()
1153                   (compile '(let ((f (case-lambda*
1154                                        ((x #:optional y) 1)
1155                                        ((x #:key y)      2)
1156                                        ((x y #:key z)    3))))
1157                               (list (f 1)
1158                                     (f 1 2)
1159                                     (f #:y 2)
1160                                     (f 1 2 #:z 3)))
1161                            #:opts %opts-w-arity
1162                            #:to 'assembly)))))
1163
1164      (pass-if "case-lambda* with wrong arguments"
1165        (let ((w (call-with-warnings
1166                   (lambda ()
1167                     (compile '(let ((f (case-lambda*
1168                                          ((x #:optional y) 1)
1169                                          ((x #:key y)      2)
1170                                          ((x y #:key z)    3))))
1171                                 (list (f)
1172                                       (f 1 #:z 3)))
1173                              #:opts %opts-w-arity
1174                              #:to 'assembly)))))
1175          (and (= (length w) 2)
1176               (null? (filter (lambda (w)
1177                                (not
1178                                 (number?
1179                                  (string-contains
1180                                   w "wrong number of arguments to"))))
1181                              w)))))
1182
1183      (pass-if "top-level applicable struct"
1184        (null? (call-with-warnings
1185                (lambda ()
1186                  (compile '(let ((p current-warning-port))
1187                              (p (+ (p) 1))
1188                              (p))
1189                           #:opts %opts-w-arity
1190                           #:to 'assembly)))))
1191
1192      (pass-if "top-level applicable struct with wrong arguments"
1193        (let ((w (call-with-warnings
1194                  (lambda ()
1195                    (compile '(let ((p current-warning-port))
1196                                (p 1 2 3))
1197                             #:opts %opts-w-arity
1198                             #:to 'assembly)))))
1199          (and (= (length w) 1)
1200               (number? (string-contains (car w)
1201                                         "wrong number of arguments to")))))
1202
1203      (pass-if "local toplevel-defines"
1204        (let ((w (call-with-warnings
1205                   (lambda ()
1206                     (let ((in (open-input-string "
1207                                 (define (g x) (f x))
1208                                 (define (f) 1)")))
1209                       (read-and-compile in
1210                                         #:opts %opts-w-arity
1211                                         #:to 'assembly))))))
1212          (and (= (length w) 1)
1213               (number? (string-contains (car w)
1214                                         "wrong number of arguments to")))))
1215
1216      (pass-if "global toplevel alias"
1217        (let ((w (call-with-warnings
1218                   (lambda ()
1219                     (let ((in (open-input-string "
1220                                 (define f cons)
1221                                 (define (g) (f))")))
1222                       (read-and-compile in
1223                                         #:opts %opts-w-arity
1224                                         #:to 'assembly))))))
1225          (and (= (length w) 1)
1226               (number? (string-contains (car w)
1227                                         "wrong number of arguments to")))))
1228
1229      (pass-if "local toplevel overrides global"
1230        (null? (call-with-warnings
1231                 (lambda ()
1232                   (let ((in (open-input-string "
1233                               (define (cons) 0)
1234                               (define (foo x) (cons))")))
1235                     (read-and-compile in
1236                                       #:opts %opts-w-arity
1237                                       #:to 'assembly))))))
1238
1239      (pass-if "keyword not passed and quiet"
1240        (null? (call-with-warnings
1241                 (lambda ()
1242                   (compile '(let ((f (lambda* (x #:key y) y)))
1243                               (f 2))
1244                            #:opts %opts-w-arity
1245                            #:to 'assembly)))))
1246
1247      (pass-if "keyword passed and quiet"
1248        (null? (call-with-warnings
1249                 (lambda ()
1250                   (compile '(let ((f (lambda* (x #:key y) y)))
1251                               (f 2 #:y 3))
1252                            #:opts %opts-w-arity
1253                            #:to 'assembly)))))
1254
1255      (pass-if "keyword passed to global and quiet"
1256        (null? (call-with-warnings
1257                 (lambda ()
1258                   (let ((in (open-input-string "
1259                               (use-modules (system base compile))
1260                               (compile '(+ 2 3) #:env (current-module))")))
1261                     (read-and-compile in
1262                                       #:opts %opts-w-arity
1263                                       #:to 'assembly))))))
1264
1265      (pass-if "extra keyword"
1266        (let ((w (call-with-warnings
1267                   (lambda ()
1268                     (compile '(let ((f (lambda* (x #:key y) y)))
1269                                 (f 2 #:Z 3))
1270                              #:opts %opts-w-arity
1271                              #:to 'assembly)))))
1272          (and (= (length w) 1)
1273               (number? (string-contains (car w)
1274                                         "wrong number of arguments to")))))
1275
1276      (pass-if "extra keywords allowed"
1277        (null? (call-with-warnings
1278                 (lambda ()
1279                   (compile '(let ((f (lambda* (x #:key y #:allow-other-keys)
1280                                        y)))
1281                               (f 2 #:Z 3))
1282                            #:opts %opts-w-arity
1283                            #:to 'assembly))))))
1284
1285    (with-test-prefix "format"
1286
1287      (pass-if "quiet (no args)"
1288        (null? (call-with-warnings
1289                (lambda ()
1290                  (compile '(format #t "hey!")
1291                           #:opts %opts-w-format
1292                           #:to 'assembly)))))
1293
1294      (pass-if "quiet (1 arg)"
1295        (null? (call-with-warnings
1296                (lambda ()
1297                  (compile '(format #t "hey ~A!" "you")
1298                           #:opts %opts-w-format
1299                           #:to 'assembly)))))
1300
1301      (pass-if "quiet (2 args)"
1302        (null? (call-with-warnings
1303                (lambda ()
1304                  (compile '(format #t "~A ~A!" "hello" "world")
1305                           #:opts %opts-w-format
1306                           #:to 'assembly)))))
1307
1308      (pass-if "wrong port arg"
1309        (let ((w (call-with-warnings
1310                  (lambda ()
1311                    (compile '(format 10 "foo")
1312                             #:opts %opts-w-format
1313                             #:to 'assembly)))))
1314          (and (= (length w) 1)
1315               (number? (string-contains (car w)
1316                                         "wrong port argument")))))
1317
1318      (pass-if "non-literal format string"
1319        (let ((w (call-with-warnings
1320                  (lambda ()
1321                    (compile '(format #f fmt)
1322                             #:opts %opts-w-format
1323                             #:to 'assembly)))))
1324          (and (= (length w) 1)
1325               (number? (string-contains (car w)
1326                                         "non-literal format string")))))
1327
1328      (pass-if "non-literal format string using gettext"
1329        (null? (call-with-warnings
1330                (lambda ()
1331                  (compile '(format #t (gettext "~A ~A!") "hello" "world")
1332                           #:opts %opts-w-format
1333                           #:to 'assembly)))))
1334
1335      (pass-if "non-literal format string using gettext as _"
1336        (null? (call-with-warnings
1337                (lambda ()
1338                  (compile '(format #t (_ "~A ~A!") "hello" "world")
1339                           #:opts %opts-w-format
1340                           #:to 'assembly)))))
1341
1342      (pass-if "non-literal format string using gettext as top-level _"
1343        (null? (call-with-warnings
1344                (lambda ()
1345                  (compile '(begin
1346                              (define (_ s) (gettext s "my-domain"))
1347                              (format #t (_ "~A ~A!") "hello" "world"))
1348                           #:opts %opts-w-format
1349                           #:to 'assembly)))))
1350
1351      (pass-if "non-literal format string using gettext as module-ref _"
1352        (null? (call-with-warnings
1353                (lambda ()
1354                  (compile '(format #t ((@@ (foo) _) "~A ~A!") "hello" "world")
1355                           #:opts %opts-w-format
1356                           #:to 'assembly)))))
1357
1358      (pass-if "non-literal format string using gettext as lexical _"
1359        (null? (call-with-warnings
1360                (lambda ()
1361                  (compile '(let ((_ (lambda (s)
1362                                       (gettext s "my-domain"))))
1363                              (format #t (_ "~A ~A!") "hello" "world"))
1364                           #:opts %opts-w-format
1365                           #:to 'assembly)))))
1366
1367      (pass-if "non-literal format string using ngettext"
1368        (null? (call-with-warnings
1369                (lambda ()
1370                  (compile '(format #t
1371                                    (ngettext "~a thing" "~a things" n "dom") n)
1372                           #:opts %opts-w-format
1373                           #:to 'assembly)))))
1374
1375      (pass-if "non-literal format string using ngettext as N_"
1376        (null? (call-with-warnings
1377                (lambda ()
1378                  (compile '(format #t (N_ "~a thing" "~a things" n) n)
1379                           #:opts %opts-w-format
1380                           #:to 'assembly)))))
1381
1382      (pass-if "non-literal format string with (define _ gettext)"
1383        (null? (call-with-warnings
1384                (lambda ()
1385                  (compile '(begin
1386                              (define _ gettext)
1387                              (define (foo)
1388                                (format #t (_ "~A ~A!") "hello" "world")))
1389                           #:opts %opts-w-format
1390                           #:to 'assembly)))))
1391
1392      (pass-if "wrong format string"
1393        (let ((w (call-with-warnings
1394                  (lambda ()
1395                    (compile '(format #f 'not-a-string)
1396                             #:opts %opts-w-format
1397                             #:to 'assembly)))))
1398          (and (= (length w) 1)
1399               (number? (string-contains (car w)
1400                                         "wrong format string")))))
1401
1402      (pass-if "wrong number of args"
1403        (let ((w (call-with-warnings
1404                  (lambda ()
1405                    (compile '(format "shbweeb")
1406                             #:opts %opts-w-format
1407                             #:to 'assembly)))))
1408          (and (= (length w) 1)
1409               (number? (string-contains (car w)
1410                                         "wrong number of arguments")))))
1411
1412      (pass-if "~%, ~~, ~&, ~t, ~_, and ~\\n"
1413        (null? (call-with-warnings
1414                (lambda ()
1415                  (compile '((@ (ice-9 format) format) some-port
1416                             "~&~3_~~ ~\n~12they~%")
1417                           #:opts %opts-w-format
1418                           #:to 'assembly)))))
1419
1420      (pass-if "one missing argument"
1421        (let ((w (call-with-warnings
1422                  (lambda ()
1423                    (compile '(format some-port "foo ~A~%")
1424                             #:opts %opts-w-format
1425                             #:to 'assembly)))))
1426          (and (= (length w) 1)
1427               (number? (string-contains (car w)
1428                                         "expected 1, got 0")))))
1429
1430      (pass-if "one missing argument, gettext"
1431        (let ((w (call-with-warnings
1432                  (lambda ()
1433                    (compile '(format some-port (gettext "foo ~A~%"))
1434                             #:opts %opts-w-format
1435                             #:to 'assembly)))))
1436          (and (= (length w) 1)
1437               (number? (string-contains (car w)
1438                                         "expected 1, got 0")))))
1439
1440      (pass-if "two missing arguments"
1441        (let ((w (call-with-warnings
1442                  (lambda ()
1443                    (compile '((@ (ice-9 format) format) #f
1444                               "foo ~10,2f and bar ~S~%")
1445                             #:opts %opts-w-format
1446                             #:to 'assembly)))))
1447          (and (= (length w) 1)
1448               (number? (string-contains (car w)
1449                                         "expected 2, got 0")))))
1450
1451      (pass-if "one given, one missing argument"
1452        (let ((w (call-with-warnings
1453                  (lambda ()
1454                    (compile '(format #t "foo ~A and ~S~%" hey)
1455                             #:opts %opts-w-format
1456                             #:to 'assembly)))))
1457          (and (= (length w) 1)
1458               (number? (string-contains (car w)
1459                                         "expected 2, got 1")))))
1460
1461      (pass-if "too many arguments"
1462        (let ((w (call-with-warnings
1463                  (lambda ()
1464                    (compile '(format #t "foo ~A~%" 1 2)
1465                             #:opts %opts-w-format
1466                             #:to 'assembly)))))
1467          (and (= (length w) 1)
1468               (number? (string-contains (car w)
1469                                         "expected 1, got 2")))))
1470
1471      (pass-if "~h"
1472        (null? (call-with-warnings
1473                  (lambda ()
1474                    (compile '((@ (ice-9 format) format) #t
1475                               "foo ~h ~a~%" 123.4 'bar)
1476                             #:opts %opts-w-format
1477                             #:to 'assembly)))))
1478
1479      (pass-if "~:h with locale object"
1480        (null? (call-with-warnings
1481                  (lambda ()
1482                    (compile '((@ (ice-9 format) format) #t
1483                               "foo ~:h~%" 123.4 %global-locale)
1484                             #:opts %opts-w-format
1485                             #:to 'assembly)))))
1486
1487      (pass-if "~:h without locale object"
1488        (let ((w (call-with-warnings
1489                  (lambda ()
1490                    (compile '((@ (ice-9 format) format) #t "foo ~,2:h" 123.4)
1491                             #:opts %opts-w-format
1492                             #:to 'assembly)))))
1493          (and (= (length w) 1)
1494               (number? (string-contains (car w)
1495                                         "expected 2, got 1")))))
1496
1497      (with-test-prefix "conditionals"
1498        (pass-if "literals"
1499         (null? (call-with-warnings
1500                 (lambda ()
1501                   (compile '((@ (ice-9 format) format) #f "~A ~[foo~;bar~;baz~;~] ~10,2f"
1502                                     'a 1 3.14)
1503                            #:opts %opts-w-format
1504                            #:to 'assembly)))))
1505
1506        (pass-if "literals with selector"
1507          (let ((w (call-with-warnings
1508                    (lambda ()
1509                      (compile '((@ (ice-9 format) format) #f "~2[foo~;bar~;baz~;~] ~A"
1510                                        1 'dont-ignore-me)
1511                               #:opts %opts-w-format
1512                               #:to 'assembly)))))
1513            (and (= (length w) 1)
1514                 (number? (string-contains (car w)
1515                                           "expected 1, got 2")))))
1516
1517        (pass-if "escapes (exact count)"
1518          (let ((w (call-with-warnings
1519                    (lambda ()
1520                      (compile '((@ (ice-9 format) format) #f "~[~a~;~a~]")
1521                               #:opts %opts-w-format
1522                               #:to 'assembly)))))
1523            (and (= (length w) 1)
1524                 (number? (string-contains (car w)
1525                                           "expected 2, got 0")))))
1526
1527        (pass-if "escapes with selector"
1528          (let ((w (call-with-warnings
1529                    (lambda ()
1530                      (compile '((@ (ice-9 format) format) #f "~1[chbouib~;~a~]")
1531                               #:opts %opts-w-format
1532                               #:to 'assembly)))))
1533            (and (= (length w) 1)
1534                 (number? (string-contains (car w)
1535                                           "expected 1, got 0")))))
1536
1537        (pass-if "escapes, range"
1538          (let ((w (call-with-warnings
1539                    (lambda ()
1540                      (compile '((@ (ice-9 format) format) #f "~[chbouib~;~a~;~2*~a~]")
1541                               #:opts %opts-w-format
1542                               #:to 'assembly)))))
1543            (and (= (length w) 1)
1544                 (number? (string-contains (car w)
1545                                           "expected 1 to 4, got 0")))))
1546
1547        (pass-if "@"
1548          (let ((w (call-with-warnings
1549                    (lambda ()
1550                      (compile '((@ (ice-9 format) format) #f "~@[temperature=~d~]")
1551                               #:opts %opts-w-format
1552                               #:to 'assembly)))))
1553            (and (= (length w) 1)
1554                 (number? (string-contains (car w)
1555                                           "expected 1, got 0")))))
1556
1557        (pass-if "nested"
1558          (let ((w (call-with-warnings
1559                    (lambda ()
1560                      (compile '((@ (ice-9 format) format) #f "~:[~[hey~;~a~;~va~]~;~3*~]")
1561                               #:opts %opts-w-format
1562                               #:to 'assembly)))))
1563            (and (= (length w) 1)
1564                 (number? (string-contains (car w)
1565                                           "expected 2 to 4, got 0")))))
1566
1567        (pass-if "unterminated"
1568          (let ((w (call-with-warnings
1569                    (lambda ()
1570                      (compile '((@ (ice-9 format) format) #f "~[unterminated")
1571                               #:opts %opts-w-format
1572                               #:to 'assembly)))))
1573            (and (= (length w) 1)
1574                 (number? (string-contains (car w)
1575                                           "unterminated conditional")))))
1576
1577        (pass-if "unexpected ~;"
1578          (let ((w (call-with-warnings
1579                    (lambda ()
1580                      (compile '((@ (ice-9 format) format) #f "foo~;bar")
1581                               #:opts %opts-w-format
1582                               #:to 'assembly)))))
1583            (and (= (length w) 1)
1584                 (number? (string-contains (car w)
1585                                           "unexpected")))))
1586
1587        (pass-if "unexpected ~]"
1588          (let ((w (call-with-warnings
1589                    (lambda ()
1590                      (compile '((@ (ice-9 format) format) #f "foo~]")
1591                               #:opts %opts-w-format
1592                               #:to 'assembly)))))
1593            (and (= (length w) 1)
1594                 (number? (string-contains (car w)
1595                                           "unexpected"))))))
1596
1597      (pass-if "~{...~}"
1598        (null? (call-with-warnings
1599                (lambda ()
1600                  (compile '((@ (ice-9 format) format) #f "~A ~{~S~} ~A"
1601                                    'hello '("ladies" "and")
1602                                    'gentlemen)
1603                           #:opts %opts-w-format
1604                           #:to 'assembly)))))
1605
1606      (pass-if "~{...~}, too many args"
1607        (let ((w (call-with-warnings
1608                  (lambda ()
1609                    (compile '((@ (ice-9 format) format) #f "~{~S~}" 1 2 3)
1610                             #:opts %opts-w-format
1611                             #:to 'assembly)))))
1612          (and (= (length w) 1)
1613               (number? (string-contains (car w)
1614                                         "expected 1, got 3")))))
1615
1616      (pass-if "~@{...~}"
1617        (null? (call-with-warnings
1618                (lambda ()
1619                  (compile '((@ (ice-9 format) format) #f "~@{~S~}" 1 2 3)
1620                           #:opts %opts-w-format
1621                           #:to 'assembly)))))
1622
1623      (pass-if "~@{...~}, too few args"
1624        (let ((w (call-with-warnings
1625                  (lambda ()
1626                    (compile '((@ (ice-9 format) format) #f "~A ~@{~S~}")
1627                             #:opts %opts-w-format
1628                             #:to 'assembly)))))
1629          (and (= (length w) 1)
1630               (number? (string-contains (car w)
1631                                         "expected at least 1, got 0")))))
1632
1633      (pass-if "unterminated ~{...~}"
1634        (let ((w (call-with-warnings
1635                  (lambda ()
1636                    (compile '((@ (ice-9 format) format) #f "~{")
1637                             #:opts %opts-w-format
1638                             #:to 'assembly)))))
1639          (and (= (length w) 1)
1640               (number? (string-contains (car w)
1641                                         "unterminated")))))
1642
1643      (pass-if "~(...~)"
1644        (null? (call-with-warnings
1645                (lambda ()
1646                  (compile '((@ (ice-9 format) format) #f "~:@(~A ~A~)" 'foo 'bar)
1647                           #:opts %opts-w-format
1648                           #:to 'assembly)))))
1649
1650      (pass-if "~v"
1651        (let ((w (call-with-warnings
1652                  (lambda ()
1653                    (compile '((@ (ice-9 format) format) #f "~v_foo")
1654                             #:opts %opts-w-format
1655                             #:to 'assembly)))))
1656          (and (= (length w) 1)
1657               (number? (string-contains (car w)
1658                                         "expected 1, got 0")))))
1659      (pass-if "~v:@y"
1660        (null? (call-with-warnings
1661                (lambda ()
1662                  (compile '((@ (ice-9 format) format) #f "~v:@y" 1 123)
1663                           #:opts %opts-w-format
1664                           #:to 'assembly)))))
1665
1666
1667      (pass-if "~*"
1668        (let ((w (call-with-warnings
1669                  (lambda ()
1670                    (compile '((@ (ice-9 format) format) #f "~2*~a" 'a 'b)
1671                             #:opts %opts-w-format
1672                             #:to 'assembly)))))
1673          (and (= (length w) 1)
1674               (number? (string-contains (car w)
1675                                         "expected 3, got 2")))))
1676
1677      (pass-if "~?"
1678        (null? (call-with-warnings
1679                (lambda ()
1680                  (compile '((@ (ice-9 format) format) #f "~?" "~d ~d" '(1 2))
1681                           #:opts %opts-w-format
1682                           #:to 'assembly)))))
1683
1684      (pass-if "complex 1"
1685        (let ((w (call-with-warnings
1686                  (lambda ()
1687                    (compile '((@ (ice-9 format) format) #f
1688                                      "~4@S    ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n"
1689                                      1 2 3 4 5 6)
1690                             #:opts %opts-w-format
1691                             #:to 'assembly)))))
1692          (and (= (length w) 1)
1693               (number? (string-contains (car w)
1694                                         "expected 4, got 6")))))
1695
1696      (pass-if "complex 2"
1697        (let ((w (call-with-warnings
1698                  (lambda ()
1699                    (compile '((@ (ice-9 format) format) #f
1700                                      "~:(~A~) Commands~:[~; [abbrev]~]:~2%"
1701                                      1 2 3 4)
1702                             #:opts %opts-w-format
1703                             #:to 'assembly)))))
1704          (and (= (length w) 1)
1705               (number? (string-contains (car w)
1706                                         "expected 2, got 4")))))
1707
1708      (pass-if "complex 3"
1709        (let ((w (call-with-warnings
1710                  (lambda ()
1711                    (compile '((@ (ice-9 format) format) #f "~9@a~:[~*~3_~;~3d~] ~v:@y~%")
1712                             #:opts %opts-w-format
1713                             #:to 'assembly)))))
1714          (and (= (length w) 1)
1715               (number? (string-contains (car w)
1716                                         "expected 5, got 0")))))
1717
1718      (pass-if "ice-9 format"
1719        (let ((w (call-with-warnings
1720                  (lambda ()
1721                    (let ((in (open-input-string
1722                               "(use-modules ((ice-9 format)
1723                                  #:renamer (symbol-prefix-proc 'i9-)))
1724                                (i9-format #t \"yo! ~A\" 1 2)")))
1725                      (read-and-compile in
1726                                        #:opts %opts-w-format
1727                                        #:to 'assembly))))))
1728          (and (= (length w) 1)
1729               (number? (string-contains (car w)
1730                                         "expected 1, got 2")))))
1731
1732      (pass-if "not format"
1733        (null? (call-with-warnings
1734                (lambda ()
1735                  (compile '(let ((format chbouib))
1736                              (format #t "not ~A a format string"))
1737                           #:opts %opts-w-format
1738                           #:to 'assembly)))))
1739
1740      (with-test-prefix "simple-format"
1741
1742        (pass-if "good"
1743          (null? (call-with-warnings
1744                  (lambda ()
1745                    (compile '(simple-format #t "foo ~a bar ~s ~%~~" 1 2)
1746                             #:opts %opts-w-format
1747                             #:to 'assembly)))))
1748
1749        (pass-if "wrong number of args"
1750          (let ((w (call-with-warnings
1751                    (lambda ()
1752                      (compile '(simple-format #t "foo ~a ~s~%" 'one-missing)
1753                               #:opts %opts-w-format
1754                               #:to 'assembly)))))
1755            (and (= (length w) 1)
1756                 (number? (string-contains (car w) "wrong number")))))
1757
1758        (pass-if "unsupported"
1759          (let ((w (call-with-warnings
1760                    (lambda ()
1761                      (compile '(simple-format #t "foo ~x~%" 16)
1762                               #:opts %opts-w-format
1763                               #:to 'assembly)))))
1764            (and (= (length w) 1)
1765                 (number? (string-contains (car w) "unsupported format option")))))
1766
1767        (pass-if "unsupported, gettext"
1768          (let ((w (call-with-warnings
1769                    (lambda ()
1770                      (compile '(simple-format #t (gettext "foo ~2f~%") 3.14)
1771                               #:opts %opts-w-format
1772                               #:to 'assembly)))))
1773            (and (= (length w) 1)
1774                 (number? (string-contains (car w) "unsupported format option")))))
1775
1776        (pass-if "unsupported, ngettext"
1777          (let ((w (call-with-warnings
1778                    (lambda ()
1779                      (compile '(simple-format #t (ngettext "s ~x" "p ~x" x) x)
1780                               #:opts %opts-w-format
1781                               #:to 'assembly)))))
1782            (and (= (length w) 1)
1783                 (number? (string-contains (car w) "unsupported format option"))))))))
1784
1785 ;; Local Variables:
1786 ;; eval: (put 'pass-if-primitives-resolved 'scheme-indent-function 1)
1787 ;; eval: (put 'pass-if-tree-il->scheme 'scheme-indent-function 1)
1788 ;; End: