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