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