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