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, 2009, 2010, 2011 Free Software Foundation, Inc.
   4 ;;;;
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library 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 GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 (define-module (test-suite test-syntax)
  20   #:use-module (ice-9 regex)
  21   #:use-module (test-suite lib))
  22
  23
  24 (define exception:generic-syncase-error
  25   "source expression failed to match")
  26 (define exception:unexpected-syntax
  27   "unexpected syntax")
  28
  29 (define exception:bad-expression
  30   "Bad expression")
  31
  32 (define exception:missing/extra-expr
  33   "Missing or extra expression")
  34 (define exception:missing-expr
  35   "Missing expression")
  36 (define exception:missing-body-expr
  37   "no expressions in body")
  38 (define exception:extra-expr
  39   "Extra expression")
  40 (define exception:illegal-empty-combination
  41   "Illegal empty combination")
  42
  43 (define exception:bad-lambda
  44   "bad lambda")
  45 (define exception:bad-let
  46   "bad let$")
  47 (define exception:bad-letrec
  48   "bad letrec$")
  49 (define exception:bad-letrec*
  50   "bad letrec\\*$")
  51 (define exception:bad-set!
  52   "bad set!")
  53 (define exception:bad-quote
  54   '(quote . "bad syntax"))
  55 (define exception:bad-bindings
  56   "Bad bindings")
  57 (define exception:bad-binding
  58   "Bad binding")
  59 (define exception:duplicate-binding
  60   "duplicate bound variable")
  61 (define exception:bad-body
  62   "^bad body")
  63 (define exception:bad-formals
  64   "invalid argument list")
  65 (define exception:bad-formal
  66   "Bad formal")
  67 (define exception:duplicate-formals
  68   "duplicate identifier in argument list")
  69
  70 (define exception:missing-clauses
  71   "Missing clauses")
  72 (define exception:misplaced-else-clause
  73   "Misplaced else clause")
  74 (define exception:bad-case-clause
  75   "Bad case clause")
  76 (define exception:bad-case-labels
  77   "Bad case labels")
  78 (define exception:bad-cond-clause
  79   "Bad cond clause")
  80
  81 (define exception:too-many-args
  82   "too many arguments")
  83
  84
  85 ;; (put 'pass-if-syntax-error 'scheme-indent-function 1)
  86 (define-syntax pass-if-syntax-error
  87   (syntax-rules ()
  88     ((_ name pat exp)
  89      (pass-if name
  90        (catch 'syntax-error
  91          (lambda () exp (error "expected uri-error exception"))
  92          (lambda (k who what where form . maybe-subform)
  93            (if (if (pair? pat)
  94                    (and (eq? who (car pat))
  95                         (string-match (cdr pat) what))
  96                    (string-match pat what))
  97                #t
  98                (error "unexpected syntax-error exception" what pat))))))))
  99
 100 (with-test-prefix "expressions"
 101
 102   (with-test-prefix "Bad argument list"
 103
 104     (pass-if-syntax-error "improper argument list of length 1"
 105       exception:generic-syncase-error
 106       (eval '(let ((foo (lambda (x y) #t)))
 107                (foo . 1))
 108             (interaction-environment)))
 109
 110     (pass-if-syntax-error "improper argument list of length 2"
 111       exception:generic-syncase-error
 112       (eval '(let ((foo (lambda (x y) #t)))
 113                (foo 1 . 2))
 114             (interaction-environment))))
 115
 116   (with-test-prefix "missing or extra expression"
 117
 118     ;; R5RS says:
 119     ;; *Note:* In many dialects of Lisp, the empty combination, (),
 120     ;; is a legitimate expression.  In Scheme, combinations must
 121     ;; have at least one subexpression, so () is not a syntactically
 122     ;; valid expression.
 123
 124     ;; Fixed on 2001-3-3
 125     (pass-if-syntax-error "empty parentheses \"()\""
 126       exception:unexpected-syntax
 127       (eval '()
 128             (interaction-environment)))))
 129
 130 (with-test-prefix "quote"
 131   #t)
 132
 133 (with-test-prefix "quasiquote"
 134
 135   (with-test-prefix "unquote"
 136
 137     (pass-if "repeated execution"
 138       (let ((foo (let ((i 0)) (lambda () (set! i (+ i 1)) `(,i)))))
 139         (and (equal? (foo) '(1)) (equal? (foo) '(2))))))
 140
 141   (with-test-prefix "unquote-splicing"
 142
 143     (pass-if "extra arguments"
 144       (equal? (eval '(quasiquote ((unquote-splicing (list 1 2) (list 3 4))))
 145                     (interaction-environment))
 146               '(1 2 3 4)))))
 147
 148 (with-test-prefix "begin"
 149
 150   (pass-if "legal (begin)"
 151     (eval '(begin (begin) #t) (interaction-environment)))
 152
 153   (pass-if-syntax-error "illegal (begin)"
 154     exception:generic-syncase-error
 155     (eval '(begin (if #t (begin)) #t) (interaction-environment))))
 156
 157 (define-syntax matches?
 158   (syntax-rules (<>)
 159     ((_ (op arg ...) pat)   (let ((x (op arg ...)))
 160                               (matches? x pat)))
 161     ((_ x ())               (null? x))
 162     ((_ x (a . b))          (and (pair? x)
 163                                  (matches? (car x) a)
 164                                  (matches? (cdr x) b)))
 165     ((_ x <>)                #t)
 166     ((_ x pat)              (equal? x 'pat))))
 167
 168 (with-test-prefix "lambda"
 169
 170   (with-test-prefix "bad formals"
 171
 172     (pass-if-syntax-error "(lambda)"
 173       exception:bad-lambda
 174       (eval '(lambda)
 175             (interaction-environment)))
 176
 177     (pass-if-syntax-error "(lambda . \"foo\")"
 178       exception:bad-lambda
 179       (eval '(lambda . "foo")
 180             (interaction-environment)))
 181
 182     (pass-if-syntax-error "(lambda \"foo\")"
 183       exception:bad-lambda
 184       (eval '(lambda "foo")
 185             (interaction-environment)))
 186
 187     (pass-if-syntax-error "(lambda \"foo\" #f)"
 188       exception:bad-formals
 189       (eval '(lambda "foo" #f)
 190             (interaction-environment)))
 191
 192     (pass-if-syntax-error "(lambda (x 1) 2)"
 193       exception:bad-formals
 194       (eval '(lambda (x 1) 2)
 195             (interaction-environment)))
 196
 197     (pass-if-syntax-error "(lambda (1 x) 2)"
 198       exception:bad-formals
 199       (eval '(lambda (1 x) 2)
 200             (interaction-environment)))
 201
 202     (pass-if-syntax-error "(lambda (x \"a\") 2)"
 203       exception:bad-formals
 204       (eval '(lambda (x "a") 2)
 205             (interaction-environment)))
 206
 207     (pass-if-syntax-error "(lambda (\"a\" x) 2)"
 208       exception:bad-formals
 209       (eval '(lambda ("a" x) 2)
 210             (interaction-environment))))
 211
 212   (with-test-prefix "duplicate formals"
 213
 214     ;; Fixed on 2001-3-3
 215     (pass-if-syntax-error "(lambda (x x) 1)"
 216       exception:duplicate-formals
 217       (eval '(lambda (x x) 1)
 218             (interaction-environment)))
 219
 220     ;; Fixed on 2001-3-3
 221     (pass-if-syntax-error "(lambda (x x x) 1)"
 222       exception:duplicate-formals
 223       (eval '(lambda (x x x) 1)
 224             (interaction-environment))))
 225
 226   (with-test-prefix "bad body"
 227
 228     (pass-if-syntax-error "(lambda ())"
 229       exception:bad-lambda
 230       (eval '(lambda ())
 231             (interaction-environment)))))
 232
 233 (with-test-prefix "let"
 234
 235   (with-test-prefix "bindings"
 236
 237     (pass-if-exception "late binding"
 238       exception:unbound-var
 239       (let ((x 1) (y x)) y)))
 240
 241   (with-test-prefix "bad bindings"
 242
 243     (pass-if-syntax-error "(let)"
 244       exception:bad-let
 245       (eval '(let)
 246             (interaction-environment)))
 247
 248     (pass-if-syntax-error "(let 1)"
 249       exception:bad-let
 250       (eval '(let 1)
 251             (interaction-environment)))
 252
 253     (pass-if-syntax-error "(let (x))"
 254       exception:bad-let
 255       (eval '(let (x))
 256             (interaction-environment)))
 257
 258     (pass-if-syntax-error "(let ((x)))"
 259       exception:bad-let
 260       (eval '(let ((x)))
 261             (interaction-environment)))
 262
 263     (pass-if-syntax-error "(let (x) 1)"
 264       exception:bad-let
 265       (eval '(let (x) 1)
 266             (interaction-environment)))
 267
 268     (pass-if-syntax-error "(let ((x)) 3)"
 269       exception:bad-let
 270       (eval '(let ((x)) 3)
 271             (interaction-environment)))
 272
 273     (pass-if-syntax-error "(let ((x 1) y) x)"
 274       exception:bad-let
 275       (eval '(let ((x 1) y) x)
 276             (interaction-environment)))
 277
 278     (pass-if-syntax-error "(let ((1 2)) 3)"
 279       exception:bad-let
 280       (eval '(let ((1 2)) 3)
 281             (interaction-environment))))
 282
 283   (with-test-prefix "duplicate bindings"
 284
 285     (pass-if-syntax-error "(let ((x 1) (x 2)) x)"
 286       exception:duplicate-binding
 287       (eval '(let ((x 1) (x 2)) x)
 288             (interaction-environment))))
 289
 290   (with-test-prefix "bad body"
 291
 292     (pass-if-syntax-error "(let ())"
 293       exception:bad-let
 294       (eval '(let ())
 295             (interaction-environment)))
 296
 297     (pass-if-syntax-error "(let ((x 1)))"
 298       exception:bad-let
 299       (eval '(let ((x 1)))
 300             (interaction-environment)))))
 301
 302 (with-test-prefix "named let"
 303
 304   (with-test-prefix "initializers"
 305
 306     (pass-if "evaluated in outer environment"
 307       (let ((f -))
 308         (eqv? (let f ((n (f 1))) n) -1))))
 309
 310   (with-test-prefix "bad bindings"
 311
 312     (pass-if-syntax-error "(let x (y))"
 313       exception:bad-let
 314       (eval '(let x (y))
 315             (interaction-environment))))
 316
 317   (with-test-prefix "bad body"
 318
 319     (pass-if-syntax-error "(let x ())"
 320       exception:bad-let
 321       (eval '(let x ())
 322             (interaction-environment)))
 323
 324     (pass-if-syntax-error "(let x ((y 1)))"
 325       exception:bad-let
 326       (eval '(let x ((y 1)))
 327             (interaction-environment)))))
 328
 329 (with-test-prefix "let*"
 330
 331   (with-test-prefix "bindings"
 332
 333     (pass-if "(let* ((x 1) (x 2)) ...)"
 334       (let* ((x 1) (x 2))
 335         (= x 2)))
 336
 337     (pass-if "(let* ((x 1) (x x)) ...)"
 338       (let* ((x 1) (x x))
 339         (= x 1)))
 340
 341     (pass-if "(let ((x 1) (y 2)) (let* () ...))"
 342       (let ((x 1) (y 2))
 343         (let* ()
 344           (and (= x 1) (= y 2))))))
 345
 346   (with-test-prefix "bad bindings"
 347
 348     (pass-if-syntax-error "(let*)"
 349       exception:generic-syncase-error
 350       (eval '(let*)
 351             (interaction-environment)))
 352
 353     (pass-if-syntax-error "(let* 1)"
 354       exception:generic-syncase-error
 355       (eval '(let* 1)
 356             (interaction-environment)))
 357
 358     (pass-if-syntax-error "(let* (x))"
 359       exception:generic-syncase-error
 360       (eval '(let* (x))
 361             (interaction-environment)))
 362
 363     (pass-if-syntax-error "(let* (x) 1)"
 364       exception:generic-syncase-error
 365       (eval '(let* (x) 1)
 366             (interaction-environment)))
 367
 368     (pass-if-syntax-error "(let* ((x)) 3)"
 369       exception:generic-syncase-error
 370       (eval '(let* ((x)) 3)
 371             (interaction-environment)))
 372
 373     (pass-if-syntax-error "(let* ((x 1) y) x)"
 374       exception:generic-syncase-error
 375       (eval '(let* ((x 1) y) x)
 376             (interaction-environment)))
 377
 378     (pass-if-syntax-error "(let* x ())"
 379       exception:generic-syncase-error
 380       (eval '(let* x ())
 381             (interaction-environment)))
 382
 383     (pass-if-syntax-error "(let* x (y))"
 384       exception:generic-syncase-error
 385       (eval '(let* x (y))
 386             (interaction-environment)))
 387
 388     (pass-if-syntax-error "(let* ((1 2)) 3)"
 389       exception:generic-syncase-error
 390       (eval '(let* ((1 2)) 3)
 391             (interaction-environment))))
 392
 393   (with-test-prefix "bad body"
 394
 395     (pass-if-syntax-error "(let* ())"
 396       exception:generic-syncase-error
 397       (eval '(let* ())
 398             (interaction-environment)))
 399
 400     (pass-if-syntax-error "(let* ((x 1)))"
 401       exception:generic-syncase-error
 402       (eval '(let* ((x 1)))
 403             (interaction-environment)))))
 404
 405 (with-test-prefix "letrec"
 406
 407   (with-test-prefix "bindings"
 408
 409     (pass-if-syntax-error "initial bindings are undefined"
 410       exception:used-before-defined
 411       (let ((x 1))
 412         ;; FIXME: the memoizer does initialize the var to undefined, but
 413         ;; the Scheme evaluator has no way of checking what's an
 414         ;; undefined value. Not sure how to do this.
 415         (throw 'unresolved)
 416         (letrec ((x 1) (y x)) y))))
 417
 418   (with-test-prefix "bad bindings"
 419
 420     (pass-if-syntax-error "(letrec)"
 421       exception:bad-letrec
 422       (eval '(letrec)
 423             (interaction-environment)))
 424
 425     (pass-if-syntax-error "(letrec 1)"
 426       exception:bad-letrec
 427       (eval '(letrec 1)
 428             (interaction-environment)))
 429
 430     (pass-if-syntax-error "(letrec (x))"
 431       exception:bad-letrec
 432       (eval '(letrec (x))
 433             (interaction-environment)))
 434
 435     (pass-if-syntax-error "(letrec (x) 1)"
 436       exception:bad-letrec
 437       (eval '(letrec (x) 1)
 438             (interaction-environment)))
 439
 440     (pass-if-syntax-error "(letrec ((x)) 3)"
 441       exception:bad-letrec
 442       (eval '(letrec ((x)) 3)
 443             (interaction-environment)))
 444
 445     (pass-if-syntax-error "(letrec ((x 1) y) x)"
 446       exception:bad-letrec
 447       (eval '(letrec ((x 1) y) x)
 448             (interaction-environment)))
 449
 450     (pass-if-syntax-error "(letrec x ())"
 451       exception:bad-letrec
 452       (eval '(letrec x ())
 453             (interaction-environment)))
 454
 455     (pass-if-syntax-error "(letrec x (y))"
 456       exception:bad-letrec
 457       (eval '(letrec x (y))
 458             (interaction-environment)))
 459
 460     (pass-if-syntax-error "(letrec ((1 2)) 3)"
 461       exception:bad-letrec
 462       (eval '(letrec ((1 2)) 3)
 463             (interaction-environment))))
 464
 465   (with-test-prefix "duplicate bindings"
 466
 467     (pass-if-syntax-error "(letrec ((x 1) (x 2)) x)"
 468       exception:duplicate-binding
 469       (eval '(letrec ((x 1) (x 2)) x)
 470             (interaction-environment))))
 471
 472   (with-test-prefix "bad body"
 473
 474     (pass-if-syntax-error "(letrec ())"
 475       exception:bad-letrec
 476       (eval '(letrec ())
 477             (interaction-environment)))
 478
 479     (pass-if-syntax-error "(letrec ((x 1)))"
 480       exception:bad-letrec
 481       (eval '(letrec ((x 1)))
 482             (interaction-environment)))))
 483
 484 (with-test-prefix "letrec*"
 485
 486   (with-test-prefix "bindings"
 487
 488     (pass-if-syntax-error "initial bindings are undefined"
 489       exception:used-before-defined
 490       (begin
 491         ;; FIXME: the memoizer does initialize the var to undefined, but
 492         ;; the Scheme evaluator has no way of checking what's an
 493         ;; undefined value. Not sure how to do this.
 494         (throw 'unresolved)
 495         (letrec* ((x y) (y 1)) y))))
 496
 497   (with-test-prefix "bad bindings"
 498
 499     (pass-if-syntax-error "(letrec*)"
 500       exception:bad-letrec*
 501       (eval '(letrec*)
 502             (interaction-environment)))
 503
 504     (pass-if-syntax-error "(letrec* 1)"
 505       exception:bad-letrec*
 506       (eval '(letrec* 1)
 507             (interaction-environment)))
 508
 509     (pass-if-syntax-error "(letrec* (x))"
 510       exception:bad-letrec*
 511       (eval '(letrec* (x))
 512             (interaction-environment)))
 513
 514     (pass-if-syntax-error "(letrec* (x) 1)"
 515       exception:bad-letrec*
 516       (eval '(letrec* (x) 1)
 517             (interaction-environment)))
 518
 519     (pass-if-syntax-error "(letrec* ((x)) 3)"
 520       exception:bad-letrec*
 521       (eval '(letrec* ((x)) 3)
 522             (interaction-environment)))
 523
 524     (pass-if-syntax-error "(letrec* ((x 1) y) x)"
 525       exception:bad-letrec*
 526       (eval '(letrec* ((x 1) y) x)
 527             (interaction-environment)))
 528
 529     (pass-if-syntax-error "(letrec* x ())"
 530       exception:bad-letrec*
 531       (eval '(letrec* x ())
 532             (interaction-environment)))
 533
 534     (pass-if-syntax-error "(letrec* x (y))"
 535       exception:bad-letrec*
 536       (eval '(letrec* x (y))
 537             (interaction-environment)))
 538
 539     (pass-if-syntax-error "(letrec* ((1 2)) 3)"
 540       exception:bad-letrec*
 541       (eval '(letrec* ((1 2)) 3)
 542             (interaction-environment))))
 543
 544   (with-test-prefix "duplicate bindings"
 545
 546     (pass-if-syntax-error "(letrec* ((x 1) (x 2)) x)"
 547       exception:duplicate-binding
 548       (eval '(letrec* ((x 1) (x 2)) x)
 549             (interaction-environment))))
 550
 551   (with-test-prefix "bad body"
 552
 553     (pass-if-syntax-error "(letrec* ())"
 554       exception:bad-letrec*
 555       (eval '(letrec* ())
 556             (interaction-environment)))
 557
 558     (pass-if-syntax-error "(letrec* ((x 1)))"
 559       exception:bad-letrec*
 560       (eval '(letrec* ((x 1)))
 561             (interaction-environment))))
 562
 563   (with-test-prefix "referencing previous values"
 564     (pass-if (equal? (letrec ((a (cons 'foo 'bar))
 565                               (b a))
 566                        b)
 567                      '(foo . bar)))
 568     (pass-if (equal? (let ()
 569                        (define a (cons 'foo 'bar))
 570                        (define b a)
 571                        b)
 572                      '(foo . bar)))))
 573
 574 (with-test-prefix "if"
 575
 576   (with-test-prefix "missing or extra expressions"
 577
 578     (pass-if-syntax-error "(if)"
 579       exception:generic-syncase-error
 580       (eval '(if)
 581             (interaction-environment)))
 582
 583     (pass-if-syntax-error "(if 1 2 3 4)"
 584       exception:generic-syncase-error
 585       (eval '(if 1 2 3 4)
 586             (interaction-environment)))))
 587
 588 (with-test-prefix "cond"
 589
 590   (with-test-prefix "cond is hygienic"
 591
 592     (pass-if "bound 'else is handled correctly"
 593       (eq? (let ((else 'ok)) (cond (else))) 'ok))
 594
 595     (with-test-prefix "bound '=> is handled correctly"
 596
 597       (pass-if "#t => 'ok"
 598         (let ((=> 'foo))
 599           (eq? (cond (#t => 'ok)) 'ok)))
 600
 601       (pass-if "else =>"
 602         (let ((=> 'foo))
 603           (eq? (cond (else =>)) 'foo)))
 604
 605       (pass-if "else => identity"
 606         (let ((=> 'foo))
 607           (eq? (cond (else => identity)) identity)))))
 608
 609   (with-test-prefix "SRFI-61"
 610
 611     (pass-if "always available"
 612       (cond-expand (srfi-61 #t) (else #f)))
 613
 614     (pass-if "single value consequent"
 615       (eq? 'ok (cond (#t identity => (lambda (x) 'ok)) (else #f))))
 616
 617     (pass-if "single value alternate"
 618       (eq? 'ok (cond (#t not => (lambda (x) #f)) (else 'ok))))
 619
 620     (pass-if-exception "doesn't affect standard =>"
 621       exception:wrong-num-args
 622       (cond ((values 1 2) => (lambda (x y) #t))))
 623
 624     (pass-if "multiple values consequent"
 625       (equal? '(2 1) (cond ((values 1 2)
 626                             (lambda (one two)
 627                               (and (= 1 one) (= 2 two))) =>
 628                             (lambda (one two) (list two one)))
 629                            (else #f))))
 630
 631     (pass-if "multiple values alternate"
 632       (eq? 'ok (cond ((values 2 3 4)
 633                       (lambda args (equal? '(1 2 3) args)) =>
 634                       (lambda (x y z) #f))
 635                      (else 'ok))))
 636
 637     (pass-if "zero values"
 638       (eq? 'ok (cond ((values) (lambda () #t) => (lambda () 'ok))
 639                      (else #f))))
 640
 641     (pass-if "bound => is handled correctly"
 642       (let ((=> 'ok))
 643         (eq? 'ok (cond (#t identity =>) (else #f)))))
 644
 645     (pass-if-syntax-error "missing recipient"
 646       '(cond . "wrong number of receiver expressions")
 647       (cond (#t identity =>)))
 648
 649     (pass-if-syntax-error "extra recipient"
 650       '(cond . "wrong number of receiver expressions")
 651       (cond (#t identity => identity identity))))
 652
 653   (with-test-prefix "bad or missing clauses"
 654
 655     (pass-if-syntax-error "(cond)"
 656       exception:generic-syncase-error
 657       (eval '(cond)
 658             (interaction-environment)))
 659
 660     (pass-if-syntax-error "(cond #t)"
 661       exception:generic-syncase-error
 662       (eval '(cond #t)
 663             (interaction-environment)))
 664
 665     (pass-if-syntax-error "(cond 1)"
 666       exception:generic-syncase-error
 667       (eval '(cond 1)
 668             (interaction-environment)))
 669
 670     (pass-if-syntax-error "(cond 1 2)"
 671       exception:generic-syncase-error
 672       (eval '(cond 1 2)
 673             (interaction-environment)))
 674
 675     (pass-if-syntax-error "(cond 1 2 3)"
 676       exception:generic-syncase-error
 677       (eval '(cond 1 2 3)
 678             (interaction-environment)))
 679
 680     (pass-if-syntax-error "(cond 1 2 3 4)"
 681       exception:generic-syncase-error
 682       (eval '(cond 1 2 3 4)
 683             (interaction-environment)))
 684
 685     (pass-if-syntax-error "(cond ())"
 686       exception:generic-syncase-error
 687       (eval '(cond ())
 688             (interaction-environment)))
 689
 690     (pass-if-syntax-error "(cond () 1)"
 691       exception:generic-syncase-error
 692       (eval '(cond () 1)
 693             (interaction-environment)))
 694
 695     (pass-if-syntax-error "(cond (1) 1)"
 696       exception:generic-syncase-error
 697       (eval '(cond (1) 1)
 698             (interaction-environment))))
 699
 700   (with-test-prefix "wrong number of arguments"
 701
 702     (pass-if-exception "=> (lambda (x y) #t)"
 703       exception:wrong-num-args
 704       (cond (1 => (lambda (x y) #t))))))
 705
 706 (with-test-prefix "case"
 707
 708   (pass-if "clause with empty labels list"
 709     (case 1 (() #f) (else #t)))
 710
 711   (with-test-prefix "case is hygienic"
 712
 713     (pass-if-syntax-error "bound 'else is handled correctly"
 714       exception:generic-syncase-error
 715       (eval '(let ((else #f)) (case 1 (else #f)))
 716             (interaction-environment))))
 717
 718   (with-test-prefix "bad or missing clauses"
 719
 720     (pass-if-syntax-error "(case)"
 721       exception:generic-syncase-error
 722       (eval '(case)
 723             (interaction-environment)))
 724
 725     (pass-if-syntax-error "(case . \"foo\")"
 726       exception:generic-syncase-error
 727       (eval '(case . "foo")
 728             (interaction-environment)))
 729
 730     (pass-if-syntax-error "(case 1)"
 731       exception:generic-syncase-error
 732       (eval '(case 1)
 733             (interaction-environment)))
 734
 735     (pass-if-syntax-error "(case 1 . \"foo\")"
 736       exception:generic-syncase-error
 737       (eval '(case 1 . "foo")
 738             (interaction-environment)))
 739
 740     (pass-if-syntax-error "(case 1 \"foo\")"
 741       exception:generic-syncase-error
 742       (eval '(case 1 "foo")
 743             (interaction-environment)))
 744
 745     (pass-if-syntax-error "(case 1 ())"
 746       exception:generic-syncase-error
 747       (eval '(case 1 ())
 748             (interaction-environment)))
 749
 750     (pass-if-syntax-error "(case 1 (\"foo\"))"
 751       exception:generic-syncase-error
 752       (eval '(case 1 ("foo"))
 753             (interaction-environment)))
 754
 755     (pass-if-syntax-error "(case 1 (\"foo\" \"bar\"))"
 756       exception:generic-syncase-error
 757       (eval '(case 1 ("foo" "bar"))
 758             (interaction-environment)))
 759
 760     (pass-if-syntax-error "(case 1 ((2) \"bar\") . \"foo\")"
 761       exception:generic-syncase-error
 762       (eval '(case 1 ((2) "bar") . "foo")
 763             (interaction-environment)))
 764
 765     (pass-if-syntax-error "(case 1 ((2) \"bar\") (else))"
 766       exception:generic-syncase-error
 767       (eval '(case 1 ((2) "bar") (else))
 768             (interaction-environment)))
 769
 770     (pass-if-syntax-error "(case 1 (else #f) . \"foo\")"
 771       exception:generic-syncase-error
 772       (eval '(case 1 (else #f) . "foo")
 773             (interaction-environment)))
 774
 775     (pass-if-syntax-error "(case 1 (else #f) ((1) #t))"
 776       exception:generic-syncase-error
 777       (eval '(case 1 (else #f) ((1) #t))
 778             (interaction-environment)))))
 779
 780 (with-test-prefix "top-level define"
 781
 782   (pass-if "redefinition"
 783     (let ((m (make-module)))
 784       (beautify-user-module! m)
 785
 786       ;; The previous value of `round' must still be visible at the time the
 787       ;; new `round' is defined.  According to R5RS (Section 5.2.1), `define'
 788       ;; should behave like `set!' in this case (except that in the case of
 789       ;; Guile, we respect module boundaries).
 790       (eval '(define round round) m)
 791       (eq? (module-ref m 'round) round)))
 792
 793   (with-test-prefix "missing or extra expressions"
 794
 795     (pass-if-syntax-error "(define)"
 796       exception:generic-syncase-error
 797       (eval '(define)
 798             (interaction-environment)))))
 799
 800 (with-test-prefix "internal define"
 801
 802   (pass-if "internal defines become letrec"
 803     (eval '(let ((a identity) (b identity) (c identity))
 804              (define (a x) (if (= x 0) 'a (b (- x 1))))
 805              (define (b x) (if (= x 0) 'b (c (- x 1))))
 806              (define (c x) (if (= x 0) 'c (a (- x 1))))
 807              (and (eq? 'a (a 0) (a 3))
 808                   (eq? 'b (a 1) (a 4))
 809                   (eq? 'c (a 2) (a 5))))
 810           (interaction-environment)))
 811
 812   (pass-if "binding is created before expression is evaluated"
 813     ;; Internal defines are equivalent to `letrec' (R5RS, Section 5.2.2).
 814     (= (eval '(let ()
 815                 (define foo
 816                   (begin
 817                     (set! foo 1)
 818                     (+ foo 1)))
 819                 foo)
 820              (interaction-environment))
 821        2))
 822
 823   (pass-if "internal defines with begin"
 824     (false-if-exception
 825      (eval '(let ((a identity) (b identity) (c identity))
 826               (define (a x) (if (= x 0) 'a (b (- x 1))))
 827               (begin
 828                 (define (b x) (if (= x 0) 'b (c (- x 1)))))
 829               (define (c x) (if (= x 0) 'c (a (- x 1))))
 830               (and (eq? 'a (a 0) (a 3))
 831                    (eq? 'b (a 1) (a 4))
 832                    (eq? 'c (a 2) (a 5))))
 833            (interaction-environment))))
 834
 835   (pass-if "internal defines with empty begin"
 836     (false-if-exception
 837      (eval '(let ((a identity) (b identity) (c identity))
 838               (define (a x) (if (= x 0) 'a (b (- x 1))))
 839               (begin)
 840               (define (b x) (if (= x 0) 'b (c (- x 1))))
 841               (define (c x) (if (= x 0) 'c (a (- x 1))))
 842               (and (eq? 'a (a 0) (a 3))
 843                    (eq? 'b (a 1) (a 4))
 844                    (eq? 'c (a 2) (a 5))))
 845            (interaction-environment))))
 846
 847   (pass-if "internal defines with macro application"
 848     (false-if-exception
 849      (eval '(begin
 850               (defmacro my-define forms
 851                 (cons 'define forms))
 852               (let ((a identity) (b identity) (c identity))
 853                 (define (a x) (if (= x 0) 'a (b (- x 1))))
 854                 (my-define (b x) (if (= x 0) 'b (c (- x 1))))
 855                 (define (c x) (if (= x 0) 'c (a (- x 1))))
 856                 (and (eq? 'a (a 0) (a 3))
 857                      (eq? 'b (a 1) (a 4))
 858                      (eq? 'c (a 2) (a 5)))))
 859            (interaction-environment))))
 860
 861   (pass-if-syntax-error "missing body expression"
 862     exception:missing-body-expr
 863     (eval '(let () (define x #t))
 864           (interaction-environment))))
 865
 866 (with-test-prefix "set!"
 867
 868   (with-test-prefix "missing or extra expressions"
 869
 870     (pass-if-syntax-error "(set!)"
 871       exception:bad-set!
 872       (eval '(set!)
 873             (interaction-environment)))
 874
 875     (pass-if-syntax-error "(set! 1)"
 876       exception:bad-set!
 877       (eval '(set! 1)
 878             (interaction-environment)))
 879
 880     (pass-if-syntax-error "(set! 1 2 3)"
 881       exception:bad-set!
 882       (eval '(set! 1 2 3)
 883             (interaction-environment))))
 884
 885   (with-test-prefix "bad variable"
 886
 887     (pass-if-syntax-error "(set! \"\" #t)"
 888       exception:bad-set!
 889       (eval '(set! "" #t)
 890             (interaction-environment)))
 891
 892     (pass-if-syntax-error "(set! 1 #t)"
 893       exception:bad-set!
 894       (eval '(set! 1 #t)
 895             (interaction-environment)))
 896
 897     (pass-if-syntax-error "(set! #t #f)"
 898       exception:bad-set!
 899       (eval '(set! #t #f)
 900             (interaction-environment)))
 901
 902     (pass-if-syntax-error "(set! #f #t)"
 903       exception:bad-set!
 904       (eval '(set! #f #t)
 905             (interaction-environment)))
 906
 907     (pass-if-syntax-error "(set! #\\space #f)"
 908       exception:bad-set!
 909       (eval '(set! #\space #f)
 910             (interaction-environment)))))
 911
 912 (with-test-prefix "quote"
 913
 914   (with-test-prefix "missing or extra expression"
 915
 916     (pass-if-syntax-error "(quote)"
 917       exception:bad-quote
 918       (eval '(quote)
 919             (interaction-environment)))
 920
 921     (pass-if-syntax-error "(quote a b)"
 922       exception:bad-quote
 923       (eval '(quote a b)
 924             (interaction-environment)))))
 925
 926 (with-test-prefix "while"
 927
 928   (define (unreachable)
 929     (error "unreachable code has been reached!"))
 930
 931   ;; Return a new procedure COND which when called (COND) will return #t the
 932   ;; first N times, then #f, then any further call is an error.  N=0 is
 933   ;; allowed, in which case #f is returned by the first call.
 934   (define (make-iterations-cond n)
 935     (lambda ()
 936       (cond ((not n)
 937              (error "oops, condition re-tested after giving false"))
 938             ((= 0 n)
 939              (set! n #f)
 940              #f)
 941             (else
 942              (set! n (1- n))
 943              #t))))
 944
 945
 946   (pass-if-syntax-error "too few args" exception:generic-syncase-error
 947     (eval '(while) (interaction-environment)))
 948
 949   (with-test-prefix "empty body"
 950     (do ((n 0 (1+ n)))
 951         ((> n 5))
 952       (pass-if n
 953         (eval `(letrec ((make-iterations-cond
 954                          (lambda (n)
 955                            (lambda ()
 956                              (cond ((not n)
 957                                     (error "oops, condition re-tested after giving false"))
 958                                    ((= 0 n)
 959                                     (set! n #f)
 960                                     #f)
 961                                    (else
 962                                     (set! n (1- n))
 963                                     #t))))))
 964                  (let ((cond (make-iterations-cond ,n)))
 965                    (while (cond))
 966                    #t))
 967               (interaction-environment)))))
 968
 969   (pass-if "initially false"
 970     (while #f
 971       (unreachable))
 972     #t)
 973
 974   (with-test-prefix "iterations"
 975     (do ((n 0 (1+ n)))
 976         ((> n 5))
 977       (pass-if n
 978         (let ((cond (make-iterations-cond n))
 979               (i    0))
 980           (while (cond)
 981             (set! i (1+ i)))
 982           (= i n)))))
 983
 984   (with-test-prefix "break"
 985
 986     (pass-if "normal return"
 987       (not (while #f (error "not reached"))))
 988
 989     (pass-if "no args"
 990       (while #t (break)))
 991
 992     (pass-if "multiple values"
 993       (equal? '(1 2 3)
 994               (call-with-values
 995                   (lambda () (while #t (break 1 2 3)))
 996                 list)))
 997
 998     (with-test-prefix "from cond"
 999       (pass-if "first"
1000         (while (begin
1001                  (break)
1002                  (unreachable))
1003           (unreachable))
1004         #t)
1005
1006       (do ((n 0 (1+ n)))
1007           ((> n 5))
1008         (pass-if n
1009           (let ((cond (make-iterations-cond n))
1010                 (i    0))
1011             (while (if (cond)
1012                        #t
1013                        (begin
1014                          (break)
1015                          (unreachable)))
1016               (set! i (1+ i)))
1017             (= i n)))))
1018
1019     (with-test-prefix "from body"
1020       (pass-if "first"
1021         (while #t
1022           (break)
1023           (unreachable))
1024         #t)
1025
1026       (do ((n 0 (1+ n)))
1027           ((> n 5))
1028         (pass-if n
1029           (let ((cond (make-iterations-cond n))
1030                 (i    0))
1031             (while #t
1032               (if (not (cond))
1033                   (begin
1034                     (break)
1035                     (unreachable)))
1036               (set! i (1+ i)))
1037             (= i n)))))
1038
1039     (pass-if "from nested"
1040       (while #t
1041         (let ((outer-break break))
1042           (while #t
1043             (outer-break)
1044             (unreachable)))
1045         (unreachable))
1046       #t)
1047
1048     (pass-if "from recursive"
1049       (let ((outer-break #f))
1050         (define (r n)
1051           (while #t
1052             (if (eq? n 'outer)
1053                 (begin
1054                   (set! outer-break break)
1055                   (r 'inner))
1056                 (begin
1057                   (outer-break)
1058                   (unreachable))))
1059           (if (eq? n 'inner)
1060               (error "broke only from inner loop")))
1061         (r 'outer))
1062       #t))
1063
1064   (with-test-prefix "continue"
1065
1066     (pass-if-syntax-error "too many args" exception:too-many-args
1067       (eval '(while #t
1068                (continue 1))
1069             (interaction-environment)))
1070
1071     (with-test-prefix "from cond"
1072       (do ((n 0 (1+ n)))
1073           ((> n 5))
1074         (pass-if n
1075           (let ((cond (make-iterations-cond n))
1076                 (i    0))
1077             (while (if (cond)
1078                        (begin
1079                          (set! i (1+ i))
1080                          (continue)
1081                          (unreachable))
1082                        #f)
1083               (unreachable))
1084             (= i n)))))
1085
1086     (with-test-prefix "from body"
1087       (do ((n 0 (1+ n)))
1088           ((> n 5))
1089         (pass-if n
1090           (let ((cond (make-iterations-cond n))
1091                 (i    0))
1092             (while (cond)
1093               (set! i (1+ i))
1094               (continue)
1095               (unreachable))
1096             (= i n)))))
1097
1098     (pass-if "from nested"
1099       (let ((cond (make-iterations-cond 3)))
1100         (while (cond)
1101           (let ((outer-continue continue))
1102             (while #t
1103               (outer-continue)
1104               (unreachable)))))
1105       #t)
1106
1107     (pass-if "from recursive"
1108       (let ((outer-continue #f))
1109         (define (r n)
1110           (let ((cond  (make-iterations-cond 3))
1111                 (first #t))
1112             (while (begin
1113                      (if (and (not first)
1114                               (eq? n 'inner))
1115                          (error "continued only to inner loop"))
1116                      (cond))
1117               (set! first #f)
1118               (if (eq? n 'outer)
1119                   (begin
1120                     (set! outer-continue continue)
1121                     (r 'inner))
1122                   (begin
1123                     (outer-continue)
1124                     (unreachable))))))
1125         (r 'outer))
1126       #t)))