test-suite/tests/syntax.test

   1 ;;;; syntax.test --- test suite for Guile's syntactic forms    -*- scheme -*-
   2 ;;;;
   3 ;;;; Copyright (C) 2001, 2003 Free Software Foundation, Inc.
   4 ;;;;
   5 ;;;; This program is free software; you can redistribute it and/or modify
   6 ;;;; it under the terms of the GNU General Public License as published by
   7 ;;;; the Free Software Foundation; either version 2, or (at your option)
   8 ;;;; any later version.
   9 ;;;;
  10 ;;;; This program is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;;;; GNU General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU General Public License
  16 ;;;; along with this software; see the file COPYING.  If not, write to
  17 ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  18 ;;;; Boston, MA 02111-1307 USA
  19
  20 (define-module (test-suite test-syntax)
  21   :use-module (test-suite lib))
  22
  23
  24 (define exception:bad-expression
  25   (cons 'syntax-error "Bad expression"))
  26
  27 (define exception:missing/extra-expr
  28   (cons 'syntax-error "Missing or extra expression"))
  29 (define exception:missing-expr
  30   (cons 'syntax-error "Missing expression"))
  31 (define exception:missing-body-expr
  32   (cons 'syntax-error "Missing body expression"))
  33 (define exception:extra-expr
  34   (cons 'syntax-error "Extra expression"))
  35 (define exception:illegal-empty-combination
  36   (cons 'syntax-error "Illegal empty combination"))
  37
  38 (define exception:bad-bindings
  39   (cons 'syntax-error "Bad bindings"))
  40 (define exception:bad-binding
  41   (cons 'syntax-error "Bad binding"))
  42 (define exception:duplicate-binding
  43   (cons 'syntax-error "Duplicate binding"))
  44 (define exception:bad-body
  45   (cons 'misc-error "^bad body"))
  46 (define exception:bad-formals
  47   (cons 'syntax-error "Bad formals"))
  48 (define exception:bad-formal
  49   (cons 'syntax-error "Bad formal"))
  50 (define exception:duplicate-formal
  51   (cons 'syntax-error "Duplicate formal"))
  52
  53 (define exception:missing-clauses
  54   (cons 'syntax-error "Missing clauses"))
  55 (define exception:misplaced-else-clause
  56   (cons 'syntax-error "Misplaced else clause"))
  57 (define exception:bad-case-clause
  58   (cons 'syntax-error "Bad case clause"))
  59 (define exception:bad-case-labels
  60   (cons 'syntax-error "Bad case labels"))
  61 (define exception:bad-cond-clause
  62   (cons 'syntax-error "Bad cond clause"))
  63
  64
  65 (with-test-prefix "expressions"
  66
  67   (with-test-prefix "Bad argument list"
  68
  69     (pass-if-exception "improper argument list of length 1"
  70       exception:wrong-num-args
  71       (eval '(let ((foo (lambda (x y) #t)))
  72                (foo . 1))
  73             (interaction-environment)))
  74
  75     (pass-if-exception "improper argument list of length 2"
  76       exception:wrong-num-args
  77       (eval '(let ((foo (lambda (x y) #t)))
  78                (foo 1 . 2))
  79             (interaction-environment))))
  80
  81   (with-test-prefix "missing or extra expression"
  82
  83     ;; R5RS says:
  84     ;; *Note:* In many dialects of Lisp, the empty combination, (),
  85     ;; is a legitimate expression.  In Scheme, combinations must
  86     ;; have at least one subexpression, so () is not a syntactically
  87     ;; valid expression.
  88
  89     ;; Fixed on 2001-3-3
  90     (pass-if-exception "empty parentheses \"()\""
  91       exception:illegal-empty-combination
  92       (eval '()
  93             (interaction-environment)))))
  94
  95 (with-test-prefix "quote"
  96   #t)
  97
  98 (with-test-prefix "quasiquote"
  99
 100   (with-test-prefix "unquote"
 101
 102     (pass-if "repeated execution"
 103       (let ((foo (let ((i 0)) (lambda () (set! i (+ i 1)) `(,i)))))
 104         (and (equal? (foo) '(1)) (equal? (foo) '(2))))))
 105
 106   (with-test-prefix "unquote-splicing"
 107
 108     (pass-if-exception "extra arguments"
 109       exception:missing/extra-expr
 110       (quasiquote ((unquote-splicing (list 1 2) (list 3 4)))))))
 111
 112 (with-test-prefix "begin"
 113
 114   (pass-if "legal (begin)"
 115     (begin)
 116     #t)
 117
 118   (expect-fail-exception "illegal (begin)"
 119     exception:bad-body
 120     (if #t (begin))
 121     #t))
 122
 123 (with-test-prefix "lambda"
 124
 125   (with-test-prefix "bad formals"
 126
 127     (pass-if-exception "(lambda)"
 128       exception:missing-expr
 129       (eval '(lambda)
 130             (interaction-environment)))
 131
 132     (pass-if-exception "(lambda . \"foo\")"
 133       exception:bad-expression
 134       (eval '(lambda . "foo")
 135             (interaction-environment)))
 136
 137     (pass-if-exception "(lambda \"foo\")"
 138       exception:missing-expr
 139       (eval '(lambda "foo")
 140             (interaction-environment)))
 141
 142     (pass-if-exception "(lambda \"foo\" #f)"
 143       exception:bad-formals
 144       (eval '(lambda "foo" #f)
 145             (interaction-environment)))
 146
 147     (pass-if-exception "(lambda (x 1) 2)"
 148       exception:bad-formal
 149       (eval '(lambda (x 1) 2)
 150             (interaction-environment)))
 151
 152     (pass-if-exception "(lambda (1 x) 2)"
 153       exception:bad-formal
 154       (eval '(lambda (1 x) 2)
 155             (interaction-environment)))
 156
 157     (pass-if-exception "(lambda (x \"a\") 2)"
 158       exception:bad-formal
 159       (eval '(lambda (x "a") 2)
 160             (interaction-environment)))
 161
 162     (pass-if-exception "(lambda (\"a\" x) 2)"
 163       exception:bad-formal
 164       (eval '(lambda ("a" x) 2)
 165             (interaction-environment))))
 166
 167   (with-test-prefix "duplicate formals"
 168
 169     ;; Fixed on 2001-3-3
 170     (pass-if-exception "(lambda (x x) 1)"
 171       exception:duplicate-formal
 172       (eval '(lambda (x x) 1)
 173             (interaction-environment)))
 174
 175     ;; Fixed on 2001-3-3
 176     (pass-if-exception "(lambda (x x x) 1)"
 177       exception:duplicate-formal
 178       (eval '(lambda (x x x) 1)
 179             (interaction-environment))))
 180
 181   (with-test-prefix "bad body"
 182
 183     (pass-if-exception "(lambda ())"
 184       exception:missing-expr
 185       (eval '(lambda ())
 186             (interaction-environment)))))
 187
 188 (with-test-prefix "let"
 189
 190   (with-test-prefix "bindings"
 191
 192     (pass-if-exception "late binding"
 193       exception:unbound-var
 194       (let ((x 1) (y x)) y)))
 195
 196   (with-test-prefix "bad bindings"
 197
 198     (pass-if-exception "(let)"
 199       exception:missing-expr
 200       (eval '(let)
 201             (interaction-environment)))
 202
 203     (pass-if-exception "(let 1)"
 204       exception:missing-expr
 205       (eval '(let 1)
 206             (interaction-environment)))
 207
 208     (pass-if-exception "(let (x))"
 209       exception:missing-expr
 210       (eval '(let (x))
 211             (interaction-environment)))
 212
 213     (pass-if-exception "(let ((x)))"
 214       exception:missing-expr
 215       (eval '(let ((x)))
 216             (interaction-environment)))
 217
 218     (pass-if-exception "(let (x) 1)"
 219       exception:bad-binding
 220       (eval '(let (x) 1)
 221             (interaction-environment)))
 222
 223     (pass-if-exception "(let ((x)) 3)"
 224       exception:bad-binding
 225       (eval '(let ((x)) 3)
 226             (interaction-environment)))
 227
 228     (pass-if-exception "(let ((x 1) y) x)"
 229       exception:bad-binding
 230       (eval '(let ((x 1) y) x)
 231             (interaction-environment)))
 232
 233     (pass-if-exception "(let ((1 2)) 3)"
 234       exception:bad-variable
 235       (eval '(let ((1 2)) 3)
 236             (interaction-environment))))
 237
 238   (with-test-prefix "duplicate bindings"
 239
 240     (pass-if-exception "(let ((x 1) (x 2)) x)"
 241       exception:duplicate-binding
 242       (eval '(let ((x 1) (x 2)) x)
 243             (interaction-environment))))
 244
 245   (with-test-prefix "bad body"
 246
 247     (pass-if-exception "(let ())"
 248       exception:missing-expr
 249       (eval '(let ())
 250             (interaction-environment)))
 251
 252     (pass-if-exception "(let ((x 1)))"
 253       exception:missing-expr
 254       (eval '(let ((x 1)))
 255             (interaction-environment)))))
 256
 257 (with-test-prefix "named let"
 258
 259   (with-test-prefix "initializers"
 260
 261     (pass-if "evaluated in outer environment"
 262       (let ((f -))
 263         (eqv? (let f ((n (f 1))) n) -1))))
 264
 265   (with-test-prefix "bad bindings"
 266
 267     (pass-if-exception "(let x (y))"
 268       exception:missing-expr
 269       (eval '(let x (y))
 270             (interaction-environment))))
 271
 272   (with-test-prefix "bad body"
 273
 274     (pass-if-exception "(let x ())"
 275       exception:missing-expr
 276       (eval '(let x ())
 277             (interaction-environment)))
 278
 279     (pass-if-exception "(let x ((y 1)))"
 280       exception:missing-expr
 281       (eval '(let x ((y 1)))
 282             (interaction-environment)))))
 283
 284 (with-test-prefix "let*"
 285
 286   (with-test-prefix "bindings"
 287
 288     (pass-if "(let* ((x 1) (x 2)) ...)"
 289       (let* ((x 1) (x 2))
 290         (= x 2)))
 291
 292     (pass-if "(let* ((x 1) (x x)) ...)"
 293       (let* ((x 1) (x x))
 294         (= x 1))))
 295
 296   (with-test-prefix "bad bindings"
 297
 298     (pass-if-exception "(let*)"
 299       exception:missing-expr
 300       (eval '(let*)
 301             (interaction-environment)))
 302
 303     (pass-if-exception "(let* 1)"
 304       exception:missing-expr
 305       (eval '(let* 1)
 306             (interaction-environment)))
 307
 308     (pass-if-exception "(let* (x))"
 309       exception:missing-expr
 310       (eval '(let* (x))
 311             (interaction-environment)))
 312
 313     (pass-if-exception "(let* (x) 1)"
 314       exception:bad-binding
 315       (eval '(let* (x) 1)
 316             (interaction-environment)))
 317
 318     (pass-if-exception "(let* ((x)) 3)"
 319       exception:bad-binding
 320       (eval '(let* ((x)) 3)
 321             (interaction-environment)))
 322
 323     (pass-if-exception "(let* ((x 1) y) x)"
 324       exception:bad-binding
 325       (eval '(let* ((x 1) y) x)
 326             (interaction-environment)))
 327
 328     (pass-if-exception "(let* x ())"
 329       exception:bad-bindings
 330       (eval '(let* x ())
 331             (interaction-environment)))
 332
 333     (pass-if-exception "(let* x (y))"
 334       exception:bad-bindings
 335       (eval '(let* x (y))
 336             (interaction-environment)))
 337
 338     (pass-if-exception "(let* ((1 2)) 3)"
 339       exception:bad-variable
 340       (eval '(let* ((1 2)) 3)
 341             (interaction-environment))))
 342
 343   (with-test-prefix "bad body"
 344
 345     (pass-if-exception "(let* ())"
 346       exception:missing-expr
 347       (eval '(let* ())
 348             (interaction-environment)))
 349
 350     (pass-if-exception "(let* ((x 1)))"
 351       exception:missing-expr
 352       (eval '(let* ((x 1)))
 353             (interaction-environment)))))
 354
 355 (with-test-prefix "letrec"
 356
 357   (with-test-prefix "bindings"
 358
 359     (pass-if-exception "initial bindings are undefined"
 360       exception:unbound-var
 361       (let ((x 1))
 362         (letrec ((x 1) (y x)) y))))
 363
 364   (with-test-prefix "bad bindings"
 365
 366     (pass-if-exception "(letrec)"
 367       exception:missing-expr
 368       (eval '(letrec)
 369             (interaction-environment)))
 370
 371     (pass-if-exception "(letrec 1)"
 372       exception:missing-expr
 373       (eval '(letrec 1)
 374             (interaction-environment)))
 375
 376     (pass-if-exception "(letrec (x))"
 377       exception:missing-expr
 378       (eval '(letrec (x))
 379             (interaction-environment)))
 380
 381     (pass-if-exception "(letrec (x) 1)"
 382       exception:bad-binding
 383       (eval '(letrec (x) 1)
 384             (interaction-environment)))
 385
 386     (pass-if-exception "(letrec ((x)) 3)"
 387       exception:bad-binding
 388       (eval '(letrec ((x)) 3)
 389             (interaction-environment)))
 390
 391     (pass-if-exception "(letrec ((x 1) y) x)"
 392       exception:bad-binding
 393       (eval '(letrec ((x 1) y) x)
 394             (interaction-environment)))
 395
 396     (pass-if-exception "(letrec x ())"
 397       exception:bad-bindings
 398       (eval '(letrec x ())
 399             (interaction-environment)))
 400
 401     (pass-if-exception "(letrec x (y))"
 402       exception:bad-bindings
 403       (eval '(letrec x (y))
 404             (interaction-environment)))
 405
 406     (pass-if-exception "(letrec ((1 2)) 3)"
 407       exception:bad-variable
 408       (eval '(letrec ((1 2)) 3)
 409             (interaction-environment))))
 410
 411   (with-test-prefix "duplicate bindings"
 412
 413     (pass-if-exception "(letrec ((x 1) (x 2)) x)"
 414       exception:duplicate-binding
 415       (eval '(letrec ((x 1) (x 2)) x)
 416             (interaction-environment))))
 417
 418   (with-test-prefix "bad body"
 419
 420     (pass-if-exception "(letrec ())"
 421       exception:missing-expr
 422       (eval '(letrec ())
 423             (interaction-environment)))
 424
 425     (pass-if-exception "(letrec ((x 1)))"
 426       exception:missing-expr
 427       (eval '(letrec ((x 1)))
 428             (interaction-environment)))))
 429
 430 (with-test-prefix "if"
 431
 432   (with-test-prefix "missing or extra expressions"
 433
 434     (pass-if-exception "(if)"
 435       exception:missing/extra-expr
 436       (eval '(if)
 437             (interaction-environment)))
 438
 439     (pass-if-exception "(if 1 2 3 4)"
 440       exception:missing/extra-expr
 441       (eval '(if 1 2 3 4)
 442             (interaction-environment)))))
 443
 444 (with-test-prefix "cond"
 445
 446   (with-test-prefix "bad or missing clauses"
 447
 448     (pass-if-exception "(cond)"
 449       exception:missing-clauses
 450       (eval '(cond)
 451             (interaction-environment)))
 452
 453     (pass-if-exception "(cond #t)"
 454       exception:bad-cond-clause
 455       (eval '(cond #t)
 456             (interaction-environment)))
 457
 458     (pass-if-exception "(cond 1)"
 459       exception:bad-cond-clause
 460       (eval '(cond 1)
 461             (interaction-environment)))
 462
 463     (pass-if-exception "(cond 1 2)"
 464       exception:bad-cond-clause
 465       (eval '(cond 1 2)
 466             (interaction-environment)))
 467
 468     (pass-if-exception "(cond 1 2 3)"
 469       exception:bad-cond-clause
 470       (eval '(cond 1 2 3)
 471             (interaction-environment)))
 472
 473     (pass-if-exception "(cond 1 2 3 4)"
 474       exception:bad-cond-clause
 475       (eval '(cond 1 2 3 4)
 476             (interaction-environment)))
 477
 478     (pass-if-exception "(cond ())"
 479       exception:bad-cond-clause
 480       (eval '(cond ())
 481             (interaction-environment)))
 482
 483     (pass-if-exception "(cond () 1)"
 484       exception:bad-cond-clause
 485       (eval '(cond () 1)
 486             (interaction-environment)))
 487
 488     (pass-if-exception "(cond (1) 1)"
 489       exception:bad-cond-clause
 490       (eval '(cond (1) 1)
 491             (interaction-environment)))))
 492
 493 (with-test-prefix "cond =>"
 494
 495   (with-test-prefix "cond is hygienic"
 496
 497     (pass-if "bound 'else is handled correctly"
 498       (eq? (let ((else 'ok)) (cond (else))) 'ok))
 499
 500     (pass-if "bound '=> is handled correctly"
 501       (eq? (let ((=> #f)) (cond (#t => 'ok))) 'ok)))
 502
 503   (with-test-prefix "else is handled correctly"
 504
 505     (pass-if "else =>"
 506       (let ((=> 'foo))
 507         (eq? (cond (else =>)) 'foo)))
 508
 509     (pass-if "else => identity"
 510       (let* ((=> 'foo))
 511         (eq? (cond (else => identity)) identity))))
 512
 513   (with-test-prefix "wrong number of arguments"
 514
 515     (pass-if-exception "=> (lambda (x y) #t)"
 516       exception:wrong-num-args
 517       (cond (1 => (lambda (x y) #t))))))
 518
 519 (with-test-prefix "case"
 520
 521   (pass-if "clause with empty labels list"
 522     (case 1 (() #f) (else #t)))
 523
 524   (with-test-prefix "case is hygienic"
 525
 526     (pass-if-exception "bound 'else is handled correctly"
 527       exception:bad-case-labels
 528       (eval '(let ((else #f)) (case 1 (else #f)))
 529             (interaction-environment))))
 530
 531   (with-test-prefix "bad or missing clauses"
 532
 533     (pass-if-exception "(case)"
 534       exception:missing-clauses
 535       (eval '(case)
 536             (interaction-environment)))
 537
 538     (pass-if-exception "(case . \"foo\")"
 539       exception:bad-expression
 540       (eval '(case . "foo")
 541             (interaction-environment)))
 542
 543     (pass-if-exception "(case 1)"
 544       exception:missing-clauses
 545       (eval '(case 1)
 546             (interaction-environment)))
 547
 548     (pass-if-exception "(case 1 . \"foo\")"
 549       exception:bad-expression
 550       (eval '(case 1 . "foo")
 551             (interaction-environment)))
 552
 553     (pass-if-exception "(case 1 \"foo\")"
 554       exception:bad-case-clause
 555       (eval '(case 1 "foo")
 556             (interaction-environment)))
 557
 558     (pass-if-exception "(case 1 ())"
 559       exception:bad-case-clause
 560       (eval '(case 1 ())
 561             (interaction-environment)))
 562
 563     (pass-if-exception "(case 1 (\"foo\"))"
 564       exception:bad-case-clause
 565       (eval '(case 1 ("foo"))
 566             (interaction-environment)))
 567
 568     (pass-if-exception "(case 1 (\"foo\" \"bar\"))"
 569       exception:bad-case-labels
 570       (eval '(case 1 ("foo" "bar"))
 571             (interaction-environment)))
 572
 573     (pass-if-exception "(case 1 ((2) \"bar\") . \"foo\")"
 574       exception:bad-expression
 575       (eval '(case 1 ((2) "bar") . "foo")
 576             (interaction-environment)))
 577
 578     (pass-if-exception "(case 1 ((2) \"bar\") (else))"
 579       exception:bad-case-clause
 580       (eval '(case 1 ((2) "bar") (else))
 581             (interaction-environment)))
 582
 583     (pass-if-exception "(case 1 (else #f) . \"foo\")"
 584       exception:bad-expression
 585       (eval '(case 1 (else #f) . "foo")
 586             (interaction-environment)))
 587
 588     (pass-if-exception "(case 1 (else #f) ((1) #t))"
 589       exception:misplaced-else-clause
 590       (eval '(case 1 (else #f) ((1) #t))
 591             (interaction-environment)))))
 592
 593 (with-test-prefix "top-level define"
 594
 595   (with-test-prefix "currying"
 596
 597     (pass-if "(define ((foo)) #f)"
 598       (eval '(begin
 599                (define ((foo)) #t)
 600                ((foo)))
 601             (interaction-environment))))
 602
 603   (with-test-prefix "missing or extra expressions"
 604
 605     (pass-if-exception "(define)"
 606       exception:missing-expr
 607       (eval '(define)
 608             (interaction-environment)))))
 609
 610 (with-test-prefix "internal define"
 611
 612   (pass-if "internal defines become letrec"
 613     (eval '(let ((a identity) (b identity) (c identity))
 614              (define (a x) (if (= x 0) 'a (b (- x 1))))
 615              (define (b x) (if (= x 0) 'b (c (- x 1))))
 616              (define (c x) (if (= x 0) 'c (a (- x 1))))
 617              (and (eq? 'a (a 0) (a 3))
 618                   (eq? 'b (a 1) (a 4))
 619                   (eq? 'c (a 2) (a 5))))
 620           (interaction-environment)))
 621
 622   (expect-fail "internal defines with begin"
 623     (false-if-exception
 624      (eval '(let ((a identity) (b identity) (c identity))
 625               (define (a x) (if (= x 0) 'a (b (- x 1))))
 626               (begin
 627                 (define (b x) (if (= x 0) 'b (c (- x 1)))))
 628               (define (c x) (if (= x 0) 'c (a (- x 1))))
 629               (and (eq? 'a (a 0) (a 3))
 630                    (eq? 'b (a 1) (a 4))
 631                    (eq? 'c (a 2) (a 5))))
 632            (interaction-environment))))
 633
 634   (expect-fail "internal defines with empty begin"
 635     (false-if-exception
 636      (eval '(let ((a identity) (b identity) (c identity))
 637               (define (a x) (if (= x 0) 'a (b (- x 1))))
 638               (begin)
 639               (define (b x) (if (= x 0) 'b (c (- x 1))))
 640               (define (c x) (if (= x 0) 'c (a (- x 1))))
 641               (and (eq? 'a (a 0) (a 3))
 642                    (eq? 'b (a 1) (a 4))
 643                    (eq? 'c (a 2) (a 5))))
 644            (interaction-environment))))
 645
 646   (pass-if "internal defines with macro application"
 647     (false-if-exception
 648      (eval '(begin
 649               (defmacro my-define forms
 650                 (cons 'define forms))
 651               (let ((a identity) (b identity) (c identity))
 652                 (define (a x) (if (= x 0) 'a (b (- x 1))))
 653                 (my-define (b x) (if (= x 0) 'b (c (- x 1))))
 654                 (define (c x) (if (= x 0) 'c (a (- x 1))))
 655                 (and (eq? 'a (a 0) (a 3))
 656                      (eq? 'b (a 1) (a 4))
 657                      (eq? 'c (a 2) (a 5)))))
 658            (interaction-environment))))
 659
 660   (pass-if-exception "missing body expression"
 661     exception:missing-body-expr
 662     (eval '(let () (define x #t))
 663           (interaction-environment))))
 664
 665 (with-test-prefix "set!"
 666
 667   (with-test-prefix "missing or extra expressions"
 668
 669     (pass-if-exception "(set!)"
 670       exception:missing/extra-expr
 671       (eval '(set!)
 672             (interaction-environment)))
 673
 674     (pass-if-exception "(set! 1)"
 675       exception:missing/extra-expr
 676       (eval '(set! 1)
 677             (interaction-environment)))
 678
 679     (pass-if-exception "(set! 1 2 3)"
 680       exception:missing/extra-expr
 681       (eval '(set! 1 2 3)
 682             (interaction-environment))))
 683
 684   (with-test-prefix "bad variable"
 685
 686     (pass-if-exception "(set! \"\" #t)"
 687       exception:bad-variable
 688       (eval '(set! "" #t)
 689             (interaction-environment)))
 690
 691     (pass-if-exception "(set! 1 #t)"
 692       exception:bad-variable
 693       (eval '(set! 1 #t)
 694             (interaction-environment)))
 695
 696     (pass-if-exception "(set! #t #f)"
 697       exception:bad-variable
 698       (eval '(set! #t #f)
 699             (interaction-environment)))
 700
 701     (pass-if-exception "(set! #f #t)"
 702       exception:bad-variable
 703       (eval '(set! #f #t)
 704             (interaction-environment)))
 705
 706     (pass-if-exception "(set! #\space #f)"
 707       exception:bad-variable
 708       (eval '(set! #\space #f)
 709             (interaction-environment)))))
 710
 711 (with-test-prefix "quote"
 712
 713   (with-test-prefix "missing or extra expression"
 714
 715     (pass-if-exception "(quote)"
 716       exception:missing/extra-expr
 717       (eval '(quote)
 718             (interaction-environment)))
 719
 720     (pass-if-exception "(quote a b)"
 721       exception:missing/extra-expr
 722       (eval '(quote a b)
 723             (interaction-environment)))))
 724
 725 (with-test-prefix "while"
 726
 727   (define (unreachable)
 728     (error "unreachable code has been reached!"))
 729
 730   ;; Return a new procedure COND which when called (COND) will return #t the
 731   ;; first N times, then #f, then any further call is an error.  N=0 is
 732   ;; allowed, in which case #f is returned by the first call.
 733   (define (make-iterations-cond n)
 734     (lambda ()
 735       (cond ((not n)
 736              (error "oops, condition re-tested after giving false"))
 737             ((= 0 n)
 738              (set! n #f)
 739              #f)
 740             (else
 741              (set! n (1- n))
 742              #t))))
 743
 744
 745   (pass-if-exception "too few args" exception:wrong-num-args
 746     (eval '(while) (interaction-environment)))
 747
 748   (with-test-prefix "empty body"
 749     (do ((n 0 (1+ n)))
 750         ((> n 5))
 751       (pass-if n
 752         (let ((cond (make-iterations-cond n)))
 753           (while (cond)))
 754         #t)))
 755
 756   (pass-if "initially false"
 757     (while #f
 758       (unreachable))
 759     #t)
 760
 761   (with-test-prefix "in empty environment"
 762
 763     ;; an environment with no bindings at all
 764     (define empty-environment
 765       (make-module 1))
 766
 767     (pass-if "empty body"
 768       (eval `(,while #f)
 769             empty-environment)
 770       #t)
 771
 772     (pass-if "initially false"
 773       (eval `(,while #f
 774                #f)
 775             empty-environment)
 776       #t)
 777
 778     (pass-if "iterating"
 779       (let ((cond (make-iterations-cond 3)))
 780         (eval `(,while (,cond)
 781                  123 456)
 782               empty-environment))
 783       #t))
 784
 785   (with-test-prefix "iterations"
 786     (do ((n 0 (1+ n)))
 787         ((> n 5))
 788       (pass-if n
 789         (let ((cond (make-iterations-cond n))
 790               (i    0))
 791           (while (cond)
 792             (set! i (1+ i)))
 793           (= i n)))))
 794
 795   (with-test-prefix "break"
 796
 797     (pass-if-exception "too many args" exception:wrong-num-args
 798       (while #t
 799         (break 1)))
 800
 801     (with-test-prefix "from cond"
 802       (pass-if "first"
 803         (while (begin
 804                  (break)
 805                  (unreachable))
 806           (unreachable))
 807         #t)
 808
 809       (do ((n 0 (1+ n)))
 810           ((> n 5))
 811         (pass-if n
 812           (let ((cond (make-iterations-cond n))
 813                 (i    0))
 814             (while (if (cond)
 815                        #t
 816                        (begin
 817                          (break)
 818                          (unreachable)))
 819               (set! i (1+ i)))
 820             (= i n)))))
 821
 822     (with-test-prefix "from body"
 823       (pass-if "first"
 824         (while #t
 825           (break)
 826           (unreachable))
 827         #t)
 828
 829       (do ((n 0 (1+ n)))
 830           ((> n 5))
 831         (pass-if n
 832           (let ((cond (make-iterations-cond n))
 833                 (i    0))
 834             (while #t
 835               (if (not (cond))
 836                   (begin
 837                     (break)
 838                     (unreachable)))
 839               (set! i (1+ i)))
 840             (= i n)))))
 841
 842     (pass-if "from nested"
 843       (while #t
 844         (let ((outer-break break))
 845           (while #t
 846             (outer-break)
 847             (unreachable)))
 848         (unreachable))
 849       #t)
 850
 851     (pass-if "from recursive"
 852       (let ((outer-break #f))
 853         (define (r n)
 854           (while #t
 855             (if (eq? n 'outer)
 856                 (begin
 857                   (set! outer-break break)
 858                   (r 'inner))
 859                 (begin
 860                   (outer-break)
 861                   (unreachable))))
 862           (if (eq? n 'inner)
 863               (error "broke only from inner loop")))
 864         (r 'outer))
 865       #t))
 866
 867   (with-test-prefix "continue"
 868
 869     (pass-if-exception "too many args" exception:wrong-num-args
 870       (while #t
 871         (continue 1)))
 872
 873     (with-test-prefix "from cond"
 874       (do ((n 0 (1+ n)))
 875           ((> n 5))
 876         (pass-if n
 877           (let ((cond (make-iterations-cond n))
 878                 (i    0))
 879             (while (if (cond)
 880                        (begin
 881                          (set! i (1+ i))
 882                          (continue)
 883                          (unreachable))
 884                        #f)
 885               (unreachable))
 886             (= i n)))))
 887
 888     (with-test-prefix "from body"
 889       (do ((n 0 (1+ n)))
 890           ((> n 5))
 891         (pass-if n
 892           (let ((cond (make-iterations-cond n))
 893                 (i    0))
 894             (while (cond)
 895               (set! i (1+ i))
 896               (continue)
 897               (unreachable))
 898             (= i n)))))
 899
 900     (pass-if "from nested"
 901       (let ((cond (make-iterations-cond 3)))
 902         (while (cond)
 903           (let ((outer-continue continue))
 904             (while #t
 905               (outer-continue)
 906               (unreachable)))))
 907       #t)
 908
 909     (pass-if "from recursive"
 910       (let ((outer-continue #f))
 911         (define (r n)
 912           (let ((cond  (make-iterations-cond 3))
 913                 (first #t))
 914             (while (begin
 915                      (if (and (not first)
 916                               (eq? n 'inner))
 917                          (error "continued only to inner loop"))
 918                      (cond))
 919               (set! first #f)
 920               (if (eq? n 'outer)
 921                   (begin
 922                     (set! outer-continue continue)
 923                     (r 'inner))
 924                   (begin
 925                     (outer-continue)
 926                     (unreachable))))))
 927         (r 'outer))
 928       #t)))