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   (pass-if "module scoping"
 848     (equal?
 849      (eval
 850       '(begin
 851          (define-module (top-level-define/module-scoping-1)
 852            #:export (define-10))
 853          (define-syntax-rule (define-10 name)
 854            (begin
 855              (define t 10)
 856              (define (name) t)))
 857          (define-module (top-level-define/module-scoping-2)
 858            #:use-module (top-level-define/module-scoping-1))
 859          (define-10 foo)
 860          (foo))
 861       (current-module))
 862      10))
 863
 864   (pass-if "module scoping, same symbolic name"
 865     (equal?
 866      (eval
 867       '(begin
 868          (define-module (top-level-define/module-scoping-3))
 869          (define a 10)
 870          (define-module (top-level-define/module-scoping-4)
 871            #:use-module (top-level-define/module-scoping-3))
 872          (define a (@@ (top-level-define/module-scoping-3) a))
 873          a)
 874       (current-module))
 875      10))
 876
 877   (pass-if "module scoping, introduced names"
 878     (equal?
 879      (eval
 880       '(begin
 881          (define-module (top-level-define/module-scoping-5)
 882            #:export (define-constant))
 883          (define-syntax-rule (define-constant name val)
 884            (begin
 885              (define t val)
 886              (define (name) t)))
 887          (define-module (top-level-define/module-scoping-6)
 888            #:use-module (top-level-define/module-scoping-5))
 889          (define-constant foo 10)
 890          (define-constant bar 20)
 891          (foo))
 892       (current-module))
 893      10))
 894
 895   (pass-if "module scoping, duplicate introduced name"
 896     (equal?
 897      (eval
 898       '(begin
 899          (define-module (top-level-define/module-scoping-7)
 900            #:export (define-constant))
 901          (define-syntax-rule (define-constant name val)
 902            (begin
 903              (define t val)
 904              (define (name) t)))
 905          (define-module (top-level-define/module-scoping-8)
 906            #:use-module (top-level-define/module-scoping-7))
 907          (define-constant foo 10)
 908          (define-constant foo 20)
 909          (foo))
 910       (current-module))
 911      20)))
 912
 913 (with-test-prefix "internal define"
 914
 915   (pass-if "internal defines become letrec"
 916     (eval '(let ((a identity) (b identity) (c identity))
 917              (define (a x) (if (= x 0) 'a (b (- x 1))))
 918              (define (b x) (if (= x 0) 'b (c (- x 1))))
 919              (define (c x) (if (= x 0) 'c (a (- x 1))))
 920              (and (eq? 'a (a 0) (a 3))
 921                   (eq? 'b (a 1) (a 4))
 922                   (eq? 'c (a 2) (a 5))))
 923           (interaction-environment)))
 924
 925   (pass-if "binding is created before expression is evaluated"
 926     ;; Internal defines are equivalent to `letrec' (R5RS, Section 5.2.2).
 927     (= (eval '(let ()
 928                 (define foo
 929                   (begin
 930                     (set! foo 1)
 931                     (+ foo 1)))
 932                 foo)
 933              (interaction-environment))
 934        2))
 935
 936   (pass-if "internal defines with begin"
 937     (false-if-exception
 938      (eval '(let ((a identity) (b identity) (c identity))
 939               (define (a x) (if (= x 0) 'a (b (- x 1))))
 940               (begin
 941                 (define (b x) (if (= x 0) 'b (c (- x 1)))))
 942               (define (c x) (if (= x 0) 'c (a (- x 1))))
 943               (and (eq? 'a (a 0) (a 3))
 944                    (eq? 'b (a 1) (a 4))
 945                    (eq? 'c (a 2) (a 5))))
 946            (interaction-environment))))
 947
 948   (pass-if "internal defines with empty begin"
 949     (false-if-exception
 950      (eval '(let ((a identity) (b identity) (c identity))
 951               (define (a x) (if (= x 0) 'a (b (- x 1))))
 952               (begin)
 953               (define (b x) (if (= x 0) 'b (c (- x 1))))
 954               (define (c x) (if (= x 0) 'c (a (- x 1))))
 955               (and (eq? 'a (a 0) (a 3))
 956                    (eq? 'b (a 1) (a 4))
 957                    (eq? 'c (a 2) (a 5))))
 958            (interaction-environment))))
 959
 960   (pass-if "internal defines with macro application"
 961     (false-if-exception
 962      (eval '(begin
 963               (defmacro my-define forms
 964                 (cons 'define forms))
 965               (let ((a identity) (b identity) (c identity))
 966                 (define (a x) (if (= x 0) 'a (b (- x 1))))
 967                 (my-define (b x) (if (= x 0) 'b (c (- x 1))))
 968                 (define (c x) (if (= x 0) 'c (a (- x 1))))
 969                 (and (eq? 'a (a 0) (a 3))
 970                      (eq? 'b (a 1) (a 4))
 971                      (eq? 'c (a 2) (a 5)))))
 972            (interaction-environment))))
 973
 974   (pass-if-syntax-error "missing body expression"
 975     exception:missing-body-expr
 976     (eval '(let () (define x #t))
 977           (interaction-environment))))
 978
 979 (with-test-prefix "set!"
 980
 981   (with-test-prefix "missing or extra expressions"
 982
 983     (pass-if-syntax-error "(set!)"
 984       exception:bad-set!
 985       (eval '(set!)
 986             (interaction-environment)))
 987
 988     (pass-if-syntax-error "(set! 1)"
 989       exception:bad-set!
 990       (eval '(set! 1)
 991             (interaction-environment)))
 992
 993     (pass-if-syntax-error "(set! 1 2 3)"
 994       exception:bad-set!
 995       (eval '(set! 1 2 3)
 996             (interaction-environment))))
 997
 998   (with-test-prefix "bad variable"
 999
1000     (pass-if-syntax-error "(set! \"\" #t)"
1001       exception:bad-set!
1002       (eval '(set! "" #t)
1003             (interaction-environment)))
1004
1005     (pass-if-syntax-error "(set! 1 #t)"
1006       exception:bad-set!
1007       (eval '(set! 1 #t)
1008             (interaction-environment)))
1009
1010     (pass-if-syntax-error "(set! #t #f)"
1011       exception:bad-set!
1012       (eval '(set! #t #f)
1013             (interaction-environment)))
1014
1015     (pass-if-syntax-error "(set! #f #t)"
1016       exception:bad-set!
1017       (eval '(set! #f #t)
1018             (interaction-environment)))
1019
1020     (pass-if-syntax-error "(set! #\\space #f)"
1021       exception:bad-set!
1022       (eval '(set! #\space #f)
1023             (interaction-environment)))))
1024
1025 (with-test-prefix "quote"
1026
1027   (with-test-prefix "missing or extra expression"
1028
1029     (pass-if-syntax-error "(quote)"
1030       exception:bad-quote
1031       (eval '(quote)
1032             (interaction-environment)))
1033
1034     (pass-if-syntax-error "(quote a b)"
1035       exception:bad-quote
1036       (eval '(quote a b)
1037             (interaction-environment)))))
1038
1039 (with-test-prefix "while"
1040
1041   (define (unreachable)
1042     (error "unreachable code has been reached!"))
1043
1044   ;; Return a new procedure COND which when called (COND) will return #t the
1045   ;; first N times, then #f, then any further call is an error.  N=0 is
1046   ;; allowed, in which case #f is returned by the first call.
1047   (define (make-iterations-cond n)
1048     (lambda ()
1049       (cond ((not n)
1050              (error "oops, condition re-tested after giving false"))
1051             ((= 0 n)
1052              (set! n #f)
1053              #f)
1054             (else
1055              (set! n (1- n))
1056              #t))))
1057
1058
1059   (pass-if-syntax-error "too few args" exception:generic-syncase-error
1060     (eval '(while) (interaction-environment)))
1061
1062   (with-test-prefix "empty body"
1063     (do ((n 0 (1+ n)))
1064         ((> n 5))
1065       (pass-if n
1066         (eval `(letrec ((make-iterations-cond
1067                          (lambda (n)
1068                            (lambda ()
1069                              (cond ((not n)
1070                                     (error "oops, condition re-tested after giving false"))
1071                                    ((= 0 n)
1072                                     (set! n #f)
1073                                     #f)
1074                                    (else
1075                                     (set! n (1- n))
1076                                     #t))))))
1077                  (let ((cond (make-iterations-cond ,n)))
1078                    (while (cond))
1079                    #t))
1080               (interaction-environment)))))
1081
1082   (pass-if "initially false"
1083     (while #f
1084       (unreachable))
1085     #t)
1086
1087   (with-test-prefix "iterations"
1088     (do ((n 0 (1+ n)))
1089         ((> n 5))
1090       (pass-if n
1091         (let ((cond (make-iterations-cond n))
1092               (i    0))
1093           (while (cond)
1094             (set! i (1+ i)))
1095           (= i n)))))
1096
1097   (with-test-prefix "break"
1098
1099     (pass-if "normal return"
1100       (not (while #f (error "not reached"))))
1101
1102     (pass-if "no args"
1103       (while #t (break)))
1104
1105     (pass-if "multiple values"
1106       (equal? '(1 2 3)
1107               (call-with-values
1108                   (lambda () (while #t (break 1 2 3)))
1109                 list)))
1110
1111     (with-test-prefix "from cond"
1112       (pass-if "first"
1113         (while (begin
1114                  (break)
1115                  (unreachable))
1116           (unreachable))
1117         #t)
1118
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                        #t
1126                        (begin
1127                          (break)
1128                          (unreachable)))
1129               (set! i (1+ i)))
1130             (= i n)))))
1131
1132     (with-test-prefix "from body"
1133       (pass-if "first"
1134         (while #t
1135           (break)
1136           (unreachable))
1137         #t)
1138
1139       (do ((n 0 (1+ n)))
1140           ((> n 5))
1141         (pass-if n
1142           (let ((cond (make-iterations-cond n))
1143                 (i    0))
1144             (while #t
1145               (if (not (cond))
1146                   (begin
1147                     (break)
1148                     (unreachable)))
1149               (set! i (1+ i)))
1150             (= i n)))))
1151
1152     (pass-if "from nested"
1153       (while #t
1154         (let ((outer-break break))
1155           (while #t
1156             (outer-break)
1157             (unreachable)))
1158         (unreachable))
1159       #t)
1160
1161     (pass-if "from recursive"
1162       (let ((outer-break #f))
1163         (define (r n)
1164           (while #t
1165             (if (eq? n 'outer)
1166                 (begin
1167                   (set! outer-break break)
1168                   (r 'inner))
1169                 (begin
1170                   (outer-break)
1171                   (unreachable))))
1172           (if (eq? n 'inner)
1173               (error "broke only from inner loop")))
1174         (r 'outer))
1175       #t))
1176
1177   (with-test-prefix "continue"
1178
1179     (pass-if-syntax-error "too many args" exception:too-many-args
1180       (eval '(while #t
1181                (continue 1))
1182             (interaction-environment)))
1183
1184     (with-test-prefix "from cond"
1185       (do ((n 0 (1+ n)))
1186           ((> n 5))
1187         (pass-if n
1188           (let ((cond (make-iterations-cond n))
1189                 (i    0))
1190             (while (if (cond)
1191                        (begin
1192                          (set! i (1+ i))
1193                          (continue)
1194                          (unreachable))
1195                        #f)
1196               (unreachable))
1197             (= i n)))))
1198
1199     (with-test-prefix "from body"
1200       (do ((n 0 (1+ n)))
1201           ((> n 5))
1202         (pass-if n
1203           (let ((cond (make-iterations-cond n))
1204                 (i    0))
1205             (while (cond)
1206               (set! i (1+ i))
1207               (continue)
1208               (unreachable))
1209             (= i n)))))
1210
1211     (pass-if "from nested"
1212       (let ((cond (make-iterations-cond 3)))
1213         (while (cond)
1214           (let ((outer-continue continue))
1215             (while #t
1216               (outer-continue)
1217               (unreachable)))))
1218       #t)
1219
1220     (pass-if "from recursive"
1221       (let ((outer-continue #f))
1222         (define (r n)
1223           (let ((cond  (make-iterations-cond 3))
1224                 (first #t))
1225             (while (begin
1226                      (if (and (not first)
1227                               (eq? n 'inner))
1228                          (error "continued only to inner loop"))
1229                      (cond))
1230               (set! first #f)
1231               (if (eq? n 'outer)
1232                   (begin
1233                     (set! outer-continue continue)
1234                     (r 'inner))
1235                   (begin
1236                     (outer-continue)
1237                     (unreachable))))))
1238         (r 'outer))
1239       #t)))
1240
1241 (with-test-prefix "syntax-case"
1242
1243   (pass-if-syntax-error "duplicate pattern variable"
1244     '(syntax-case . "duplicate pattern variable")
1245     (eval '(lambda (e)
1246              (syntax-case e ()
1247                ((a b c d e d f) #f)))
1248           (interaction-environment)))
1249
1250   (with-test-prefix "misplaced ellipses"
1251
1252     (pass-if-syntax-error "bare ellipsis"
1253       '(syntax-case . "misplaced ellipsis")
1254       (eval '(lambda (e)
1255                (syntax-case e ()
1256                  (... #f)))
1257             (interaction-environment)))
1258
1259     (pass-if-syntax-error "ellipsis singleton"
1260       '(syntax-case . "misplaced ellipsis")
1261       (eval '(lambda (e)
1262                (syntax-case e ()
1263                  ((...) #f)))
1264             (interaction-environment)))
1265
1266     (pass-if-syntax-error "ellipsis in car"
1267       '(syntax-case . "misplaced ellipsis")
1268       (eval '(lambda (e)
1269                (syntax-case e ()
1270                  ((... . _) #f)))
1271             (interaction-environment)))
1272
1273     (pass-if-syntax-error "ellipsis in cdr"
1274       '(syntax-case . "misplaced ellipsis")
1275       (eval '(lambda (e)
1276                (syntax-case e ()
1277                  ((_ . ...) #f)))
1278             (interaction-environment)))
1279
1280     (pass-if-syntax-error "two ellipses in the same list"
1281       '(syntax-case . "misplaced ellipsis")
1282       (eval '(lambda (e)
1283                (syntax-case e ()
1284                  ((x ... y ...) #f)))
1285             (interaction-environment)))
1286
1287     (pass-if-syntax-error "three ellipses in the same list"
1288       '(syntax-case . "misplaced ellipsis")
1289       (eval '(lambda (e)
1290                (syntax-case e ()
1291                  ((x ... y ... z ...) #f)))
1292             (interaction-environment)))))
1293
1294 ;;; Local Variables:
1295 ;;; eval: (put 'pass-if-syntax-error 'scheme-indent-function 1)
1296 ;;; End: