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,
   4 ;;;;   2011, 2012, 2013, 2014 Free Software Foundation, Inc.
   5 ;;;;
   6 ;;;; This library is free software; you can redistribute it and/or
   7 ;;;; modify it under the terms of the GNU Lesser General Public
   8 ;;;; License as published by the Free Software Foundation; either
   9 ;;;; version 3 of the License, or (at your option) any later version.
  10 ;;;;
  11 ;;;; This library is distributed in the hope that it will be useful,
  12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14 ;;;; Lesser General Public License for more details.
  15 ;;;;
  16 ;;;; You should have received a copy of the GNU Lesser General Public
  17 ;;;; License along with this library; if not, write to the Free Software
  18 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  19
  20 (define-module (test-suite test-syntax)
  21   #:use-module (ice-9 regex)
  22   #:use-module (ice-9 local-eval)
  23   #:use-module (test-suite lib))
  24
  25
  26 (define exception:generic-syncase-error
  27   "source expression failed to match")
  28 (define exception:unexpected-syntax
  29   "unexpected syntax")
  30
  31 (define exception:bad-expression
  32   "Bad expression")
  33
  34 (define exception:missing/extra-expr
  35   "Missing or extra expression")
  36 (define exception:missing-expr
  37   "Missing expression")
  38 (define exception:missing-body-expr
  39   "no expressions in body")
  40 (define exception:extra-expr
  41   "Extra expression")
  42 (define exception:illegal-empty-combination
  43   "Illegal empty combination")
  44
  45 (define exception:bad-lambda
  46   "bad lambda")
  47 (define exception:bad-let
  48   "bad let$")
  49 (define exception:bad-letrec
  50   "bad letrec$")
  51 (define exception:bad-letrec*
  52   "bad letrec\\*$")
  53 (define exception:bad-set!
  54   "bad set!")
  55 (define exception:bad-quote
  56   '(quote . "bad syntax"))
  57 (define exception:bad-bindings
  58   "Bad bindings")
  59 (define exception:bad-binding
  60   "Bad binding")
  61 (define exception:duplicate-binding
  62   "duplicate bound variable")
  63 (define exception:bad-body
  64   "^bad body")
  65 (define exception:bad-formals
  66   "invalid argument list")
  67 (define exception:bad-formal
  68   "Bad formal")
  69 (define exception:duplicate-formals
  70   "duplicate identifier in argument list")
  71
  72 (define exception:missing-clauses
  73   "Missing clauses")
  74 (define exception:misplaced-else-clause
  75   "Misplaced else clause")
  76 (define exception:bad-case-clause
  77   "Bad case clause")
  78 (define exception:bad-case-labels
  79   "Bad case labels")
  80 (define exception:bad-cond-clause
  81   "Bad cond clause")
  82
  83 (define exception:too-many-args
  84   "too many arguments")
  85 (define exception:zero-expression-sequence
  86   "sequence of zero expressions")
  87
  88 (define exception:define-values-wrong-number-of-return-values
  89   (cons 'wrong-number-of-args "^define-values: wrong number of return values returned by expression"))
  90
  91
  92 ;; (put 'pass-if-syntax-error 'scheme-indent-function 1)
  93 (define-syntax pass-if-syntax-error
  94   (syntax-rules ()
  95     ((_ name pat exp)
  96      (pass-if name
  97        (catch 'syntax-error
  98          (lambda () exp (error "expected syntax-error exception"))
  99          (lambda (k who what where form . maybe-subform)
 100            (if (if (pair? pat)
 101                    (and (eq? who (car pat))
 102                         (string-match (cdr pat) what))
 103                    (string-match pat what))
 104                #t
 105                (error "unexpected syntax-error exception" what pat))))))))
 106
 107 (with-test-prefix "expressions"
 108
 109   (with-test-prefix "Bad argument list"
 110
 111     (pass-if-syntax-error "improper argument list of length 1"
 112       exception:generic-syncase-error
 113       (eval '(let ((foo (lambda (x y) #t)))
 114                (foo . 1))
 115             (interaction-environment)))
 116
 117     (pass-if-syntax-error "improper argument list of length 2"
 118       exception:generic-syncase-error
 119       (eval '(let ((foo (lambda (x y) #t)))
 120                (foo 1 . 2))
 121             (interaction-environment))))
 122
 123   (with-test-prefix "missing or extra expression"
 124
 125     ;; R5RS says:
 126     ;; *Note:* In many dialects of Lisp, the empty combination, (),
 127     ;; is a legitimate expression.  In Scheme, combinations must
 128     ;; have at least one subexpression, so () is not a syntactically
 129     ;; valid expression.
 130
 131     ;; Fixed on 2001-3-3
 132     (pass-if-syntax-error "empty parentheses \"()\""
 133       exception:unexpected-syntax
 134       (eval '()
 135             (interaction-environment)))))
 136
 137 (with-test-prefix "quote"
 138   #t)
 139
 140 (with-test-prefix "quasiquote"
 141
 142   (with-test-prefix "unquote"
 143
 144     (pass-if "repeated execution"
 145       (let ((foo (let ((i 0)) (lambda () (set! i (+ i 1)) `(,i)))))
 146         (and (equal? (foo) '(1)) (equal? (foo) '(2))))))
 147
 148   (with-test-prefix "unquote-splicing"
 149
 150     (pass-if "extra arguments"
 151       (equal? (eval '(quasiquote ((unquote-splicing (list 1 2) (list 3 4))))
 152                     (interaction-environment))
 153               '(1 2 3 4)))))
 154
 155 (with-test-prefix "begin"
 156
 157   (pass-if "valid (begin)"
 158     (eval '(begin (begin) #t) (interaction-environment)))
 159
 160   (if (not (include-deprecated-features))
 161       (pass-if-syntax-error "invalid (begin)"
 162         exception:zero-expression-sequence
 163         (eval '(begin (if #t (begin)) #t) (interaction-environment)))))
 164
 165 (define-syntax matches?
 166   (syntax-rules (<>)
 167     ((_ (op arg ...) pat)   (let ((x (op arg ...)))
 168                               (matches? x pat)))
 169     ((_ x ())               (null? x))
 170     ((_ x (a . b))          (and (pair? x)
 171                                  (matches? (car x) a)
 172                                  (matches? (cdr x) b)))
 173     ((_ x <>)                #t)
 174     ((_ x pat)              (equal? x 'pat))))
 175
 176 (with-test-prefix "lambda"
 177
 178   (with-test-prefix "bad formals"
 179
 180     (pass-if-syntax-error "(lambda)"
 181       exception:bad-lambda
 182       (eval '(lambda)
 183             (interaction-environment)))
 184
 185     (pass-if-syntax-error "(lambda . \"foo\")"
 186       exception:bad-lambda
 187       (eval '(lambda . "foo")
 188             (interaction-environment)))
 189
 190     (pass-if-syntax-error "(lambda \"foo\")"
 191       exception:bad-lambda
 192       (eval '(lambda "foo")
 193             (interaction-environment)))
 194
 195     (pass-if-syntax-error "(lambda \"foo\" #f)"
 196       exception:bad-formals
 197       (eval '(lambda "foo" #f)
 198             (interaction-environment)))
 199
 200     (pass-if-syntax-error "(lambda (x 1) 2)"
 201       exception:bad-formals
 202       (eval '(lambda (x 1) 2)
 203             (interaction-environment)))
 204
 205     (pass-if-syntax-error "(lambda (1 x) 2)"
 206       exception:bad-formals
 207       (eval '(lambda (1 x) 2)
 208             (interaction-environment)))
 209
 210     (pass-if-syntax-error "(lambda (x \"a\") 2)"
 211       exception:bad-formals
 212       (eval '(lambda (x "a") 2)
 213             (interaction-environment)))
 214
 215     (pass-if-syntax-error "(lambda (\"a\" x) 2)"
 216       exception:bad-formals
 217       (eval '(lambda ("a" x) 2)
 218             (interaction-environment))))
 219
 220   (with-test-prefix "duplicate formals"
 221
 222     ;; Fixed on 2001-3-3
 223     (pass-if-syntax-error "(lambda (x x) 1)"
 224       exception:duplicate-formals
 225       (eval '(lambda (x x) 1)
 226             (interaction-environment)))
 227
 228     ;; Fixed on 2001-3-3
 229     (pass-if-syntax-error "(lambda (x x x) 1)"
 230       exception:duplicate-formals
 231       (eval '(lambda (x x x) 1)
 232             (interaction-environment))))
 233
 234   (with-test-prefix "bad body"
 235
 236     (pass-if-syntax-error "(lambda ())"
 237       exception:bad-lambda
 238       (eval '(lambda ())
 239             (interaction-environment)))))
 240
 241 (with-test-prefix "let"
 242
 243   (with-test-prefix "bindings"
 244
 245     (pass-if-exception "late binding"
 246       exception:unbound-var
 247       (let ((x 1) (y x)) y)))
 248
 249   (with-test-prefix "bad bindings"
 250
 251     (pass-if-syntax-error "(let)"
 252       exception:bad-let
 253       (eval '(let)
 254             (interaction-environment)))
 255
 256     (pass-if-syntax-error "(let 1)"
 257       exception:bad-let
 258       (eval '(let 1)
 259             (interaction-environment)))
 260
 261     (pass-if-syntax-error "(let (x))"
 262       exception:bad-let
 263       (eval '(let (x))
 264             (interaction-environment)))
 265
 266     (pass-if-syntax-error "(let ((x)))"
 267       exception:bad-let
 268       (eval '(let ((x)))
 269             (interaction-environment)))
 270
 271     (pass-if-syntax-error "(let (x) 1)"
 272       exception:bad-let
 273       (eval '(let (x) 1)
 274             (interaction-environment)))
 275
 276     (pass-if-syntax-error "(let ((x)) 3)"
 277       exception:bad-let
 278       (eval '(let ((x)) 3)
 279             (interaction-environment)))
 280
 281     (pass-if-syntax-error "(let ((x 1) y) x)"
 282       exception:bad-let
 283       (eval '(let ((x 1) y) x)
 284             (interaction-environment)))
 285
 286     (pass-if-syntax-error "(let ((1 2)) 3)"
 287       exception:bad-let
 288       (eval '(let ((1 2)) 3)
 289             (interaction-environment))))
 290
 291   (with-test-prefix "duplicate bindings"
 292
 293     (pass-if-syntax-error "(let ((x 1) (x 2)) x)"
 294       exception:duplicate-binding
 295       (eval '(let ((x 1) (x 2)) x)
 296             (interaction-environment))))
 297
 298   (with-test-prefix "bad body"
 299
 300     (pass-if-syntax-error "(let ())"
 301       exception:bad-let
 302       (eval '(let ())
 303             (interaction-environment)))
 304
 305     (pass-if-syntax-error "(let ((x 1)))"
 306       exception:bad-let
 307       (eval '(let ((x 1)))
 308             (interaction-environment)))))
 309
 310 (with-test-prefix "named let"
 311
 312   (with-test-prefix "initializers"
 313
 314     (pass-if "evaluated in outer environment"
 315       (let ((f -))
 316         (eqv? (let f ((n (f 1))) n) -1))))
 317
 318   (with-test-prefix "bad bindings"
 319
 320     (pass-if-syntax-error "(let x (y))"
 321       exception:bad-let
 322       (eval '(let x (y))
 323             (interaction-environment))))
 324
 325   (with-test-prefix "bad body"
 326
 327     (pass-if-syntax-error "(let x ())"
 328       exception:bad-let
 329       (eval '(let x ())
 330             (interaction-environment)))
 331
 332     (pass-if-syntax-error "(let x ((y 1)))"
 333       exception:bad-let
 334       (eval '(let x ((y 1)))
 335             (interaction-environment)))))
 336
 337 (with-test-prefix "let*"
 338
 339   (with-test-prefix "bindings"
 340
 341     (pass-if "(let* ((x 1) (x 2)) ...)"
 342       (let* ((x 1) (x 2))
 343         (= x 2)))
 344
 345     (pass-if "(let* ((x 1) (x x)) ...)"
 346       (let* ((x 1) (x x))
 347         (= x 1)))
 348
 349     (pass-if "(let ((x 1) (y 2)) (let* () ...))"
 350       (let ((x 1) (y 2))
 351         (let* ()
 352           (and (= x 1) (= y 2))))))
 353
 354   (with-test-prefix "bad bindings"
 355
 356     (pass-if-syntax-error "(let*)"
 357       exception:generic-syncase-error
 358       (eval '(let*)
 359             (interaction-environment)))
 360
 361     (pass-if-syntax-error "(let* 1)"
 362       exception:generic-syncase-error
 363       (eval '(let* 1)
 364             (interaction-environment)))
 365
 366     (pass-if-syntax-error "(let* (x))"
 367       exception:generic-syncase-error
 368       (eval '(let* (x))
 369             (interaction-environment)))
 370
 371     (pass-if-syntax-error "(let* (x) 1)"
 372       exception:generic-syncase-error
 373       (eval '(let* (x) 1)
 374             (interaction-environment)))
 375
 376     (pass-if-syntax-error "(let* ((x)) 3)"
 377       exception:generic-syncase-error
 378       (eval '(let* ((x)) 3)
 379             (interaction-environment)))
 380
 381     (pass-if-syntax-error "(let* ((x 1) y) x)"
 382       exception:generic-syncase-error
 383       (eval '(let* ((x 1) y) x)
 384             (interaction-environment)))
 385
 386     (pass-if-syntax-error "(let* x ())"
 387       exception:generic-syncase-error
 388       (eval '(let* x ())
 389             (interaction-environment)))
 390
 391     (pass-if-syntax-error "(let* x (y))"
 392       exception:generic-syncase-error
 393       (eval '(let* x (y))
 394             (interaction-environment)))
 395
 396     (pass-if-syntax-error "(let* ((1 2)) 3)"
 397       exception:generic-syncase-error
 398       (eval '(let* ((1 2)) 3)
 399             (interaction-environment))))
 400
 401   (with-test-prefix "bad body"
 402
 403     (pass-if-syntax-error "(let* ())"
 404       exception:generic-syncase-error
 405       (eval '(let* ())
 406             (interaction-environment)))
 407
 408     (pass-if-syntax-error "(let* ((x 1)))"
 409       exception:generic-syncase-error
 410       (eval '(let* ((x 1)))
 411             (interaction-environment)))))
 412
 413 (with-test-prefix "letrec"
 414
 415   (with-test-prefix "bindings"
 416
 417     (pass-if-syntax-error "initial bindings are undefined"
 418       exception:used-before-defined
 419       (let ((x 1))
 420         ;; FIXME: the memoizer does initialize the var to undefined, but
 421         ;; the Scheme evaluator has no way of checking what's an
 422         ;; undefined value. Not sure how to do this.
 423         (throw 'unresolved)
 424         (letrec ((x 1) (y x)) y))))
 425
 426   (with-test-prefix "bad bindings"
 427
 428     (pass-if-syntax-error "(letrec)"
 429       exception:bad-letrec
 430       (eval '(letrec)
 431             (interaction-environment)))
 432
 433     (pass-if-syntax-error "(letrec 1)"
 434       exception:bad-letrec
 435       (eval '(letrec 1)
 436             (interaction-environment)))
 437
 438     (pass-if-syntax-error "(letrec (x))"
 439       exception:bad-letrec
 440       (eval '(letrec (x))
 441             (interaction-environment)))
 442
 443     (pass-if-syntax-error "(letrec (x) 1)"
 444       exception:bad-letrec
 445       (eval '(letrec (x) 1)
 446             (interaction-environment)))
 447
 448     (pass-if-syntax-error "(letrec ((x)) 3)"
 449       exception:bad-letrec
 450       (eval '(letrec ((x)) 3)
 451             (interaction-environment)))
 452
 453     (pass-if-syntax-error "(letrec ((x 1) y) x)"
 454       exception:bad-letrec
 455       (eval '(letrec ((x 1) y) x)
 456             (interaction-environment)))
 457
 458     (pass-if-syntax-error "(letrec x ())"
 459       exception:bad-letrec
 460       (eval '(letrec x ())
 461             (interaction-environment)))
 462
 463     (pass-if-syntax-error "(letrec x (y))"
 464       exception:bad-letrec
 465       (eval '(letrec x (y))
 466             (interaction-environment)))
 467
 468     (pass-if-syntax-error "(letrec ((1 2)) 3)"
 469       exception:bad-letrec
 470       (eval '(letrec ((1 2)) 3)
 471             (interaction-environment))))
 472
 473   (with-test-prefix "duplicate bindings"
 474
 475     (pass-if-syntax-error "(letrec ((x 1) (x 2)) x)"
 476       exception:duplicate-binding
 477       (eval '(letrec ((x 1) (x 2)) x)
 478             (interaction-environment))))
 479
 480   (with-test-prefix "bad body"
 481
 482     (pass-if-syntax-error "(letrec ())"
 483       exception:bad-letrec
 484       (eval '(letrec ())
 485             (interaction-environment)))
 486
 487     (pass-if-syntax-error "(letrec ((x 1)))"
 488       exception:bad-letrec
 489       (eval '(letrec ((x 1)))
 490             (interaction-environment)))))
 491
 492 (with-test-prefix "letrec*"
 493
 494   (with-test-prefix "bindings"
 495
 496     (pass-if-syntax-error "initial bindings are undefined"
 497       exception:used-before-defined
 498       (begin
 499         ;; FIXME: the memoizer does initialize the var to undefined, but
 500         ;; the Scheme evaluator has no way of checking what's an
 501         ;; undefined value. Not sure how to do this.
 502         (throw 'unresolved)
 503         (letrec* ((x y) (y 1)) y))))
 504
 505   (with-test-prefix "bad bindings"
 506
 507     (pass-if-syntax-error "(letrec*)"
 508       exception:bad-letrec*
 509       (eval '(letrec*)
 510             (interaction-environment)))
 511
 512     (pass-if-syntax-error "(letrec* 1)"
 513       exception:bad-letrec*
 514       (eval '(letrec* 1)
 515             (interaction-environment)))
 516
 517     (pass-if-syntax-error "(letrec* (x))"
 518       exception:bad-letrec*
 519       (eval '(letrec* (x))
 520             (interaction-environment)))
 521
 522     (pass-if-syntax-error "(letrec* (x) 1)"
 523       exception:bad-letrec*
 524       (eval '(letrec* (x) 1)
 525             (interaction-environment)))
 526
 527     (pass-if-syntax-error "(letrec* ((x)) 3)"
 528       exception:bad-letrec*
 529       (eval '(letrec* ((x)) 3)
 530             (interaction-environment)))
 531
 532     (pass-if-syntax-error "(letrec* ((x 1) y) x)"
 533       exception:bad-letrec*
 534       (eval '(letrec* ((x 1) y) x)
 535             (interaction-environment)))
 536
 537     (pass-if-syntax-error "(letrec* x ())"
 538       exception:bad-letrec*
 539       (eval '(letrec* x ())
 540             (interaction-environment)))
 541
 542     (pass-if-syntax-error "(letrec* x (y))"
 543       exception:bad-letrec*
 544       (eval '(letrec* x (y))
 545             (interaction-environment)))
 546
 547     (pass-if-syntax-error "(letrec* ((1 2)) 3)"
 548       exception:bad-letrec*
 549       (eval '(letrec* ((1 2)) 3)
 550             (interaction-environment))))
 551
 552   (with-test-prefix "duplicate bindings"
 553
 554     (pass-if-syntax-error "(letrec* ((x 1) (x 2)) x)"
 555       exception:duplicate-binding
 556       (eval '(letrec* ((x 1) (x 2)) x)
 557             (interaction-environment))))
 558
 559   (with-test-prefix "bad body"
 560
 561     (pass-if-syntax-error "(letrec* ())"
 562       exception:bad-letrec*
 563       (eval '(letrec* ())
 564             (interaction-environment)))
 565
 566     (pass-if-syntax-error "(letrec* ((x 1)))"
 567       exception:bad-letrec*
 568       (eval '(letrec* ((x 1)))
 569             (interaction-environment))))
 570
 571   (with-test-prefix "referencing previous values"
 572     (pass-if (equal? (letrec ((a (cons 'foo 'bar))
 573                               (b a))
 574                        b)
 575                      '(foo . bar)))
 576     (pass-if (equal? (let ()
 577                        (define a (cons 'foo 'bar))
 578                        (define b a)
 579                        b)
 580                      '(foo . bar)))))
 581
 582 (with-test-prefix "if"
 583
 584   (with-test-prefix "missing or extra expressions"
 585
 586     (pass-if-syntax-error "(if)"
 587       exception:generic-syncase-error
 588       (eval '(if)
 589             (interaction-environment)))
 590
 591     (pass-if-syntax-error "(if 1 2 3 4)"
 592       exception:generic-syncase-error
 593       (eval '(if 1 2 3 4)
 594             (interaction-environment)))))
 595
 596 (with-test-prefix "cond"
 597
 598   (with-test-prefix "cond is hygienic"
 599
 600     (pass-if "bound 'else is handled correctly"
 601       (eq? (let ((else 'ok)) (cond (else))) 'ok))
 602
 603     (with-test-prefix "bound '=> is handled correctly"
 604
 605       (pass-if "#t => 'ok"
 606         (let ((=> 'foo))
 607           (eq? (cond (#t => 'ok)) 'ok)))
 608
 609       (pass-if "else =>"
 610         (let ((=> 'foo))
 611           (eq? (cond (else =>)) 'foo)))
 612
 613       (pass-if "else => identity"
 614         (let ((=> 'foo))
 615           (eq? (cond (else => identity)) identity)))))
 616
 617   (with-test-prefix "SRFI-61"
 618
 619     (pass-if "always available"
 620       (cond-expand (srfi-61 #t) (else #f)))
 621
 622     (pass-if "single value consequent"
 623       (eq? 'ok (cond (#t identity => (lambda (x) 'ok)) (else #f))))
 624
 625     (pass-if "single value alternate"
 626       (eq? 'ok (cond (#t not => (lambda (x) #f)) (else 'ok))))
 627
 628     (pass-if-exception "doesn't affect standard =>"
 629       exception:wrong-num-args
 630       (cond ((values 1 2) => (lambda (x y) #t))))
 631
 632     (pass-if "multiple values consequent"
 633       (equal? '(2 1) (cond ((values 1 2)
 634                             (lambda (one two)
 635                               (and (= 1 one) (= 2 two))) =>
 636                             (lambda (one two) (list two one)))
 637                            (else #f))))
 638
 639     (pass-if "multiple values alternate"
 640       (eq? 'ok (cond ((values 2 3 4)
 641                       (lambda args (equal? '(1 2 3) args)) =>
 642                       (lambda (x y z) #f))
 643                      (else 'ok))))
 644
 645     (pass-if "zero values"
 646       (eq? 'ok (cond ((values) (lambda () #t) => (lambda () 'ok))
 647                      (else #f))))
 648
 649     (pass-if "bound => is handled correctly"
 650       (let ((=> 'ok))
 651         (eq? 'ok (cond (#t identity =>) (else #f)))))
 652
 653     (pass-if-syntax-error "missing recipient"
 654       '(cond . "wrong number of receiver expressions")
 655       (eval '(cond (#t identity =>))
 656             (interaction-environment)))
 657
 658     (pass-if-syntax-error "extra recipient"
 659       '(cond . "wrong number of receiver expressions")
 660       (eval '(cond (#t identity => identity identity))
 661             (interaction-environment))))
 662
 663   (with-test-prefix "bad or missing clauses"
 664
 665     (pass-if-syntax-error "(cond)"
 666       exception:generic-syncase-error
 667       (eval '(cond)
 668             (interaction-environment)))
 669
 670     (pass-if-syntax-error "(cond #t)"
 671       '(cond . "invalid clause")
 672       (eval '(cond #t)
 673             (interaction-environment)))
 674
 675     (pass-if-syntax-error "(cond 1)"
 676       '(cond . "invalid clause")
 677       (eval '(cond 1)
 678             (interaction-environment)))
 679
 680     (pass-if-syntax-error "(cond 1 2)"
 681       '(cond . "invalid clause")
 682       (eval '(cond 1 2)
 683             (interaction-environment)))
 684
 685     (pass-if-syntax-error "(cond 1 2 3)"
 686       '(cond . "invalid clause")
 687       (eval '(cond 1 2 3)
 688             (interaction-environment)))
 689
 690     (pass-if-syntax-error "(cond 1 2 3 4)"
 691       '(cond . "invalid clause")
 692       (eval '(cond 1 2 3 4)
 693             (interaction-environment)))
 694
 695     (pass-if-syntax-error "(cond ())"
 696       '(cond . "invalid clause")
 697       (eval '(cond ())
 698             (interaction-environment)))
 699
 700     (pass-if-syntax-error "(cond () 1)"
 701       '(cond . "invalid clause")
 702       (eval '(cond () 1)
 703             (interaction-environment)))
 704
 705     (pass-if-syntax-error "(cond (1) 1)"
 706       '(cond . "invalid clause")
 707       (eval '(cond (1) 1)
 708             (interaction-environment)))
 709
 710     (pass-if-syntax-error "(cond (else #f) (#t #t))"
 711       '(cond . "else must be the last clause")
 712       (eval '(cond (else #f) (#t #t))
 713             (interaction-environment))))
 714
 715   (with-test-prefix "wrong number of arguments"
 716
 717     (pass-if-exception "=> (lambda (x y) #t)"
 718       exception:wrong-num-args
 719       (cond (1 => (lambda (x y) #t))))))
 720
 721 (with-test-prefix "case"
 722
 723   (pass-if "clause with empty labels list"
 724     (case 1 (() #f) (else #t)))
 725
 726   (with-test-prefix "case handles '=> correctly"
 727
 728     (pass-if "(1 2 3) => list"
 729       (equal? (case 1 ((1 2 3) => list))
 730               '(1)))
 731
 732     (pass-if "else => list"
 733       (equal? (case 6
 734                 ((1 2 3) 'wrong)
 735                 (else => list))
 736               '(6)))
 737
 738     (with-test-prefix "bound '=> is handled correctly"
 739
 740       (pass-if "(1) => 'ok"
 741         (let ((=> 'foo))
 742           (eq? (case 1 ((1) => 'ok)) 'ok)))
 743
 744       (pass-if "else =>"
 745         (let ((=> 'foo))
 746           (eq? (case 1 (else =>)) 'foo)))
 747
 748       (pass-if "else => list"
 749         (let ((=> 'foo))
 750           (eq? (case 1 (else => identity)) identity))))
 751
 752     (pass-if-syntax-error "missing recipient"
 753       '(case . "wrong number of receiver expressions")
 754       (eval '(case 1 ((1) =>))
 755             (interaction-environment)))
 756
 757     (pass-if-syntax-error "extra recipient"
 758       '(case . "wrong number of receiver expressions")
 759       (eval '(case 1 ((1) => identity identity))
 760             (interaction-environment))))
 761
 762   (with-test-prefix "case is hygienic"
 763
 764     (pass-if-syntax-error "bound 'else is handled correctly"
 765       '(case . "invalid clause")
 766       (eval '(let ((else #f)) (case 1 (else #f)))
 767             (interaction-environment))))
 768
 769   (with-test-prefix "bad or missing clauses"
 770
 771     (pass-if-syntax-error "(case)"
 772       exception:generic-syncase-error
 773       (eval '(case)
 774             (interaction-environment)))
 775
 776     (pass-if-syntax-error "(case . \"foo\")"
 777       exception:generic-syncase-error
 778       (eval '(case . "foo")
 779             (interaction-environment)))
 780
 781     (pass-if-syntax-error "(case 1)"
 782       exception:generic-syncase-error
 783       (eval '(case 1)
 784             (interaction-environment)))
 785
 786     (pass-if-syntax-error "(case 1 . \"foo\")"
 787       exception:generic-syncase-error
 788       (eval '(case 1 . "foo")
 789             (interaction-environment)))
 790
 791     (pass-if-syntax-error "(case 1 \"foo\")"
 792       '(case . "invalid clause")
 793       (eval '(case 1 "foo")
 794             (interaction-environment)))
 795
 796     (pass-if-syntax-error "(case 1 ())"
 797       '(case . "invalid clause")
 798       (eval '(case 1 ())
 799             (interaction-environment)))
 800
 801     (pass-if-syntax-error "(case 1 (\"foo\"))"
 802       '(case . "invalid clause")
 803       (eval '(case 1 ("foo"))
 804             (interaction-environment)))
 805
 806     (pass-if-syntax-error "(case 1 (\"foo\" \"bar\"))"
 807       '(case . "invalid clause")
 808       (eval '(case 1 ("foo" "bar"))
 809             (interaction-environment)))
 810
 811     (pass-if-syntax-error "(case 1 ((2) \"bar\") . \"foo\")"
 812       exception:generic-syncase-error
 813       (eval '(case 1 ((2) "bar") . "foo")
 814             (interaction-environment)))
 815
 816     (pass-if-syntax-error "(case 1 ((2) \"bar\") (else))"
 817       '(case . "invalid clause")
 818       (eval '(case 1 ((2) "bar") (else))
 819             (interaction-environment)))
 820
 821     (pass-if-syntax-error "(case 1 (else #f) . \"foo\")"
 822       exception:generic-syncase-error
 823       (eval '(case 1 (else #f) . "foo")
 824             (interaction-environment)))
 825
 826     (pass-if-syntax-error "(case 1 (else #f) ((1) #t))"
 827       '(case . "else must be the last clause")
 828       (eval '(case 1 (else #f) ((1) #t))
 829             (interaction-environment)))))
 830
 831 (with-test-prefix "top-level define"
 832
 833   (pass-if "redefinition"
 834     (let ((m (make-module)))
 835       (beautify-user-module! m)
 836
 837       ;; The previous value of `round' must still be visible at the time the
 838       ;; new `round' is defined.  According to R5RS (Section 5.2.1), `define'
 839       ;; should behave like `set!' in this case (except that in the case of
 840       ;; Guile, we respect module boundaries).
 841       (eval '(define round round) m)
 842       (eq? (module-ref m 'round) round)))
 843
 844   (with-test-prefix "missing or extra expressions"
 845
 846     (pass-if-syntax-error "(define)"
 847       exception:generic-syncase-error
 848       (eval '(define)
 849             (interaction-environment)))))
 850
 851 (with-test-prefix "internal define"
 852
 853   (pass-if "internal defines become letrec"
 854     (eval '(let ((a identity) (b identity) (c identity))
 855              (define (a x) (if (= x 0) 'a (b (- x 1))))
 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 "binding is created before expression is evaluated"
 864     ;; Internal defines are equivalent to `letrec' (R5RS, Section 5.2.2).
 865     (= (eval '(let ()
 866                 (define foo
 867                   (begin
 868                     (set! foo 1)
 869                     (+ foo 1)))
 870                 foo)
 871              (interaction-environment))
 872        2))
 873
 874   (pass-if "internal defines with begin"
 875     (false-if-exception
 876      (eval '(let ((a identity) (b identity) (c identity))
 877               (define (a x) (if (= x 0) 'a (b (- x 1))))
 878               (begin
 879                 (define (b x) (if (= x 0) 'b (c (- x 1)))))
 880               (define (c x) (if (= x 0) 'c (a (- x 1))))
 881               (and (eq? 'a (a 0) (a 3))
 882                    (eq? 'b (a 1) (a 4))
 883                    (eq? 'c (a 2) (a 5))))
 884            (interaction-environment))))
 885
 886   (pass-if "internal defines with empty begin"
 887     (false-if-exception
 888      (eval '(let ((a identity) (b identity) (c identity))
 889               (define (a x) (if (= x 0) 'a (b (- x 1))))
 890               (begin)
 891               (define (b x) (if (= x 0) 'b (c (- x 1))))
 892               (define (c x) (if (= x 0) 'c (a (- x 1))))
 893               (and (eq? 'a (a 0) (a 3))
 894                    (eq? 'b (a 1) (a 4))
 895                    (eq? 'c (a 2) (a 5))))
 896            (interaction-environment))))
 897
 898   (pass-if "internal defines with macro application"
 899     (false-if-exception
 900      (eval '(begin
 901               (defmacro my-define forms
 902                 (cons 'define forms))
 903               (let ((a identity) (b identity) (c identity))
 904                 (define (a x) (if (= x 0) 'a (b (- x 1))))
 905                 (my-define (b x) (if (= x 0) 'b (c (- x 1))))
 906                 (define (c x) (if (= x 0) 'c (a (- x 1))))
 907                 (and (eq? 'a (a 0) (a 3))
 908                      (eq? 'b (a 1) (a 4))
 909                      (eq? 'c (a 2) (a 5)))))
 910            (interaction-environment))))
 911
 912   (pass-if-syntax-error "missing body expression"
 913     exception:missing-body-expr
 914     (eval '(let () (define x #t))
 915           (interaction-environment))))
 916
 917 (with-test-prefix "top-level define-values"
 918
 919   (pass-if "zero values"
 920     (eval '(begin (define-values () (values))
 921                   #t)
 922           (interaction-environment)))
 923
 924   (pass-if-equal "one value"
 925       1
 926     (eval '(begin (define-values (x) 1)
 927                   x)
 928           (interaction-environment)))
 929
 930   (pass-if-equal "two values"
 931       '(2 3)
 932     (eval '(begin (define-values (x y) (values 2 3))
 933                   (list x y))
 934           (interaction-environment)))
 935
 936   (pass-if-equal "three values"
 937       '(4 5 6)
 938     (eval '(begin (define-values (x y z) (values 4 5 6))
 939                   (list x y z))
 940           (interaction-environment)))
 941
 942   (pass-if-equal "one value with tail"
 943       '(a (b c d))
 944     (eval '(begin (define-values (x . y) (values 'a 'b 'c 'd))
 945                   (list x y))
 946           (interaction-environment)))
 947
 948   (pass-if-equal "two values with tail"
 949       '(x y (z w))
 950     (eval '(begin (define-values (x y . z) (values 'x 'y 'z 'w))
 951                   (list x y z))
 952           (interaction-environment)))
 953
 954   (pass-if-equal "just tail"
 955       '(1 2 3)
 956     (eval '(begin (define-values x (values 1 2 3))
 957                   x)
 958           (interaction-environment)))
 959
 960   (pass-if-exception "expected 0 values, got 1"
 961       exception:define-values-wrong-number-of-return-values
 962     (eval '(define-values () 1)
 963           (interaction-environment)))
 964
 965   (pass-if-exception "expected 1 value, got 0"
 966       exception:define-values-wrong-number-of-return-values
 967     (eval '(define-values (x) (values))
 968           (interaction-environment)))
 969
 970   (pass-if-exception "expected 1 value, got 2"
 971       exception:define-values-wrong-number-of-return-values
 972     (eval '(define-values (x) (values 1 2))
 973           (interaction-environment)))
 974
 975   (pass-if-exception "expected 1 value with tail, got 0"
 976       exception:define-values-wrong-number-of-return-values
 977     (eval '(define-values (x . y) (values))
 978           (interaction-environment)))
 979
 980   (pass-if-exception "expected 2 value with tail, got 1"
 981       exception:define-values-wrong-number-of-return-values
 982     (eval '(define-values (x y . z) 1)
 983           (interaction-environment)))
 984
 985   (pass-if "redefinition"
 986     (let ((m (make-module)))
 987       (beautify-user-module! m)
 988
 989       ;; The previous values of `floor' and `round' must still be
 990       ;; visible at the time the new `floor' and `round' are defined.
 991       (eval '(define-values (floor round) (values floor round)) m)
 992       (and (eq? (module-ref m 'floor) floor)
 993            (eq? (module-ref m 'round) round))))
 994
 995   (with-test-prefix "missing expression"
 996
 997     (pass-if-syntax-error "(define-values)"
 998       exception:generic-syncase-error
 999       (eval '(define-values)
1000             (interaction-environment)))))
1001
1002 (with-test-prefix "internal define-values"
1003
1004   (pass-if "zero values"
1005     (let ()
1006       (define-values () (values))
1007       #t))
1008
1009   (pass-if-equal "one value"
1010       1
1011     (let ()
1012       (define-values (x) 1)
1013       x))
1014
1015   (pass-if-equal "two values"
1016       '(2 3)
1017     (let ()
1018       (define-values (x y) (values 2 3))
1019       (list x y)))
1020
1021   (pass-if-equal "three values"
1022       '(4 5 6)
1023     (let ()
1024       (define-values (x y z) (values 4 5 6))
1025       (list x y z)))
1026
1027   (pass-if-equal "one value with tail"
1028       '(a (b c d))
1029     (let ()
1030       (define-values (x . y) (values 'a 'b 'c 'd))
1031       (list x y)))
1032
1033   (pass-if-equal "two values with tail"
1034       '(x y (z w))
1035     (let ()
1036       (define-values (x y . z) (values 'x 'y 'z 'w))
1037       (list x y z)))
1038
1039   (pass-if-equal "just tail"
1040       '(1 2 3)
1041     (let ()
1042       (define-values x (values 1 2 3))
1043       x))
1044
1045   (pass-if-exception "expected 0 values, got 1"
1046       exception:define-values-wrong-number-of-return-values
1047     (eval '(let ()
1048              (define-values () 1)
1049              #f)
1050           (interaction-environment)))
1051
1052   (pass-if-exception "expected 1 value, got 0"
1053       exception:define-values-wrong-number-of-return-values
1054     (eval '(let ()
1055              (define-values (x) (values))
1056              #f)
1057           (interaction-environment)))
1058
1059   (pass-if-exception "expected 1 value, got 2"
1060       exception:define-values-wrong-number-of-return-values
1061     (eval '(let ()
1062              (define-values (x) (values 1 2))
1063              #f)
1064           (interaction-environment)))
1065
1066   (pass-if-exception "expected 1 value with tail, got 0"
1067       exception:define-values-wrong-number-of-return-values
1068     (eval '(let ()
1069              (define-values (x . y) (values))
1070              #f)
1071           (interaction-environment)))
1072
1073   (pass-if-exception "expected 2 value with tail, got 1"
1074       exception:define-values-wrong-number-of-return-values
1075     (eval '(let ()
1076              (define-values (x y . z) 1)
1077              #f)
1078           (interaction-environment)))
1079
1080   (with-test-prefix "missing expression"
1081
1082     (pass-if-syntax-error "(define-values)"
1083       exception:generic-syncase-error
1084       (eval '(let ()
1085                (define-values)
1086                #f)
1087             (interaction-environment)))))
1088
1089 (with-test-prefix "set!"
1090
1091   (with-test-prefix "missing or extra expressions"
1092
1093     (pass-if-syntax-error "(set!)"
1094       exception:bad-set!
1095       (eval '(set!)
1096             (interaction-environment)))
1097
1098     (pass-if-syntax-error "(set! 1)"
1099       exception:bad-set!
1100       (eval '(set! 1)
1101             (interaction-environment)))
1102
1103     (pass-if-syntax-error "(set! 1 2 3)"
1104       exception:bad-set!
1105       (eval '(set! 1 2 3)
1106             (interaction-environment))))
1107
1108   (with-test-prefix "bad variable"
1109
1110     (pass-if-syntax-error "(set! \"\" #t)"
1111       exception:bad-set!
1112       (eval '(set! "" #t)
1113             (interaction-environment)))
1114
1115     (pass-if-syntax-error "(set! 1 #t)"
1116       exception:bad-set!
1117       (eval '(set! 1 #t)
1118             (interaction-environment)))
1119
1120     (pass-if-syntax-error "(set! #t #f)"
1121       exception:bad-set!
1122       (eval '(set! #t #f)
1123             (interaction-environment)))
1124
1125     (pass-if-syntax-error "(set! #f #t)"
1126       exception:bad-set!
1127       (eval '(set! #f #t)
1128             (interaction-environment)))
1129
1130     (pass-if-syntax-error "(set! #\\space #f)"
1131       exception:bad-set!
1132       (eval '(set! #\space #f)
1133             (interaction-environment)))))
1134
1135 (with-test-prefix "quote"
1136
1137   (with-test-prefix "missing or extra expression"
1138
1139     (pass-if-syntax-error "(quote)"
1140       exception:bad-quote
1141       (eval '(quote)
1142             (interaction-environment)))
1143
1144     (pass-if-syntax-error "(quote a b)"
1145       exception:bad-quote
1146       (eval '(quote a b)
1147             (interaction-environment)))))
1148
1149 (with-test-prefix "while"
1150
1151   (define (unreachable)
1152     (error "unreachable code has been reached!"))
1153
1154   ;; Return a new procedure COND which when called (COND) will return #t the
1155   ;; first N times, then #f, then any further call is an error.  N=0 is
1156   ;; allowed, in which case #f is returned by the first call.
1157   (define (make-iterations-cond n)
1158     (lambda ()
1159       (cond ((not n)
1160              (error "oops, condition re-tested after giving false"))
1161             ((= 0 n)
1162              (set! n #f)
1163              #f)
1164             (else
1165              (set! n (1- n))
1166              #t))))
1167
1168
1169   (pass-if-syntax-error "too few args" exception:generic-syncase-error
1170     (eval '(while) (interaction-environment)))
1171
1172   (with-test-prefix "empty body"
1173     (do ((n 0 (1+ n)))
1174         ((> n 5))
1175       (pass-if n
1176         (eval `(letrec ((make-iterations-cond
1177                          (lambda (n)
1178                            (lambda ()
1179                              (cond ((not n)
1180                                     (error "oops, condition re-tested after giving false"))
1181                                    ((= 0 n)
1182                                     (set! n #f)
1183                                     #f)
1184                                    (else
1185                                     (set! n (1- n))
1186                                     #t))))))
1187                  (let ((cond (make-iterations-cond ,n)))
1188                    (while (cond))
1189                    #t))
1190               (interaction-environment)))))
1191
1192   (pass-if "initially false"
1193     (while #f
1194       (unreachable))
1195     #t)
1196
1197   (with-test-prefix "iterations"
1198     (do ((n 0 (1+ n)))
1199         ((> n 5))
1200       (pass-if n
1201         (let ((cond (make-iterations-cond n))
1202               (i    0))
1203           (while (cond)
1204             (set! i (1+ i)))
1205           (= i n)))))
1206
1207   (with-test-prefix "break"
1208
1209     (pass-if "normal return"
1210       (not (while #f (error "not reached"))))
1211
1212     (pass-if "no args"
1213       (while #t (break)))
1214
1215     (pass-if "multiple values"
1216       (equal? '(1 2 3)
1217               (call-with-values
1218                   (lambda () (while #t (break 1 2 3)))
1219                 list)))
1220
1221     (with-test-prefix "from cond"
1222       (pass-if "first"
1223         (while (begin
1224                  (break)
1225                  (unreachable))
1226           (unreachable))
1227         #t)
1228
1229       (do ((n 0 (1+ n)))
1230           ((> n 5))
1231         (pass-if n
1232           (let ((cond (make-iterations-cond n))
1233                 (i    0))
1234             (while (if (cond)
1235                        #t
1236                        (begin
1237                          (break)
1238                          (unreachable)))
1239               (set! i (1+ i)))
1240             (= i n)))))
1241
1242     (with-test-prefix "from body"
1243       (pass-if "first"
1244         (while #t
1245           (break)
1246           (unreachable))
1247         #t)
1248
1249       (do ((n 0 (1+ n)))
1250           ((> n 5))
1251         (pass-if n
1252           (let ((cond (make-iterations-cond n))
1253                 (i    0))
1254             (while #t
1255               (if (not (cond))
1256                   (begin
1257                     (break)
1258                     (unreachable)))
1259               (set! i (1+ i)))
1260             (= i n)))))
1261
1262     (pass-if "from nested"
1263       (while #t
1264         (let ((outer-break break))
1265           (while #t
1266             (outer-break)
1267             (unreachable)))
1268         (unreachable))
1269       #t)
1270
1271     (pass-if "from recursive"
1272       (let ((outer-break #f))
1273         (define (r n)
1274           (while #t
1275             (if (eq? n 'outer)
1276                 (begin
1277                   (set! outer-break break)
1278                   (r 'inner))
1279                 (begin
1280                   (outer-break)
1281                   (unreachable))))
1282           (if (eq? n 'inner)
1283               (error "broke only from inner loop")))
1284         (r 'outer))
1285       #t))
1286
1287   (with-test-prefix "continue"
1288
1289     (pass-if-syntax-error "too many args" exception:too-many-args
1290       (eval '(while #t
1291                (continue 1))
1292             (interaction-environment)))
1293
1294     (with-test-prefix "from cond"
1295       (do ((n 0 (1+ n)))
1296           ((> n 5))
1297         (pass-if n
1298           (let ((cond (make-iterations-cond n))
1299                 (i    0))
1300             (while (if (cond)
1301                        (begin
1302                          (set! i (1+ i))
1303                          (continue)
1304                          (unreachable))
1305                        #f)
1306               (unreachable))
1307             (= i n)))))
1308
1309     (with-test-prefix "from body"
1310       (do ((n 0 (1+ n)))
1311           ((> n 5))
1312         (pass-if n
1313           (let ((cond (make-iterations-cond n))
1314                 (i    0))
1315             (while (cond)
1316               (set! i (1+ i))
1317               (continue)
1318               (unreachable))
1319             (= i n)))))
1320
1321     (pass-if "from nested"
1322       (let ((cond (make-iterations-cond 3)))
1323         (while (cond)
1324           (let ((outer-continue continue))
1325             (while #t
1326               (outer-continue)
1327               (unreachable)))))
1328       #t)
1329
1330     (pass-if "from recursive"
1331       (let ((outer-continue #f))
1332         (define (r n)
1333           (let ((cond  (make-iterations-cond 3))
1334                 (first #t))
1335             (while (begin
1336                      (if (and (not first)
1337                               (eq? n 'inner))
1338                          (error "continued only to inner loop"))
1339                      (cond))
1340               (set! first #f)
1341               (if (eq? n 'outer)
1342                   (begin
1343                     (set! outer-continue continue)
1344                     (r 'inner))
1345                   (begin
1346                     (outer-continue)
1347                     (unreachable))))))
1348         (r 'outer))
1349       #t)))
1350
1351 (with-test-prefix "syntax-rules"
1352
1353   (pass-if-equal "custom ellipsis within normal ellipsis"
1354       '((((a x) (a y) (a …))
1355          ((b x) (b y) (b …))
1356          ((c x) (c y) (c …)))
1357         (((a x) (b x) (c x))
1358          ((a y) (b y) (c y))
1359          ((a …) (b …) (c …))))
1360     (let ()
1361       (define-syntax foo
1362         (syntax-rules ()
1363           ((_ y ...)
1364            (syntax-rules … ()
1365              ((_ x …)
1366               '((((x y) ...) …)
1367                 (((x y) …) ...)))))))
1368       (define-syntax bar (foo x y …))
1369       (bar a b c)))
1370
1371   (pass-if-equal "normal ellipsis within custom ellipsis"
1372       '((((a x) (a y) (a z))
1373          ((b x) (b y) (b z))
1374          ((c x) (c y) (c z)))
1375         (((a x) (b x) (c x))
1376          ((a y) (b y) (c y))
1377          ((a z) (b z) (c z))))
1378     (let ()
1379       (define-syntax foo
1380         (syntax-rules … ()
1381           ((_ y …)
1382            (syntax-rules ()
1383              ((_ x ...)
1384               '((((x y) …) ...)
1385                 (((x y) ...) …)))))))
1386       (define-syntax bar (foo x y z))
1387       (bar a b c)))
1388
1389   ;; This test is given in SRFI-46.
1390   (pass-if-equal "custom ellipsis is handled hygienically"
1391       '((1) 2 (3) (4))
1392     (let-syntax
1393         ((f (syntax-rules ()
1394               ((f ?e)
1395                (let-syntax
1396                    ((g (syntax-rules --- ()
1397                          ((g (??x ?e) (??y ---))
1398                           '((??x) ?e (??y) ---)))))
1399                  (g (1 2) (3 4)))))))
1400       (f ---))))
1401
1402 (with-test-prefix "syntax-error"
1403
1404   (pass-if-syntax-error "outside of macro without args"
1405     "test error"
1406     (eval '(syntax-error "test error")
1407           (interaction-environment)))
1408
1409   (pass-if-syntax-error "outside of macro with args"
1410     "test error x \\(y z\\)"
1411     (eval '(syntax-error "test error" x (y z))
1412           (interaction-environment)))
1413
1414   (pass-if-equal "within macro"
1415       '(simple-let
1416         "expected an identifier but got (z1 z2)"
1417         (simple-let ((y (* x x))
1418                      ((z1 z2) (values x x)))
1419           (+ y 1)))
1420     (catch 'syntax-error
1421       (lambda ()
1422         (eval '(let ()
1423                  (define-syntax simple-let
1424                    (syntax-rules ()
1425                      ((_ (head ... ((x . y) val) . tail)
1426                          body1 body2 ...)
1427                       (syntax-error
1428                        "expected an identifier but got"
1429                        (x . y)))
1430                      ((_ ((name val) ...) body1 body2 ...)
1431                       ((lambda (name ...) body1 body2 ...)
1432                        val ...))))
1433                  (define (foo x)
1434                    (simple-let ((y (* x x))
1435                                 ((z1 z2) (values x x)))
1436                      (+ y 1)))
1437                  foo)
1438               (interaction-environment))
1439         (error "expected syntax-error exception"))
1440       (lambda (k who what where form . maybe-subform)
1441         (list who what form)))))
1442
1443 (with-test-prefix "syntax-case"
1444
1445   (pass-if-syntax-error "duplicate pattern variable"
1446     '(syntax-case . "duplicate pattern variable")
1447     (eval '(lambda (e)
1448              (syntax-case e ()
1449                ((a b c d e d f) #f)))
1450           (interaction-environment)))
1451
1452   (with-test-prefix "misplaced ellipses"
1453
1454     (pass-if-syntax-error "bare ellipsis"
1455       '(syntax-case . "misplaced ellipsis")
1456       (eval '(lambda (e)
1457                (syntax-case e ()
1458                  (... #f)))
1459             (interaction-environment)))
1460
1461     (pass-if-syntax-error "ellipsis singleton"
1462       '(syntax-case . "misplaced ellipsis")
1463       (eval '(lambda (e)
1464                (syntax-case e ()
1465                  ((...) #f)))
1466             (interaction-environment)))
1467
1468     (pass-if-syntax-error "ellipsis in car"
1469       '(syntax-case . "misplaced ellipsis")
1470       (eval '(lambda (e)
1471                (syntax-case e ()
1472                  ((... . _) #f)))
1473             (interaction-environment)))
1474
1475     (pass-if-syntax-error "ellipsis in cdr"
1476       '(syntax-case . "misplaced ellipsis")
1477       (eval '(lambda (e)
1478                (syntax-case e ()
1479                  ((_ . ...) #f)))
1480             (interaction-environment)))
1481
1482     (pass-if-syntax-error "two ellipses in the same list"
1483       '(syntax-case . "misplaced ellipsis")
1484       (eval '(lambda (e)
1485                (syntax-case e ()
1486                  ((x ... y ...) #f)))
1487             (interaction-environment)))
1488
1489     (pass-if-syntax-error "three ellipses in the same list"
1490       '(syntax-case . "misplaced ellipsis")
1491       (eval '(lambda (e)
1492                (syntax-case e ()
1493                  ((x ... y ... z ...) #f)))
1494             (interaction-environment)))))
1495
1496 (with-test-prefix "with-ellipsis"
1497
1498   (pass-if-equal "simple"
1499       '(a 1 2 3)
1500     (let ()
1501       (define-syntax define-quotation-macros
1502         (lambda (x)
1503           (syntax-case x ()
1504             ((_ (macro-name head-symbol) ...)
1505              #'(begin (define-syntax macro-name
1506                         (lambda (x)
1507                           (with-ellipsis …
1508                             (syntax-case x ()
1509                               ((_ x …)
1510                                #'(quote (head-symbol x …)))))))
1511                       ...)))))
1512       (define-quotation-macros (quote-a a) (quote-b b))
1513       (quote-a 1 2 3)))
1514
1515   (pass-if-equal "disables normal ellipsis"
1516       '(a ...)
1517     (let ()
1518       (define-syntax foo
1519         (lambda (x)
1520           (with-ellipsis …
1521             (syntax-case x ()
1522               ((_)
1523                #'(quote (a ...)))))))
1524       (foo)))
1525
1526   (pass-if-equal "doesn't affect ellipsis for generated code"
1527       '(a b c)
1528     (let ()
1529       (define-syntax quotation-macro
1530         (lambda (x)
1531           (with-ellipsis …
1532             (syntax-case x ()
1533               ((_)
1534                #'(lambda (x)
1535                    (syntax-case x ()
1536                      ((_ x ...)
1537                       #'(quote (x ...))))))))))
1538       (define-syntax kwote (quotation-macro))
1539       (kwote a b c)))
1540
1541   (pass-if-equal "propagates into syntax binders"
1542       '(a b c)
1543     (let ()
1544       (with-ellipsis …
1545         (define-syntax kwote
1546           (lambda (x)
1547             (syntax-case x ()
1548               ((_ x …)
1549                #'(quote (x …))))))
1550         (kwote a b c))))
1551
1552   (pass-if-equal "works with local-eval"
1553       5
1554     (let ((env (with-ellipsis … (the-environment))))
1555       (local-eval '(syntax-case #'(a b c d e) ()
1556                      ((x …)
1557                       (length #'(x …))))
1558                   env))))
1559
1560 ;;; Local Variables:
1561 ;;; eval: (put 'pass-if-syntax-error 'scheme-indent-function 1)
1562 ;;; eval: (put 'with-ellipsis 'scheme-indent-function 1)
1563 ;;; End: