test-suite/tests/syntax.test

   1 ;;;; syntax.test --- test suite for Guile's syntactic forms    -*- scheme -*-
   2 ;;;;
   3 ;;;; Copyright (C) 2001, 2003 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., 59 Temple Place, Suite 330,
  18 ;;;; Boston, MA 02111-1307 USA
  19
  20
  21 (define exception:bad-bindings
  22   (cons 'misc-error "^bad bindings"))
  23 (define exception:duplicate-bindings
  24   (cons 'misc-error "^duplicate bindings"))
  25 (define exception:bad-body
  26   (cons 'misc-error "^bad body"))
  27 (define exception:bad-formals
  28   (cons 'misc-error "^bad formals"))
  29 (define exception:duplicate-formals
  30   (cons 'misc-error "^duplicate formals"))
  31 (define exception:bad-var
  32   (cons 'misc-error "^bad variable"))
  33 (define exception:bad/missing-clauses
  34   (cons 'misc-error "^bad or missing clauses"))
  35 (define exception:missing/extra-expr
  36   (cons 'misc-error "^missing or extra expression"))
  37
  38
  39 (with-test-prefix "expressions"
  40
  41   (with-test-prefix "missing or extra expression"
  42
  43     ;; R5RS says:
  44     ;; *Note:* In many dialects of Lisp, the empty combination, (),
  45     ;; is a legitimate expression.  In Scheme, combinations must
  46     ;; have at least one subexpression, so () is not a syntactically
  47     ;; valid expression.
  48
  49     ;; Fixed on 2001-3-3
  50     (pass-if-exception "empty parentheses \"()\""
  51       exception:missing/extra-expr
  52       ())))
  53
  54 (with-test-prefix "quote"
  55   #t)
  56
  57 (with-test-prefix "quasiquote"
  58
  59   (with-test-prefix "unquote"
  60
  61     (pass-if "repeated execution"
  62       (let ((foo (let ((i 0)) (lambda () (set! i (+ i 1)) `(,i)))))
  63         (and (equal? (foo) '(1)) (equal? (foo) '(2))))))
  64
  65   (with-test-prefix "unquote-splicing"
  66
  67     (pass-if-exception "extra arguments"
  68       exception:missing/extra-expr
  69       (quasiquote ((unquote-splicing (list 1 2) (list 3 4)))))))
  70
  71 (with-test-prefix "begin"
  72
  73   (pass-if "legal (begin)"
  74     (begin)
  75     #t)
  76
  77   (expect-fail-exception "illegal (begin)"
  78     exception:bad-body
  79     (if #t (begin))
  80     #t))
  81
  82 (with-test-prefix "lambda"
  83
  84   (with-test-prefix "bad formals"
  85
  86     (pass-if-exception "(lambda)"
  87       exception:bad-formals
  88       (lambda))
  89
  90     (pass-if-exception "(lambda . \"foo\")"
  91       exception:bad-formals
  92       (lambda . "foo"))
  93
  94     (pass-if-exception "(lambda \"foo\")"
  95       exception:bad-formals
  96       (lambda "foo"))
  97
  98     (pass-if-exception "(lambda \"foo\" #f)"
  99       exception:bad-formals
 100       (eval '(lambda "foo" #f)
 101             (interaction-environment)))
 102
 103     (pass-if-exception "(lambda (x 1) 2)"
 104       exception:bad-formals
 105       (lambda (x 1) 2))
 106
 107     (pass-if-exception "(lambda (1 x) 2)"
 108       exception:bad-formals
 109       (lambda (1 x) 2))
 110
 111     (pass-if-exception "(lambda (x \"a\") 2)"
 112       exception:bad-formals
 113       (lambda (x "a") 2))
 114
 115     (pass-if-exception "(lambda (\"a\" x) 2)"
 116       exception:bad-formals
 117       (lambda ("a" x) 2)))
 118
 119   (with-test-prefix "duplicate formals"
 120
 121     ;; Fixed on 2001-3-3
 122     (pass-if-exception "(lambda (x x) 1)"
 123       exception:duplicate-formals
 124       (lambda (x x) 1))
 125
 126     ;; Fixed on 2001-3-3
 127     (pass-if-exception "(lambda (x x x) 1)"
 128       exception:duplicate-formals
 129       (lambda (x x x) 1)))
 130
 131   (with-test-prefix "bad body"
 132
 133     (pass-if-exception "(lambda ())"
 134       exception:bad-body
 135       (lambda ()))))
 136
 137 (with-test-prefix "let"
 138
 139   (with-test-prefix "bindings"
 140
 141     (pass-if-exception "late binding"
 142       exception:unbound-var
 143       (let ((x 1) (y x)) y)))
 144
 145   (with-test-prefix "bad bindings"
 146
 147     (pass-if-exception "(let)"
 148       exception:bad-bindings
 149       (let))
 150
 151     (pass-if-exception "(let 1)"
 152       exception:bad-bindings
 153       (let 1))
 154
 155     (pass-if-exception "(let (x))"
 156       exception:bad-bindings
 157       (let (x)))
 158
 159     ;; FIXME:  Wouldn't one rather expect a 'bad bindings' error?
 160     ;; (Even although the body is bad as well...)
 161     (pass-if-exception "(let ((x)))"
 162       exception:bad-body
 163       (let ((x))))
 164
 165     (pass-if-exception "(let (x) 1)"
 166       exception:bad-bindings
 167       (let (x) 1))
 168
 169     (pass-if-exception "(let ((x)) 3)"
 170       exception:bad-bindings
 171       (let ((x)) 3))
 172
 173     (pass-if-exception "(let ((x 1) y) x)"
 174       exception:bad-bindings
 175       (let ((x 1) y) x))
 176
 177     (pass-if-exception "(let ((1 2)) 3)"
 178       exception:bad-var
 179       (eval '(let ((1 2)) 3)
 180             (interaction-environment))))
 181
 182   (with-test-prefix "duplicate bindings"
 183
 184     (pass-if-exception "(let ((x 1) (x 2)) x)"
 185       exception:duplicate-bindings
 186       (let ((x 1) (x 2)) x)))
 187
 188   (with-test-prefix "bad body"
 189
 190     (pass-if-exception "(let ())"
 191       exception:bad-body
 192       (let ()))
 193
 194     (pass-if-exception "(let ((x 1)))"
 195       exception:bad-body
 196       (let ((x 1))))))
 197
 198 (with-test-prefix "named let"
 199
 200   (with-test-prefix "initializers"
 201
 202     (pass-if "evaluated in outer environment"
 203       (let ((f -))
 204         (eqv? (let f ((n (f 1))) n) -1))))
 205
 206   (with-test-prefix "bad bindings"
 207
 208     (pass-if-exception "(let x (y))"
 209       exception:bad-bindings
 210       (let x (y))))
 211
 212   (with-test-prefix "bad body"
 213
 214     (pass-if-exception "(let x ())"
 215       exception:bad-body
 216       (let x ()))
 217
 218     (pass-if-exception "(let x ((y 1)))"
 219       exception:bad-body
 220       (let x ((y 1))))))
 221
 222 (with-test-prefix "let*"
 223
 224   (with-test-prefix "bindings"
 225
 226     (pass-if "(let* ((x 1) (x 2)) ...)"
 227       (let* ((x 1) (x 2))
 228         (= x 2)))
 229
 230     (pass-if "(let* ((x 1) (x x)) ...)"
 231       (let* ((x 1) (x x))
 232         (= x 1))))
 233
 234   (with-test-prefix "bad bindings"
 235
 236     (pass-if-exception "(let*)"
 237       exception:bad-bindings
 238       (let*))
 239
 240     (pass-if-exception "(let* 1)"
 241       exception:bad-bindings
 242       (let* 1))
 243
 244     (pass-if-exception "(let* (x))"
 245       exception:bad-bindings
 246       (let* (x)))
 247
 248     (pass-if-exception "(let* (x) 1)"
 249       exception:bad-bindings
 250       (let* (x) 1))
 251
 252     (pass-if-exception "(let* ((x)) 3)"
 253       exception:bad-bindings
 254       (let* ((x)) 3))
 255
 256     (pass-if-exception "(let* ((x 1) y) x)"
 257       exception:bad-bindings
 258       (let* ((x 1) y) x))
 259
 260     (pass-if-exception "(let* x ())"
 261       exception:bad-bindings
 262       (eval '(let* x ())
 263             (interaction-environment)))
 264
 265     (pass-if-exception "(let* x (y))"
 266       exception:bad-bindings
 267       (eval '(let* x (y))
 268             (interaction-environment)))
 269
 270     (pass-if-exception "(let* ((1 2)) 3)"
 271       exception:bad-var
 272       (eval '(let* ((1 2)) 3)
 273             (interaction-environment))))
 274
 275   (with-test-prefix "bad body"
 276
 277     (pass-if-exception "(let* ())"
 278       exception:bad-body
 279       (let* ()))
 280
 281     (pass-if-exception "(let* ((x 1)))"
 282       exception:bad-body
 283       (let* ((x 1))))))
 284
 285 (with-test-prefix "letrec"
 286
 287   (with-test-prefix "bindings"
 288
 289     (pass-if-exception "initial bindings are undefined"
 290       exception:unbound-var
 291       (let ((x 1))
 292         (letrec ((x 1) (y x)) y))))
 293
 294   (with-test-prefix "bad bindings"
 295
 296     (pass-if-exception "(letrec)"
 297       exception:bad-bindings
 298       (letrec))
 299
 300     (pass-if-exception "(letrec 1)"
 301       exception:bad-bindings
 302       (letrec 1))
 303
 304     (pass-if-exception "(letrec (x))"
 305       exception:bad-bindings
 306       (letrec (x)))
 307
 308     (pass-if-exception "(letrec (x) 1)"
 309       exception:bad-bindings
 310       (letrec (x) 1))
 311
 312     (pass-if-exception "(letrec ((x)) 3)"
 313       exception:bad-bindings
 314       (letrec ((x)) 3))
 315
 316     (pass-if-exception "(letrec ((x 1) y) x)"
 317       exception:bad-bindings
 318       (letrec ((x 1) y) x))
 319
 320     (pass-if-exception "(letrec x ())"
 321       exception:bad-bindings
 322       (eval '(letrec x ())
 323             (interaction-environment)))
 324
 325     (pass-if-exception "(letrec x (y))"
 326       exception:bad-bindings
 327       (eval '(letrec x (y))
 328             (interaction-environment)))
 329
 330     (pass-if-exception "(letrec ((1 2)) 3)"
 331       exception:bad-var
 332       (eval '(letrec ((1 2)) 3)
 333             (interaction-environment))))
 334
 335   (with-test-prefix "duplicate bindings"
 336
 337     (pass-if-exception "(letrec ((x 1) (x 2)) x)"
 338       exception:duplicate-bindings
 339       (letrec ((x 1) (x 2)) x)))
 340
 341   (with-test-prefix "bad body"
 342
 343     (pass-if-exception "(letrec ())"
 344       exception:bad-body
 345       (letrec ()))
 346
 347     (pass-if-exception "(letrec ((x 1)))"
 348       exception:bad-body
 349       (letrec ((x 1))))))
 350
 351 (with-test-prefix "if"
 352
 353   (with-test-prefix "missing or extra expressions"
 354
 355     (pass-if-exception "(if)"
 356       exception:missing/extra-expr
 357       (eval '(if)
 358             (interaction-environment)))
 359
 360     (pass-if-exception "(if 1 2 3 4)"
 361       exception:missing/extra-expr
 362       (eval '(if 1 2 3 4)
 363             (interaction-environment)))))
 364
 365 (with-test-prefix "cond"
 366
 367   (with-test-prefix "bad or missing clauses"
 368
 369     (pass-if-exception "(cond)"
 370       exception:bad/missing-clauses
 371       (cond))
 372
 373     (pass-if-exception "(cond #t)"
 374       exception:bad/missing-clauses
 375       (cond #t))
 376
 377     (pass-if-exception "(cond 1)"
 378       exception:bad/missing-clauses
 379       (cond 1))
 380
 381     (pass-if-exception "(cond 1 2)"
 382       exception:bad/missing-clauses
 383       (cond 1 2))
 384
 385     (pass-if-exception "(cond 1 2 3)"
 386       exception:bad/missing-clauses
 387       (cond 1 2 3))
 388
 389     (pass-if-exception "(cond 1 2 3 4)"
 390       exception:bad/missing-clauses
 391       (cond 1 2 3 4))
 392
 393     (pass-if-exception "(cond ())"
 394       exception:bad/missing-clauses
 395       (cond ()))
 396
 397     (pass-if-exception "(cond () 1)"
 398       exception:bad/missing-clauses
 399       (cond () 1))
 400
 401     (pass-if-exception "(cond (1) 1)"
 402       exception:bad/missing-clauses
 403       (cond (1) 1))))
 404
 405 (with-test-prefix "cond =>"
 406
 407   (with-test-prefix "else is handled correctly"
 408
 409     (pass-if "else =>"
 410       (let ((=> 'foo))
 411         (eq? (cond (else =>)) 'foo)))
 412
 413     (pass-if "else => identity"
 414       (let* ((=> 'foo))
 415         (eq? (cond (else => identity)) identity))))
 416
 417   (with-test-prefix "bad formals"
 418
 419     (pass-if-exception "=> (lambda (x 1) 2)"
 420       exception:bad-formals
 421       (cond (1 => (lambda (x 1) 2))))))
 422
 423 (with-test-prefix "case"
 424
 425   (with-test-prefix "bad or missing clauses"
 426
 427     (pass-if-exception "(case)"
 428       exception:bad/missing-clauses
 429       (case))
 430
 431     (pass-if-exception "(case . \"foo\")"
 432       exception:bad/missing-clauses
 433       (case . "foo"))
 434
 435     (pass-if-exception "(case 1)"
 436       exception:bad/missing-clauses
 437       (case 1))
 438
 439     (pass-if-exception "(case 1 . \"foo\")"
 440       exception:bad/missing-clauses
 441       (case 1 . "foo"))
 442
 443     (pass-if-exception "(case 1 \"foo\")"
 444       exception:bad/missing-clauses
 445       (case 1 "foo"))
 446
 447     (pass-if-exception "(case 1 ())"
 448       exception:bad/missing-clauses
 449       (case 1 ()))
 450
 451     (pass-if-exception "(case 1 (\"foo\"))"
 452       exception:bad/missing-clauses
 453       (case 1 ("foo")))
 454
 455     (pass-if-exception "(case 1 (\"foo\" \"bar\"))"
 456       exception:bad/missing-clauses
 457       (case 1 ("foo" "bar")))
 458
 459     ;; According to R5RS, the following one is syntactically correct.
 460     ;; (pass-if-exception "(case 1 (() \"bar\"))"
 461     ;;   exception:bad/missing-clauses
 462     ;;   (case 1 (() "bar")))
 463
 464     (pass-if-exception "(case 1 ((2) \"bar\") . \"foo\")"
 465       exception:bad/missing-clauses
 466       (case 1 ((2) "bar") . "foo"))
 467
 468     (pass-if-exception "(case 1 (else #f) ((1) #t))"
 469       exception:bad/missing-clauses
 470       (case 1 ((2) "bar") (else)))
 471
 472     (pass-if-exception "(case 1 (else #f) . \"foo\")"
 473       exception:bad/missing-clauses
 474       (case 1 (else #f) . "foo"))
 475
 476     (pass-if-exception "(case 1 (else #f) ((1) #t))"
 477       exception:bad/missing-clauses
 478       (case 1 (else #f) ((1) #t)))))
 479
 480 (with-test-prefix "define"
 481
 482   (with-test-prefix "currying"
 483
 484     (pass-if "(define ((foo)) #f)"
 485       (define ((foo)) #t)
 486       ((foo))))
 487
 488   (with-test-prefix "missing or extra expressions"
 489
 490     (pass-if-exception "(define)"
 491       exception:missing/extra-expr
 492       (define))))
 493
 494 (with-test-prefix "set!"
 495
 496   (with-test-prefix "missing or extra expressions"
 497
 498     (pass-if-exception "(set!)"
 499       exception:missing/extra-expr
 500       (eval '(set!)
 501             (interaction-environment)))
 502
 503     (pass-if-exception "(set! 1)"
 504       exception:missing/extra-expr
 505       (eval '(set! 1)
 506             (interaction-environment)))
 507
 508     (pass-if-exception "(set! 1 2 3)"
 509       exception:missing/extra-expr
 510       (eval '(set! 1 2 3)
 511             (interaction-environment))))
 512
 513   (with-test-prefix "bad variable"
 514
 515     (pass-if-exception "(set! \"\" #t)"
 516       exception:bad-var
 517       (eval '(set! "" #t)
 518             (interaction-environment)))
 519
 520     (pass-if-exception "(set! 1 #t)"
 521       exception:bad-var
 522       (eval '(set! 1 #t)
 523             (interaction-environment)))
 524
 525     (pass-if-exception "(set! #t #f)"
 526       exception:bad-var
 527       (eval '(set! #t #f)
 528             (interaction-environment)))
 529
 530     (pass-if-exception "(set! #f #t)"
 531       exception:bad-var
 532       (eval '(set! #f #t)
 533             (interaction-environment)))
 534
 535     (pass-if-exception "(set! #\space #f)"
 536       exception:bad-var
 537       (eval '(set! #\space #f)
 538             (interaction-environment)))))
 539
 540 (with-test-prefix "quote"
 541
 542   (with-test-prefix "missing or extra expression"
 543
 544     (pass-if-exception "(quote)"
 545       exception:missing/extra-expr
 546       (eval '(quote)
 547             (interaction-environment)))
 548
 549     (pass-if-exception "(quote a b)"
 550       exception:missing/extra-expr
 551       (eval '(quote a b)
 552             (interaction-environment)))))
 553
 554 (with-test-prefix "while"
 555
 556   (define (unreachable)
 557     (error "unreachable code has been reached!"))
 558
 559   ;; an environment with no bindings at all
 560   (define empty-environment
 561     (make-module 1))
 562
 563   ;; Return a new procedure COND which when called (COND) will return #t the
 564   ;; first N times, then #f, then any further call is an error.  N=0 is
 565   ;; allowed, in which case #f is returned by the first call.
 566   (define (make-iterations-cond n)
 567     (lambda ()
 568       (cond ((not n)
 569              (error "oops, condition re-tested after giving false"))
 570             ((= 0 n)
 571              (set! n #f)
 572              #f)
 573             (else
 574              (set! n (1- n))
 575              #t))))
 576
 577
 578   (pass-if-exception "too few args" exception:wrong-num-args
 579     (while))
 580
 581   (with-test-prefix "empty body"
 582     (do ((n 0 (1+ n)))
 583         ((> n 5))
 584       (pass-if n
 585         (let ((cond (make-iterations-cond n)))
 586           (while (cond)))
 587         #t)))
 588
 589   (pass-if "initially false"
 590     (while #f
 591       (unreachable))
 592     #t)
 593
 594   (with-test-prefix "in empty environment"
 595
 596     (pass-if "empty body"
 597       (eval `(,while #f)
 598             empty-environment)
 599       #t)
 600
 601     (pass-if "initially false"
 602       (eval `(,while #f
 603                #f)
 604             empty-environment)
 605       #t)
 606
 607     (pass-if "iterating"
 608       (let ((cond (make-iterations-cond 3)))
 609         (eval `(,while (,cond)
 610                  123 456)
 611               empty-environment))
 612       #t))
 613
 614   (with-test-prefix "iterations"
 615     (do ((n 0 (1+ n)))
 616         ((> n 5))
 617       (pass-if n
 618         (let ((cond (make-iterations-cond n))
 619               (i    0))
 620           (while (cond)
 621             (set! i (1+ i)))
 622           (= i n)))))
 623
 624   (with-test-prefix "break"
 625
 626     (pass-if-exception "too many args" exception:wrong-num-args
 627       (while #t
 628         (break 1)))
 629
 630     (with-test-prefix "from cond"
 631       (pass-if "first"
 632         (while (begin
 633                  (break)
 634                  (unreachable))
 635           (unreachable))
 636         #t)
 637
 638       (do ((n 0 (1+ n)))
 639           ((> n 5))
 640         (pass-if n
 641           (let ((cond (make-iterations-cond n))
 642                 (i    0))
 643             (while (if (cond)
 644                        #t
 645                        (begin
 646                          (break)
 647                          (unreachable)))
 648               (set! i (1+ i)))
 649             (= i n)))))
 650
 651     (with-test-prefix "from body"
 652       (pass-if "first"
 653         (while #t
 654           (break)
 655           (unreachable))
 656         #t)
 657
 658       (do ((n 0 (1+ n)))
 659           ((> n 5))
 660         (pass-if n
 661           (let ((cond (make-iterations-cond n))
 662                 (i    0))
 663             (while #t
 664               (if (not (cond))
 665                   (begin
 666                     (break)
 667                     (unreachable)))
 668               (set! i (1+ i)))
 669             (= i n)))))
 670
 671     (pass-if "from nested"
 672       (while #t
 673         (let ((outer-break break))
 674           (while #t
 675             (outer-break)
 676             (unreachable)))
 677         (unreachable))
 678       #t))
 679
 680   (with-test-prefix "continue"
 681
 682     (pass-if-exception "too many args" exception:wrong-num-args
 683       (while #t
 684         (continue 1)))
 685
 686     (with-test-prefix "from cond"
 687       (do ((n 0 (1+ n)))
 688           ((> n 5))
 689         (pass-if n
 690           (let ((cond (make-iterations-cond n))
 691                 (i    0))
 692             (while (if (cond)
 693                        (begin
 694                          (set! i (1+ i))
 695                          (continue)
 696                          (unreachable))
 697                        #f)
 698               (unreachable))
 699             (= i n)))))
 700
 701     (with-test-prefix "from body"
 702       (do ((n 0 (1+ n)))
 703           ((> n 5))
 704         (pass-if n
 705           (let ((cond (make-iterations-cond n))
 706                 (i    0))
 707             (while (cond)
 708               (set! i (1+ i))
 709               (continue)
 710               (unreachable))
 711             (= i n)))))
 712
 713     (pass-if "from nested"
 714       (let ((cond (make-iterations-cond 3)))
 715         (while (cond)
 716           (let ((outer-continue continue))
 717             (while #t
 718               (outer-continue)
 719               (unreachable)))))
 720       #t)))