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 Free Software Foundation, Inc.
   4 ;;;;
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 (define-module (test-suite test-syntax)
  20   :use-module (test-suite lib))
  21
  22
  23 (define exception:generic-syncase-error
  24   (cons 'syntax-error "source expression failed to match"))
  25 (define exception:unexpected-syntax
  26   (cons 'syntax-error "unexpected syntax"))
  27
  28 (define exception:bad-expression
  29   (cons 'syntax-error "Bad expression"))
  30
  31 (define exception:missing/extra-expr
  32   (cons 'syntax-error "Missing or extra expression"))
  33 (define exception:missing-expr
  34   (cons 'syntax-error "Missing expression"))
  35 (define exception:missing-body-expr
  36   (cons 'syntax-error "no expressions in body"))
  37 (define exception:extra-expr
  38   (cons 'syntax-error "Extra expression"))
  39 (define exception:illegal-empty-combination
  40   (cons 'syntax-error "Illegal empty combination"))
  41
  42 (define exception:bad-lambda
  43   '(syntax-error . "bad lambda"))
  44 (define exception:bad-let
  45   '(syntax-error . "bad let "))
  46 (define exception:bad-letrec
  47   '(syntax-error . "bad letrec "))
  48 (define exception:bad-set!
  49   '(syntax-error . "bad set!"))
  50 (define exception:bad-quote
  51   '(syntax-error . "quote: bad syntax"))
  52 (define exception:bad-bindings
  53   (cons 'syntax-error "Bad bindings"))
  54 (define exception:bad-binding
  55   (cons 'syntax-error "Bad binding"))
  56 (define exception:duplicate-binding
  57   (cons 'syntax-error "duplicate bound variable"))
  58 (define exception:bad-body
  59   (cons 'misc-error "^bad body"))
  60 (define exception:bad-formals
  61   '(syntax-error . "invalid argument list"))
  62 (define exception:bad-formal
  63   (cons 'syntax-error "Bad formal"))
  64 (define exception:duplicate-formals
  65   (cons 'syntax-error "duplicate identifier in argument list"))
  66
  67 (define exception:missing-clauses
  68   (cons 'syntax-error "Missing clauses"))
  69 (define exception:misplaced-else-clause
  70   (cons 'syntax-error "Misplaced else clause"))
  71 (define exception:bad-case-clause
  72   (cons 'syntax-error "Bad case clause"))
  73 (define exception:bad-case-labels
  74   (cons 'syntax-error "Bad case labels"))
  75 (define exception:bad-cond-clause
  76   (cons 'syntax-error "Bad cond clause"))
  77
  78
  79 (with-test-prefix "expressions"
  80
  81   (with-test-prefix "Bad argument list"
  82
  83     (pass-if-exception "improper argument list of length 1"
  84       exception:generic-syncase-error
  85       (eval '(let ((foo (lambda (x y) #t)))
  86                (foo . 1))
  87             (interaction-environment)))
  88
  89     (pass-if-exception "improper argument list of length 2"
  90       exception:generic-syncase-error
  91       (eval '(let ((foo (lambda (x y) #t)))
  92                (foo 1 . 2))
  93             (interaction-environment))))
  94
  95   (with-test-prefix "missing or extra expression"
  96
  97     ;; R5RS says:
  98     ;; *Note:* In many dialects of Lisp, the empty combination, (),
  99     ;; is a legitimate expression.  In Scheme, combinations must
 100     ;; have at least one subexpression, so () is not a syntactically
 101     ;; valid expression.
 102
 103     ;; Fixed on 2001-3-3
 104     (pass-if-exception "empty parentheses \"()\""
 105       exception:unexpected-syntax
 106       (eval '()
 107             (interaction-environment)))))
 108
 109 (with-test-prefix "quote"
 110   #t)
 111
 112 (with-test-prefix "quasiquote"
 113
 114   (with-test-prefix "unquote"
 115
 116     (pass-if "repeated execution"
 117       (let ((foo (let ((i 0)) (lambda () (set! i (+ i 1)) `(,i)))))
 118         (and (equal? (foo) '(1)) (equal? (foo) '(2))))))
 119
 120   (with-test-prefix "unquote-splicing"
 121
 122     (pass-if-exception "extra arguments"
 123       '(syntax-error . "unquote-splicing takes exactly one argument")
 124       (eval '(quasiquote ((unquote-splicing (list 1 2) (list 3 4))))
 125             (interaction-environment)))))
 126
 127 (with-test-prefix "begin"
 128
 129   (pass-if "legal (begin)"
 130     (eval '(begin (begin) #t) (interaction-environment)))
 131
 132   (pass-if-exception "illegal (begin)"
 133     exception:generic-syncase-error
 134     (eval '(begin (if #t (begin)) #t) (interaction-environment))))
 135
 136 (define-syntax matches?
 137   (syntax-rules (_)
 138     ((_ (op arg ...) pat)   (let ((x (op arg ...)))
 139                               (matches? x pat)))
 140     ((_ x ())               (null? x))
 141     ((_ x (a . b))          (and (pair? x)
 142                                  (matches? (car x) a)
 143                                  (matches? (cdr x) b)))
 144     ((_ x _)                #t)
 145     ((_ x pat)              (equal? x 'pat))))
 146
 147 (with-test-prefix "lambda"
 148
 149   (with-test-prefix "bad formals"
 150
 151     (pass-if-exception "(lambda)"
 152       exception:bad-lambda
 153       (eval '(lambda)
 154             (interaction-environment)))
 155
 156     (pass-if-exception "(lambda . \"foo\")"
 157       exception:bad-lambda
 158       (eval '(lambda . "foo")
 159             (interaction-environment)))
 160
 161     (pass-if-exception "(lambda \"foo\")"
 162       exception:bad-lambda
 163       (eval '(lambda "foo")
 164             (interaction-environment)))
 165
 166     (pass-if-exception "(lambda \"foo\" #f)"
 167       exception:bad-formals
 168       (eval '(lambda "foo" #f)
 169             (interaction-environment)))
 170
 171     (pass-if-exception "(lambda (x 1) 2)"
 172       exception:bad-formals
 173       (eval '(lambda (x 1) 2)
 174             (interaction-environment)))
 175
 176     (pass-if-exception "(lambda (1 x) 2)"
 177       exception:bad-formals
 178       (eval '(lambda (1 x) 2)
 179             (interaction-environment)))
 180
 181     (pass-if-exception "(lambda (x \"a\") 2)"
 182       exception:bad-formals
 183       (eval '(lambda (x "a") 2)
 184             (interaction-environment)))
 185
 186     (pass-if-exception "(lambda (\"a\" x) 2)"
 187       exception:bad-formals
 188       (eval '(lambda ("a" x) 2)
 189             (interaction-environment))))
 190
 191   (with-test-prefix "duplicate formals"
 192
 193     ;; Fixed on 2001-3-3
 194     (pass-if-exception "(lambda (x x) 1)"
 195       exception:duplicate-formals
 196       (eval '(lambda (x x) 1)
 197             (interaction-environment)))
 198
 199     ;; Fixed on 2001-3-3
 200     (pass-if-exception "(lambda (x x x) 1)"
 201       exception:duplicate-formals
 202       (eval '(lambda (x x x) 1)
 203             (interaction-environment))))
 204
 205   (with-test-prefix "bad body"
 206
 207     (pass-if-exception "(lambda ())"
 208       exception:bad-lambda
 209       (eval '(lambda ())
 210             (interaction-environment)))))
 211
 212 (with-test-prefix "let"
 213
 214   (with-test-prefix "bindings"
 215
 216     (pass-if-exception "late binding"
 217       exception:unbound-var
 218       (let ((x 1) (y x)) y)))
 219
 220   (with-test-prefix "bad bindings"
 221
 222     (pass-if-exception "(let)"
 223       exception:bad-let
 224       (eval '(let)
 225             (interaction-environment)))
 226
 227     (pass-if-exception "(let 1)"
 228       exception:bad-let
 229       (eval '(let 1)
 230             (interaction-environment)))
 231
 232     (pass-if-exception "(let (x))"
 233       exception:bad-let
 234       (eval '(let (x))
 235             (interaction-environment)))
 236
 237     (pass-if-exception "(let ((x)))"
 238       exception:bad-let
 239       (eval '(let ((x)))
 240             (interaction-environment)))
 241
 242     (pass-if-exception "(let (x) 1)"
 243       exception:bad-let
 244       (eval '(let (x) 1)
 245             (interaction-environment)))
 246
 247     (pass-if-exception "(let ((x)) 3)"
 248       exception:bad-let
 249       (eval '(let ((x)) 3)
 250             (interaction-environment)))
 251
 252     (pass-if-exception "(let ((x 1) y) x)"
 253       exception:bad-let
 254       (eval '(let ((x 1) y) x)
 255             (interaction-environment)))
 256
 257     (pass-if-exception "(let ((1 2)) 3)"
 258       exception:bad-let
 259       (eval '(let ((1 2)) 3)
 260             (interaction-environment))))
 261
 262   (with-test-prefix "duplicate bindings"
 263
 264     (pass-if-exception "(let ((x 1) (x 2)) x)"
 265       exception:duplicate-binding
 266       (eval '(let ((x 1) (x 2)) x)
 267             (interaction-environment))))
 268
 269   (with-test-prefix "bad body"
 270
 271     (pass-if-exception "(let ())"
 272       exception:bad-let
 273       (eval '(let ())
 274             (interaction-environment)))
 275
 276     (pass-if-exception "(let ((x 1)))"
 277       exception:bad-let
 278       (eval '(let ((x 1)))
 279             (interaction-environment)))))
 280
 281 (with-test-prefix "named let"
 282
 283   (with-test-prefix "initializers"
 284
 285     (pass-if "evaluated in outer environment"
 286       (let ((f -))
 287         (eqv? (let f ((n (f 1))) n) -1))))
 288
 289   (with-test-prefix "bad bindings"
 290
 291     (pass-if-exception "(let x (y))"
 292       exception:bad-let
 293       (eval '(let x (y))
 294             (interaction-environment))))
 295
 296   (with-test-prefix "bad body"
 297
 298     (pass-if-exception "(let x ())"
 299       exception:bad-let
 300       (eval '(let x ())
 301             (interaction-environment)))
 302
 303     (pass-if-exception "(let x ((y 1)))"
 304       exception:bad-let
 305       (eval '(let x ((y 1)))
 306             (interaction-environment)))))
 307
 308 (with-test-prefix "let*"
 309
 310   (with-test-prefix "bindings"
 311
 312     (pass-if "(let* ((x 1) (x 2)) ...)"
 313       (let* ((x 1) (x 2))
 314         (= x 2)))
 315
 316     (pass-if "(let* ((x 1) (x x)) ...)"
 317       (let* ((x 1) (x x))
 318         (= x 1)))
 319
 320     (pass-if "(let ((x 1) (y 2)) (let* () ...))"
 321       (let ((x 1) (y 2))
 322         (let* ()
 323           (and (= x 1) (= y 2))))))
 324
 325   (with-test-prefix "bad bindings"
 326
 327     (pass-if-exception "(let*)"
 328       exception:generic-syncase-error
 329       (eval '(let*)
 330             (interaction-environment)))
 331
 332     (pass-if-exception "(let* 1)"
 333       exception:generic-syncase-error
 334       (eval '(let* 1)
 335             (interaction-environment)))
 336
 337     (pass-if-exception "(let* (x))"
 338       exception:generic-syncase-error
 339       (eval '(let* (x))
 340             (interaction-environment)))
 341
 342     (pass-if-exception "(let* (x) 1)"
 343       exception:generic-syncase-error
 344       (eval '(let* (x) 1)
 345             (interaction-environment)))
 346
 347     (pass-if-exception "(let* ((x)) 3)"
 348       exception:generic-syncase-error
 349       (eval '(let* ((x)) 3)
 350             (interaction-environment)))
 351
 352     (pass-if-exception "(let* ((x 1) y) x)"
 353       exception:generic-syncase-error
 354       (eval '(let* ((x 1) y) x)
 355             (interaction-environment)))
 356
 357     (pass-if-exception "(let* x ())"
 358       exception:generic-syncase-error
 359       (eval '(let* x ())
 360             (interaction-environment)))
 361
 362     (pass-if-exception "(let* x (y))"
 363       exception:generic-syncase-error
 364       (eval '(let* x (y))
 365             (interaction-environment)))
 366
 367     (pass-if-exception "(let* ((1 2)) 3)"
 368       exception:generic-syncase-error
 369       (eval '(let* ((1 2)) 3)
 370             (interaction-environment))))
 371
 372   (with-test-prefix "bad body"
 373
 374     (pass-if-exception "(let* ())"
 375       exception:generic-syncase-error
 376       (eval '(let* ())
 377             (interaction-environment)))
 378
 379     (pass-if-exception "(let* ((x 1)))"
 380       exception:generic-syncase-error
 381       (eval '(let* ((x 1)))
 382             (interaction-environment)))))
 383
 384 (with-test-prefix "letrec"
 385
 386   (with-test-prefix "bindings"
 387
 388     (pass-if-exception "initial bindings are undefined"
 389       exception:used-before-defined
 390       (let ((x 1))
 391         ;; FIXME: the memoizer does initialize the var to undefined, but
 392         ;; the Scheme evaluator has no way of checking what's an
 393         ;; undefined value. Not sure how to do this.
 394         (throw 'unresolved)
 395         (letrec ((x 1) (y x)) y))))
 396
 397   (with-test-prefix "bad bindings"
 398
 399     (pass-if-exception "(letrec)"
 400       exception:bad-letrec
 401       (eval '(letrec)
 402             (interaction-environment)))
 403
 404     (pass-if-exception "(letrec 1)"
 405       exception:bad-letrec
 406       (eval '(letrec 1)
 407             (interaction-environment)))
 408
 409     (pass-if-exception "(letrec (x))"
 410       exception:bad-letrec
 411       (eval '(letrec (x))
 412             (interaction-environment)))
 413
 414     (pass-if-exception "(letrec (x) 1)"
 415       exception:bad-letrec
 416       (eval '(letrec (x) 1)
 417             (interaction-environment)))
 418
 419     (pass-if-exception "(letrec ((x)) 3)"
 420       exception:bad-letrec
 421       (eval '(letrec ((x)) 3)
 422             (interaction-environment)))
 423
 424     (pass-if-exception "(letrec ((x 1) y) x)"
 425       exception:bad-letrec
 426       (eval '(letrec ((x 1) y) x)
 427             (interaction-environment)))
 428
 429     (pass-if-exception "(letrec x ())"
 430       exception:bad-letrec
 431       (eval '(letrec x ())
 432             (interaction-environment)))
 433
 434     (pass-if-exception "(letrec x (y))"
 435       exception:bad-letrec
 436       (eval '(letrec x (y))
 437             (interaction-environment)))
 438
 439     (pass-if-exception "(letrec ((1 2)) 3)"
 440       exception:bad-letrec
 441       (eval '(letrec ((1 2)) 3)
 442             (interaction-environment))))
 443
 444   (with-test-prefix "duplicate bindings"
 445
 446     (pass-if-exception "(letrec ((x 1) (x 2)) x)"
 447       exception:duplicate-binding
 448       (eval '(letrec ((x 1) (x 2)) x)
 449             (interaction-environment))))
 450
 451   (with-test-prefix "bad body"
 452
 453     (pass-if-exception "(letrec ())"
 454       exception:bad-letrec
 455       (eval '(letrec ())
 456             (interaction-environment)))
 457
 458     (pass-if-exception "(letrec ((x 1)))"
 459       exception:bad-letrec
 460       (eval '(letrec ((x 1)))
 461             (interaction-environment)))))
 462
 463 (with-test-prefix "if"
 464
 465   (with-test-prefix "missing or extra expressions"
 466
 467     (pass-if-exception "(if)"
 468       exception:generic-syncase-error
 469       (eval '(if)
 470             (interaction-environment)))
 471
 472     (pass-if-exception "(if 1 2 3 4)"
 473       exception:generic-syncase-error
 474       (eval '(if 1 2 3 4)
 475             (interaction-environment)))))
 476
 477 (with-test-prefix "cond"
 478
 479   (with-test-prefix "cond is hygienic"
 480
 481     (pass-if "bound 'else is handled correctly"
 482       (eq? (let ((else 'ok)) (cond (else))) 'ok))
 483
 484     (with-test-prefix "bound '=> is handled correctly"
 485
 486       (pass-if "#t => 'ok"
 487         (let ((=> 'foo))
 488           (eq? (cond (#t => 'ok)) 'ok)))
 489
 490       (pass-if "else =>"
 491         (let ((=> 'foo))
 492           (eq? (cond (else =>)) 'foo)))
 493
 494       (pass-if "else => identity"
 495         (let ((=> 'foo))
 496           (eq? (cond (else => identity)) identity)))))
 497
 498   (with-test-prefix "SRFI-61"
 499
 500     (pass-if "always available"
 501       (cond-expand (srfi-61 #t) (else #f)))
 502
 503     (pass-if "single value consequent"
 504       (eq? 'ok (cond (#t identity => (lambda (x) 'ok)) (else #f))))
 505
 506     (pass-if "single value alternate"
 507       (eq? 'ok (cond (#t not => (lambda (x) #f)) (else 'ok))))
 508
 509     (pass-if-exception "doesn't affect standard =>"
 510       exception:wrong-num-args
 511       (cond ((values 1 2) => (lambda (x y) #t))))
 512
 513     (pass-if "multiple values consequent"
 514       (equal? '(2 1) (cond ((values 1 2)
 515                             (lambda (one two)
 516                               (and (= 1 one) (= 2 two))) =>
 517                             (lambda (one two) (list two one)))
 518                            (else #f))))
 519
 520     (pass-if "multiple values alternate"
 521       (eq? 'ok (cond ((values 2 3 4)
 522                       (lambda args (equal? '(1 2 3) args)) =>
 523                       (lambda (x y z) #f))
 524                      (else 'ok))))
 525
 526     (pass-if "zero values"
 527       (eq? 'ok (cond ((values) (lambda () #t) => (lambda () 'ok))
 528                      (else #f))))
 529
 530     (pass-if "bound => is handled correctly"
 531       (let ((=> 'ok))
 532         (eq? 'ok (cond (#t identity =>) (else #f)))))
 533
 534     (pass-if-exception "missing recipient"
 535       '(syntax-error . "cond: wrong number of receiver expressions")
 536       (cond (#t identity =>)))
 537
 538     (pass-if-exception "extra recipient"
 539       '(syntax-error . "cond: wrong number of receiver expressions")
 540       (cond (#t identity => identity identity))))
 541
 542   (with-test-prefix "bad or missing clauses"
 543
 544     (pass-if-exception "(cond)"
 545       exception:generic-syncase-error
 546       (eval '(cond)
 547             (interaction-environment)))
 548
 549     (pass-if-exception "(cond #t)"
 550       exception:generic-syncase-error
 551       (eval '(cond #t)
 552             (interaction-environment)))
 553
 554     (pass-if-exception "(cond 1)"
 555       exception:generic-syncase-error
 556       (eval '(cond 1)
 557             (interaction-environment)))
 558
 559     (pass-if-exception "(cond 1 2)"
 560       exception:generic-syncase-error
 561       (eval '(cond 1 2)
 562             (interaction-environment)))
 563
 564     (pass-if-exception "(cond 1 2 3)"
 565       exception:generic-syncase-error
 566       (eval '(cond 1 2 3)
 567             (interaction-environment)))
 568
 569     (pass-if-exception "(cond 1 2 3 4)"
 570       exception:generic-syncase-error
 571       (eval '(cond 1 2 3 4)
 572             (interaction-environment)))
 573
 574     (pass-if-exception "(cond ())"
 575       exception:generic-syncase-error
 576       (eval '(cond ())
 577             (interaction-environment)))
 578
 579     (pass-if-exception "(cond () 1)"
 580       exception:generic-syncase-error
 581       (eval '(cond () 1)
 582             (interaction-environment)))
 583
 584     (pass-if-exception "(cond (1) 1)"
 585       exception:generic-syncase-error
 586       (eval '(cond (1) 1)
 587             (interaction-environment))))
 588
 589   (with-test-prefix "wrong number of arguments"
 590
 591     (pass-if-exception "=> (lambda (x y) #t)"
 592       exception:wrong-num-args
 593       (cond (1 => (lambda (x y) #t))))))
 594
 595 (with-test-prefix "case"
 596
 597   (pass-if "clause with empty labels list"
 598     (case 1 (() #f) (else #t)))
 599
 600   (with-test-prefix "case is hygienic"
 601
 602     (pass-if-exception "bound 'else is handled correctly"
 603       exception:generic-syncase-error
 604       (eval '(let ((else #f)) (case 1 (else #f)))
 605             (interaction-environment))))
 606
 607   (with-test-prefix "bad or missing clauses"
 608
 609     (pass-if-exception "(case)"
 610       exception:generic-syncase-error
 611       (eval '(case)
 612             (interaction-environment)))
 613
 614     (pass-if-exception "(case . \"foo\")"
 615       exception:generic-syncase-error
 616       (eval '(case . "foo")
 617             (interaction-environment)))
 618
 619     (pass-if-exception "(case 1)"
 620       exception:generic-syncase-error
 621       (eval '(case 1)
 622             (interaction-environment)))
 623
 624     (pass-if-exception "(case 1 . \"foo\")"
 625       exception:generic-syncase-error
 626       (eval '(case 1 . "foo")
 627             (interaction-environment)))
 628
 629     (pass-if-exception "(case 1 \"foo\")"
 630       exception:generic-syncase-error
 631       (eval '(case 1 "foo")
 632             (interaction-environment)))
 633
 634     (pass-if-exception "(case 1 ())"
 635       exception:generic-syncase-error
 636       (eval '(case 1 ())
 637             (interaction-environment)))
 638
 639     (pass-if-exception "(case 1 (\"foo\"))"
 640       exception:generic-syncase-error
 641       (eval '(case 1 ("foo"))
 642             (interaction-environment)))
 643
 644     (pass-if-exception "(case 1 (\"foo\" \"bar\"))"
 645       exception:generic-syncase-error
 646       (eval '(case 1 ("foo" "bar"))
 647             (interaction-environment)))
 648
 649     (pass-if-exception "(case 1 ((2) \"bar\") . \"foo\")"
 650       exception:generic-syncase-error
 651       (eval '(case 1 ((2) "bar") . "foo")
 652             (interaction-environment)))
 653
 654     (pass-if-exception "(case 1 ((2) \"bar\") (else))"
 655       exception:generic-syncase-error
 656       (eval '(case 1 ((2) "bar") (else))
 657             (interaction-environment)))
 658
 659     (pass-if-exception "(case 1 (else #f) . \"foo\")"
 660       exception:generic-syncase-error
 661       (eval '(case 1 (else #f) . "foo")
 662             (interaction-environment)))
 663
 664     (pass-if-exception "(case 1 (else #f) ((1) #t))"
 665       exception:generic-syncase-error
 666       (eval '(case 1 (else #f) ((1) #t))
 667             (interaction-environment)))))
 668
 669 (with-test-prefix "top-level define"
 670
 671   (pass-if "redefinition"
 672     (let ((m (make-module)))
 673       (beautify-user-module! m)
 674
 675       ;; The previous value of `round' must still be visible at the time the
 676       ;; new `round' is defined.  According to R5RS (Section 5.2.1), `define'
 677       ;; should behave like `set!' in this case (except that in the case of
 678       ;; Guile, we respect module boundaries).
 679       (eval '(define round round) m)
 680       (eq? (module-ref m 'round) round)))
 681
 682   (with-test-prefix "missing or extra expressions"
 683
 684     (pass-if-exception "(define)"
 685       exception:generic-syncase-error
 686       (eval '(define)
 687             (interaction-environment)))))
 688
 689 (with-test-prefix "internal define"
 690
 691   (pass-if "internal defines become letrec"
 692     (eval '(let ((a identity) (b identity) (c identity))
 693              (define (a x) (if (= x 0) 'a (b (- x 1))))
 694              (define (b x) (if (= x 0) 'b (c (- x 1))))
 695              (define (c x) (if (= x 0) 'c (a (- x 1))))
 696              (and (eq? 'a (a 0) (a 3))
 697                   (eq? 'b (a 1) (a 4))
 698                   (eq? 'c (a 2) (a 5))))
 699           (interaction-environment)))
 700
 701   (pass-if "binding is created before expression is evaluated"
 702     ;; Internal defines are equivalent to `letrec' (R5RS, Section 5.2.2).
 703     (= (eval '(let ()
 704                 (define foo
 705                   (begin
 706                     (set! foo 1)
 707                     (+ foo 1)))
 708                 foo)
 709              (interaction-environment))
 710        2))
 711
 712   (pass-if "internal defines with begin"
 713     (false-if-exception
 714      (eval '(let ((a identity) (b identity) (c identity))
 715               (define (a x) (if (= x 0) 'a (b (- x 1))))
 716               (begin
 717                 (define (b x) (if (= x 0) 'b (c (- x 1)))))
 718               (define (c x) (if (= x 0) 'c (a (- x 1))))
 719               (and (eq? 'a (a 0) (a 3))
 720                    (eq? 'b (a 1) (a 4))
 721                    (eq? 'c (a 2) (a 5))))
 722            (interaction-environment))))
 723
 724   (pass-if "internal defines with empty begin"
 725     (false-if-exception
 726      (eval '(let ((a identity) (b identity) (c identity))
 727               (define (a x) (if (= x 0) 'a (b (- x 1))))
 728               (begin)
 729               (define (b x) (if (= x 0) 'b (c (- x 1))))
 730               (define (c x) (if (= x 0) 'c (a (- x 1))))
 731               (and (eq? 'a (a 0) (a 3))
 732                    (eq? 'b (a 1) (a 4))
 733                    (eq? 'c (a 2) (a 5))))
 734            (interaction-environment))))
 735
 736   (pass-if "internal defines with macro application"
 737     (false-if-exception
 738      (eval '(begin
 739               (defmacro my-define forms
 740                 (cons 'define forms))
 741               (let ((a identity) (b identity) (c identity))
 742                 (define (a x) (if (= x 0) 'a (b (- x 1))))
 743                 (my-define (b x) (if (= x 0) 'b (c (- x 1))))
 744                 (define (c x) (if (= x 0) 'c (a (- x 1))))
 745                 (and (eq? 'a (a 0) (a 3))
 746                      (eq? 'b (a 1) (a 4))
 747                      (eq? 'c (a 2) (a 5)))))
 748            (interaction-environment))))
 749
 750   (pass-if-exception "missing body expression"
 751     exception:missing-body-expr
 752     (eval '(let () (define x #t))
 753           (interaction-environment))))
 754
 755 (with-test-prefix "set!"
 756
 757   (with-test-prefix "missing or extra expressions"
 758
 759     (pass-if-exception "(set!)"
 760       exception:bad-set!
 761       (eval '(set!)
 762             (interaction-environment)))
 763
 764     (pass-if-exception "(set! 1)"
 765       exception:bad-set!
 766       (eval '(set! 1)
 767             (interaction-environment)))
 768
 769     (pass-if-exception "(set! 1 2 3)"
 770       exception:bad-set!
 771       (eval '(set! 1 2 3)
 772             (interaction-environment))))
 773
 774   (with-test-prefix "bad variable"
 775
 776     (pass-if-exception "(set! \"\" #t)"
 777       exception:bad-set!
 778       (eval '(set! "" #t)
 779             (interaction-environment)))
 780
 781     (pass-if-exception "(set! 1 #t)"
 782       exception:bad-set!
 783       (eval '(set! 1 #t)
 784             (interaction-environment)))
 785
 786     (pass-if-exception "(set! #t #f)"
 787       exception:bad-set!
 788       (eval '(set! #t #f)
 789             (interaction-environment)))
 790
 791     (pass-if-exception "(set! #f #t)"
 792       exception:bad-set!
 793       (eval '(set! #f #t)
 794             (interaction-environment)))
 795
 796     (pass-if-exception "(set! #\\space #f)"
 797       exception:bad-set!
 798       (eval '(set! #\space #f)
 799             (interaction-environment)))))
 800
 801 (with-test-prefix "quote"
 802
 803   (with-test-prefix "missing or extra expression"
 804
 805     (pass-if-exception "(quote)"
 806       exception:bad-quote
 807       (eval '(quote)
 808             (interaction-environment)))
 809
 810     (pass-if-exception "(quote a b)"
 811       exception:bad-quote
 812       (eval '(quote a b)
 813             (interaction-environment)))))
 814
 815 (with-test-prefix "while"
 816
 817   (define (unreachable)
 818     (error "unreachable code has been reached!"))
 819
 820   ;; Return a new procedure COND which when called (COND) will return #t the
 821   ;; first N times, then #f, then any further call is an error.  N=0 is
 822   ;; allowed, in which case #f is returned by the first call.
 823   (define (make-iterations-cond n)
 824     (lambda ()
 825       (cond ((not n)
 826              (error "oops, condition re-tested after giving false"))
 827             ((= 0 n)
 828              (set! n #f)
 829              #f)
 830             (else
 831              (set! n (1- n))
 832              #t))))
 833
 834
 835   (pass-if-exception "too few args" exception:wrong-num-args
 836     (eval '(while) (interaction-environment)))
 837
 838   (with-test-prefix "empty body"
 839     (do ((n 0 (1+ n)))
 840         ((> n 5))
 841       (pass-if n
 842         (eval `(letrec ((make-iterations-cond
 843                          (lambda (n)
 844                            (lambda ()
 845                              (cond ((not n)
 846                                     (error "oops, condition re-tested after giving false"))
 847                                    ((= 0 n)
 848                                     (set! n #f)
 849                                     #f)
 850                                    (else
 851                                     (set! n (1- n))
 852                                     #t))))))
 853                  (let ((cond (make-iterations-cond ,n)))
 854                    (while (cond))
 855                    #t))
 856               (interaction-environment)))))
 857
 858   (pass-if "initially false"
 859     (while #f
 860       (unreachable))
 861     #t)
 862
 863   (with-test-prefix "iterations"
 864     (do ((n 0 (1+ n)))
 865         ((> n 5))
 866       (pass-if n
 867         (let ((cond (make-iterations-cond n))
 868               (i    0))
 869           (while (cond)
 870             (set! i (1+ i)))
 871           (= i n)))))
 872
 873   (with-test-prefix "break"
 874
 875     (pass-if-exception "too many args" exception:wrong-num-args
 876       (eval '(while #t
 877                (break 1))
 878             (interaction-environment)))
 879
 880     (with-test-prefix "from cond"
 881       (pass-if "first"
 882         (while (begin
 883                  (break)
 884                  (unreachable))
 885           (unreachable))
 886         #t)
 887
 888       (do ((n 0 (1+ n)))
 889           ((> n 5))
 890         (pass-if n
 891           (let ((cond (make-iterations-cond n))
 892                 (i    0))
 893             (while (if (cond)
 894                        #t
 895                        (begin
 896                          (break)
 897                          (unreachable)))
 898               (set! i (1+ i)))
 899             (= i n)))))
 900
 901     (with-test-prefix "from body"
 902       (pass-if "first"
 903         (while #t
 904           (break)
 905           (unreachable))
 906         #t)
 907
 908       (do ((n 0 (1+ n)))
 909           ((> n 5))
 910         (pass-if n
 911           (let ((cond (make-iterations-cond n))
 912                 (i    0))
 913             (while #t
 914               (if (not (cond))
 915                   (begin
 916                     (break)
 917                     (unreachable)))
 918               (set! i (1+ i)))
 919             (= i n)))))
 920
 921     (pass-if "from nested"
 922       (while #t
 923         (let ((outer-break break))
 924           (while #t
 925             (outer-break)
 926             (unreachable)))
 927         (unreachable))
 928       #t)
 929
 930     (pass-if "from recursive"
 931       (let ((outer-break #f))
 932         (define (r n)
 933           (while #t
 934             (if (eq? n 'outer)
 935                 (begin
 936                   (set! outer-break break)
 937                   (r 'inner))
 938                 (begin
 939                   (outer-break)
 940                   (unreachable))))
 941           (if (eq? n 'inner)
 942               (error "broke only from inner loop")))
 943         (r 'outer))
 944       #t))
 945
 946   (with-test-prefix "continue"
 947
 948     (pass-if-exception "too many args" exception:wrong-num-args
 949       (eval '(while #t
 950                (continue 1))
 951             (interaction-environment)))
 952
 953     (with-test-prefix "from cond"
 954       (do ((n 0 (1+ n)))
 955           ((> n 5))
 956         (pass-if n
 957           (let ((cond (make-iterations-cond n))
 958                 (i    0))
 959             (while (if (cond)
 960                        (begin
 961                          (set! i (1+ i))
 962                          (continue)
 963                          (unreachable))
 964                        #f)
 965               (unreachable))
 966             (= i n)))))
 967
 968     (with-test-prefix "from body"
 969       (do ((n 0 (1+ n)))
 970           ((> n 5))
 971         (pass-if n
 972           (let ((cond (make-iterations-cond n))
 973                 (i    0))
 974             (while (cond)
 975               (set! i (1+ i))
 976               (continue)
 977               (unreachable))
 978             (= i n)))))
 979
 980     (pass-if "from nested"
 981       (let ((cond (make-iterations-cond 3)))
 982         (while (cond)
 983           (let ((outer-continue continue))
 984             (while #t
 985               (outer-continue)
 986               (unreachable)))))
 987       #t)
 988
 989     (pass-if "from recursive"
 990       (let ((outer-continue #f))
 991         (define (r n)
 992           (let ((cond  (make-iterations-cond 3))
 993                 (first #t))
 994             (while (begin
 995                      (if (and (not first)
 996                               (eq? n 'inner))
 997                          (error "continued only to inner loop"))
 998                      (cond))
 999               (set! first #f)
1000               (if (eq? n 'outer)
1001                   (begin
1002                     (set! outer-continue continue)
1003                     (r 'inner))
1004                   (begin
1005                     (outer-continue)
1006                     (unreachable))))))
1007         (r 'outer))
1008       #t)))