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