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