test-suite/tests/syntax.test

   1 ;;;; syntax.test --- test suite for Guile's syntactic forms    -*- scheme -*-
   2 ;;;;
   3 ;;;; Copyright (C) 2001,2003,2004, 2005 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., 51 Franklin Street, Fifth Floor,
  18 ;;;; Boston, MA 02110-1301 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   (with-test-prefix "unmemoization"
 119
 120     (pass-if "normal begin"
 121       (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (+ 2))))))
 122         (foo) ; make sure, memoization has been performed
 123         (equal? (procedure-source foo)
 124                 '(lambda () (if (= 1 1) (begin (+ 1) (+ 2)))))))
 125
 126     (pass-if "redundant nested begin"
 127       (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3)))))))
 128         (foo) ; make sure, memoization has been performed
 129         (equal? (procedure-source foo)
 130                 '(lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3))))))))
 131
 132     (pass-if "redundant begin at start of body"
 133       (let ((foo (lambda () (begin (+ 1) (+ 2))))) ; should be optimized
 134         (foo) ; make sure, memoization has been performed
 135         (equal? (procedure-source foo)
 136                 '(lambda () (begin (+ 1) (+ 2)))))))
 137
 138   (expect-fail-exception "illegal (begin)"
 139     exception:bad-body
 140     (if #t (begin))
 141     #t))
 142
 143 (with-test-prefix "lambda"
 144
 145   (with-test-prefix "unmemoization"
 146
 147     (pass-if "normal lambda"
 148       (let ((foo (lambda () (lambda (x y) (+ x y)))))
 149         ((foo) 1 2) ; make sure, memoization has been performed
 150         (equal? (procedure-source foo)
 151                 '(lambda () (lambda (x y) (+ x y))))))
 152
 153     (pass-if "lambda with documentation"
 154       (let ((foo (lambda () (lambda (x y) "docstring" (+ x y)))))
 155         ((foo) 1 2) ; make sure, memoization has been performed
 156         (equal? (procedure-source foo)
 157                 '(lambda () (lambda (x y) "docstring" (+ x y)))))))
 158
 159   (with-test-prefix "bad formals"
 160
 161     (pass-if-exception "(lambda)"
 162       exception:missing-expr
 163       (eval '(lambda)
 164             (interaction-environment)))
 165
 166     (pass-if-exception "(lambda . \"foo\")"
 167       exception:bad-expression
 168       (eval '(lambda . "foo")
 169             (interaction-environment)))
 170
 171     (pass-if-exception "(lambda \"foo\")"
 172       exception:missing-expr
 173       (eval '(lambda "foo")
 174             (interaction-environment)))
 175
 176     (pass-if-exception "(lambda \"foo\" #f)"
 177       exception:bad-formals
 178       (eval '(lambda "foo" #f)
 179             (interaction-environment)))
 180
 181     (pass-if-exception "(lambda (x 1) 2)"
 182       exception:bad-formal
 183       (eval '(lambda (x 1) 2)
 184             (interaction-environment)))
 185
 186     (pass-if-exception "(lambda (1 x) 2)"
 187       exception:bad-formal
 188       (eval '(lambda (1 x) 2)
 189             (interaction-environment)))
 190
 191     (pass-if-exception "(lambda (x \"a\") 2)"
 192       exception:bad-formal
 193       (eval '(lambda (x "a") 2)
 194             (interaction-environment)))
 195
 196     (pass-if-exception "(lambda (\"a\" x) 2)"
 197       exception:bad-formal
 198       (eval '(lambda ("a" x) 2)
 199             (interaction-environment))))
 200
 201   (with-test-prefix "duplicate formals"
 202
 203     ;; Fixed on 2001-3-3
 204     (pass-if-exception "(lambda (x x) 1)"
 205       exception:duplicate-formal
 206       (eval '(lambda (x x) 1)
 207             (interaction-environment)))
 208
 209     ;; Fixed on 2001-3-3
 210     (pass-if-exception "(lambda (x x x) 1)"
 211       exception:duplicate-formal
 212       (eval '(lambda (x x x) 1)
 213             (interaction-environment))))
 214
 215   (with-test-prefix "bad body"
 216
 217     (pass-if-exception "(lambda ())"
 218       exception:missing-expr
 219       (eval '(lambda ())
 220             (interaction-environment)))))
 221
 222 (with-test-prefix "let"
 223
 224   (with-test-prefix "unmemoization"
 225
 226     (pass-if "normal let"
 227       (let ((foo (lambda () (let ((i 1) (j 2)) (+ i j)))))
 228         (foo) ; make sure, memoization has been performed
 229         (equal? (procedure-source foo)
 230                 '(lambda () (let ((i 1) (j 2)) (+ i j)))))))
 231
 232   (with-test-prefix "bindings"
 233
 234     (pass-if-exception "late binding"
 235       exception:unbound-var
 236       (let ((x 1) (y x)) y)))
 237
 238   (with-test-prefix "bad bindings"
 239
 240     (pass-if-exception "(let)"
 241       exception:missing-expr
 242       (eval '(let)
 243             (interaction-environment)))
 244
 245     (pass-if-exception "(let 1)"
 246       exception:missing-expr
 247       (eval '(let 1)
 248             (interaction-environment)))
 249
 250     (pass-if-exception "(let (x))"
 251       exception:missing-expr
 252       (eval '(let (x))
 253             (interaction-environment)))
 254
 255     (pass-if-exception "(let ((x)))"
 256       exception:missing-expr
 257       (eval '(let ((x)))
 258             (interaction-environment)))
 259
 260     (pass-if-exception "(let (x) 1)"
 261       exception:bad-binding
 262       (eval '(let (x) 1)
 263             (interaction-environment)))
 264
 265     (pass-if-exception "(let ((x)) 3)"
 266       exception:bad-binding
 267       (eval '(let ((x)) 3)
 268             (interaction-environment)))
 269
 270     (pass-if-exception "(let ((x 1) y) x)"
 271       exception:bad-binding
 272       (eval '(let ((x 1) y) x)
 273             (interaction-environment)))
 274
 275     (pass-if-exception "(let ((1 2)) 3)"
 276       exception:bad-variable
 277       (eval '(let ((1 2)) 3)
 278             (interaction-environment))))
 279
 280   (with-test-prefix "duplicate bindings"
 281
 282     (pass-if-exception "(let ((x 1) (x 2)) x)"
 283       exception:duplicate-binding
 284       (eval '(let ((x 1) (x 2)) x)
 285             (interaction-environment))))
 286
 287   (with-test-prefix "bad body"
 288
 289     (pass-if-exception "(let ())"
 290       exception:missing-expr
 291       (eval '(let ())
 292             (interaction-environment)))
 293
 294     (pass-if-exception "(let ((x 1)))"
 295       exception:missing-expr
 296       (eval '(let ((x 1)))
 297             (interaction-environment)))))
 298
 299 (with-test-prefix "named let"
 300
 301   (with-test-prefix "initializers"
 302
 303     (pass-if "evaluated in outer environment"
 304       (let ((f -))
 305         (eqv? (let f ((n (f 1))) n) -1))))
 306
 307   (with-test-prefix "bad bindings"
 308
 309     (pass-if-exception "(let x (y))"
 310       exception:missing-expr
 311       (eval '(let x (y))
 312             (interaction-environment))))
 313
 314   (with-test-prefix "bad body"
 315
 316     (pass-if-exception "(let x ())"
 317       exception:missing-expr
 318       (eval '(let x ())
 319             (interaction-environment)))
 320
 321     (pass-if-exception "(let x ((y 1)))"
 322       exception:missing-expr
 323       (eval '(let x ((y 1)))
 324             (interaction-environment)))))
 325
 326 (with-test-prefix "let*"
 327
 328   (with-test-prefix "unmemoization"
 329
 330     (pass-if "normal let*"
 331       (let ((foo (lambda () (let* ((x 1) (y 2)) (+ x y)))))
 332         (foo) ; make sure, memoization has been performed
 333         (equal? (procedure-source foo)
 334                 '(lambda () (let* ((x 1) (y 2)) (+ x y))))))
 335
 336     (pass-if "let* without bindings"
 337       (let ((foo (lambda () (let ((x 1) (y 2))
 338                               (let* ()
 339                                 (and (= x 1) (= y 2)))))))
 340         (foo) ; make sure, memoization has been performed
 341         (equal? (procedure-source foo)
 342                 '(lambda () (let ((x 1) (y 2))
 343                               (let* ()
 344                                 (and (= x 1) (= y 2)))))))))
 345
 346   (with-test-prefix "bindings"
 347
 348     (pass-if "(let* ((x 1) (x 2)) ...)"
 349       (let* ((x 1) (x 2))
 350         (= x 2)))
 351
 352     (pass-if "(let* ((x 1) (x x)) ...)"
 353       (let* ((x 1) (x x))
 354         (= x 1)))
 355
 356     (pass-if "(let ((x 1) (y 2)) (let* () ...))"
 357       (let ((x 1) (y 2))
 358         (let* ()
 359           (and (= x 1) (= y 2))))))
 360
 361   (with-test-prefix "bad bindings"
 362
 363     (pass-if-exception "(let*)"
 364       exception:missing-expr
 365       (eval '(let*)
 366             (interaction-environment)))
 367
 368     (pass-if-exception "(let* 1)"
 369       exception:missing-expr
 370       (eval '(let* 1)
 371             (interaction-environment)))
 372
 373     (pass-if-exception "(let* (x))"
 374       exception:missing-expr
 375       (eval '(let* (x))
 376             (interaction-environment)))
 377
 378     (pass-if-exception "(let* (x) 1)"
 379       exception:bad-binding
 380       (eval '(let* (x) 1)
 381             (interaction-environment)))
 382
 383     (pass-if-exception "(let* ((x)) 3)"
 384       exception:bad-binding
 385       (eval '(let* ((x)) 3)
 386             (interaction-environment)))
 387
 388     (pass-if-exception "(let* ((x 1) y) x)"
 389       exception:bad-binding
 390       (eval '(let* ((x 1) y) x)
 391             (interaction-environment)))
 392
 393     (pass-if-exception "(let* x ())"
 394       exception:bad-bindings
 395       (eval '(let* x ())
 396             (interaction-environment)))
 397
 398     (pass-if-exception "(let* x (y))"
 399       exception:bad-bindings
 400       (eval '(let* x (y))
 401             (interaction-environment)))
 402
 403     (pass-if-exception "(let* ((1 2)) 3)"
 404       exception:bad-variable
 405       (eval '(let* ((1 2)) 3)
 406             (interaction-environment))))
 407
 408   (with-test-prefix "bad body"
 409
 410     (pass-if-exception "(let* ())"
 411       exception:missing-expr
 412       (eval '(let* ())
 413             (interaction-environment)))
 414
 415     (pass-if-exception "(let* ((x 1)))"
 416       exception:missing-expr
 417       (eval '(let* ((x 1)))
 418             (interaction-environment)))))
 419
 420 (with-test-prefix "letrec"
 421
 422   (with-test-prefix "unmemoization"
 423
 424     (pass-if "normal letrec"
 425       (let ((foo (lambda () (letrec ((i 1) (j 2)) (+ i j)))))
 426         (foo) ; make sure, memoization has been performed
 427         (equal? (procedure-source foo)
 428                 '(lambda () (letrec ((i 1) (j 2)) (+ i j)))))))
 429
 430   (with-test-prefix "bindings"
 431
 432     (pass-if-exception "initial bindings are undefined"
 433       exception:used-before-defined
 434       (let ((x 1))
 435         (letrec ((x 1) (y x)) y))))
 436
 437   (with-test-prefix "bad bindings"
 438
 439     (pass-if-exception "(letrec)"
 440       exception:missing-expr
 441       (eval '(letrec)
 442             (interaction-environment)))
 443
 444     (pass-if-exception "(letrec 1)"
 445       exception:missing-expr
 446       (eval '(letrec 1)
 447             (interaction-environment)))
 448
 449     (pass-if-exception "(letrec (x))"
 450       exception:missing-expr
 451       (eval '(letrec (x))
 452             (interaction-environment)))
 453
 454     (pass-if-exception "(letrec (x) 1)"
 455       exception:bad-binding
 456       (eval '(letrec (x) 1)
 457             (interaction-environment)))
 458
 459     (pass-if-exception "(letrec ((x)) 3)"
 460       exception:bad-binding
 461       (eval '(letrec ((x)) 3)
 462             (interaction-environment)))
 463
 464     (pass-if-exception "(letrec ((x 1) y) x)"
 465       exception:bad-binding
 466       (eval '(letrec ((x 1) y) x)
 467             (interaction-environment)))
 468
 469     (pass-if-exception "(letrec x ())"
 470       exception:bad-bindings
 471       (eval '(letrec x ())
 472             (interaction-environment)))
 473
 474     (pass-if-exception "(letrec x (y))"
 475       exception:bad-bindings
 476       (eval '(letrec x (y))
 477             (interaction-environment)))
 478
 479     (pass-if-exception "(letrec ((1 2)) 3)"
 480       exception:bad-variable
 481       (eval '(letrec ((1 2)) 3)
 482             (interaction-environment))))
 483
 484   (with-test-prefix "duplicate bindings"
 485
 486     (pass-if-exception "(letrec ((x 1) (x 2)) x)"
 487       exception:duplicate-binding
 488       (eval '(letrec ((x 1) (x 2)) x)
 489             (interaction-environment))))
 490
 491   (with-test-prefix "bad body"
 492
 493     (pass-if-exception "(letrec ())"
 494       exception:missing-expr
 495       (eval '(letrec ())
 496             (interaction-environment)))
 497
 498     (pass-if-exception "(letrec ((x 1)))"
 499       exception:missing-expr
 500       (eval '(letrec ((x 1)))
 501             (interaction-environment)))))
 502
 503 (with-test-prefix "if"
 504
 505   (with-test-prefix "unmemoization"
 506
 507     (pass-if "normal if"
 508       (let ((foo (lambda (x) (if x (+ 1) (+ 2)))))
 509         (foo #t) ; make sure, memoization has been performed
 510         (foo #f) ; make sure, memoization has been performed
 511         (equal? (procedure-source foo)
 512                 '(lambda (x) (if x (+ 1) (+ 2))))))
 513
 514     (pass-if "if without else"
 515       (let ((foo (lambda (x) (if x (+ 1)))))
 516         (foo #t) ; make sure, memoization has been performed
 517         (foo #f) ; make sure, memoization has been performed
 518         (equal? (procedure-source foo)
 519                 '(lambda (x) (if x (+ 1))))))
 520
 521     (pass-if "if #f without else"
 522       (let ((foo (lambda () (if #f #f))))
 523         (foo) ; make sure, memoization has been performed
 524         (equal? (procedure-source foo)
 525                 `(lambda () (if #f #f))))))
 526
 527   (with-test-prefix "missing or extra expressions"
 528
 529     (pass-if-exception "(if)"
 530       exception:missing/extra-expr
 531       (eval '(if)
 532             (interaction-environment)))
 533
 534     (pass-if-exception "(if 1 2 3 4)"
 535       exception:missing/extra-expr
 536       (eval '(if 1 2 3 4)
 537             (interaction-environment)))))
 538
 539 (with-test-prefix "cond"
 540
 541   (with-test-prefix "cond is hygienic"
 542
 543     (pass-if "bound 'else is handled correctly"
 544       (eq? (let ((else 'ok)) (cond (else))) 'ok))
 545
 546     (with-test-prefix "bound '=> is handled correctly"
 547
 548       (pass-if "#t => 'ok"
 549         (let ((=> 'foo))
 550           (eq? (cond (#t => 'ok)) 'ok)))
 551
 552       (pass-if "else =>"
 553         (let ((=> 'foo))
 554           (eq? (cond (else =>)) 'foo)))
 555
 556       (pass-if "else => identity"
 557         (let ((=> 'foo))
 558           (eq? (cond (else => identity)) identity)))))
 559
 560   (with-test-prefix "unmemoization"
 561
 562     (pass-if "normal clauses"
 563       (let ((foo (lambda (x) (cond ((= x 1) 'bar) ((= x 2) 'baz)))))
 564         (foo 1) ; make sure, memoization has been performed
 565         (foo 2) ; make sure, memoization has been performed
 566         (equal? (procedure-source foo)
 567                 '(lambda (x) (cond ((= x 1) 'bar) ((= x 2) 'baz))))))
 568
 569     (pass-if "else"
 570       (let ((foo (lambda () (cond (else 'bar)))))
 571         (foo) ; make sure, memoization has been performed
 572         (equal? (procedure-source foo)
 573                 '(lambda () (cond (else 'bar))))))
 574
 575     (pass-if "=>"
 576       (let ((foo (lambda () (cond (#t => identity)))))
 577         (foo) ; make sure, memoization has been performed
 578         (equal? (procedure-source foo)
 579                 '(lambda () (cond (#t => identity)))))))
 580
 581   (with-test-prefix "bad or missing clauses"
 582
 583     (pass-if-exception "(cond)"
 584       exception:missing-clauses
 585       (eval '(cond)
 586             (interaction-environment)))
 587
 588     (pass-if-exception "(cond #t)"
 589       exception:bad-cond-clause
 590       (eval '(cond #t)
 591             (interaction-environment)))
 592
 593     (pass-if-exception "(cond 1)"
 594       exception:bad-cond-clause
 595       (eval '(cond 1)
 596             (interaction-environment)))
 597
 598     (pass-if-exception "(cond 1 2)"
 599       exception:bad-cond-clause
 600       (eval '(cond 1 2)
 601             (interaction-environment)))
 602
 603     (pass-if-exception "(cond 1 2 3)"
 604       exception:bad-cond-clause
 605       (eval '(cond 1 2 3)
 606             (interaction-environment)))
 607
 608     (pass-if-exception "(cond 1 2 3 4)"
 609       exception:bad-cond-clause
 610       (eval '(cond 1 2 3 4)
 611             (interaction-environment)))
 612
 613     (pass-if-exception "(cond ())"
 614       exception:bad-cond-clause
 615       (eval '(cond ())
 616             (interaction-environment)))
 617
 618     (pass-if-exception "(cond () 1)"
 619       exception:bad-cond-clause
 620       (eval '(cond () 1)
 621             (interaction-environment)))
 622
 623     (pass-if-exception "(cond (1) 1)"
 624       exception:bad-cond-clause
 625       (eval '(cond (1) 1)
 626             (interaction-environment))))
 627
 628   (with-test-prefix "wrong number of arguments"
 629
 630     (pass-if-exception "=> (lambda (x y) #t)"
 631       exception:wrong-num-args
 632       (cond (1 => (lambda (x y) #t))))))
 633
 634 (with-test-prefix "case"
 635
 636   (pass-if "clause with empty labels list"
 637     (case 1 (() #f) (else #t)))
 638
 639   (with-test-prefix "case is hygienic"
 640
 641     (pass-if-exception "bound 'else is handled correctly"
 642       exception:bad-case-labels
 643       (eval '(let ((else #f)) (case 1 (else #f)))
 644             (interaction-environment))))
 645
 646   (with-test-prefix "unmemoization"
 647
 648     (pass-if "normal clauses"
 649       (let ((foo (lambda (x) (case x ((1) 'bar) ((2) 'baz) (else 'foobar)))))
 650         (foo 1) ; make sure, memoization has been performed
 651         (foo 2) ; make sure, memoization has been performed
 652         (foo 3) ; make sure, memoization has been performed
 653         (equal? (procedure-source foo)
 654                 '(lambda (x) (case x ((1) 'bar) ((2) 'baz) (else 'foobar))))))
 655
 656     (pass-if "empty labels"
 657       (let ((foo (lambda (x) (case x ((1) 'bar) (() 'baz) (else 'foobar)))))
 658         (foo 1) ; make sure, memoization has been performed
 659         (foo 2) ; make sure, memoization has been performed
 660         (foo 3) ; make sure, memoization has been performed
 661         (equal? (procedure-source foo)
 662                 '(lambda (x) (case x ((1) 'bar) (() 'baz) (else 'foobar)))))))
 663
 664   (with-test-prefix "bad or missing clauses"
 665
 666     (pass-if-exception "(case)"
 667       exception:missing-clauses
 668       (eval '(case)
 669             (interaction-environment)))
 670
 671     (pass-if-exception "(case . \"foo\")"
 672       exception:bad-expression
 673       (eval '(case . "foo")
 674             (interaction-environment)))
 675
 676     (pass-if-exception "(case 1)"
 677       exception:missing-clauses
 678       (eval '(case 1)
 679             (interaction-environment)))
 680
 681     (pass-if-exception "(case 1 . \"foo\")"
 682       exception:bad-expression
 683       (eval '(case 1 . "foo")
 684             (interaction-environment)))
 685
 686     (pass-if-exception "(case 1 \"foo\")"
 687       exception:bad-case-clause
 688       (eval '(case 1 "foo")
 689             (interaction-environment)))
 690
 691     (pass-if-exception "(case 1 ())"
 692       exception:bad-case-clause
 693       (eval '(case 1 ())
 694             (interaction-environment)))
 695
 696     (pass-if-exception "(case 1 (\"foo\"))"
 697       exception:bad-case-clause
 698       (eval '(case 1 ("foo"))
 699             (interaction-environment)))
 700
 701     (pass-if-exception "(case 1 (\"foo\" \"bar\"))"
 702       exception:bad-case-labels
 703       (eval '(case 1 ("foo" "bar"))
 704             (interaction-environment)))
 705
 706     (pass-if-exception "(case 1 ((2) \"bar\") . \"foo\")"
 707       exception:bad-expression
 708       (eval '(case 1 ((2) "bar") . "foo")
 709             (interaction-environment)))
 710
 711     (pass-if-exception "(case 1 ((2) \"bar\") (else))"
 712       exception:bad-case-clause
 713       (eval '(case 1 ((2) "bar") (else))
 714             (interaction-environment)))
 715
 716     (pass-if-exception "(case 1 (else #f) . \"foo\")"
 717       exception:bad-expression
 718       (eval '(case 1 (else #f) . "foo")
 719             (interaction-environment)))
 720
 721     (pass-if-exception "(case 1 (else #f) ((1) #t))"
 722       exception:misplaced-else-clause
 723       (eval '(case 1 (else #f) ((1) #t))
 724             (interaction-environment)))))
 725
 726 (with-test-prefix "top-level define"
 727
 728   (pass-if "binding is created before expression is evaluated"
 729     (= (eval '(begin
 730                 (define foo
 731                   (begin
 732                     (set! foo 1)
 733                     (+ foo 1)))
 734                 foo)
 735              (interaction-environment))
 736        2))
 737
 738   (with-test-prefix "currying"
 739
 740     (pass-if "(define ((foo)) #f)"
 741       (eval '(begin
 742                (define ((foo)) #t)
 743                ((foo)))
 744             (interaction-environment))))
 745
 746   (with-test-prefix "unmemoization"
 747
 748     (pass-if "definition unmemoized without prior execution"
 749       (eval '(begin
 750                (define (blub) (cons ('(1 . 2)) 2))
 751                (equal?
 752                  (procedure-source blub)
 753                  '(lambda () (cons ('(1 . 2)) 2))))
 754             (interaction-environment)))
 755
 756     (pass-if "definition with documentation unmemoized without prior execution"
 757       (eval '(begin
 758                (define (blub) "Comment" (cons ('(1 . 2)) 2))
 759                (equal?
 760                  (procedure-source blub)
 761                  '(lambda () "Comment" (cons ('(1 . 2)) 2))))
 762             (interaction-environment))))
 763
 764   (with-test-prefix "missing or extra expressions"
 765
 766     (pass-if-exception "(define)"
 767       exception:missing-expr
 768       (eval '(define)
 769             (interaction-environment)))))
 770
 771 (with-test-prefix "internal define"
 772
 773   (pass-if "internal defines become letrec"
 774     (eval '(let ((a identity) (b identity) (c identity))
 775              (define (a x) (if (= x 0) 'a (b (- x 1))))
 776              (define (b x) (if (= x 0) 'b (c (- x 1))))
 777              (define (c x) (if (= x 0) 'c (a (- x 1))))
 778              (and (eq? 'a (a 0) (a 3))
 779                   (eq? 'b (a 1) (a 4))
 780                   (eq? 'c (a 2) (a 5))))
 781           (interaction-environment)))
 782
 783   (pass-if "internal defines with begin"
 784     (false-if-exception
 785      (eval '(let ((a identity) (b identity) (c identity))
 786               (define (a x) (if (= x 0) 'a (b (- x 1))))
 787               (begin
 788                 (define (b x) (if (= x 0) 'b (c (- x 1)))))
 789               (define (c x) (if (= x 0) 'c (a (- x 1))))
 790               (and (eq? 'a (a 0) (a 3))
 791                    (eq? 'b (a 1) (a 4))
 792                    (eq? 'c (a 2) (a 5))))
 793            (interaction-environment))))
 794
 795   (pass-if "internal defines with empty begin"
 796     (false-if-exception
 797      (eval '(let ((a identity) (b identity) (c identity))
 798               (define (a x) (if (= x 0) 'a (b (- x 1))))
 799               (begin)
 800               (define (b x) (if (= x 0) 'b (c (- x 1))))
 801               (define (c x) (if (= x 0) 'c (a (- x 1))))
 802               (and (eq? 'a (a 0) (a 3))
 803                    (eq? 'b (a 1) (a 4))
 804                    (eq? 'c (a 2) (a 5))))
 805            (interaction-environment))))
 806
 807   (pass-if "internal defines with macro application"
 808     (false-if-exception
 809      (eval '(begin
 810               (defmacro my-define forms
 811                 (cons 'define forms))
 812               (let ((a identity) (b identity) (c identity))
 813                 (define (a x) (if (= x 0) 'a (b (- x 1))))
 814                 (my-define (b x) (if (= x 0) 'b (c (- x 1))))
 815                 (define (c x) (if (= x 0) 'c (a (- x 1))))
 816                 (and (eq? 'a (a 0) (a 3))
 817                      (eq? 'b (a 1) (a 4))
 818                      (eq? 'c (a 2) (a 5)))))
 819            (interaction-environment))))
 820
 821   (pass-if-exception "missing body expression"
 822     exception:missing-body-expr
 823     (eval '(let () (define x #t))
 824           (interaction-environment)))
 825
 826   (pass-if "unmemoization"
 827     (eval '(begin
 828              (define (foo)
 829                (define (bar)
 830                  'ok)
 831                (bar))
 832              (foo)
 833              (equal?
 834               (procedure-source foo)
 835               '(lambda () (letrec ((bar (lambda () (quote ok)))) (bar)))))
 836           (interaction-environment))))
 837
 838 (with-test-prefix "do"
 839
 840   (with-test-prefix "unmemoization"
 841
 842     (pass-if "normal case"
 843       (let ((foo (lambda () (do ((i 1 (+ i 1)) (j 2))
 844                                 ((> i 9) (+ i j))
 845                               (identity i)))))
 846         (foo) ; make sure, memoization has been performed
 847         (equal? (procedure-source foo)
 848                 '(lambda () (do ((i 1 (+ i 1)) (j 2))
 849                                 ((> i 9) (+ i j))
 850                               (identity i))))))
 851
 852     (pass-if "reduced case"
 853       (let ((foo (lambda () (do ((i 1 (+ i 1)) (j 2 j)) ; redundant step for j
 854                                 ((> i 9) (+ i j))
 855                               (identity i)))))
 856         (foo) ; make sure, memoization has been performed
 857         (equal? (procedure-source foo)
 858                 '(lambda () (do ((i 1 (+ i 1)) (j 2)) ; no redundancy here
 859                                 ((> i 9) (+ i j))
 860                               (identity i))))))))
 861
 862 (with-test-prefix "set!"
 863
 864   (with-test-prefix "unmemoization"
 865
 866     (pass-if "normal set!"
 867       (let ((foo (lambda (x) (set! x (+ 1 x)))))
 868         (foo 1) ; make sure, memoization has been performed
 869         (equal? (procedure-source foo)
 870                 '(lambda (x) (set! x (+ 1 x)))))))
 871
 872   (with-test-prefix "missing or extra expressions"
 873
 874     (pass-if-exception "(set!)"
 875       exception:missing/extra-expr
 876       (eval '(set!)
 877             (interaction-environment)))
 878
 879     (pass-if-exception "(set! 1)"
 880       exception:missing/extra-expr
 881       (eval '(set! 1)
 882             (interaction-environment)))
 883
 884     (pass-if-exception "(set! 1 2 3)"
 885       exception:missing/extra-expr
 886       (eval '(set! 1 2 3)
 887             (interaction-environment))))
 888
 889   (with-test-prefix "bad variable"
 890
 891     (pass-if-exception "(set! \"\" #t)"
 892       exception:bad-variable
 893       (eval '(set! "" #t)
 894             (interaction-environment)))
 895
 896     (pass-if-exception "(set! 1 #t)"
 897       exception:bad-variable
 898       (eval '(set! 1 #t)
 899             (interaction-environment)))
 900
 901     (pass-if-exception "(set! #t #f)"
 902       exception:bad-variable
 903       (eval '(set! #t #f)
 904             (interaction-environment)))
 905
 906     (pass-if-exception "(set! #f #t)"
 907       exception:bad-variable
 908       (eval '(set! #f #t)
 909             (interaction-environment)))
 910
 911     (pass-if-exception "(set! #\\space #f)"
 912       exception:bad-variable
 913       (eval '(set! #\space #f)
 914             (interaction-environment)))))
 915
 916 (with-test-prefix "quote"
 917
 918   (with-test-prefix "missing or extra expression"
 919
 920     (pass-if-exception "(quote)"
 921       exception:missing/extra-expr
 922       (eval '(quote)
 923             (interaction-environment)))
 924
 925     (pass-if-exception "(quote a b)"
 926       exception:missing/extra-expr
 927       (eval '(quote a b)
 928             (interaction-environment)))))
 929
 930 (with-test-prefix "while"
 931
 932   (define (unreachable)
 933     (error "unreachable code has been reached!"))
 934
 935   ;; Return a new procedure COND which when called (COND) will return #t the
 936   ;; first N times, then #f, then any further call is an error.  N=0 is
 937   ;; allowed, in which case #f is returned by the first call.
 938   (define (make-iterations-cond n)
 939     (lambda ()
 940       (cond ((not n)
 941              (error "oops, condition re-tested after giving false"))
 942             ((= 0 n)
 943              (set! n #f)
 944              #f)
 945             (else
 946              (set! n (1- n))
 947              #t))))
 948
 949
 950   (pass-if-exception "too few args" exception:wrong-num-args
 951     (eval '(while) (interaction-environment)))
 952
 953   (with-test-prefix "empty body"
 954     (do ((n 0 (1+ n)))
 955         ((> n 5))
 956       (pass-if n
 957         (let ((cond (make-iterations-cond n)))
 958           (while (cond)))
 959         #t)))
 960
 961   (pass-if "initially false"
 962     (while #f
 963       (unreachable))
 964     #t)
 965
 966   (with-test-prefix "in empty environment"
 967
 968     ;; an environment with no bindings at all
 969     (define empty-environment
 970       (make-module 1))
 971
 972     ;; these tests are 'unresolved because to work with ice-9 syncase it was
 973     ;; necessary to drop the unquote from `do' in the implementation, and
 974     ;; unfortunately that makes `while' depend on its evaluation environment
 975
 976     (pass-if "empty body"
 977       (throw 'unresolved)
 978       (eval `(,while #f)
 979             empty-environment)
 980       #t)
 981
 982     (pass-if "initially false"
 983       (throw 'unresolved)
 984       (eval `(,while #f
 985                #f)
 986             empty-environment)
 987       #t)
 988
 989     (pass-if "iterating"
 990       (throw 'unresolved)
 991       (let ((cond (make-iterations-cond 3)))
 992         (eval `(,while (,cond)
 993                  123 456)
 994               empty-environment))
 995       #t))
 996
 997   (with-test-prefix "iterations"
 998     (do ((n 0 (1+ n)))
 999         ((> n 5))
1000       (pass-if n
1001         (let ((cond (make-iterations-cond n))
1002               (i    0))
1003           (while (cond)
1004             (set! i (1+ i)))
1005           (= i n)))))
1006
1007   (with-test-prefix "break"
1008
1009     (pass-if-exception "too many args" exception:wrong-num-args
1010       (while #t
1011         (break 1)))
1012
1013     (with-test-prefix "from cond"
1014       (pass-if "first"
1015         (while (begin
1016                  (break)
1017                  (unreachable))
1018           (unreachable))
1019         #t)
1020
1021       (do ((n 0 (1+ n)))
1022           ((> n 5))
1023         (pass-if n
1024           (let ((cond (make-iterations-cond n))
1025                 (i    0))
1026             (while (if (cond)
1027                        #t
1028                        (begin
1029                          (break)
1030                          (unreachable)))
1031               (set! i (1+ i)))
1032             (= i n)))))
1033
1034     (with-test-prefix "from body"
1035       (pass-if "first"
1036         (while #t
1037           (break)
1038           (unreachable))
1039         #t)
1040
1041       (do ((n 0 (1+ n)))
1042           ((> n 5))
1043         (pass-if n
1044           (let ((cond (make-iterations-cond n))
1045                 (i    0))
1046             (while #t
1047               (if (not (cond))
1048                   (begin
1049                     (break)
1050                     (unreachable)))
1051               (set! i (1+ i)))
1052             (= i n)))))
1053
1054     (pass-if "from nested"
1055       (while #t
1056         (let ((outer-break break))
1057           (while #t
1058             (outer-break)
1059             (unreachable)))
1060         (unreachable))
1061       #t)
1062
1063     (pass-if "from recursive"
1064       (let ((outer-break #f))
1065         (define (r n)
1066           (while #t
1067             (if (eq? n 'outer)
1068                 (begin
1069                   (set! outer-break break)
1070                   (r 'inner))
1071                 (begin
1072                   (outer-break)
1073                   (unreachable))))
1074           (if (eq? n 'inner)
1075               (error "broke only from inner loop")))
1076         (r 'outer))
1077       #t))
1078
1079   (with-test-prefix "continue"
1080
1081     (pass-if-exception "too many args" exception:wrong-num-args
1082       (while #t
1083         (continue 1)))
1084
1085     (with-test-prefix "from cond"
1086       (do ((n 0 (1+ n)))
1087           ((> n 5))
1088         (pass-if n
1089           (let ((cond (make-iterations-cond n))
1090                 (i    0))
1091             (while (if (cond)
1092                        (begin
1093                          (set! i (1+ i))
1094                          (continue)
1095                          (unreachable))
1096                        #f)
1097               (unreachable))
1098             (= i n)))))
1099
1100     (with-test-prefix "from body"
1101       (do ((n 0 (1+ n)))
1102           ((> n 5))
1103         (pass-if n
1104           (let ((cond (make-iterations-cond n))
1105                 (i    0))
1106             (while (cond)
1107               (set! i (1+ i))
1108               (continue)
1109               (unreachable))
1110             (= i n)))))
1111
1112     (pass-if "from nested"
1113       (let ((cond (make-iterations-cond 3)))
1114         (while (cond)
1115           (let ((outer-continue continue))
1116             (while #t
1117               (outer-continue)
1118               (unreachable)))))
1119       #t)
1120
1121     (pass-if "from recursive"
1122       (let ((outer-continue #f))
1123         (define (r n)
1124           (let ((cond  (make-iterations-cond 3))
1125                 (first #t))
1126             (while (begin
1127                      (if (and (not first)
1128                               (eq? n 'inner))
1129                          (error "continued only to inner loop"))
1130                      (cond))
1131               (set! first #f)
1132               (if (eq? n 'outer)
1133                   (begin
1134                     (set! outer-continue continue)
1135                     (r 'inner))
1136                   (begin
1137                     (outer-continue)
1138                     (unreachable))))))
1139         (r 'outer))
1140       #t)))