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