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    (apply (primitive +) (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    (apply (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 (apply (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    (apply (toplevel foo) (apply (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    (apply (primitive 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    (apply (primitive 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 with-options (#:partial-eval? #f #:cse? #f)
 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)) (apply (primitive 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) (apply (primitive 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) (apply (primitive 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      (apply (primitive null?)
 189             (set! (lexical x y) (apply (primitive 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    (apply (primitive 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    (apply (primitive 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    (apply (primitive 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    (apply (primitive 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    (apply (primitive 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    (apply (primitive 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    (apply (primitive 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    (apply (primitive 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            (apply (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) ((apply (toplevel foo)) (apply (toplevel bar)))
 361            (apply (primitive +) (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) ((apply (toplevel foo)) (apply (toplevel bar)))
 379             (apply (primitive +) (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    (apply (primitive 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    (apply (primitive values)
 505           (apply (primitive 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    (apply (primitive values)
 511           (apply (primitive 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    (apply (primitive +)
 518           (apply (primitive 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    (apply (primitive cdr)
 525           (letrec (lp) (#{lp ~V9KrhVD4PFEL6oCTrLg3A}#)
 526                   ((lambda ((name . lp))
 527                      (lambda-case ((() #f #f #f () ())
 528                                    (apply (toplevel values) (const (one two)))))))
 529                   (apply (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    (apply (primitive @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 (apply (primitive @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    (apply (toplevel foo) (apply (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    (apply (primitive @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 (apply (primitive @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    (apply (toplevel foo)
 608           (apply (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                                        (apply (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 "top-level applicable struct"
1107        (null? (call-with-warnings
1108                (lambda ()
1109                  (compile '(let ((p current-warning-port))
1110                              (p (+ (p) 1))
1111                              (p))
1112                           #:opts %opts-w-arity
1113                           #:to 'assembly)))))
1114
1115      (pass-if "top-level applicable struct with wrong arguments"
1116        (let ((w (call-with-warnings
1117                  (lambda ()
1118                    (compile '(let ((p current-warning-port))
1119                                (p 1 2 3))
1120                             #:opts %opts-w-arity
1121                             #:to 'assembly)))))
1122          (and (= (length w) 1)
1123               (number? (string-contains (car w)
1124                                         "wrong number of arguments to")))))
1125
1126      (pass-if "local toplevel-defines"
1127        (let ((w (call-with-warnings
1128                   (lambda ()
1129                     (let ((in (open-input-string "
1130                                 (define (g x) (f x))
1131                                 (define (f) 1)")))
1132                       (read-and-compile in
1133                                         #:opts %opts-w-arity
1134                                         #:to 'assembly))))))
1135          (and (= (length w) 1)
1136               (number? (string-contains (car w)
1137                                         "wrong number of arguments to")))))
1138
1139      (pass-if "global toplevel alias"
1140        (let ((w (call-with-warnings
1141                   (lambda ()
1142                     (let ((in (open-input-string "
1143                                 (define f cons)
1144                                 (define (g) (f))")))
1145                       (read-and-compile in
1146                                         #:opts %opts-w-arity
1147                                         #:to 'assembly))))))
1148          (and (= (length w) 1)
1149               (number? (string-contains (car w)
1150                                         "wrong number of arguments to")))))
1151
1152      (pass-if "local toplevel overrides global"
1153        (null? (call-with-warnings
1154                 (lambda ()
1155                   (let ((in (open-input-string "
1156                               (define (cons) 0)
1157                               (define (foo x) (cons))")))
1158                     (read-and-compile in
1159                                       #:opts %opts-w-arity
1160                                       #:to 'assembly))))))
1161
1162      (pass-if "keyword not passed and quiet"
1163        (null? (call-with-warnings
1164                 (lambda ()
1165                   (compile '(let ((f (lambda* (x #:key y) y)))
1166                               (f 2))
1167                            #:opts %opts-w-arity
1168                            #:to 'assembly)))))
1169
1170      (pass-if "keyword passed and quiet"
1171        (null? (call-with-warnings
1172                 (lambda ()
1173                   (compile '(let ((f (lambda* (x #:key y) y)))
1174                               (f 2 #:y 3))
1175                            #:opts %opts-w-arity
1176                            #:to 'assembly)))))
1177
1178      (pass-if "keyword passed to global and quiet"
1179        (null? (call-with-warnings
1180                 (lambda ()
1181                   (let ((in (open-input-string "
1182                               (use-modules (system base compile))
1183                               (compile '(+ 2 3) #:env (current-module))")))
1184                     (read-and-compile in
1185                                       #:opts %opts-w-arity
1186                                       #:to 'assembly))))))
1187
1188      (pass-if "extra keyword"
1189        (let ((w (call-with-warnings
1190                   (lambda ()
1191                     (compile '(let ((f (lambda* (x #:key y) y)))
1192                                 (f 2 #:Z 3))
1193                              #:opts %opts-w-arity
1194                              #:to 'assembly)))))
1195          (and (= (length w) 1)
1196               (number? (string-contains (car w)
1197                                         "wrong number of arguments to")))))
1198
1199      (pass-if "extra keywords allowed"
1200        (null? (call-with-warnings
1201                 (lambda ()
1202                   (compile '(let ((f (lambda* (x #:key y #:allow-other-keys)
1203                                        y)))
1204                               (f 2 #:Z 3))
1205                            #:opts %opts-w-arity
1206                            #:to 'assembly))))))
1207
1208    (with-test-prefix "format"
1209
1210      (pass-if "quiet (no args)"
1211        (null? (call-with-warnings
1212                (lambda ()
1213                  (compile '(format #t "hey!")
1214                           #:opts %opts-w-format
1215                           #:to 'assembly)))))
1216
1217      (pass-if "quiet (1 arg)"
1218        (null? (call-with-warnings
1219                (lambda ()
1220                  (compile '(format #t "hey ~A!" "you")
1221                           #:opts %opts-w-format
1222                           #:to 'assembly)))))
1223
1224      (pass-if "quiet (2 args)"
1225        (null? (call-with-warnings
1226                (lambda ()
1227                  (compile '(format #t "~A ~A!" "hello" "world")
1228                           #:opts %opts-w-format
1229                           #:to 'assembly)))))
1230
1231      (pass-if "wrong port arg"
1232        (let ((w (call-with-warnings
1233                  (lambda ()
1234                    (compile '(format 10 "foo")
1235                             #:opts %opts-w-format
1236                             #:to 'assembly)))))
1237          (and (= (length w) 1)
1238               (number? (string-contains (car w)
1239                                         "wrong port argument")))))
1240
1241      (pass-if "non-literal format string"
1242        (let ((w (call-with-warnings
1243                  (lambda ()
1244                    (compile '(format #f fmt)
1245                             #:opts %opts-w-format
1246                             #:to 'assembly)))))
1247          (and (= (length w) 1)
1248               (number? (string-contains (car w)
1249                                         "non-literal format string")))))
1250
1251      (pass-if "non-literal format string using gettext"
1252        (null? (call-with-warnings
1253                (lambda ()
1254                  (compile '(format #t (gettext "~A ~A!") "hello" "world")
1255                           #:opts %opts-w-format
1256                           #:to 'assembly)))))
1257
1258      (pass-if "non-literal format string using gettext as _"
1259        (null? (call-with-warnings
1260                (lambda ()
1261                  (compile '(format #t (_ "~A ~A!") "hello" "world")
1262                           #:opts %opts-w-format
1263                           #:to 'assembly)))))
1264
1265      (pass-if "non-literal format string using gettext as module-ref _"
1266        (null? (call-with-warnings
1267                (lambda ()
1268                  (compile '(format #t ((@@ (foo) _) "~A ~A!") "hello" "world")
1269                           #:opts %opts-w-format
1270                           #:to 'assembly)))))
1271
1272      (pass-if "non-literal format string using gettext as lexical _"
1273        (null? (call-with-warnings
1274                (lambda ()
1275                  (compile '(let ((_ (lambda (s)
1276                                       (gettext s "my-domain"))))
1277                              (format #t (_ "~A ~A!") "hello" "world"))
1278                           #:opts %opts-w-format
1279                           #:to 'assembly)))))
1280
1281      (pass-if "non-literal format string using ngettext"
1282        (null? (call-with-warnings
1283                (lambda ()
1284                  (compile '(format #t
1285                                    (ngettext "~a thing" "~a things" n "dom") n)
1286                           #:opts %opts-w-format
1287                           #:to 'assembly)))))
1288
1289      (pass-if "non-literal format string using ngettext as N_"
1290        (null? (call-with-warnings
1291                (lambda ()
1292                  (compile '(format #t (N_ "~a thing" "~a things" n) n)
1293                           #:opts %opts-w-format
1294                           #:to 'assembly)))))
1295
1296      (pass-if "non-literal format string with (define _ gettext)"
1297        (null? (call-with-warnings
1298                (lambda ()
1299                  (compile '(begin
1300                              (define _ gettext)
1301                              (define (foo)
1302                                (format #t (_ "~A ~A!") "hello" "world")))
1303                           #:opts %opts-w-format
1304                           #:to 'assembly)))))
1305
1306      (pass-if "wrong format string"
1307        (let ((w (call-with-warnings
1308                  (lambda ()
1309                    (compile '(format #f 'not-a-string)
1310                             #:opts %opts-w-format
1311                             #:to 'assembly)))))
1312          (and (= (length w) 1)
1313               (number? (string-contains (car w)
1314                                         "wrong format string")))))
1315
1316      (pass-if "wrong number of args"
1317        (let ((w (call-with-warnings
1318                  (lambda ()
1319                    (compile '(format "shbweeb")
1320                             #:opts %opts-w-format
1321                             #:to 'assembly)))))
1322          (and (= (length w) 1)
1323               (number? (string-contains (car w)
1324                                         "wrong number of arguments")))))
1325
1326      (pass-if "~%, ~~, ~&, ~t, ~_, and ~\\n"
1327        (null? (call-with-warnings
1328                (lambda ()
1329                  (compile '((@ (ice-9 format) format) some-port
1330                             "~&~3_~~ ~\n~12they~%")
1331                           #:opts %opts-w-format
1332                           #:to 'assembly)))))
1333
1334      (pass-if "one missing argument"
1335        (let ((w (call-with-warnings
1336                  (lambda ()
1337                    (compile '(format some-port "foo ~A~%")
1338                             #:opts %opts-w-format
1339                             #:to 'assembly)))))
1340          (and (= (length w) 1)
1341               (number? (string-contains (car w)
1342                                         "expected 1, got 0")))))
1343
1344      (pass-if "one missing argument, gettext"
1345        (let ((w (call-with-warnings
1346                  (lambda ()
1347                    (compile '(format some-port (gettext "foo ~A~%"))
1348                             #:opts %opts-w-format
1349                             #:to 'assembly)))))
1350          (and (= (length w) 1)
1351               (number? (string-contains (car w)
1352                                         "expected 1, got 0")))))
1353
1354      (pass-if "two missing arguments"
1355        (let ((w (call-with-warnings
1356                  (lambda ()
1357                    (compile '((@ (ice-9 format) format) #f
1358                               "foo ~10,2f and bar ~S~%")
1359                             #:opts %opts-w-format
1360                             #:to 'assembly)))))
1361          (and (= (length w) 1)
1362               (number? (string-contains (car w)
1363                                         "expected 2, got 0")))))
1364
1365      (pass-if "one given, one missing argument"
1366        (let ((w (call-with-warnings
1367                  (lambda ()
1368                    (compile '(format #t "foo ~A and ~S~%" hey)
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      (pass-if "too many arguments"
1376        (let ((w (call-with-warnings
1377                  (lambda ()
1378                    (compile '(format #t "foo ~A~%" 1 2)
1379                             #:opts %opts-w-format
1380                             #:to 'assembly)))))
1381          (and (= (length w) 1)
1382               (number? (string-contains (car w)
1383                                         "expected 1, got 2")))))
1384
1385      (pass-if "~h"
1386        (null? (call-with-warnings
1387                  (lambda ()
1388                    (compile '((@ (ice-9 format) format) #t
1389                               "foo ~h ~a~%" 123.4 'bar)
1390                             #:opts %opts-w-format
1391                             #:to 'assembly)))))
1392
1393      (pass-if "~:h with locale object"
1394        (null? (call-with-warnings
1395                  (lambda ()
1396                    (compile '((@ (ice-9 format) format) #t
1397                               "foo ~:h~%" 123.4 %global-locale)
1398                             #:opts %opts-w-format
1399                             #:to 'assembly)))))
1400
1401      (pass-if "~:h without locale object"
1402        (let ((w (call-with-warnings
1403                  (lambda ()
1404                    (compile '((@ (ice-9 format) format) #t "foo ~,2:h" 123.4)
1405                             #:opts %opts-w-format
1406                             #:to 'assembly)))))
1407          (and (= (length w) 1)
1408               (number? (string-contains (car w)
1409                                         "expected 2, got 1")))))
1410
1411      (with-test-prefix "conditionals"
1412        (pass-if "literals"
1413         (null? (call-with-warnings
1414                 (lambda ()
1415                   (compile '((@ (ice-9 format) format) #f "~A ~[foo~;bar~;baz~;~] ~10,2f"
1416                                     'a 1 3.14)
1417                            #:opts %opts-w-format
1418                            #:to 'assembly)))))
1419
1420        (pass-if "literals with selector"
1421          (let ((w (call-with-warnings
1422                    (lambda ()
1423                      (compile '((@ (ice-9 format) format) #f "~2[foo~;bar~;baz~;~] ~A"
1424                                        1 'dont-ignore-me)
1425                               #:opts %opts-w-format
1426                               #:to 'assembly)))))
1427            (and (= (length w) 1)
1428                 (number? (string-contains (car w)
1429                                           "expected 1, got 2")))))
1430
1431        (pass-if "escapes (exact count)"
1432          (let ((w (call-with-warnings
1433                    (lambda ()
1434                      (compile '((@ (ice-9 format) format) #f "~[~a~;~a~]")
1435                               #:opts %opts-w-format
1436                               #:to 'assembly)))))
1437            (and (= (length w) 1)
1438                 (number? (string-contains (car w)
1439                                           "expected 2, got 0")))))
1440
1441        (pass-if "escapes with selector"
1442          (let ((w (call-with-warnings
1443                    (lambda ()
1444                      (compile '((@ (ice-9 format) format) #f "~1[chbouib~;~a~]")
1445                               #:opts %opts-w-format
1446                               #:to 'assembly)))))
1447            (and (= (length w) 1)
1448                 (number? (string-contains (car w)
1449                                           "expected 1, got 0")))))
1450
1451        (pass-if "escapes, range"
1452          (let ((w (call-with-warnings
1453                    (lambda ()
1454                      (compile '((@ (ice-9 format) format) #f "~[chbouib~;~a~;~2*~a~]")
1455                               #:opts %opts-w-format
1456                               #:to 'assembly)))))
1457            (and (= (length w) 1)
1458                 (number? (string-contains (car w)
1459                                           "expected 1 to 4, got 0")))))
1460
1461        (pass-if "@"
1462          (let ((w (call-with-warnings
1463                    (lambda ()
1464                      (compile '((@ (ice-9 format) format) #f "~@[temperature=~d~]")
1465                               #:opts %opts-w-format
1466                               #:to 'assembly)))))
1467            (and (= (length w) 1)
1468                 (number? (string-contains (car w)
1469                                           "expected 1, got 0")))))
1470
1471        (pass-if "nested"
1472          (let ((w (call-with-warnings
1473                    (lambda ()
1474                      (compile '((@ (ice-9 format) format) #f "~:[~[hey~;~a~;~va~]~;~3*~]")
1475                               #:opts %opts-w-format
1476                               #:to 'assembly)))))
1477            (and (= (length w) 1)
1478                 (number? (string-contains (car w)
1479                                           "expected 2 to 4, got 0")))))
1480
1481        (pass-if "unterminated"
1482          (let ((w (call-with-warnings
1483                    (lambda ()
1484                      (compile '((@ (ice-9 format) format) #f "~[unterminated")
1485                               #:opts %opts-w-format
1486                               #:to 'assembly)))))
1487            (and (= (length w) 1)
1488                 (number? (string-contains (car w)
1489                                           "unterminated conditional")))))
1490
1491        (pass-if "unexpected ~;"
1492          (let ((w (call-with-warnings
1493                    (lambda ()
1494                      (compile '((@ (ice-9 format) format) #f "foo~;bar")
1495                               #:opts %opts-w-format
1496                               #:to 'assembly)))))
1497            (and (= (length w) 1)
1498                 (number? (string-contains (car w)
1499                                           "unexpected")))))
1500
1501        (pass-if "unexpected ~]"
1502          (let ((w (call-with-warnings
1503                    (lambda ()
1504                      (compile '((@ (ice-9 format) format) #f "foo~]")
1505                               #:opts %opts-w-format
1506                               #:to 'assembly)))))
1507            (and (= (length w) 1)
1508                 (number? (string-contains (car w)
1509                                           "unexpected"))))))
1510
1511      (pass-if "~{...~}"
1512        (null? (call-with-warnings
1513                (lambda ()
1514                  (compile '((@ (ice-9 format) format) #f "~A ~{~S~} ~A"
1515                                    'hello '("ladies" "and")
1516                                    'gentlemen)
1517                           #:opts %opts-w-format
1518                           #:to 'assembly)))))
1519
1520      (pass-if "~{...~}, too many args"
1521        (let ((w (call-with-warnings
1522                  (lambda ()
1523                    (compile '((@ (ice-9 format) format) #f "~{~S~}" 1 2 3)
1524                             #:opts %opts-w-format
1525                             #:to 'assembly)))))
1526          (and (= (length w) 1)
1527               (number? (string-contains (car w)
1528                                         "expected 1, got 3")))))
1529
1530      (pass-if "~@{...~}"
1531        (null? (call-with-warnings
1532                (lambda ()
1533                  (compile '((@ (ice-9 format) format) #f "~@{~S~}" 1 2 3)
1534                           #:opts %opts-w-format
1535                           #:to 'assembly)))))
1536
1537      (pass-if "~@{...~}, too few args"
1538        (let ((w (call-with-warnings
1539                  (lambda ()
1540                    (compile '((@ (ice-9 format) format) #f "~A ~@{~S~}")
1541                             #:opts %opts-w-format
1542                             #:to 'assembly)))))
1543          (and (= (length w) 1)
1544               (number? (string-contains (car w)
1545                                         "expected at least 1, got 0")))))
1546
1547      (pass-if "unterminated ~{...~}"
1548        (let ((w (call-with-warnings
1549                  (lambda ()
1550                    (compile '((@ (ice-9 format) format) #f "~{")
1551                             #:opts %opts-w-format
1552                             #:to 'assembly)))))
1553          (and (= (length w) 1)
1554               (number? (string-contains (car w)
1555                                         "unterminated")))))
1556
1557      (pass-if "~(...~)"
1558        (null? (call-with-warnings
1559                (lambda ()
1560                  (compile '((@ (ice-9 format) format) #f "~:@(~A ~A~)" 'foo 'bar)
1561                           #:opts %opts-w-format
1562                           #:to 'assembly)))))
1563
1564      (pass-if "~v"
1565        (let ((w (call-with-warnings
1566                  (lambda ()
1567                    (compile '((@ (ice-9 format) format) #f "~v_foo")
1568                             #:opts %opts-w-format
1569                             #:to 'assembly)))))
1570          (and (= (length w) 1)
1571               (number? (string-contains (car w)
1572                                         "expected 1, got 0")))))
1573      (pass-if "~v:@y"
1574        (null? (call-with-warnings
1575                (lambda ()
1576                  (compile '((@ (ice-9 format) format) #f "~v:@y" 1 123)
1577                           #:opts %opts-w-format
1578                           #:to 'assembly)))))
1579
1580
1581      (pass-if "~*"
1582        (let ((w (call-with-warnings
1583                  (lambda ()
1584                    (compile '((@ (ice-9 format) format) #f "~2*~a" 'a 'b)
1585                             #:opts %opts-w-format
1586                             #:to 'assembly)))))
1587          (and (= (length w) 1)
1588               (number? (string-contains (car w)
1589                                         "expected 3, got 2")))))
1590
1591      (pass-if "~?"
1592        (null? (call-with-warnings
1593                (lambda ()
1594                  (compile '((@ (ice-9 format) format) #f "~?" "~d ~d" '(1 2))
1595                           #:opts %opts-w-format
1596                           #:to 'assembly)))))
1597
1598      (pass-if "complex 1"
1599        (let ((w (call-with-warnings
1600                  (lambda ()
1601                    (compile '((@ (ice-9 format) format) #f
1602                                      "~4@S    ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n"
1603                                      1 2 3 4 5 6)
1604                             #:opts %opts-w-format
1605                             #:to 'assembly)))))
1606          (and (= (length w) 1)
1607               (number? (string-contains (car w)
1608                                         "expected 4, got 6")))))
1609
1610      (pass-if "complex 2"
1611        (let ((w (call-with-warnings
1612                  (lambda ()
1613                    (compile '((@ (ice-9 format) format) #f
1614                                      "~:(~A~) Commands~:[~; [abbrev]~]:~2%"
1615                                      1 2 3 4)
1616                             #:opts %opts-w-format
1617                             #:to 'assembly)))))
1618          (and (= (length w) 1)
1619               (number? (string-contains (car w)
1620                                         "expected 2, got 4")))))
1621
1622      (pass-if "complex 3"
1623        (let ((w (call-with-warnings
1624                  (lambda ()
1625                    (compile '((@ (ice-9 format) format) #f "~9@a~:[~*~3_~;~3d~] ~v:@y~%")
1626                             #:opts %opts-w-format
1627                             #:to 'assembly)))))
1628          (and (= (length w) 1)
1629               (number? (string-contains (car w)
1630                                         "expected 5, got 0")))))
1631
1632      (pass-if "ice-9 format"
1633        (let ((w (call-with-warnings
1634                  (lambda ()
1635                    (let ((in (open-input-string
1636                               "(use-modules ((ice-9 format)
1637                                  #:renamer (symbol-prefix-proc 'i9-)))
1638                                (i9-format #t \"yo! ~A\" 1 2)")))
1639                      (read-and-compile in
1640                                        #:opts %opts-w-format
1641                                        #:to 'assembly))))))
1642          (and (= (length w) 1)
1643               (number? (string-contains (car w)
1644                                         "expected 1, got 2")))))
1645
1646      (pass-if "not format"
1647        (null? (call-with-warnings
1648                (lambda ()
1649                  (compile '(let ((format chbouib))
1650                              (format #t "not ~A a format string"))
1651                           #:opts %opts-w-format
1652                           #:to 'assembly)))))
1653
1654      (with-test-prefix "simple-format"
1655
1656        (pass-if "good"
1657          (null? (call-with-warnings
1658                  (lambda ()
1659                    (compile '(simple-format #t "foo ~a bar ~s ~%~~" 1 2)
1660                             #:opts %opts-w-format
1661                             #:to 'assembly)))))
1662
1663        (pass-if "wrong number of args"
1664          (let ((w (call-with-warnings
1665                    (lambda ()
1666                      (compile '(simple-format #t "foo ~a ~s~%" 'one-missing)
1667                               #:opts %opts-w-format
1668                               #:to 'assembly)))))
1669            (and (= (length w) 1)
1670                 (number? (string-contains (car w) "wrong number")))))
1671
1672        (pass-if "unsupported"
1673          (let ((w (call-with-warnings
1674                    (lambda ()
1675                      (compile '(simple-format #t "foo ~x~%" 16)
1676                               #:opts %opts-w-format
1677                               #:to 'assembly)))))
1678            (and (= (length w) 1)
1679                 (number? (string-contains (car w) "unsupported format option")))))
1680
1681        (pass-if "unsupported, gettext"
1682          (let ((w (call-with-warnings
1683                    (lambda ()
1684                      (compile '(simple-format #t (gettext "foo ~2f~%") 3.14)
1685                               #:opts %opts-w-format
1686                               #:to 'assembly)))))
1687            (and (= (length w) 1)
1688                 (number? (string-contains (car w) "unsupported format option")))))
1689
1690        (pass-if "unsupported, ngettext"
1691          (let ((w (call-with-warnings
1692                    (lambda ()
1693                      (compile '(simple-format #t (ngettext "s ~x" "p ~x" x) x)
1694                               #:opts %opts-w-format
1695                               #:to 'assembly)))))
1696            (and (= (length w) 1)
1697                 (number? (string-contains (car w) "unsupported format option"))))))))