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   (pass-if "module scoping"
 801     (equal?
 802      (eval
 803       '(begin
 804          (define-module (top-level-define/module-scoping-1)
 805            #:export (define-10))
 806          (define-syntax-rule (define-10 name)
 807            (begin
 808              (define t 10)
 809              (define (name) t)))
 810          (define-module (top-level-define/module-scoping-2)
 811            #:use-module (top-level-define/module-scoping-1))
 812          (define-10 foo)
 813          (foo))
 814       (current-module))
 815      10))
 816
 817   (pass-if "module scoping, same symbolic name"
 818     (equal?
 819      (eval
 820       '(begin
 821          (define-module (top-level-define/module-scoping-3))
 822          (define a 10)
 823          (define-module (top-level-define/module-scoping-4)
 824            #:use-module (top-level-define/module-scoping-3))
 825          (define a (@@ (top-level-define/module-scoping-3) a))
 826          a)
 827       (current-module))
 828      10))
 829
 830   (pass-if "module scoping, introduced names"
 831     (equal?
 832      (eval
 833       '(begin
 834          (define-module (top-level-define/module-scoping-5)
 835            #:export (define-constant))
 836          (define-syntax-rule (define-constant name val)
 837            (begin
 838              (define t val)
 839              (define (name) t)))
 840          (define-module (top-level-define/module-scoping-6)
 841            #:use-module (top-level-define/module-scoping-5))
 842          (define-constant foo 10)
 843          (define-constant bar 20)
 844          (foo))
 845       (current-module))
 846      10))
 847
 848   (pass-if "module scoping, duplicate introduced name"
 849     (equal?
 850      (eval
 851       '(begin
 852          (define-module (top-level-define/module-scoping-7)
 853            #:export (define-constant))
 854          (define-syntax-rule (define-constant name val)
 855            (begin
 856              (define t val)
 857              (define (name) t)))
 858          (define-module (top-level-define/module-scoping-8)
 859            #:use-module (top-level-define/module-scoping-7))
 860          (define-constant foo 10)
 861          (define-constant foo 20)
 862          (foo))
 863       (current-module))
 864      20)))
 865
 866 (with-test-prefix "internal define"
 867
 868   (pass-if "internal defines become letrec"
 869     (eval '(let ((a identity) (b identity) (c identity))
 870              (define (a x) (if (= x 0) 'a (b (- x 1))))
 871              (define (b x) (if (= x 0) 'b (c (- x 1))))
 872              (define (c x) (if (= x 0) 'c (a (- x 1))))
 873              (and (eq? 'a (a 0) (a 3))
 874                   (eq? 'b (a 1) (a 4))
 875                   (eq? 'c (a 2) (a 5))))
 876           (interaction-environment)))
 877
 878   (pass-if "binding is created before expression is evaluated"
 879     ;; Internal defines are equivalent to `letrec' (R5RS, Section 5.2.2).
 880     (= (eval '(let ()
 881                 (define foo
 882                   (begin
 883                     (set! foo 1)
 884                     (+ foo 1)))
 885                 foo)
 886              (interaction-environment))
 887        2))
 888
 889   (pass-if "internal defines with begin"
 890     (false-if-exception
 891      (eval '(let ((a identity) (b identity) (c identity))
 892               (define (a x) (if (= x 0) 'a (b (- x 1))))
 893               (begin
 894                 (define (b x) (if (= x 0) 'b (c (- x 1)))))
 895               (define (c x) (if (= x 0) 'c (a (- x 1))))
 896               (and (eq? 'a (a 0) (a 3))
 897                    (eq? 'b (a 1) (a 4))
 898                    (eq? 'c (a 2) (a 5))))
 899            (interaction-environment))))
 900
 901   (pass-if "internal defines with empty begin"
 902     (false-if-exception
 903      (eval '(let ((a identity) (b identity) (c identity))
 904               (define (a x) (if (= x 0) 'a (b (- x 1))))
 905               (begin)
 906               (define (b x) (if (= x 0) 'b (c (- x 1))))
 907               (define (c x) (if (= x 0) 'c (a (- x 1))))
 908               (and (eq? 'a (a 0) (a 3))
 909                    (eq? 'b (a 1) (a 4))
 910                    (eq? 'c (a 2) (a 5))))
 911            (interaction-environment))))
 912
 913   (pass-if "internal defines with macro application"
 914     (false-if-exception
 915      (eval '(begin
 916               (defmacro my-define forms
 917                 (cons 'define forms))
 918               (let ((a identity) (b identity) (c identity))
 919                 (define (a x) (if (= x 0) 'a (b (- x 1))))
 920                 (my-define (b x) (if (= x 0) 'b (c (- x 1))))
 921                 (define (c x) (if (= x 0) 'c (a (- x 1))))
 922                 (and (eq? 'a (a 0) (a 3))
 923                      (eq? 'b (a 1) (a 4))
 924                      (eq? 'c (a 2) (a 5)))))
 925            (interaction-environment))))
 926
 927   (pass-if-syntax-error "missing body expression"
 928     exception:missing-body-expr
 929     (eval '(let () (define x #t))
 930           (interaction-environment))))
 931
 932 (with-test-prefix "set!"
 933
 934   (with-test-prefix "missing or extra expressions"
 935
 936     (pass-if-syntax-error "(set!)"
 937       exception:bad-set!
 938       (eval '(set!)
 939             (interaction-environment)))
 940
 941     (pass-if-syntax-error "(set! 1)"
 942       exception:bad-set!
 943       (eval '(set! 1)
 944             (interaction-environment)))
 945
 946     (pass-if-syntax-error "(set! 1 2 3)"
 947       exception:bad-set!
 948       (eval '(set! 1 2 3)
 949             (interaction-environment))))
 950
 951   (with-test-prefix "bad variable"
 952
 953     (pass-if-syntax-error "(set! \"\" #t)"
 954       exception:bad-set!
 955       (eval '(set! "" #t)
 956             (interaction-environment)))
 957
 958     (pass-if-syntax-error "(set! 1 #t)"
 959       exception:bad-set!
 960       (eval '(set! 1 #t)
 961             (interaction-environment)))
 962
 963     (pass-if-syntax-error "(set! #t #f)"
 964       exception:bad-set!
 965       (eval '(set! #t #f)
 966             (interaction-environment)))
 967
 968     (pass-if-syntax-error "(set! #f #t)"
 969       exception:bad-set!
 970       (eval '(set! #f #t)
 971             (interaction-environment)))
 972
 973     (pass-if-syntax-error "(set! #\\space #f)"
 974       exception:bad-set!
 975       (eval '(set! #\space #f)
 976             (interaction-environment)))))
 977
 978 (with-test-prefix "quote"
 979
 980   (with-test-prefix "missing or extra expression"
 981
 982     (pass-if-syntax-error "(quote)"
 983       exception:bad-quote
 984       (eval '(quote)
 985             (interaction-environment)))
 986
 987     (pass-if-syntax-error "(quote a b)"
 988       exception:bad-quote
 989       (eval '(quote a b)
 990             (interaction-environment)))))
 991
 992 (with-test-prefix "while"
 993
 994   (define (unreachable)
 995     (error "unreachable code has been reached!"))
 996
 997   ;; Return a new procedure COND which when called (COND) will return #t the
 998   ;; first N times, then #f, then any further call is an error.  N=0 is
 999   ;; allowed, in which case #f is returned by the first call.
1000   (define (make-iterations-cond n)
1001     (lambda ()
1002       (cond ((not n)
1003              (error "oops, condition re-tested after giving false"))
1004             ((= 0 n)
1005              (set! n #f)
1006              #f)
1007             (else
1008              (set! n (1- n))
1009              #t))))
1010
1011
1012   (pass-if-syntax-error "too few args" exception:generic-syncase-error
1013     (eval '(while) (interaction-environment)))
1014
1015   (with-test-prefix "empty body"
1016     (do ((n 0 (1+ n)))
1017         ((> n 5))
1018       (pass-if n
1019         (eval `(letrec ((make-iterations-cond
1020                          (lambda (n)
1021                            (lambda ()
1022                              (cond ((not n)
1023                                     (error "oops, condition re-tested after giving false"))
1024                                    ((= 0 n)
1025                                     (set! n #f)
1026                                     #f)
1027                                    (else
1028                                     (set! n (1- n))
1029                                     #t))))))
1030                  (let ((cond (make-iterations-cond ,n)))
1031                    (while (cond))
1032                    #t))
1033               (interaction-environment)))))
1034
1035   (pass-if "initially false"
1036     (while #f
1037       (unreachable))
1038     #t)
1039
1040   (with-test-prefix "iterations"
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 (cond)
1047             (set! i (1+ i)))
1048           (= i n)))))
1049
1050   (with-test-prefix "break"
1051
1052     (pass-if "normal return"
1053       (not (while #f (error "not reached"))))
1054
1055     (pass-if "no args"
1056       (while #t (break)))
1057
1058     (pass-if "multiple values"
1059       (equal? '(1 2 3)
1060               (call-with-values
1061                   (lambda () (while #t (break 1 2 3)))
1062                 list)))
1063
1064     (with-test-prefix "from cond"
1065       (pass-if "first"
1066         (while (begin
1067                  (break)
1068                  (unreachable))
1069           (unreachable))
1070         #t)
1071
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                        #t
1079                        (begin
1080                          (break)
1081                          (unreachable)))
1082               (set! i (1+ i)))
1083             (= i n)))))
1084
1085     (with-test-prefix "from body"
1086       (pass-if "first"
1087         (while #t
1088           (break)
1089           (unreachable))
1090         #t)
1091
1092       (do ((n 0 (1+ n)))
1093           ((> n 5))
1094         (pass-if n
1095           (let ((cond (make-iterations-cond n))
1096                 (i    0))
1097             (while #t
1098               (if (not (cond))
1099                   (begin
1100                     (break)
1101                     (unreachable)))
1102               (set! i (1+ i)))
1103             (= i n)))))
1104
1105     (pass-if "from nested"
1106       (while #t
1107         (let ((outer-break break))
1108           (while #t
1109             (outer-break)
1110             (unreachable)))
1111         (unreachable))
1112       #t)
1113
1114     (pass-if "from recursive"
1115       (let ((outer-break #f))
1116         (define (r n)
1117           (while #t
1118             (if (eq? n 'outer)
1119                 (begin
1120                   (set! outer-break break)
1121                   (r 'inner))
1122                 (begin
1123                   (outer-break)
1124                   (unreachable))))
1125           (if (eq? n 'inner)
1126               (error "broke only from inner loop")))
1127         (r 'outer))
1128       #t))
1129
1130   (with-test-prefix "continue"
1131
1132     (pass-if-syntax-error "too many args" exception:too-many-args
1133       (eval '(while #t
1134                (continue 1))
1135             (interaction-environment)))
1136
1137     (with-test-prefix "from cond"
1138       (do ((n 0 (1+ n)))
1139           ((> n 5))
1140         (pass-if n
1141           (let ((cond (make-iterations-cond n))
1142                 (i    0))
1143             (while (if (cond)
1144                        (begin
1145                          (set! i (1+ i))
1146                          (continue)
1147                          (unreachable))
1148                        #f)
1149               (unreachable))
1150             (= i n)))))
1151
1152     (with-test-prefix "from body"
1153       (do ((n 0 (1+ n)))
1154           ((> n 5))
1155         (pass-if n
1156           (let ((cond (make-iterations-cond n))
1157                 (i    0))
1158             (while (cond)
1159               (set! i (1+ i))
1160               (continue)
1161               (unreachable))
1162             (= i n)))))
1163
1164     (pass-if "from nested"
1165       (let ((cond (make-iterations-cond 3)))
1166         (while (cond)
1167           (let ((outer-continue continue))
1168             (while #t
1169               (outer-continue)
1170               (unreachable)))))
1171       #t)
1172
1173     (pass-if "from recursive"
1174       (let ((outer-continue #f))
1175         (define (r n)
1176           (let ((cond  (make-iterations-cond 3))
1177                 (first #t))
1178             (while (begin
1179                      (if (and (not first)
1180                               (eq? n 'inner))
1181                          (error "continued only to inner loop"))
1182                      (cond))
1183               (set! first #f)
1184               (if (eq? n 'outer)
1185                   (begin
1186                     (set! outer-continue continue)
1187                     (r 'inner))
1188                   (begin
1189                     (outer-continue)
1190                     (unreachable))))))
1191         (r 'outer))
1192       #t)))