guile18/test-suite/tests/syntax.test

   1 ;;;; syntax.test --- test suite for Guile's syntactic forms    -*- scheme -*-
   2 ;;;;
   3 ;;;; Copyright (C) 2001,2003,2004, 2005, 2006 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 "SRFI-61"
 561
 562     (pass-if "always available"
 563       (cond-expand (srfi-61 #t) (else #f)))
 564
 565     (pass-if "single value consequent"
 566       (eq? 'ok (cond (#t identity => (lambda (x) 'ok)) (else #f))))
 567
 568     (pass-if "single value alternate"
 569       (eq? 'ok (cond (#t not => (lambda (x) #f)) (else 'ok))))
 570
 571     (pass-if-exception "doesn't affect standard =>"
 572       exception:wrong-num-args
 573       (cond ((values 1 2) => (lambda (x y) #t))))
 574
 575     (pass-if "multiple values consequent"
 576       (equal? '(2 1) (cond ((values 1 2)
 577                             (lambda (one two)
 578                               (and (= 1 one) (= 2 two))) =>
 579                             (lambda (one two) (list two one)))
 580                            (else #f))))
 581
 582     (pass-if "multiple values alternate"
 583       (eq? 'ok (cond ((values 2 3 4)
 584                       (lambda args (equal? '(1 2 3) args)) =>
 585                       (lambda (x y z) #f))
 586                      (else 'ok))))
 587
 588     (pass-if "zero values"
 589       (eq? 'ok (cond ((values) (lambda () #t) => (lambda () 'ok))
 590                      (else #f))))
 591
 592     (pass-if "bound => is handled correctly"
 593       (let ((=> 'ok))
 594         (eq? 'ok (cond (#t identity =>) (else #f)))))
 595
 596     (pass-if-exception "missing recipient"
 597       '(syntax-error . "Missing recipient")
 598       (cond (#t identity =>)))
 599
 600     (pass-if-exception "extra recipient"
 601       '(syntax-error . "Extra expression")
 602       (cond (#t identity => identity identity))))
 603
 604   (with-test-prefix "unmemoization"
 605
 606     (pass-if "normal clauses"
 607       (let ((foo (lambda (x) (cond ((= x 1) 'bar) ((= x 2) 'baz)))))
 608         (foo 1) ; make sure, memoization has been performed
 609         (foo 2) ; make sure, memoization has been performed
 610         (equal? (procedure-source foo)
 611                 '(lambda (x) (cond ((= x 1) 'bar) ((= x 2) 'baz))))))
 612
 613     (pass-if "else"
 614       (let ((foo (lambda () (cond (else 'bar)))))
 615         (foo) ; make sure, memoization has been performed
 616         (equal? (procedure-source foo)
 617                 '(lambda () (cond (else 'bar))))))
 618
 619     (pass-if "=>"
 620       (let ((foo (lambda () (cond (#t => identity)))))
 621         (foo) ; make sure, memoization has been performed
 622         (equal? (procedure-source foo)
 623                 '(lambda () (cond (#t => identity)))))))
 624
 625   (with-test-prefix "bad or missing clauses"
 626
 627     (pass-if-exception "(cond)"
 628       exception:missing-clauses
 629       (eval '(cond)
 630             (interaction-environment)))
 631
 632     (pass-if-exception "(cond #t)"
 633       exception:bad-cond-clause
 634       (eval '(cond #t)
 635             (interaction-environment)))
 636
 637     (pass-if-exception "(cond 1)"
 638       exception:bad-cond-clause
 639       (eval '(cond 1)
 640             (interaction-environment)))
 641
 642     (pass-if-exception "(cond 1 2)"
 643       exception:bad-cond-clause
 644       (eval '(cond 1 2)
 645             (interaction-environment)))
 646
 647     (pass-if-exception "(cond 1 2 3)"
 648       exception:bad-cond-clause
 649       (eval '(cond 1 2 3)
 650             (interaction-environment)))
 651
 652     (pass-if-exception "(cond 1 2 3 4)"
 653       exception:bad-cond-clause
 654       (eval '(cond 1 2 3 4)
 655             (interaction-environment)))
 656
 657     (pass-if-exception "(cond ())"
 658       exception:bad-cond-clause
 659       (eval '(cond ())
 660             (interaction-environment)))
 661
 662     (pass-if-exception "(cond () 1)"
 663       exception:bad-cond-clause
 664       (eval '(cond () 1)
 665             (interaction-environment)))
 666
 667     (pass-if-exception "(cond (1) 1)"
 668       exception:bad-cond-clause
 669       (eval '(cond (1) 1)
 670             (interaction-environment))))
 671
 672   (with-test-prefix "wrong number of arguments"
 673
 674     (pass-if-exception "=> (lambda (x y) #t)"
 675       exception:wrong-num-args
 676       (cond (1 => (lambda (x y) #t))))))
 677
 678 (with-test-prefix "case"
 679
 680   (pass-if "clause with empty labels list"
 681     (case 1 (() #f) (else #t)))
 682
 683   (with-test-prefix "case is hygienic"
 684
 685     (pass-if-exception "bound 'else is handled correctly"
 686       exception:bad-case-labels
 687       (eval '(let ((else #f)) (case 1 (else #f)))
 688             (interaction-environment))))
 689
 690   (with-test-prefix "unmemoization"
 691
 692     (pass-if "normal clauses"
 693       (let ((foo (lambda (x) (case x ((1) 'bar) ((2) 'baz) (else 'foobar)))))
 694         (foo 1) ; make sure, memoization has been performed
 695         (foo 2) ; make sure, memoization has been performed
 696         (foo 3) ; make sure, memoization has been performed
 697         (equal? (procedure-source foo)
 698                 '(lambda (x) (case x ((1) 'bar) ((2) 'baz) (else 'foobar))))))
 699
 700     (pass-if "empty labels"
 701       (let ((foo (lambda (x) (case x ((1) 'bar) (() 'baz) (else 'foobar)))))
 702         (foo 1) ; make sure, memoization has been performed
 703         (foo 2) ; make sure, memoization has been performed
 704         (foo 3) ; make sure, memoization has been performed
 705         (equal? (procedure-source foo)
 706                 '(lambda (x) (case x ((1) 'bar) (() 'baz) (else 'foobar)))))))
 707
 708   (with-test-prefix "bad or missing clauses"
 709
 710     (pass-if-exception "(case)"
 711       exception:missing-clauses
 712       (eval '(case)
 713             (interaction-environment)))
 714
 715     (pass-if-exception "(case . \"foo\")"
 716       exception:bad-expression
 717       (eval '(case . "foo")
 718             (interaction-environment)))
 719
 720     (pass-if-exception "(case 1)"
 721       exception:missing-clauses
 722       (eval '(case 1)
 723             (interaction-environment)))
 724
 725     (pass-if-exception "(case 1 . \"foo\")"
 726       exception:bad-expression
 727       (eval '(case 1 . "foo")
 728             (interaction-environment)))
 729
 730     (pass-if-exception "(case 1 \"foo\")"
 731       exception:bad-case-clause
 732       (eval '(case 1 "foo")
 733             (interaction-environment)))
 734
 735     (pass-if-exception "(case 1 ())"
 736       exception:bad-case-clause
 737       (eval '(case 1 ())
 738             (interaction-environment)))
 739
 740     (pass-if-exception "(case 1 (\"foo\"))"
 741       exception:bad-case-clause
 742       (eval '(case 1 ("foo"))
 743             (interaction-environment)))
 744
 745     (pass-if-exception "(case 1 (\"foo\" \"bar\"))"
 746       exception:bad-case-labels
 747       (eval '(case 1 ("foo" "bar"))
 748             (interaction-environment)))
 749
 750     (pass-if-exception "(case 1 ((2) \"bar\") . \"foo\")"
 751       exception:bad-expression
 752       (eval '(case 1 ((2) "bar") . "foo")
 753             (interaction-environment)))
 754
 755     (pass-if-exception "(case 1 ((2) \"bar\") (else))"
 756       exception:bad-case-clause
 757       (eval '(case 1 ((2) "bar") (else))
 758             (interaction-environment)))
 759
 760     (pass-if-exception "(case 1 (else #f) . \"foo\")"
 761       exception:bad-expression
 762       (eval '(case 1 (else #f) . "foo")
 763             (interaction-environment)))
 764
 765     (pass-if-exception "(case 1 (else #f) ((1) #t))"
 766       exception:misplaced-else-clause
 767       (eval '(case 1 (else #f) ((1) #t))
 768             (interaction-environment)))))
 769
 770 (with-test-prefix "top-level define"
 771
 772   (pass-if "redefinition"
 773     (let ((m (make-module)))
 774       (beautify-user-module! m)
 775
 776       ;; The previous value of `round' must still be visible at the time the
 777       ;; new `round' is defined.  According to R5RS (Section 5.2.1), `define'
 778       ;; should behave like `set!' in this case (except that in the case of
 779       ;; Guile, we respect module boundaries).
 780       (eval '(define round round) m)
 781       (eq? (module-ref m 'round) round)))
 782
 783   (with-test-prefix "currying"
 784
 785     (pass-if "(define ((foo)) #f)"
 786       (eval '(begin
 787                (define ((foo)) #t)
 788                ((foo)))
 789             (interaction-environment))))
 790
 791   (with-test-prefix "unmemoization"
 792
 793     (pass-if "definition unmemoized without prior execution"
 794       (eval '(begin
 795                (define (blub) (cons ('(1 . 2)) 2))
 796                (equal?
 797                  (procedure-source blub)
 798                  '(lambda () (cons ('(1 . 2)) 2))))
 799             (interaction-environment)))
 800
 801     (pass-if "definition with documentation unmemoized without prior execution"
 802       (eval '(begin
 803                (define (blub) "Comment" (cons ('(1 . 2)) 2))
 804                (equal?
 805                  (procedure-source blub)
 806                  '(lambda () "Comment" (cons ('(1 . 2)) 2))))
 807             (interaction-environment))))
 808
 809   (with-test-prefix "missing or extra expressions"
 810
 811     (pass-if-exception "(define)"
 812       exception:missing-expr
 813       (eval '(define)
 814             (interaction-environment)))))
 815
 816 (with-test-prefix "internal define"
 817
 818   (pass-if "internal defines become letrec"
 819     (eval '(let ((a identity) (b identity) (c identity))
 820              (define (a x) (if (= x 0) 'a (b (- x 1))))
 821              (define (b x) (if (= x 0) 'b (c (- x 1))))
 822              (define (c x) (if (= x 0) 'c (a (- x 1))))
 823              (and (eq? 'a (a 0) (a 3))
 824                   (eq? 'b (a 1) (a 4))
 825                   (eq? 'c (a 2) (a 5))))
 826           (interaction-environment)))
 827
 828   (pass-if "binding is created before expression is evaluated"
 829     ;; Internal defines are equivalent to `letrec' (R5RS, Section 5.2.2).
 830     (= (eval '(let ()
 831                 (define foo
 832                   (begin
 833                     (set! foo 1)
 834                     (+ foo 1)))
 835                 foo)
 836              (interaction-environment))
 837        2))
 838
 839   (pass-if "internal defines with begin"
 840     (false-if-exception
 841      (eval '(let ((a identity) (b identity) (c identity))
 842               (define (a x) (if (= x 0) 'a (b (- x 1))))
 843               (begin
 844                 (define (b x) (if (= x 0) 'b (c (- x 1)))))
 845               (define (c x) (if (= x 0) 'c (a (- x 1))))
 846               (and (eq? 'a (a 0) (a 3))
 847                    (eq? 'b (a 1) (a 4))
 848                    (eq? 'c (a 2) (a 5))))
 849            (interaction-environment))))
 850
 851   (pass-if "internal defines with empty begin"
 852     (false-if-exception
 853      (eval '(let ((a identity) (b identity) (c identity))
 854               (define (a x) (if (= x 0) 'a (b (- x 1))))
 855               (begin)
 856               (define (b x) (if (= x 0) 'b (c (- x 1))))
 857               (define (c x) (if (= x 0) 'c (a (- x 1))))
 858               (and (eq? 'a (a 0) (a 3))
 859                    (eq? 'b (a 1) (a 4))
 860                    (eq? 'c (a 2) (a 5))))
 861            (interaction-environment))))
 862
 863   (pass-if "internal defines with macro application"
 864     (false-if-exception
 865      (eval '(begin
 866               (defmacro my-define forms
 867                 (cons 'define forms))
 868               (let ((a identity) (b identity) (c identity))
 869                 (define (a x) (if (= x 0) 'a (b (- x 1))))
 870                 (my-define (b x) (if (= x 0) 'b (c (- x 1))))
 871                 (define (c x) (if (= x 0) 'c (a (- x 1))))
 872                 (and (eq? 'a (a 0) (a 3))
 873                      (eq? 'b (a 1) (a 4))
 874                      (eq? 'c (a 2) (a 5)))))
 875            (interaction-environment))))
 876
 877   (pass-if-exception "missing body expression"
 878     exception:missing-body-expr
 879     (eval '(let () (define x #t))
 880           (interaction-environment)))
 881
 882   (pass-if "unmemoization"
 883     (eval '(begin
 884              (define (foo)
 885                (define (bar)
 886                  'ok)
 887                (bar))
 888              (foo)
 889              (equal?
 890               (procedure-source foo)
 891               '(lambda () (letrec ((bar (lambda () (quote ok)))) (bar)))))
 892           (interaction-environment))))
 893
 894 (with-test-prefix "do"
 895
 896   (with-test-prefix "unmemoization"
 897
 898     (pass-if "normal case"
 899       (let ((foo (lambda () (do ((i 1 (+ i 1)) (j 2))
 900                                 ((> i 9) (+ i j))
 901                               (identity i)))))
 902         (foo) ; make sure, memoization has been performed
 903         (equal? (procedure-source foo)
 904                 '(lambda () (do ((i 1 (+ i 1)) (j 2))
 905                                 ((> i 9) (+ i j))
 906                               (identity i))))))
 907
 908     (pass-if "reduced case"
 909       (let ((foo (lambda () (do ((i 1 (+ i 1)) (j 2 j)) ; redundant step for j
 910                                 ((> i 9) (+ i j))
 911                               (identity i)))))
 912         (foo) ; make sure, memoization has been performed
 913         (equal? (procedure-source foo)
 914                 '(lambda () (do ((i 1 (+ i 1)) (j 2)) ; no redundancy here
 915                                 ((> i 9) (+ i j))
 916                               (identity i))))))))
 917
 918 (with-test-prefix "set!"
 919
 920   (with-test-prefix "unmemoization"
 921
 922     (pass-if "normal set!"
 923       (let ((foo (lambda (x) (set! x (+ 1 x)))))
 924         (foo 1) ; make sure, memoization has been performed
 925         (equal? (procedure-source foo)
 926                 '(lambda (x) (set! x (+ 1 x)))))))
 927
 928   (with-test-prefix "missing or extra expressions"
 929
 930     (pass-if-exception "(set!)"
 931       exception:missing/extra-expr
 932       (eval '(set!)
 933             (interaction-environment)))
 934
 935     (pass-if-exception "(set! 1)"
 936       exception:missing/extra-expr
 937       (eval '(set! 1)
 938             (interaction-environment)))
 939
 940     (pass-if-exception "(set! 1 2 3)"
 941       exception:missing/extra-expr
 942       (eval '(set! 1 2 3)
 943             (interaction-environment))))
 944
 945   (with-test-prefix "bad variable"
 946
 947     (pass-if-exception "(set! \"\" #t)"
 948       exception:bad-variable
 949       (eval '(set! "" #t)
 950             (interaction-environment)))
 951
 952     (pass-if-exception "(set! 1 #t)"
 953       exception:bad-variable
 954       (eval '(set! 1 #t)
 955             (interaction-environment)))
 956
 957     (pass-if-exception "(set! #t #f)"
 958       exception:bad-variable
 959       (eval '(set! #t #f)
 960             (interaction-environment)))
 961
 962     (pass-if-exception "(set! #f #t)"
 963       exception:bad-variable
 964       (eval '(set! #f #t)
 965             (interaction-environment)))
 966
 967     (pass-if-exception "(set! #\\space #f)"
 968       exception:bad-variable
 969       (eval '(set! #\space #f)
 970             (interaction-environment)))))
 971
 972 (with-test-prefix "quote"
 973
 974   (with-test-prefix "missing or extra expression"
 975
 976     (pass-if-exception "(quote)"
 977       exception:missing/extra-expr
 978       (eval '(quote)
 979             (interaction-environment)))
 980
 981     (pass-if-exception "(quote a b)"
 982       exception:missing/extra-expr
 983       (eval '(quote a b)
 984             (interaction-environment)))))
 985
 986 (with-test-prefix "while"
 987
 988   (define (unreachable)
 989     (error "unreachable code has been reached!"))
 990
 991   ;; Return a new procedure COND which when called (COND) will return #t the
 992   ;; first N times, then #f, then any further call is an error.  N=0 is
 993   ;; allowed, in which case #f is returned by the first call.
 994   (define (make-iterations-cond n)
 995     (lambda ()
 996       (cond ((not n)
 997              (error "oops, condition re-tested after giving false"))
 998             ((= 0 n)
 999              (set! n #f)
1000              #f)
1001             (else
1002              (set! n (1- n))
1003              #t))))
1004
1005
1006   (pass-if-exception "too few args" exception:wrong-num-args
1007     (eval '(while) (interaction-environment)))
1008
1009   (with-test-prefix "empty body"
1010     (do ((n 0 (1+ n)))
1011         ((> n 5))
1012       (pass-if n
1013         (let ((cond (make-iterations-cond n)))
1014           (while (cond)))
1015         #t)))
1016
1017   (pass-if "initially false"
1018     (while #f
1019       (unreachable))
1020     #t)
1021
1022   (with-test-prefix "in empty environment"
1023
1024     ;; an environment with no bindings at all
1025     (define empty-environment
1026       (make-module 1))
1027
1028     ;; these tests are 'unresolved because to work with ice-9 syncase it was
1029     ;; necessary to drop the unquote from `do' in the implementation, and
1030     ;; unfortunately that makes `while' depend on its evaluation environment
1031
1032     (pass-if "empty body"
1033       (throw 'unresolved)
1034       (eval `(,while #f)
1035             empty-environment)
1036       #t)
1037
1038     (pass-if "initially false"
1039       (throw 'unresolved)
1040       (eval `(,while #f
1041                #f)
1042             empty-environment)
1043       #t)
1044
1045     (pass-if "iterating"
1046       (throw 'unresolved)
1047       (let ((cond (make-iterations-cond 3)))
1048         (eval `(,while (,cond)
1049                  123 456)
1050               empty-environment))
1051       #t))
1052
1053   (with-test-prefix "iterations"
1054     (do ((n 0 (1+ n)))
1055         ((> n 5))
1056       (pass-if n
1057         (let ((cond (make-iterations-cond n))
1058               (i    0))
1059           (while (cond)
1060             (set! i (1+ i)))
1061           (= i n)))))
1062
1063   (with-test-prefix "break"
1064
1065     (pass-if-exception "too many args" exception:wrong-num-args
1066       (while #t
1067         (break 1)))
1068
1069     (with-test-prefix "from cond"
1070       (pass-if "first"
1071         (while (begin
1072                  (break)
1073                  (unreachable))
1074           (unreachable))
1075         #t)
1076
1077       (do ((n 0 (1+ n)))
1078           ((> n 5))
1079         (pass-if n
1080           (let ((cond (make-iterations-cond n))
1081                 (i    0))
1082             (while (if (cond)
1083                        #t
1084                        (begin
1085                          (break)
1086                          (unreachable)))
1087               (set! i (1+ i)))
1088             (= i n)))))
1089
1090     (with-test-prefix "from body"
1091       (pass-if "first"
1092         (while #t
1093           (break)
1094           (unreachable))
1095         #t)
1096
1097       (do ((n 0 (1+ n)))
1098           ((> n 5))
1099         (pass-if n
1100           (let ((cond (make-iterations-cond n))
1101                 (i    0))
1102             (while #t
1103               (if (not (cond))
1104                   (begin
1105                     (break)
1106                     (unreachable)))
1107               (set! i (1+ i)))
1108             (= i n)))))
1109
1110     (pass-if "from nested"
1111       (while #t
1112         (let ((outer-break break))
1113           (while #t
1114             (outer-break)
1115             (unreachable)))
1116         (unreachable))
1117       #t)
1118
1119     (pass-if "from recursive"
1120       (let ((outer-break #f))
1121         (define (r n)
1122           (while #t
1123             (if (eq? n 'outer)
1124                 (begin
1125                   (set! outer-break break)
1126                   (r 'inner))
1127                 (begin
1128                   (outer-break)
1129                   (unreachable))))
1130           (if (eq? n 'inner)
1131               (error "broke only from inner loop")))
1132         (r 'outer))
1133       #t))
1134
1135   (with-test-prefix "continue"
1136
1137     (pass-if-exception "too many args" exception:wrong-num-args
1138       (while #t
1139         (continue 1)))
1140
1141     (with-test-prefix "from cond"
1142       (do ((n 0 (1+ n)))
1143           ((> n 5))
1144         (pass-if n
1145           (let ((cond (make-iterations-cond n))
1146                 (i    0))
1147             (while (if (cond)
1148                        (begin
1149                          (set! i (1+ i))
1150                          (continue)
1151                          (unreachable))
1152                        #f)
1153               (unreachable))
1154             (= i n)))))
1155
1156     (with-test-prefix "from body"
1157       (do ((n 0 (1+ n)))
1158           ((> n 5))
1159         (pass-if n
1160           (let ((cond (make-iterations-cond n))
1161                 (i    0))
1162             (while (cond)
1163               (set! i (1+ i))
1164               (continue)
1165               (unreachable))
1166             (= i n)))))
1167
1168     (pass-if "from nested"
1169       (let ((cond (make-iterations-cond 3)))
1170         (while (cond)
1171           (let ((outer-continue continue))
1172             (while #t
1173               (outer-continue)
1174               (unreachable)))))
1175       #t)
1176
1177     (pass-if "from recursive"
1178       (let ((outer-continue #f))
1179         (define (r n)
1180           (let ((cond  (make-iterations-cond 3))
1181                 (first #t))
1182             (while (begin
1183                      (if (and (not first)
1184                               (eq? n 'inner))
1185                          (error "continued only to inner loop"))
1186                      (cond))
1187               (set! first #f)
1188               (if (eq? n 'outer)
1189                   (begin
1190                     (set! outer-continue continue)
1191                     (r 'inner))
1192                   (begin
1193                     (outer-continue)
1194                     (unreachable))))))
1195         (r 'outer))
1196       #t)))