test-suite/tests/syntax.test

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