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