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 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 glil)
  27   #:use-module (srfi srfi-13))
  28
  29 ;; Of course, the GLIL that is emitted depends on the source info of the
  30 ;; input. Here we're not concerned about that, so we strip source
  31 ;; information from the incoming tree-il.
  32
  33 (define (strip-source x)
  34   (post-order! (lambda (x) (set! (tree-il-src x) #f))
  35                x))
  36
  37 (define-syntax assert-scheme->glil
  38   (syntax-rules ()
  39     ((_ in out)
  40      (let ((tree-il (strip-source
  41                      (compile 'in #:from 'scheme #:to 'tree-il))))
  42        (pass-if 'in
  43                 (equal? (unparse-glil (compile tree-il #:from 'tree-il #:to 'glil))
  44                         'out))))))
  45
  46 (define-syntax assert-tree-il->glil
  47   (syntax-rules ()
  48     ((_ in pat test ...)
  49      (let ((exp 'in))
  50        (pass-if 'in
  51          (let ((glil (unparse-glil
  52                       (compile (strip-source (parse-tree-il exp))
  53                                #:from 'tree-il #:to 'glil))))
  54            (pmatch glil
  55              (pat (guard test ...) #t)
  56              (else #f))))))))
  57
  58 (with-test-prefix "void"
  59   (assert-tree-il->glil
  60    (void)
  61    (program () (std-prelude 0 0 #f) (label _) (void) (call return 1)))
  62   (assert-tree-il->glil
  63    (begin (void) (const 1))
  64    (program () (std-prelude 0 0 #f) (label _) (const 1) (call return 1)))
  65   (assert-tree-il->glil
  66    (apply (primitive +) (void) (const 1))
  67    (program () (std-prelude 0 0 #f) (label _) (void) (call add1 1) (call return 1))))
  68
  69 (with-test-prefix "application"
  70   (assert-tree-il->glil
  71    (apply (toplevel foo) (const 1))
  72    (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (const 1) (call goto/args 1)))
  73   (assert-tree-il->glil
  74    (begin (apply (toplevel foo) (const 1)) (void))
  75    (program () (std-prelude 0 0 #f) (label _) (call new-frame 0) (toplevel ref foo) (const 1) (mv-call 1 ,l1)
  76             (call drop 1) (branch br ,l2)
  77             (label ,l3) (mv-bind () #f) (unbind)
  78             (label ,l4)
  79             (void) (call return 1))
  80    (and (eq? l1 l3) (eq? l2 l4)))
  81   (assert-tree-il->glil
  82    (apply (toplevel foo) (apply (toplevel bar)))
  83    (program ()  (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call new-frame 0) (toplevel ref bar) (call call 0)
  84             (call goto/args 1))))
  85
  86 (with-test-prefix "conditional"
  87   (assert-tree-il->glil
  88    (if (const #t) (const 1) (const 2))
  89    (program () (std-prelude 0 0 #f) (label _) (const #t) (branch br-if-not ,l1)
  90             (const 1) (call return 1)
  91             (label ,l2) (const 2) (call return 1))
  92    (eq? l1 l2))
  93
  94   (assert-tree-il->glil
  95    (begin (if (const #t) (const 1) (const 2)) (const #f))
  96    (program () (std-prelude 0 0 #f) (label _) (const #t) (branch br-if-not ,l1) (branch br ,l2)
  97             (label ,l3) (label ,l4) (const #f) (call return 1))
  98    (eq? l1 l3) (eq? l2 l4))
  99
 100   (assert-tree-il->glil
 101    (apply (primitive null?) (if (const #t) (const 1) (const 2)))
 102    (program () (std-prelude 0 0 #f) (label _) (const #t) (branch br-if-not ,l1)
 103             (const 1) (branch br ,l2)
 104                     (label ,l3) (const 2) (label ,l4)
 105                     (call null? 1) (call return 1))
 106    (eq? l1 l3) (eq? l2 l4)))
 107
 108 (with-test-prefix "primitive-ref"
 109   (assert-tree-il->glil
 110    (primitive +)
 111    (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call return 1)))
 112
 113   (assert-tree-il->glil
 114    (begin (primitive +) (const #f))
 115    (program () (std-prelude 0 0 #f) (label _) (const #f) (call return 1)))
 116
 117   (assert-tree-il->glil
 118    (apply (primitive null?) (primitive +))
 119    (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call null? 1)
 120             (call return 1))))
 121
 122 (with-test-prefix "lexical refs"
 123   (assert-tree-il->glil
 124    (let (x) (y) ((const 1)) (lexical x y))
 125    (program () (std-prelude 0 1 #f) (label _)
 126             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
 127             (lexical #t #f ref 0) (call return 1)
 128             (unbind)))
 129
 130   (assert-tree-il->glil
 131    (let (x) (y) ((const 1)) (begin (lexical x y) (const #f)))
 132    (program () (std-prelude 0 1 #f) (label _)
 133             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
 134             (const #f) (call return 1)
 135             (unbind)))
 136
 137   (assert-tree-il->glil
 138    (let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y)))
 139    (program () (std-prelude 0 1 #f) (label _)
 140             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
 141             (lexical #t #f ref 0) (call null? 1) (call return 1)
 142             (unbind))))
 143
 144 (with-test-prefix "lexical sets"
 145   (assert-tree-il->glil
 146    ;; unreferenced sets may be optimized away -- make sure they are ref'd
 147    (let (x) (y) ((const 1))
 148         (set! (lexical x y) (apply (primitive 1+) (lexical x y))))
 149    (program () (std-prelude 0 1 #f) (label _)
 150             (const 1) (bind (x #t 0)) (lexical #t #t box 0)
 151             (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
 152             (void) (call return 1)
 153             (unbind)))
 154
 155   (assert-tree-il->glil
 156    (let (x) (y) ((const 1))
 157         (begin (set! (lexical x y) (apply (primitive 1+) (lexical x y)))
 158                (lexical x y)))
 159    (program () (std-prelude 0 1 #f) (label _)
 160             (const 1) (bind (x #t 0)) (lexical #t #t box 0)
 161             (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
 162             (lexical #t #t ref 0) (call return 1)
 163             (unbind)))
 164
 165   (assert-tree-il->glil
 166    (let (x) (y) ((const 1))
 167      (apply (primitive null?)
 168             (set! (lexical x y) (apply (primitive 1+) (lexical x y)))))
 169    (program () (std-prelude 0 1 #f) (label _)
 170             (const 1) (bind (x #t 0)) (lexical #t #t box 0)
 171             (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (void)
 172             (call null? 1) (call return 1)
 173             (unbind))))
 174
 175 (with-test-prefix "module refs"
 176   (assert-tree-il->glil
 177    (@ (foo) bar)
 178    (program () (std-prelude 0 0 #f) (label _)
 179             (module public ref (foo) bar)
 180             (call return 1)))
 181
 182   (assert-tree-il->glil
 183    (begin (@ (foo) bar) (const #f))
 184    (program () (std-prelude 0 0 #f) (label _)
 185             (module public ref (foo) bar) (call drop 1)
 186             (const #f) (call return 1)))
 187
 188   (assert-tree-il->glil
 189    (apply (primitive null?) (@ (foo) bar))
 190    (program () (std-prelude 0 0 #f) (label _)
 191             (module public ref (foo) bar)
 192             (call null? 1) (call return 1)))
 193
 194   (assert-tree-il->glil
 195    (@@ (foo) bar)
 196    (program () (std-prelude 0 0 #f) (label _)
 197             (module private ref (foo) bar)
 198             (call return 1)))
 199
 200   (assert-tree-il->glil
 201    (begin (@@ (foo) bar) (const #f))
 202    (program () (std-prelude 0 0 #f) (label _)
 203             (module private ref (foo) bar) (call drop 1)
 204             (const #f) (call return 1)))
 205
 206   (assert-tree-il->glil
 207    (apply (primitive null?) (@@ (foo) bar))
 208    (program () (std-prelude 0 0 #f) (label _)
 209             (module private ref (foo) bar)
 210             (call null? 1) (call return 1))))
 211
 212 (with-test-prefix "module sets"
 213   (assert-tree-il->glil
 214    (set! (@ (foo) bar) (const 2))
 215    (program () (std-prelude 0 0 #f) (label _)
 216             (const 2) (module public set (foo) bar)
 217             (void) (call return 1)))
 218
 219   (assert-tree-il->glil
 220    (begin (set! (@ (foo) bar) (const 2)) (const #f))
 221    (program () (std-prelude 0 0 #f) (label _)
 222             (const 2) (module public set (foo) bar)
 223             (const #f) (call return 1)))
 224
 225   (assert-tree-il->glil
 226    (apply (primitive null?) (set! (@ (foo) bar) (const 2)))
 227    (program () (std-prelude 0 0 #f) (label _)
 228             (const 2) (module public set (foo) bar)
 229             (void) (call null? 1) (call return 1)))
 230
 231   (assert-tree-il->glil
 232    (set! (@@ (foo) bar) (const 2))
 233    (program () (std-prelude 0 0 #f) (label _)
 234             (const 2) (module private set (foo) bar)
 235             (void) (call return 1)))
 236
 237   (assert-tree-il->glil
 238    (begin (set! (@@ (foo) bar) (const 2)) (const #f))
 239    (program () (std-prelude 0 0 #f) (label _)
 240             (const 2) (module private set (foo) bar)
 241             (const #f) (call return 1)))
 242
 243   (assert-tree-il->glil
 244    (apply (primitive null?) (set! (@@ (foo) bar) (const 2)))
 245    (program () (std-prelude 0 0 #f) (label _)
 246             (const 2) (module private set (foo) bar)
 247             (void) (call null? 1) (call return 1))))
 248
 249 (with-test-prefix "toplevel refs"
 250   (assert-tree-il->glil
 251    (toplevel bar)
 252    (program () (std-prelude 0 0 #f) (label _)
 253             (toplevel ref bar)
 254             (call return 1)))
 255
 256   (assert-tree-il->glil
 257    (begin (toplevel bar) (const #f))
 258    (program () (std-prelude 0 0 #f) (label _)
 259             (toplevel ref bar) (call drop 1)
 260             (const #f) (call return 1)))
 261
 262   (assert-tree-il->glil
 263    (apply (primitive null?) (toplevel bar))
 264    (program () (std-prelude 0 0 #f) (label _)
 265             (toplevel ref bar)
 266             (call null? 1) (call return 1))))
 267
 268 (with-test-prefix "toplevel sets"
 269   (assert-tree-il->glil
 270    (set! (toplevel bar) (const 2))
 271    (program () (std-prelude 0 0 #f) (label _)
 272             (const 2) (toplevel set bar)
 273             (void) (call return 1)))
 274
 275   (assert-tree-il->glil
 276    (begin (set! (toplevel bar) (const 2)) (const #f))
 277    (program () (std-prelude 0 0 #f) (label _)
 278             (const 2) (toplevel set bar)
 279             (const #f) (call return 1)))
 280
 281   (assert-tree-il->glil
 282    (apply (primitive null?) (set! (toplevel bar) (const 2)))
 283    (program () (std-prelude 0 0 #f) (label _)
 284             (const 2) (toplevel set bar)
 285             (void) (call null? 1) (call return 1))))
 286
 287 (with-test-prefix "toplevel defines"
 288   (assert-tree-il->glil
 289    (define bar (const 2))
 290    (program () (std-prelude 0 0 #f) (label _)
 291             (const 2) (toplevel define bar)
 292             (void) (call return 1)))
 293
 294   (assert-tree-il->glil
 295    (begin (define bar (const 2)) (const #f))
 296    (program () (std-prelude 0 0 #f) (label _)
 297             (const 2) (toplevel define bar)
 298             (const #f) (call return 1)))
 299
 300   (assert-tree-il->glil
 301    (apply (primitive null?) (define bar (const 2)))
 302    (program () (std-prelude 0 0 #f) (label _)
 303             (const 2) (toplevel define bar)
 304             (void) (call null? 1) (call return 1))))
 305
 306 (with-test-prefix "constants"
 307   (assert-tree-il->glil
 308    (const 2)
 309    (program () (std-prelude 0 0 #f) (label _)
 310             (const 2) (call return 1)))
 311
 312   (assert-tree-il->glil
 313    (begin (const 2) (const #f))
 314    (program () (std-prelude 0 0 #f) (label _)
 315             (const #f) (call return 1)))
 316
 317   (assert-tree-il->glil
 318    (apply (primitive null?) (const 2))
 319    (program () (std-prelude 0 0 #f) (label _)
 320             (const 2) (call null? 1) (call return 1))))
 321
 322 (with-test-prefix "lambda"
 323   (assert-tree-il->glil
 324    (lambda ()
 325      (lambda-case (((x) #f #f #f () (y) #f) (const 2)) #f))
 326    (program ()  (std-prelude 0 0 #f) (label _)
 327             (program () (std-prelude 1 1 #f)
 328                      (bind (x #f 0)) (label _)
 329                      (const 2) (call return 1) (unbind))
 330             (call return 1)))
 331
 332   (assert-tree-il->glil
 333    (lambda ()
 334      (lambda-case (((x y) #f #f #f () (x1 y1) #f)
 335                    (const 2))
 336                   #f))
 337    (program () (std-prelude 0 0 #f) (label _)
 338             (program () (std-prelude 2 2 #f)
 339                      (bind (x #f 0) (y #f 1)) (label _)
 340                      (const 2) (call return 1)
 341                      (unbind))
 342             (call return 1)))
 343
 344   (assert-tree-il->glil
 345    (lambda ()
 346      (lambda-case ((() #f x #f () (y) #f) (const 2))
 347                   #f))
 348    (program () (std-prelude 0 0 #f) (label _)
 349             (program () (opt-prelude 0 0 0 1 #f)
 350                      (bind (x #f 0)) (label _)
 351                      (const 2) (call return 1)
 352                      (unbind))
 353             (call return 1)))
 354
 355   (assert-tree-il->glil
 356    (lambda ()
 357      (lambda-case (((x) #f x1 #f () (y y1) #f) (const 2))
 358                   #f))
 359    (program () (std-prelude 0 0 #f) (label _)
 360             (program () (opt-prelude 1 0 1 2 #f)
 361                      (bind (x #f 0) (x1 #f 1)) (label _)
 362                      (const 2) (call return 1)
 363                      (unbind))
 364             (call return 1)))
 365
 366   (assert-tree-il->glil
 367    (lambda ()
 368      (lambda-case (((x) #f x1 #f () (y y1) #f) (lexical x y))
 369                   #f))
 370    (program () (std-prelude 0 0 #f) (label _)
 371             (program () (opt-prelude 1 0 1 2 #f)
 372                      (bind (x #f 0) (x1 #f 1)) (label _)
 373                      (lexical #t #f ref 0) (call return 1)
 374                      (unbind))
 375             (call return 1)))
 376
 377   (assert-tree-il->glil
 378    (lambda ()
 379      (lambda-case (((x) #f x1 #f () (y y1) #f) (lexical x1 y1))
 380                   #f))
 381    (program () (std-prelude 0 0 #f) (label _)
 382             (program () (opt-prelude 1 0 1 2 #f)
 383                      (bind (x #f 0) (x1 #f 1)) (label _)
 384                      (lexical #t #f ref 1) (call return 1)
 385                      (unbind))
 386             (call return 1)))
 387
 388   (assert-tree-il->glil
 389    (lambda ()
 390      (lambda-case (((x) #f #f #f () (x1) #f)
 391                    (lambda ()
 392                      (lambda-case (((y) #f #f #f () (y1) #f)
 393                                    (lexical x x1))
 394                                   #f)))
 395                   #f))
 396    (program () (std-prelude 0 0 #f) (label _)
 397             (program () (std-prelude 1 1 #f)
 398                      (bind (x #f 0)) (label _)
 399                      (program () (std-prelude 1 1 #f)
 400                               (bind (y #f 0)) (label _)
 401                               (lexical #f #f ref 0) (call return 1)
 402                               (unbind))
 403                      (lexical #t #f ref 0)
 404                      (call vector 1)
 405                      (call make-closure 2)
 406                      (call return 1)
 407                      (unbind))
 408             (call return 1))))
 409
 410 (with-test-prefix "sequence"
 411   (assert-tree-il->glil
 412    (begin (begin (const 2) (const #f)) (const #t))
 413    (program () (std-prelude 0 0 #f) (label _)
 414             (const #t) (call return 1)))
 415
 416   (assert-tree-il->glil
 417    (apply (primitive null?) (begin (const #f) (const 2)))
 418    (program () (std-prelude 0 0 #f) (label _)
 419             (const 2) (call null? 1) (call return 1))))
 420
 421 ;; FIXME: binding info for or-hacked locals might bork the disassembler,
 422 ;; and could be tightened in any case
 423 (with-test-prefix "the or hack"
 424   (assert-tree-il->glil
 425    (let (x) (y) ((const 1))
 426         (if (lexical x y)
 427             (lexical x y)
 428             (let (a) (b) ((const 2))
 429                  (lexical a b))))
 430    (program () (std-prelude 0 1 #f) (label _)
 431             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
 432             (lexical #t #f ref 0) (branch br-if-not ,l1)
 433             (lexical #t #f ref 0) (call return 1)
 434             (label ,l2)
 435             (const 2) (bind (a #f 0)) (lexical #t #f set 0)
 436             (lexical #t #f ref 0) (call return 1)
 437             (unbind)
 438             (unbind))
 439    (eq? l1 l2))
 440
 441   ;; second bound var is unreferenced
 442   (assert-tree-il->glil
 443    (let (x) (y) ((const 1))
 444         (if (lexical x y)
 445             (lexical x y)
 446             (let (a) (b) ((const 2))
 447                  (lexical x y))))
 448    (program () (std-prelude 0 1 #f) (label _)
 449             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
 450             (lexical #t #f ref 0) (branch br-if-not ,l1)
 451             (lexical #t #f ref 0) (call return 1)
 452             (label ,l2)
 453             (lexical #t #f ref 0) (call return 1)
 454             (unbind))
 455    (eq? l1 l2)))
 456
 457 (with-test-prefix "apply"
 458   (assert-tree-il->glil
 459    (apply (primitive @apply) (toplevel foo) (toplevel bar))
 460    (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (toplevel ref bar) (call goto/apply 2)))
 461   (assert-tree-il->glil
 462    (begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void))
 463    (program () (std-prelude 0 0 #f) (label _)
 464             (call new-frame 0) (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1)
 465             (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
 466             (label ,l4)
 467             (void) (call return 1))
 468    (and (eq? l1 l3) (eq? l2 l4)))
 469   (assert-tree-il->glil
 470    (apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz)))
 471    (program () (std-prelude 0 0 #f) (label _)
 472             (toplevel ref foo)
 473             (call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call apply 2)
 474             (call goto/args 1))))
 475
 476 (with-test-prefix "call/cc"
 477   (assert-tree-il->glil
 478    (apply (primitive @call-with-current-continuation) (toplevel foo))
 479    (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call goto/cc 1)))
 480   (assert-tree-il->glil
 481    (begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void))
 482    (program () (std-prelude 0 0 #f) (label _)
 483             (call new-frame 0) (toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1)
 484             (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
 485             (label ,l4)
 486             (void) (call return 1))
 487    (and (eq? l1 l3) (eq? l2 l4)))
 488   (assert-tree-il->glil
 489    (apply (toplevel foo)
 490           (apply (toplevel @call-with-current-continuation) (toplevel bar)))
 491    (program () (std-prelude 0 0 #f) (label _)
 492             (toplevel ref foo)
 493             (toplevel ref bar) (call call/cc 1)
 494             (call goto/args 1))))
 495
 496 \f
 497 (with-test-prefix "tree-il-fold"
 498
 499   (pass-if "empty tree"
 500     (let ((leaf? #f) (up? #f) (down? #f) (mark (list 'mark)))
 501       (and (eq? mark
 502                 (tree-il-fold (lambda (x y) (set! leaf? #t) y)
 503                               (lambda (x y) (set! down? #t) y)
 504                               (lambda (x y) (set! up? #t) y)
 505                               mark
 506                               '()))
 507            (not leaf?)
 508            (not up?)
 509            (not down?))))
 510
 511   (pass-if "lambda and application"
 512     (let* ((leaves '()) (ups '()) (downs '())
 513            (result (tree-il-fold (lambda (x y)
 514                                    (set! leaves (cons x leaves))
 515                                    (1+ y))
 516                                  (lambda (x y)
 517                                    (set! downs (cons x downs))
 518                                    (1+ y))
 519                                  (lambda (x y)
 520                                    (set! ups (cons x ups))
 521                                    (1+ y))
 522                                  0
 523                                  (parse-tree-il
 524                                   '(lambda ()
 525                                      (lambda-case
 526                                       (((x y) #f #f #f () (x1 y1) #f)
 527                                        (apply (toplevel +)
 528                                               (lexical x x1)
 529                                               (lexical y y1)))
 530                                       #f))))))
 531       (and (equal? (map strip-source leaves)
 532                    (list (make-lexical-ref #f 'y 'y1)
 533                          (make-lexical-ref #f 'x 'x1)
 534                          (make-toplevel-ref #f '+)))
 535            (= (length downs) 3)
 536            (equal? (reverse (map strip-source ups))
 537                    (map strip-source downs))))))
 538
 539 \f
 540 ;;;
 541 ;;; Warnings.
 542 ;;;
 543
 544 ;; Make sure we get English messages.
 545 (setlocale LC_ALL "C")
 546
 547 (define (call-with-warnings thunk)
 548   (let ((port (open-output-string)))
 549     (with-fluid* *current-warning-port* port
 550       thunk)
 551     (let ((warnings (get-output-string port)))
 552       (string-tokenize warnings
 553                        (char-set-complement (char-set #\newline))))))
 554
 555 (define %opts-w-unused
 556   '(#:warnings (unused-variable)))
 557
 558 (define %opts-w-unbound
 559   '(#:warnings (unbound-variable)))
 560
 561 (define %opts-w-arity
 562   '(#:warnings (arity-mismatch)))
 563
 564
 565 (with-test-prefix "warnings"
 566
 567    (pass-if "unknown warning type"
 568      (let ((w (call-with-warnings
 569                 (lambda ()
 570                   (compile #t #:opts '(#:warnings (does-not-exist)))))))
 571        (and (= (length w) 1)
 572             (number? (string-contains (car w) "unknown warning")))))
 573
 574    (with-test-prefix "unused-variable"
 575
 576      (pass-if "quiet"
 577        (null? (call-with-warnings
 578                 (lambda ()
 579                   (compile '(lambda (x y) (+ x y))
 580                            #:opts %opts-w-unused)))))
 581
 582      (pass-if "let/unused"
 583        (let ((w (call-with-warnings
 584                   (lambda ()
 585                     (compile '(lambda (x)
 586                                 (let ((y (+ x 2)))
 587                                   x))
 588                              #:opts %opts-w-unused)))))
 589          (and (= (length w) 1)
 590               (number? (string-contains (car w) "unused variable `y'")))))
 591
 592      (pass-if "shadowed variable"
 593        (let ((w (call-with-warnings
 594                   (lambda ()
 595                     (compile '(lambda (x)
 596                                 (let ((y x))
 597                                   (let ((y (+ x 2)))
 598                                     (+ x y))))
 599                              #:opts %opts-w-unused)))))
 600          (and (= (length w) 1)
 601               (number? (string-contains (car w) "unused variable `y'")))))
 602
 603      (pass-if "letrec"
 604        (null? (call-with-warnings
 605                 (lambda ()
 606                   (compile '(lambda ()
 607                               (letrec ((x (lambda () (y)))
 608                                        (y (lambda () (x))))
 609                                 y))
 610                            #:opts %opts-w-unused)))))
 611
 612      (pass-if "unused argument"
 613        ;; Unused arguments should not be reported.
 614        (null? (call-with-warnings
 615                 (lambda ()
 616                   (compile '(lambda (x y z) #t)
 617                            #:opts %opts-w-unused))))))
 618
 619    (with-test-prefix "unbound variable"
 620
 621      (pass-if "quiet"
 622        (null? (call-with-warnings
 623                 (lambda ()
 624                   (compile '+ #:opts %opts-w-unbound)))))
 625
 626      (pass-if "ref"
 627        (let* ((v (gensym))
 628               (w (call-with-warnings
 629                    (lambda ()
 630                      (compile v
 631                               #:to 'assembly
 632                               #:opts %opts-w-unbound)))))
 633          (and (= (length w) 1)
 634               (number? (string-contains (car w)
 635                                         (format #f "unbound variable `~A'"
 636                                                 v))))))
 637
 638      (pass-if "set!"
 639        (let* ((v (gensym))
 640               (w (call-with-warnings
 641                    (lambda ()
 642                      (compile `(set! ,v 7)
 643                               #:to 'assembly
 644                               #:opts %opts-w-unbound)))))
 645          (and (= (length w) 1)
 646               (number? (string-contains (car w)
 647                                         (format #f "unbound variable `~A'"
 648                                                 v))))))
 649
 650      (pass-if "module-local top-level is visible"
 651        (let ((m (make-module))
 652              (v (gensym)))
 653          (beautify-user-module! m)
 654          (compile `(define ,v 123)
 655                   #:env m #:opts %opts-w-unbound)
 656          (null? (call-with-warnings
 657                   (lambda ()
 658                     (compile v
 659                              #:env m
 660                              #:to 'assembly
 661                              #:opts %opts-w-unbound))))))
 662
 663      (pass-if "module-local top-level is visible after"
 664        (let ((m (make-module))
 665              (v (gensym)))
 666          (beautify-user-module! m)
 667          (null? (call-with-warnings
 668                   (lambda ()
 669                     (let ((in (open-input-string
 670                                "(define (f)
 671                                   (set! chbouib 3))
 672                                 (define chbouib 5)")))
 673                       (read-and-compile in
 674                                         #:env m
 675                                         #:opts %opts-w-unbound)))))))
 676
 677      (pass-if "optional arguments are visible"
 678        (null? (call-with-warnings
 679                 (lambda ()
 680                   (compile '(lambda* (x #:optional y z) (list x y z))
 681                            #:opts %opts-w-unbound
 682                            #:to 'assembly)))))
 683
 684      (pass-if "keyword arguments are visible"
 685        (null? (call-with-warnings
 686                 (lambda ()
 687                   (compile '(lambda* (x #:key y z) (list x y z))
 688                            #:opts %opts-w-unbound
 689                            #:to 'assembly)))))
 690
 691      (pass-if "GOOPS definitions are visible"
 692        (let ((m (make-module))
 693              (v (gensym)))
 694          (beautify-user-module! m)
 695          (module-use! m (resolve-interface '(oop goops)))
 696          (null? (call-with-warnings
 697                   (lambda ()
 698                     (let ((in (open-input-string
 699                                "(define-class <foo> ()
 700                                   (bar #:getter foo-bar))
 701                                 (define z (foo-bar (make <foo>)))")))
 702                       (read-and-compile in
 703                                         #:env m
 704                                         #:opts %opts-w-unbound))))))))
 705
 706    (with-test-prefix "arity mismatch"
 707
 708      (pass-if "quiet"
 709        (null? (call-with-warnings
 710                 (lambda ()
 711                   (compile '(cons 'a 'b) #:opts %opts-w-arity)))))
 712
 713      (pass-if "direct application"
 714        (let ((w (call-with-warnings
 715                   (lambda ()
 716                     (compile '((lambda (x y) (or x y)) 1 2 3 4 5)
 717                              #:opts %opts-w-arity
 718                              #:to 'assembly)))))
 719          (and (= (length w) 1)
 720               (number? (string-contains (car w)
 721                                         "wrong number of arguments to")))))
 722      (pass-if "local"
 723        (let ((w (call-with-warnings
 724                   (lambda ()
 725                     (compile '(let ((f (lambda (x y) (+ x y))))
 726                                 (f 2))
 727                              #:opts %opts-w-arity
 728                              #:to 'assembly)))))
 729          (and (= (length w) 1)
 730               (number? (string-contains (car w)
 731                                         "wrong number of arguments to")))))
 732
 733      (pass-if "global"
 734        (let ((w (call-with-warnings
 735                   (lambda ()
 736                     (compile '(cons 1 2 3 4)
 737                              #:opts %opts-w-arity
 738                              #:to 'assembly)))))
 739          (and (= (length w) 1)
 740               (number? (string-contains (car w)
 741                                         "wrong number of arguments to")))))
 742
 743      (pass-if "alias to global"
 744        (let ((w (call-with-warnings
 745                   (lambda ()
 746                     (compile '(let ((f cons)) (f 1 2 3 4))
 747                              #:opts %opts-w-arity
 748                              #:to 'assembly)))))
 749          (and (= (length w) 1)
 750               (number? (string-contains (car w)
 751                                         "wrong number of arguments to")))))
 752
 753      (pass-if "alias to lexical to global"
 754        (let ((w (call-with-warnings
 755                   (lambda ()
 756                     (compile '(let ((f number?))
 757                                 (let ((g f))
 758                                   (f 1 2 3 4)))
 759                              #:opts %opts-w-arity
 760                              #:to 'assembly)))))
 761          (and (= (length w) 1)
 762               (number? (string-contains (car w)
 763                                         "wrong number of arguments to")))))
 764
 765      (pass-if "alias to lexical"
 766        (let ((w (call-with-warnings
 767                   (lambda ()
 768                     (compile '(let ((f (lambda (x y z) (+ x y z))))
 769                                 (let ((g f))
 770                                   (g 1)))
 771                              #:opts %opts-w-arity
 772                              #:to 'assembly)))))
 773          (and (= (length w) 1)
 774               (number? (string-contains (car w)
 775                                         "wrong number of arguments to")))))
 776
 777      (pass-if "letrec"
 778        (let ((w (call-with-warnings
 779                   (lambda ()
 780                     (compile '(letrec ((odd?  (lambda (x) (even? (1- x))))
 781                                        (even? (lambda (x)
 782                                                 (or (= 0 x)
 783                                                     (odd?)))))
 784                                 (odd? 1))
 785                              #:opts %opts-w-arity
 786                              #:to 'assembly)))))
 787          (and (= (length w) 1)
 788               (number? (string-contains (car w)
 789                                         "wrong number of arguments to")))))
 790
 791      (pass-if "local toplevel-defines"
 792        (let ((w (call-with-warnings
 793                   (lambda ()
 794                     (let ((in (open-input-string "
 795                                 (define (g x) (f x))
 796                                 (define (f) 1)")))
 797                       (read-and-compile in
 798                                         #:opts %opts-w-arity
 799                                         #:to 'assembly))))))
 800          (and (= (length w) 1)
 801               (number? (string-contains (car w)
 802                                         "wrong number of arguments to")))))
 803
 804      (pass-if "global toplevel alias"
 805        (let ((w (call-with-warnings
 806                   (lambda ()
 807                     (let ((in (open-input-string "
 808                                 (define f cons)
 809                                 (define (g) (f))")))
 810                       (read-and-compile in
 811                                         #:opts %opts-w-arity
 812                                         #:to 'assembly))))))
 813          (and (= (length w) 1)
 814               (number? (string-contains (car w)
 815                                         "wrong number of arguments to")))))
 816
 817      (pass-if "local toplevel overrides global"
 818        (null? (call-with-warnings
 819                 (lambda ()
 820                   (let ((in (open-input-string "
 821                               (define (cons) 0)
 822                               (define (foo x) (cons))")))
 823                     (read-and-compile in
 824                                       #:opts %opts-w-arity
 825                                       #:to 'assembly))))))
 826
 827      (pass-if "keyword not passed and quiet"
 828        (null? (call-with-warnings
 829                 (lambda ()
 830                   (compile '(let ((f (lambda* (x #:key y) y)))
 831                               (f 2))
 832                            #:opts %opts-w-arity
 833                            #:to 'assembly)))))
 834
 835      (pass-if "keyword passed and quiet"
 836        (null? (call-with-warnings
 837                 (lambda ()
 838                   (compile '(let ((f (lambda* (x #:key y) y)))
 839                               (f 2 #:y 3))
 840                            #:opts %opts-w-arity
 841                            #:to 'assembly)))))
 842
 843      (pass-if "keyword passed to global and quiet"
 844        (null? (call-with-warnings
 845                 (lambda ()
 846                   (let ((in (open-input-string "
 847                               (use-modules (system base compile))
 848                               (compile '(+ 2 3) #:env (current-module))")))
 849                     (read-and-compile in
 850                                       #:opts %opts-w-arity
 851                                       #:to 'assembly))))))
 852
 853      (pass-if "extra keyword"
 854        (let ((w (call-with-warnings
 855                   (lambda ()
 856                     (compile '(let ((f (lambda* (x #:key y) y)))
 857                                 (f 2 #:Z 3))
 858                              #:opts %opts-w-arity
 859                              #:to 'assembly)))))
 860          (and (= (length w) 1)
 861               (number? (string-contains (car w)
 862                                         "wrong number of arguments to")))))
 863
 864      (pass-if "extra keywords allowed"
 865        (null? (call-with-warnings
 866                 (lambda ()
 867                   (compile '(let ((f (lambda* (x #:key y #:allow-other-keys)
 868                                        y)))
 869                               (f 2 #:Z 3))
 870                            #:opts %opts-w-arity
 871                            #:to 'assembly)))))))