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