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   (pass-if "binding is created before expression is evaluated"
 596     (= (eval '(begin
 597                 (define foo
 598                   (begin
 599                     (set! foo 1)
 600                     (+ foo 1)))
 601                 foo)
 602              (interaction-environment))
 603        2))
 604
 605   (with-test-prefix "currying"
 606
 607     (pass-if "(define ((foo)) #f)"
 608       (eval '(begin
 609                (define ((foo)) #t)
 610                ((foo)))
 611             (interaction-environment))))
 612
 613   (with-test-prefix "missing or extra expressions"
 614
 615     (pass-if-exception "(define)"
 616       exception:missing-expr
 617       (eval '(define)
 618             (interaction-environment)))))
 619
 620 (with-test-prefix "internal define"
 621
 622   (pass-if "internal defines become letrec"
 623     (eval '(let ((a identity) (b identity) (c identity))
 624              (define (a x) (if (= x 0) 'a (b (- x 1))))
 625              (define (b x) (if (= x 0) 'b (c (- x 1))))
 626              (define (c x) (if (= x 0) 'c (a (- x 1))))
 627              (and (eq? 'a (a 0) (a 3))
 628                   (eq? 'b (a 1) (a 4))
 629                   (eq? 'c (a 2) (a 5))))
 630           (interaction-environment)))
 631
 632   (pass-if "internal defines with begin"
 633     (false-if-exception
 634      (eval '(let ((a identity) (b identity) (c identity))
 635               (define (a x) (if (= x 0) 'a (b (- x 1))))
 636               (begin
 637                 (define (b x) (if (= x 0) 'b (c (- x 1)))))
 638               (define (c x) (if (= x 0) 'c (a (- x 1))))
 639               (and (eq? 'a (a 0) (a 3))
 640                    (eq? 'b (a 1) (a 4))
 641                    (eq? 'c (a 2) (a 5))))
 642            (interaction-environment))))
 643
 644   (pass-if "internal defines with empty begin"
 645     (false-if-exception
 646      (eval '(let ((a identity) (b identity) (c identity))
 647               (define (a x) (if (= x 0) 'a (b (- x 1))))
 648               (begin)
 649               (define (b x) (if (= x 0) 'b (c (- x 1))))
 650               (define (c x) (if (= x 0) 'c (a (- x 1))))
 651               (and (eq? 'a (a 0) (a 3))
 652                    (eq? 'b (a 1) (a 4))
 653                    (eq? 'c (a 2) (a 5))))
 654            (interaction-environment))))
 655
 656   (pass-if "internal defines with macro application"
 657     (false-if-exception
 658      (eval '(begin
 659               (defmacro my-define forms
 660                 (cons 'define forms))
 661               (let ((a identity) (b identity) (c identity))
 662                 (define (a x) (if (= x 0) 'a (b (- x 1))))
 663                 (my-define (b x) (if (= x 0) 'b (c (- x 1))))
 664                 (define (c x) (if (= x 0) 'c (a (- x 1))))
 665                 (and (eq? 'a (a 0) (a 3))
 666                      (eq? 'b (a 1) (a 4))
 667                      (eq? 'c (a 2) (a 5)))))
 668            (interaction-environment))))
 669
 670   (pass-if-exception "missing body expression"
 671     exception:missing-body-expr
 672     (eval '(let () (define x #t))
 673           (interaction-environment)))
 674
 675   (pass-if "unmemoization"
 676     (eval '(begin
 677              (define (foo)
 678                (define (bar)
 679                  'ok)
 680                (bar))
 681              (foo)
 682              (equal?
 683               (procedure-source foo)
 684               '(lambda () (letrec ((bar (lambda () (quote ok)))) (bar)))))
 685           (interaction-environment))))
 686
 687 (with-test-prefix "set!"
 688
 689   (with-test-prefix "missing or extra expressions"
 690
 691     (pass-if-exception "(set!)"
 692       exception:missing/extra-expr
 693       (eval '(set!)
 694             (interaction-environment)))
 695
 696     (pass-if-exception "(set! 1)"
 697       exception:missing/extra-expr
 698       (eval '(set! 1)
 699             (interaction-environment)))
 700
 701     (pass-if-exception "(set! 1 2 3)"
 702       exception:missing/extra-expr
 703       (eval '(set! 1 2 3)
 704             (interaction-environment))))
 705
 706   (with-test-prefix "bad variable"
 707
 708     (pass-if-exception "(set! \"\" #t)"
 709       exception:bad-variable
 710       (eval '(set! "" #t)
 711             (interaction-environment)))
 712
 713     (pass-if-exception "(set! 1 #t)"
 714       exception:bad-variable
 715       (eval '(set! 1 #t)
 716             (interaction-environment)))
 717
 718     (pass-if-exception "(set! #t #f)"
 719       exception:bad-variable
 720       (eval '(set! #t #f)
 721             (interaction-environment)))
 722
 723     (pass-if-exception "(set! #f #t)"
 724       exception:bad-variable
 725       (eval '(set! #f #t)
 726             (interaction-environment)))
 727
 728     (pass-if-exception "(set! #\\space #f)"
 729       exception:bad-variable
 730       (eval '(set! #\space #f)
 731             (interaction-environment)))))
 732
 733 (with-test-prefix "quote"
 734
 735   (with-test-prefix "missing or extra expression"
 736
 737     (pass-if-exception "(quote)"
 738       exception:missing/extra-expr
 739       (eval '(quote)
 740             (interaction-environment)))
 741
 742     (pass-if-exception "(quote a b)"
 743       exception:missing/extra-expr
 744       (eval '(quote a b)
 745             (interaction-environment)))))
 746
 747 (with-test-prefix "while"
 748
 749   (define (unreachable)
 750     (error "unreachable code has been reached!"))
 751
 752   ;; Return a new procedure COND which when called (COND) will return #t the
 753   ;; first N times, then #f, then any further call is an error.  N=0 is
 754   ;; allowed, in which case #f is returned by the first call.
 755   (define (make-iterations-cond n)
 756     (lambda ()
 757       (cond ((not n)
 758              (error "oops, condition re-tested after giving false"))
 759             ((= 0 n)
 760              (set! n #f)
 761              #f)
 762             (else
 763              (set! n (1- n))
 764              #t))))
 765
 766
 767   (pass-if-exception "too few args" exception:wrong-num-args
 768     (eval '(while) (interaction-environment)))
 769
 770   (with-test-prefix "empty body"
 771     (do ((n 0 (1+ n)))
 772         ((> n 5))
 773       (pass-if n
 774         (let ((cond (make-iterations-cond n)))
 775           (while (cond)))
 776         #t)))
 777
 778   (pass-if "initially false"
 779     (while #f
 780       (unreachable))
 781     #t)
 782
 783   (with-test-prefix "in empty environment"
 784
 785     ;; an environment with no bindings at all
 786     (define empty-environment
 787       (make-module 1))
 788
 789     (pass-if "empty body"
 790       (eval `(,while #f)
 791             empty-environment)
 792       #t)
 793
 794     (pass-if "initially false"
 795       (eval `(,while #f
 796                #f)
 797             empty-environment)
 798       #t)
 799
 800     (pass-if "iterating"
 801       (let ((cond (make-iterations-cond 3)))
 802         (eval `(,while (,cond)
 803                  123 456)
 804               empty-environment))
 805       #t))
 806
 807   (with-test-prefix "iterations"
 808     (do ((n 0 (1+ n)))
 809         ((> n 5))
 810       (pass-if n
 811         (let ((cond (make-iterations-cond n))
 812               (i    0))
 813           (while (cond)
 814             (set! i (1+ i)))
 815           (= i n)))))
 816
 817   (with-test-prefix "break"
 818
 819     (pass-if-exception "too many args" exception:wrong-num-args
 820       (while #t
 821         (break 1)))
 822
 823     (with-test-prefix "from cond"
 824       (pass-if "first"
 825         (while (begin
 826                  (break)
 827                  (unreachable))
 828           (unreachable))
 829         #t)
 830
 831       (do ((n 0 (1+ n)))
 832           ((> n 5))
 833         (pass-if n
 834           (let ((cond (make-iterations-cond n))
 835                 (i    0))
 836             (while (if (cond)
 837                        #t
 838                        (begin
 839                          (break)
 840                          (unreachable)))
 841               (set! i (1+ i)))
 842             (= i n)))))
 843
 844     (with-test-prefix "from body"
 845       (pass-if "first"
 846         (while #t
 847           (break)
 848           (unreachable))
 849         #t)
 850
 851       (do ((n 0 (1+ n)))
 852           ((> n 5))
 853         (pass-if n
 854           (let ((cond (make-iterations-cond n))
 855                 (i    0))
 856             (while #t
 857               (if (not (cond))
 858                   (begin
 859                     (break)
 860                     (unreachable)))
 861               (set! i (1+ i)))
 862             (= i n)))))
 863
 864     (pass-if "from nested"
 865       (while #t
 866         (let ((outer-break break))
 867           (while #t
 868             (outer-break)
 869             (unreachable)))
 870         (unreachable))
 871       #t)
 872
 873     (pass-if "from recursive"
 874       (let ((outer-break #f))
 875         (define (r n)
 876           (while #t
 877             (if (eq? n 'outer)
 878                 (begin
 879                   (set! outer-break break)
 880                   (r 'inner))
 881                 (begin
 882                   (outer-break)
 883                   (unreachable))))
 884           (if (eq? n 'inner)
 885               (error "broke only from inner loop")))
 886         (r 'outer))
 887       #t))
 888
 889   (with-test-prefix "continue"
 890
 891     (pass-if-exception "too many args" exception:wrong-num-args
 892       (while #t
 893         (continue 1)))
 894
 895     (with-test-prefix "from cond"
 896       (do ((n 0 (1+ n)))
 897           ((> n 5))
 898         (pass-if n
 899           (let ((cond (make-iterations-cond n))
 900                 (i    0))
 901             (while (if (cond)
 902                        (begin
 903                          (set! i (1+ i))
 904                          (continue)
 905                          (unreachable))
 906                        #f)
 907               (unreachable))
 908             (= i n)))))
 909
 910     (with-test-prefix "from body"
 911       (do ((n 0 (1+ n)))
 912           ((> n 5))
 913         (pass-if n
 914           (let ((cond (make-iterations-cond n))
 915                 (i    0))
 916             (while (cond)
 917               (set! i (1+ i))
 918               (continue)
 919               (unreachable))
 920             (= i n)))))
 921
 922     (pass-if "from nested"
 923       (let ((cond (make-iterations-cond 3)))
 924         (while (cond)
 925           (let ((outer-continue continue))
 926             (while #t
 927               (outer-continue)
 928               (unreachable)))))
 929       #t)
 930
 931     (pass-if "from recursive"
 932       (let ((outer-continue #f))
 933         (define (r n)
 934           (let ((cond  (make-iterations-cond 3))
 935                 (first #t))
 936             (while (begin
 937                      (if (and (not first)
 938                               (eq? n 'inner))
 939                          (error "continued only to inner loop"))
 940                      (cond))
 941               (set! first #f)
 942               (if (eq? n 'outer)
 943                   (begin
 944                     (set! outer-continue continue)
 945                     (r 'inner))
 946                   (begin
 947                     (outer-continue)
 948                     (unreachable))))))
 949         (r 'outer))
 950       #t)))