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 (define read-and-compile
  30   (@@ (system base compile) read-and-compile))
  31
  32 ;; Of course, the GLIL that is emitted depends on the source info of the
  33 ;; input. Here we're not concerned about that, so we strip source
  34 ;; information from the incoming tree-il.
  35
  36 (define (strip-source x)
  37   (post-order! (lambda (x) (set! (tree-il-src x) #f))
  38                x))
  39
  40 (define-syntax assert-scheme->glil
  41   (syntax-rules ()
  42     ((_ in out)
  43      (let ((tree-il (strip-source
  44                      (compile 'in #:from 'scheme #:to 'tree-il))))
  45        (pass-if 'in
  46                 (equal? (unparse-glil (compile tree-il #:from 'tree-il #:to 'glil))
  47                         'out))))))
  48
  49 (define-syntax assert-tree-il->glil
  50   (syntax-rules ()
  51     ((_ in out)
  52      (pass-if 'in
  53               (let ((tree-il (strip-source (parse-tree-il 'in))))
  54                 (equal? (unparse-glil (compile tree-il #:from 'tree-il #:to 'glil))
  55                         'out))))))
  56
  57 (define-syntax assert-tree-il->glil/pmatch
  58   (syntax-rules ()
  59     ((_ in pat test ...)
  60      (let ((exp 'in))
  61        (pass-if 'in
  62          (let ((glil (unparse-glil
  63                       (compile (strip-source (parse-tree-il exp))
  64                                #:from 'tree-il #:to 'glil))))
  65            (pmatch glil
  66              (pat (guard test ...) #t)
  67              (else #f))))))))
  68
  69 (with-test-prefix "void"
  70   (assert-tree-il->glil
  71    (void)
  72    (program 0 0 0 () (arity 0 0 #f) (void) (call return 1)))
  73   (assert-tree-il->glil
  74    (begin (void) (const 1))
  75    (program 0 0 0 () (arity 0 0 #f) (const 1) (call return 1)))
  76   (assert-tree-il->glil
  77    (apply (primitive +) (void) (const 1))
  78    (program 0 0 0 () (arity 0 0 #f) (void) (call add1 1) (call return 1))))
  79
  80 (with-test-prefix "application"
  81   (assert-tree-il->glil
  82    (apply (toplevel foo) (const 1))
  83    (program 0 0 0 () (arity 0 0 #f) (toplevel ref foo) (const 1) (call goto/args 1)))
  84   (assert-tree-il->glil/pmatch
  85    (begin (apply (toplevel foo) (const 1)) (void))
  86    (program 0 0 0 () (arity 0 0 #f) (call new-frame 0) (toplevel ref foo) (const 1) (mv-call 1 ,l1)
  87             (call drop 1) (branch br ,l2)
  88             (label ,l3) (mv-bind () #f) (unbind)
  89             (label ,l4)
  90             (void) (call return 1))
  91    (and (eq? l1 l3) (eq? l2 l4)))
  92   (assert-tree-il->glil
  93    (apply (toplevel foo) (apply (toplevel bar)))
  94    (program 0 0 0 ()  (arity 0 0 #f)(toplevel ref foo) (call new-frame 0) (toplevel ref bar) (call call 0)
  95             (call goto/args 1))))
  96
  97 (with-test-prefix "conditional"
  98   (assert-tree-il->glil/pmatch
  99    (if (const #t) (const 1) (const 2))
 100    (program 0 0 0 () (arity 0 0 #f) (const #t) (branch br-if-not ,l1)
 101             (const 1) (call return 1)
 102             (label ,l2) (const 2) (call return 1))
 103    (eq? l1 l2))
 104
 105   (assert-tree-il->glil/pmatch
 106    (begin (if (const #t) (const 1) (const 2)) (const #f))
 107    (program 0 0 0 () (arity 0 0 #f) (const #t) (branch br-if-not ,l1) (branch br ,l2)
 108             (label ,l3) (label ,l4) (const #f) (call return 1))
 109    (eq? l1 l3) (eq? l2 l4))
 110
 111   (assert-tree-il->glil/pmatch
 112    (apply (primitive null?) (if (const #t) (const 1) (const 2)))
 113    (program 0 0 0 () (arity 0 0 #f) (const #t) (branch br-if-not ,l1)
 114             (const 1) (branch br ,l2)
 115                     (label ,l3) (const 2) (label ,l4)
 116                     (call null? 1) (call return 1))
 117    (eq? l1 l3) (eq? l2 l4)))
 118
 119 (with-test-prefix "primitive-ref"
 120   (assert-tree-il->glil
 121    (primitive +)
 122    (program 0 0 0 () (arity 0 0 #f) (toplevel ref +) (call return 1)))
 123
 124   (assert-tree-il->glil
 125    (begin (primitive +) (const #f))
 126    (program 0 0 0 () (arity 0 0 #f) (const #f) (call return 1)))
 127
 128   (assert-tree-il->glil
 129    (apply (primitive null?) (primitive +))
 130    (program 0 0 0 () (arity 0 0 #f) (toplevel ref +) (call null? 1)
 131             (call return 1))))
 132
 133 (with-test-prefix "lexical refs"
 134   (assert-tree-il->glil
 135    (let (x) (y) ((const 1)) (lexical x y))
 136    (program 0 0 1 () (arity 0 0 #f) (call reserve-locals 1)
 137             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
 138             (lexical #t #f ref 0) (call return 1)
 139             (unbind)))
 140
 141   (assert-tree-il->glil
 142    (let (x) (y) ((const 1)) (begin (lexical x y) (const #f)))
 143    (program 0 0 1 () (arity 0 0 #f) (call reserve-locals 1)
 144             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
 145             (const #f) (call return 1)
 146             (unbind)))
 147
 148   (assert-tree-il->glil
 149    (let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y)))
 150    (program 0 0 1 () (arity 0 0 #f) (call reserve-locals 1)
 151             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
 152             (lexical #t #f ref 0) (call null? 1) (call return 1)
 153             (unbind))))
 154
 155 (with-test-prefix "lexical sets"
 156   (assert-tree-il->glil
 157    ;; unreferenced sets may be optimized away -- make sure they are ref'd
 158    (let (x) (y) ((const 1))
 159         (set! (lexical x y) (apply (primitive 1+) (lexical x y))))
 160    (program 0 0 1 () (arity 0 0 #f) (call reserve-locals 1)
 161             (const 1) (bind (x #t 0)) (lexical #t #t box 0)
 162             (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
 163             (void) (call return 1)
 164             (unbind)))
 165
 166   (assert-tree-il->glil
 167    (let (x) (y) ((const 1))
 168         (begin (set! (lexical x y) (apply (primitive 1+) (lexical x y)))
 169                (lexical x y)))
 170    (program 0 0 1 () (arity 0 0 #f) (call reserve-locals 1)
 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             (lexical #t #t ref 0) (call return 1)
 174             (unbind)))
 175
 176   (assert-tree-il->glil
 177    (let (x) (y) ((const 1))
 178      (apply (primitive null?)
 179             (set! (lexical x y) (apply (primitive 1+) (lexical x y)))))
 180    (program 0 0 1 () (arity 0 0 #f) (call reserve-locals 1)
 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) (void)
 183             (call null? 1) (call return 1)
 184             (unbind))))
 185
 186 (with-test-prefix "module refs"
 187   (assert-tree-il->glil
 188    (@ (foo) bar)
 189    (program 0 0 0 () (arity 0 0 #f)
 190             (module public ref (foo) bar)
 191             (call return 1)))
 192
 193   (assert-tree-il->glil
 194    (begin (@ (foo) bar) (const #f))
 195    (program 0 0 0 () (arity 0 0 #f)
 196             (module public ref (foo) bar) (call drop 1)
 197             (const #f) (call return 1)))
 198
 199   (assert-tree-il->glil
 200    (apply (primitive null?) (@ (foo) bar))
 201    (program 0 0 0 () (arity 0 0 #f)
 202             (module public ref (foo) bar)
 203             (call null? 1) (call return 1)))
 204
 205   (assert-tree-il->glil
 206    (@@ (foo) bar)
 207    (program 0 0 0 () (arity 0 0 #f)
 208             (module private ref (foo) bar)
 209             (call return 1)))
 210
 211   (assert-tree-il->glil
 212    (begin (@@ (foo) bar) (const #f))
 213    (program 0 0 0 () (arity 0 0 #f)
 214             (module private ref (foo) bar) (call drop 1)
 215             (const #f) (call return 1)))
 216
 217   (assert-tree-il->glil
 218    (apply (primitive null?) (@@ (foo) bar))
 219    (program 0 0 0 () (arity 0 0 #f)
 220             (module private ref (foo) bar)
 221             (call null? 1) (call return 1))))
 222
 223 (with-test-prefix "module sets"
 224   (assert-tree-il->glil
 225    (set! (@ (foo) bar) (const 2))
 226    (program 0 0 0 () (arity 0 0 #f)
 227             (const 2) (module public set (foo) bar)
 228             (void) (call return 1)))
 229
 230   (assert-tree-il->glil
 231    (begin (set! (@ (foo) bar) (const 2)) (const #f))
 232    (program 0 0 0 () (arity 0 0 #f)
 233             (const 2) (module public set (foo) bar)
 234             (const #f) (call return 1)))
 235
 236   (assert-tree-il->glil
 237    (apply (primitive null?) (set! (@ (foo) bar) (const 2)))
 238    (program 0 0 0 () (arity 0 0 #f)
 239             (const 2) (module public set (foo) bar)
 240             (void) (call null? 1) (call return 1)))
 241
 242   (assert-tree-il->glil
 243    (set! (@@ (foo) bar) (const 2))
 244    (program 0 0 0 () (arity 0 0 #f)
 245             (const 2) (module private set (foo) bar)
 246             (void) (call return 1)))
 247
 248   (assert-tree-il->glil
 249    (begin (set! (@@ (foo) bar) (const 2)) (const #f))
 250    (program 0 0 0 () (arity 0 0 #f)
 251             (const 2) (module private set (foo) bar)
 252             (const #f) (call return 1)))
 253
 254   (assert-tree-il->glil
 255    (apply (primitive null?) (set! (@@ (foo) bar) (const 2)))
 256    (program 0 0 0 () (arity 0 0 #f)
 257             (const 2) (module private set (foo) bar)
 258             (void) (call null? 1) (call return 1))))
 259
 260 (with-test-prefix "toplevel refs"
 261   (assert-tree-il->glil
 262    (toplevel bar)
 263    (program 0 0 0 () (arity 0 0 #f)
 264             (toplevel ref bar)
 265             (call return 1)))
 266
 267   (assert-tree-il->glil
 268    (begin (toplevel bar) (const #f))
 269    (program 0 0 0 () (arity 0 0 #f)
 270             (toplevel ref bar) (call drop 1)
 271             (const #f) (call return 1)))
 272
 273   (assert-tree-il->glil
 274    (apply (primitive null?) (toplevel bar))
 275    (program 0 0 0 () (arity 0 0 #f)
 276             (toplevel ref bar)
 277             (call null? 1) (call return 1))))
 278
 279 (with-test-prefix "toplevel sets"
 280   (assert-tree-il->glil
 281    (set! (toplevel bar) (const 2))
 282    (program 0 0 0 () (arity 0 0 #f)
 283             (const 2) (toplevel set bar)
 284             (void) (call return 1)))
 285
 286   (assert-tree-il->glil
 287    (begin (set! (toplevel bar) (const 2)) (const #f))
 288    (program 0 0 0 () (arity 0 0 #f)
 289             (const 2) (toplevel set bar)
 290             (const #f) (call return 1)))
 291
 292   (assert-tree-il->glil
 293    (apply (primitive null?) (set! (toplevel bar) (const 2)))
 294    (program 0 0 0 () (arity 0 0 #f)
 295             (const 2) (toplevel set bar)
 296             (void) (call null? 1) (call return 1))))
 297
 298 (with-test-prefix "toplevel defines"
 299   (assert-tree-il->glil
 300    (define bar (const 2))
 301    (program 0 0 0 () (arity 0 0 #f)
 302             (const 2) (toplevel define bar)
 303             (void) (call return 1)))
 304
 305   (assert-tree-il->glil
 306    (begin (define bar (const 2)) (const #f))
 307    (program 0 0 0 () (arity 0 0 #f)
 308             (const 2) (toplevel define bar)
 309             (const #f) (call return 1)))
 310
 311   (assert-tree-il->glil
 312    (apply (primitive null?) (define bar (const 2)))
 313    (program 0 0 0 () (arity 0 0 #f)
 314             (const 2) (toplevel define bar)
 315             (void) (call null? 1) (call return 1))))
 316
 317 (with-test-prefix "constants"
 318   (assert-tree-il->glil
 319    (const 2)
 320    (program 0 0 0 () (arity 0 0 #f)
 321             (const 2) (call return 1)))
 322
 323   (assert-tree-il->glil
 324    (begin (const 2) (const #f))
 325    (program 0 0 0 () (arity 0 0 #f)
 326             (const #f) (call return 1)))
 327
 328   (assert-tree-il->glil
 329    (apply (primitive null?) (const 2))
 330    (program 0 0 0 () (arity 0 0 #f)
 331             (const 2) (call null? 1) (call return 1))))
 332
 333 (with-test-prefix "lambda"
 334   (assert-tree-il->glil
 335    (lambda (x) (y) () (const 2))
 336    (program 0 0 0 ()  (arity 0 0 #f)
 337             (program 1 0 0 () (arity 1 0 #f)
 338                      (bind (x #f 0))
 339                      (const 2) (call return 1))
 340             (call return 1)))
 341
 342   (assert-tree-il->glil
 343    (lambda (x x1) (y y1) () (const 2))
 344    (program 0 0 0 () (arity 0 0 #f)
 345             (program 2 0 0 () (arity 2 0 #f)
 346                      (bind (x #f 0) (x1 #f 1))
 347                      (const 2) (call return 1))
 348             (call return 1)))
 349
 350   (assert-tree-il->glil
 351    (lambda x y () (const 2))
 352    (program 0 0 0 () (arity 0 0 #f)
 353             (program 1 1 0 () (arity 1 1 #f)
 354                      (bind (x #f 0))
 355                      (const 2) (call return 1))
 356             (call return 1)))
 357
 358   (assert-tree-il->glil
 359    (lambda (x . x1) (y . y1) () (const 2))
 360    (program 0 0 0 () (arity 0 0 #f)
 361             (program 2 1 0 () (arity 2 1 #f)
 362                      (bind (x #f 0) (x1 #f 1))
 363                      (const 2) (call return 1))
 364             (call return 1)))
 365
 366   (assert-tree-il->glil
 367    (lambda (x . x1) (y . y1) () (lexical x y))
 368    (program 0 0 0 () (arity 0 0 #f)
 369             (program 2 1 0 () (arity 2 1 #f)
 370                      (bind (x #f 0) (x1 #f 1))
 371                      (lexical #t #f ref 0) (call return 1))
 372             (call return 1)))
 373
 374   (assert-tree-il->glil
 375    (lambda (x . x1) (y . y1) () (lexical x1 y1))
 376    (program 0 0 0 () (arity 0 0 #f)
 377             (program 2 1 0 () (arity 2 1 #f)
 378                      (bind (x #f 0) (x1 #f 1))
 379                      (lexical #t #f ref 1) (call return 1))
 380             (call return 1)))
 381
 382   (assert-tree-il->glil
 383    (lambda (x) (x1) () (lambda (y) (y1) () (lexical x x1)))
 384    (program 0 0 0 () (arity 0 0 #f)
 385             (program 1 0 0 () (arity 1 0 #f)
 386                      (bind (x #f 0))
 387                      (program 1 0 0 () (arity 1 0 #f)
 388                               (bind (y #f 0))
 389                               (lexical #f #f ref 0) (call return 1))
 390                      (lexical #t #f ref 0)
 391                      (call vector 1)
 392                      (call make-closure 2)
 393                      (call return 1))
 394             (call return 1))))
 395
 396 (with-test-prefix "sequence"
 397   (assert-tree-il->glil
 398    (begin (begin (const 2) (const #f)) (const #t))
 399    (program 0 0 0 () (arity 0 0 #f)
 400             (const #t) (call return 1)))
 401
 402   (assert-tree-il->glil
 403    (apply (primitive null?) (begin (const #f) (const 2)))
 404    (program 0 0 0 () (arity 0 0 #f)
 405             (const 2) (call null? 1) (call return 1))))
 406
 407 ;; FIXME: binding info for or-hacked locals might bork the disassembler,
 408 ;; and could be tightened in any case
 409 (with-test-prefix "the or hack"
 410   (assert-tree-il->glil/pmatch
 411    (let (x) (y) ((const 1))
 412         (if (lexical x y)
 413             (lexical x y)
 414             (let (a) (b) ((const 2))
 415                  (lexical a b))))
 416    (program 0 0 1 () (arity 0 0 #f) (call reserve-locals 1)
 417             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
 418             (lexical #t #f ref 0) (branch br-if-not ,l1)
 419             (lexical #t #f ref 0) (call return 1)
 420             (label ,l2)
 421             (const 2) (bind (a #f 0)) (lexical #t #f set 0)
 422             (lexical #t #f ref 0) (call return 1)
 423             (unbind)
 424             (unbind))
 425    (eq? l1 l2))
 426
 427   ;; second bound var is unreferenced
 428   (assert-tree-il->glil/pmatch
 429    (let (x) (y) ((const 1))
 430         (if (lexical x y)
 431             (lexical x y)
 432             (let (a) (b) ((const 2))
 433                  (lexical x y))))
 434    (program 0 0 1 () (arity 0 0 #f) (call reserve-locals 1)
 435             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
 436             (lexical #t #f ref 0) (branch br-if-not ,l1)
 437             (lexical #t #f ref 0) (call return 1)
 438             (label ,l2)
 439             (lexical #t #f ref 0) (call return 1)
 440             (unbind))
 441    (eq? l1 l2)))
 442
 443 (with-test-prefix "apply"
 444   (assert-tree-il->glil
 445    (apply (primitive @apply) (toplevel foo) (toplevel bar))
 446    (program 0 0 0 () (arity 0 0 #f) (toplevel ref foo) (toplevel ref bar) (call goto/apply 2)))
 447   (assert-tree-il->glil/pmatch
 448    (begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void))
 449    (program 0 0 0 () (arity 0 0 #f)
 450             (call new-frame 0) (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1)
 451             (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
 452             (label ,l4)
 453             (void) (call return 1))
 454    (and (eq? l1 l3) (eq? l2 l4)))
 455   (assert-tree-il->glil
 456    (apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz)))
 457    (program 0 0 0 () (arity 0 0 #f)
 458             (toplevel ref foo)
 459             (call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call apply 2)
 460             (call goto/args 1))))
 461
 462 (with-test-prefix "call/cc"
 463   (assert-tree-il->glil
 464    (apply (primitive @call-with-current-continuation) (toplevel foo))
 465    (program 0 0 0 () (arity 0 0 #f) (toplevel ref foo) (call goto/cc 1)))
 466   (assert-tree-il->glil/pmatch
 467    (begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void))
 468    (program 0 0 0 () (arity 0 0 #f)
 469             (call new-frame 0) (toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1)
 470             (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
 471             (label ,l4)
 472             (void) (call return 1))
 473    (and (eq? l1 l3) (eq? l2 l4)))
 474   (assert-tree-il->glil
 475    (apply (toplevel foo)
 476           (apply (toplevel @call-with-current-continuation) (toplevel bar)))
 477    (program 0 0 0 () (arity 0 0 #f)
 478             (toplevel ref foo)
 479             (toplevel ref bar) (call call/cc 1)
 480             (call goto/args 1))))
 481
 482 \f
 483 (with-test-prefix "tree-il-fold"
 484
 485   (pass-if "empty tree"
 486     (let ((leaf? #f) (up? #f) (down? #f) (mark (list 'mark)))
 487       (and (eq? mark
 488                 (tree-il-fold (lambda (x y) (set! leaf? #t) y)
 489                               (lambda (x y) (set! down? #t) y)
 490                               (lambda (x y) (set! up? #t) y)
 491                               mark
 492                               '()))
 493            (not leaf?)
 494            (not up?)
 495            (not down?))))
 496
 497   (pass-if "lambda and application"
 498     (let* ((leaves '()) (ups '()) (downs '())
 499            (result (tree-il-fold (lambda (x y)
 500                                    (set! leaves (cons x leaves))
 501                                    (1+ y))
 502                                  (lambda (x y)
 503                                    (set! downs (cons x downs))
 504                                    (1+ y))
 505                                  (lambda (x y)
 506                                    (set! ups (cons x ups))
 507                                    (1+ y))
 508                                  0
 509                                  (parse-tree-il
 510                                   '(lambda (x y) (x1 y1)
 511                                      (apply (toplevel +)
 512                                             (lexical x x1)
 513                                             (lexical y y1)))))))
 514       (and (equal? (map strip-source leaves)
 515                    (list (make-lexical-ref #f 'y 'y1)
 516                          (make-lexical-ref #f 'x 'x1)
 517                          (make-toplevel-ref #f '+)))
 518            (= (length downs) 2)
 519            (equal? (reverse (map strip-source ups))
 520                    (map strip-source downs))))))
 521
 522 \f
 523 ;;;
 524 ;;; Warnings.
 525 ;;;
 526
 527 ;; Make sure we get English messages.
 528 (setlocale LC_ALL "C")
 529
 530 (define (call-with-warnings thunk)
 531   (let ((port (open-output-string)))
 532     (with-fluid* *current-warning-port* port
 533       thunk)
 534     (let ((warnings (get-output-string port)))
 535       (string-tokenize warnings
 536                        (char-set-complement (char-set #\newline))))))
 537
 538 (define %opts-w-unused
 539   '(#:warnings (unused-variable)))
 540
 541 (define %opts-w-unbound
 542   '(#:warnings (unbound-variable)))
 543
 544 (with-test-prefix "warnings"
 545
 546    (pass-if "unknown warning type"
 547      (let ((w (call-with-warnings
 548                 (lambda ()
 549                   (compile #t #:opts '(#:warnings (does-not-exist)))))))
 550        (and (= (length w) 1)
 551             (number? (string-contains (car w) "unknown warning")))))
 552
 553    (with-test-prefix "unused-variable"
 554
 555      (pass-if "quiet"
 556        (null? (call-with-warnings
 557                 (lambda ()
 558                   (compile '(lambda (x y) (+ x y))
 559                            #:opts %opts-w-unused)))))
 560
 561      (pass-if "let/unused"
 562        (let ((w (call-with-warnings
 563                   (lambda ()
 564                     (compile '(lambda (x)
 565                                 (let ((y (+ x 2)))
 566                                   x))
 567                              #:opts %opts-w-unused)))))
 568          (and (= (length w) 1)
 569               (number? (string-contains (car w) "unused variable `y'")))))
 570
 571      (pass-if "shadowed variable"
 572        (let ((w (call-with-warnings
 573                   (lambda ()
 574                     (compile '(lambda (x)
 575                                 (let ((y x))
 576                                   (let ((y (+ x 2)))
 577                                     (+ x y))))
 578                              #:opts %opts-w-unused)))))
 579          (and (= (length w) 1)
 580               (number? (string-contains (car w) "unused variable `y'")))))
 581
 582      (pass-if "letrec"
 583        (null? (call-with-warnings
 584                 (lambda ()
 585                   (compile '(lambda ()
 586                               (letrec ((x (lambda () (y)))
 587                                        (y (lambda () (x))))
 588                                 y))
 589                            #:opts %opts-w-unused)))))
 590
 591      (pass-if "unused argument"
 592        ;; Unused arguments should not be reported.
 593        (null? (call-with-warnings
 594                 (lambda ()
 595                   (compile '(lambda (x y z) #t)
 596                            #:opts %opts-w-unused))))))
 597
 598    (with-test-prefix "unbound variable"
 599
 600      (pass-if "quiet"
 601        (null? (call-with-warnings
 602                 (lambda ()
 603                   (compile '+ #:opts %opts-w-unbound)))))
 604
 605      (pass-if "ref"
 606        (let* ((v (gensym))
 607               (w (call-with-warnings
 608                    (lambda ()
 609                      (compile v
 610                               #:to 'assembly
 611                               #:opts %opts-w-unbound)))))
 612          (and (= (length w) 1)
 613               (number? (string-contains (car w)
 614                                         (format #f "unbound variable `~A'"
 615                                                 v))))))
 616
 617      (pass-if "set!"
 618        (let* ((v (gensym))
 619               (w (call-with-warnings
 620                    (lambda ()
 621                      (compile `(set! ,v 7)
 622                               #:to 'assembly
 623                               #:opts %opts-w-unbound)))))
 624          (and (= (length w) 1)
 625               (number? (string-contains (car w)
 626                                         (format #f "unbound variable `~A'"
 627                                                 v))))))
 628
 629      (pass-if "module-local top-level is visible"
 630        (let ((m (make-module))
 631              (v (gensym)))
 632          (beautify-user-module! m)
 633          (compile `(define ,v 123)
 634                   #:env m #:opts %opts-w-unbound)
 635          (null? (call-with-warnings
 636                   (lambda ()
 637                     (compile v
 638                              #:env m
 639                              #:to 'assembly
 640                              #:opts %opts-w-unbound))))))
 641
 642      (pass-if "module-local top-level is visible after"
 643        (let ((m (make-module))
 644              (v (gensym)))
 645          (beautify-user-module! m)
 646          (null? (call-with-warnings
 647                   (lambda ()
 648                     (let ((in (open-input-string
 649                                "(define (f)
 650                                   (set! chbouib 3))
 651                                 (define chbouib 5)")))
 652                       (read-and-compile in
 653                                         #:env m
 654                                         #:opts %opts-w-unbound)))))))
 655
 656      (pass-if "GOOPS definitions are visible"
 657        (let ((m (make-module))
 658              (v (gensym)))
 659          (beautify-user-module! m)
 660          (module-use! m (resolve-interface '(oop goops)))
 661          (null? (call-with-warnings
 662                   (lambda ()
 663                     (let ((in (open-input-string
 664                                "(define-class <foo> ()
 665                                   (bar #:getter foo-bar))
 666                                 (define z (foo-bar (make <foo>)))")))
 667                       (read-and-compile in
 668                                         #:env m
 669                                         #:opts %opts-w-unbound)))))))))