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