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:misplaced-else-clause
  39   (cons 'syntax-error "Misplaced else clause"))
  40 (define exception:bad-case-clause
  41   (cons 'syntax-error "Bad case clause"))
  42 (define exception:bad-case-labels
  43   (cons 'syntax-error "Bad case labels"))
  44 (define exception:bad-cond-clause
  45   (cons 'syntax-error "Bad cond clause"))
  46 (define exception:bad-var
  47   (cons 'misc-error "^bad variable"))
  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:missing-clauses
 439       (eval '(cond)
 440             (interaction-environment)))
 441
 442     (pass-if-exception "(cond #t)"
 443       exception:bad-cond-clause
 444       (eval '(cond #t)
 445             (interaction-environment)))
 446
 447     (pass-if-exception "(cond 1)"
 448       exception:bad-cond-clause
 449       (eval '(cond 1)
 450             (interaction-environment)))
 451
 452     (pass-if-exception "(cond 1 2)"
 453       exception:bad-cond-clause
 454       (eval '(cond 1 2)
 455             (interaction-environment)))
 456
 457     (pass-if-exception "(cond 1 2 3)"
 458       exception:bad-cond-clause
 459       (eval '(cond 1 2 3)
 460             (interaction-environment)))
 461
 462     (pass-if-exception "(cond 1 2 3 4)"
 463       exception:bad-cond-clause
 464       (eval '(cond 1 2 3 4)
 465             (interaction-environment)))
 466
 467     (pass-if-exception "(cond ())"
 468       exception:bad-cond-clause
 469       (eval '(cond ())
 470             (interaction-environment)))
 471
 472     (pass-if-exception "(cond () 1)"
 473       exception:bad-cond-clause
 474       (eval '(cond () 1)
 475             (interaction-environment)))
 476
 477     (pass-if-exception "(cond (1) 1)"
 478       exception:bad-cond-clause
 479       (eval '(cond (1) 1)
 480             (interaction-environment)))))
 481
 482 (with-test-prefix "cond =>"
 483
 484   (with-test-prefix "cond is hygienic"
 485
 486     (pass-if "bound 'else is handled correctly"
 487       (eq? (let ((else 'ok)) (cond (else))) 'ok))
 488
 489     (pass-if "bound '=> is handled correctly"
 490       (eq? (let ((=> #f)) (cond (#t => 'ok))) 'ok)))
 491
 492   (with-test-prefix "else is handled correctly"
 493
 494     (pass-if "else =>"
 495       (let ((=> 'foo))
 496         (eq? (cond (else =>)) 'foo)))
 497
 498     (pass-if "else => identity"
 499       (let* ((=> 'foo))
 500         (eq? (cond (else => identity)) identity))))
 501
 502   (with-test-prefix "wrong number of arguments"
 503
 504     (pass-if-exception "=> (lambda (x y) #t)"
 505       exception:wrong-num-args
 506       (cond (1 => (lambda (x y) #t))))))
 507
 508 (with-test-prefix "case"
 509
 510   (pass-if "clause with empty labels list"
 511     (case 1 (() #f) (else #t)))
 512
 513   (with-test-prefix "case is hygienic"
 514
 515     (pass-if-exception "bound 'else is handled correctly"
 516       exception:bad-case-labels
 517       (eval '(let ((else #f)) (case 1 (else #f)))
 518             (interaction-environment))))
 519
 520   (with-test-prefix "bad or missing clauses"
 521
 522     (pass-if-exception "(case)"
 523       exception:missing-clauses
 524       (eval '(case)
 525             (interaction-environment)))
 526
 527     (pass-if-exception "(case . \"foo\")"
 528       exception:bad-expression
 529       (eval '(case . "foo")
 530             (interaction-environment)))
 531
 532     (pass-if-exception "(case 1)"
 533       exception:missing-clauses
 534       (eval '(case 1)
 535             (interaction-environment)))
 536
 537     (pass-if-exception "(case 1 . \"foo\")"
 538       exception:bad-expression
 539       (eval '(case 1 . "foo")
 540             (interaction-environment)))
 541
 542     (pass-if-exception "(case 1 \"foo\")"
 543       exception:bad-case-clause
 544       (eval '(case 1 "foo")
 545             (interaction-environment)))
 546
 547     (pass-if-exception "(case 1 ())"
 548       exception:bad-case-clause
 549       (eval '(case 1 ())
 550             (interaction-environment)))
 551
 552     (pass-if-exception "(case 1 (\"foo\"))"
 553       exception:bad-case-clause
 554       (eval '(case 1 ("foo"))
 555             (interaction-environment)))
 556
 557     (pass-if-exception "(case 1 (\"foo\" \"bar\"))"
 558       exception:bad-case-labels
 559       (eval '(case 1 ("foo" "bar"))
 560             (interaction-environment)))
 561
 562     (pass-if-exception "(case 1 ((2) \"bar\") . \"foo\")"
 563       exception:bad-expression
 564       (eval '(case 1 ((2) "bar") . "foo")
 565             (interaction-environment)))
 566
 567     (pass-if-exception "(case 1 ((2) \"bar\") (else))"
 568       exception:bad-case-clause
 569       (eval '(case 1 ((2) "bar") (else))
 570             (interaction-environment)))
 571
 572     (pass-if-exception "(case 1 (else #f) . \"foo\")"
 573       exception:bad-expression
 574       (eval '(case 1 (else #f) . "foo")
 575             (interaction-environment)))
 576
 577     (pass-if-exception "(case 1 (else #f) ((1) #t))"
 578       exception:misplaced-else-clause
 579       (eval '(case 1 (else #f) ((1) #t))
 580             (interaction-environment)))))
 581
 582 (with-test-prefix "define"
 583
 584   (with-test-prefix "currying"
 585
 586     (pass-if "(define ((foo)) #f)"
 587       (define ((foo)) #t)
 588       ((foo))))
 589
 590   (with-test-prefix "missing or extra expressions"
 591
 592     (pass-if-exception "(define)"
 593       exception:missing/extra-expr
 594       (eval '(define)
 595             (interaction-environment)))))
 596
 597 (with-test-prefix "set!"
 598
 599   (with-test-prefix "missing or extra expressions"
 600
 601     (pass-if-exception "(set!)"
 602       exception:missing/extra-expr
 603       (eval '(set!)
 604             (interaction-environment)))
 605
 606     (pass-if-exception "(set! 1)"
 607       exception:missing/extra-expr
 608       (eval '(set! 1)
 609             (interaction-environment)))
 610
 611     (pass-if-exception "(set! 1 2 3)"
 612       exception:missing/extra-expr
 613       (eval '(set! 1 2 3)
 614             (interaction-environment))))
 615
 616   (with-test-prefix "bad variable"
 617
 618     (pass-if-exception "(set! \"\" #t)"
 619       exception:bad-var
 620       (eval '(set! "" #t)
 621             (interaction-environment)))
 622
 623     (pass-if-exception "(set! 1 #t)"
 624       exception:bad-var
 625       (eval '(set! 1 #t)
 626             (interaction-environment)))
 627
 628     (pass-if-exception "(set! #t #f)"
 629       exception:bad-var
 630       (eval '(set! #t #f)
 631             (interaction-environment)))
 632
 633     (pass-if-exception "(set! #f #t)"
 634       exception:bad-var
 635       (eval '(set! #f #t)
 636             (interaction-environment)))
 637
 638     (pass-if-exception "(set! #\space #f)"
 639       exception:bad-var
 640       (eval '(set! #\space #f)
 641             (interaction-environment)))))
 642
 643 (with-test-prefix "quote"
 644
 645   (with-test-prefix "missing or extra expression"
 646
 647     (pass-if-exception "(quote)"
 648       exception:missing/extra-expr
 649       (eval '(quote)
 650             (interaction-environment)))
 651
 652     (pass-if-exception "(quote a b)"
 653       exception:missing/extra-expr
 654       (eval '(quote a b)
 655             (interaction-environment)))))
 656
 657 (with-test-prefix "while"
 658
 659   (define (unreachable)
 660     (error "unreachable code has been reached!"))
 661
 662   ;; Return a new procedure COND which when called (COND) will return #t the
 663   ;; first N times, then #f, then any further call is an error.  N=0 is
 664   ;; allowed, in which case #f is returned by the first call.
 665   (define (make-iterations-cond n)
 666     (lambda ()
 667       (cond ((not n)
 668              (error "oops, condition re-tested after giving false"))
 669             ((= 0 n)
 670              (set! n #f)
 671              #f)
 672             (else
 673              (set! n (1- n))
 674              #t))))
 675
 676
 677   (pass-if-exception "too few args" exception:wrong-num-args
 678     (eval '(while) (interaction-environment)))
 679
 680   (with-test-prefix "empty body"
 681     (do ((n 0 (1+ n)))
 682         ((> n 5))
 683       (pass-if n
 684         (let ((cond (make-iterations-cond n)))
 685           (while (cond)))
 686         #t)))
 687
 688   (pass-if "initially false"
 689     (while #f
 690       (unreachable))
 691     #t)
 692
 693   (with-test-prefix "in empty environment"
 694
 695     ;; an environment with no bindings at all
 696     (define empty-environment
 697       (make-module 1))
 698
 699     (pass-if "empty body"
 700       (eval `(,while #f)
 701             empty-environment)
 702       #t)
 703
 704     (pass-if "initially false"
 705       (eval `(,while #f
 706                #f)
 707             empty-environment)
 708       #t)
 709
 710     (pass-if "iterating"
 711       (let ((cond (make-iterations-cond 3)))
 712         (eval `(,while (,cond)
 713                  123 456)
 714               empty-environment))
 715       #t))
 716
 717   (with-test-prefix "iterations"
 718     (do ((n 0 (1+ n)))
 719         ((> n 5))
 720       (pass-if n
 721         (let ((cond (make-iterations-cond n))
 722               (i    0))
 723           (while (cond)
 724             (set! i (1+ i)))
 725           (= i n)))))
 726
 727   (with-test-prefix "break"
 728
 729     (pass-if-exception "too many args" exception:wrong-num-args
 730       (while #t
 731         (break 1)))
 732
 733     (with-test-prefix "from cond"
 734       (pass-if "first"
 735         (while (begin
 736                  (break)
 737                  (unreachable))
 738           (unreachable))
 739         #t)
 740
 741       (do ((n 0 (1+ n)))
 742           ((> n 5))
 743         (pass-if n
 744           (let ((cond (make-iterations-cond n))
 745                 (i    0))
 746             (while (if (cond)
 747                        #t
 748                        (begin
 749                          (break)
 750                          (unreachable)))
 751               (set! i (1+ i)))
 752             (= i n)))))
 753
 754     (with-test-prefix "from body"
 755       (pass-if "first"
 756         (while #t
 757           (break)
 758           (unreachable))
 759         #t)
 760
 761       (do ((n 0 (1+ n)))
 762           ((> n 5))
 763         (pass-if n
 764           (let ((cond (make-iterations-cond n))
 765                 (i    0))
 766             (while #t
 767               (if (not (cond))
 768                   (begin
 769                     (break)
 770                     (unreachable)))
 771               (set! i (1+ i)))
 772             (= i n)))))
 773
 774     (pass-if "from nested"
 775       (while #t
 776         (let ((outer-break break))
 777           (while #t
 778             (outer-break)
 779             (unreachable)))
 780         (unreachable))
 781       #t)
 782
 783     (pass-if "from recursive"
 784       (let ((outer-break #f))
 785         (define (r n)
 786           (while #t
 787             (if (eq? n 'outer)
 788                 (begin
 789                   (set! outer-break break)
 790                   (r 'inner))
 791                 (begin
 792                   (outer-break)
 793                   (unreachable))))
 794           (if (eq? n 'inner)
 795               (error "broke only from inner loop")))
 796         (r 'outer))
 797       #t))
 798
 799   (with-test-prefix "continue"
 800
 801     (pass-if-exception "too many args" exception:wrong-num-args
 802       (while #t
 803         (continue 1)))
 804
 805     (with-test-prefix "from cond"
 806       (do ((n 0 (1+ n)))
 807           ((> n 5))
 808         (pass-if n
 809           (let ((cond (make-iterations-cond n))
 810                 (i    0))
 811             (while (if (cond)
 812                        (begin
 813                          (set! i (1+ i))
 814                          (continue)
 815                          (unreachable))
 816                        #f)
 817               (unreachable))
 818             (= i n)))))
 819
 820     (with-test-prefix "from body"
 821       (do ((n 0 (1+ n)))
 822           ((> n 5))
 823         (pass-if n
 824           (let ((cond (make-iterations-cond n))
 825                 (i    0))
 826             (while (cond)
 827               (set! i (1+ i))
 828               (continue)
 829               (unreachable))
 830             (= i n)))))
 831
 832     (pass-if "from nested"
 833       (let ((cond (make-iterations-cond 3)))
 834         (while (cond)
 835           (let ((outer-continue continue))
 836             (while #t
 837               (outer-continue)
 838               (unreachable)))))
 839       #t)
 840
 841     (pass-if "from recursive"
 842       (let ((outer-continue #f))
 843         (define (r n)
 844           (let ((cond  (make-iterations-cond 3))
 845                 (first #t))
 846             (while (begin
 847                      (if (and (not first)
 848                               (eq? n 'inner))
 849                          (error "continued only to inner loop"))
 850                      (cond))
 851               (set! first #f)
 852               (if (eq? n 'outer)
 853                   (begin
 854                     (set! outer-continue continue)
 855                     (r 'inner))
 856                   (begin
 857                     (outer-continue)
 858                     (unreachable))))))
 859         (r 'outer))
 860       #t)))