PageRenderTime 10ms CodeModel.GetById 6ms app.highlight 350ms RepoModel.GetById 1ms app.codeStats 1ms

/pkgs/racket-pkgs/racket-test/tests/racket/syntax.rktl

http://github.com/plt/racket
Unknown | 1817 lines | 1663 code | 154 blank | 0 comment | 0 complexity | 7c3cee4b16f0a20309cfd1cdfe0887e1 MD5 | raw file

Large files files are truncated, but you can click here to view the full file

   1
   2(load-relative "loadtest.rktl")
   3
   4(Section 'syntax)
   5
   6;; ----------------------------------------
   7
   8(test 0 'with-handlers (with-handlers () 0))
   9(test 1 'with-handlers (with-handlers ([void void]) 1))
  10(test 2 'with-handlers (with-handlers ([void void]) 1 2))
  11(test 'zero 'zero
  12      (with-handlers ((zero? (lambda (x) 'zero)))
  13		     (raise 0)))
  14(test 'zero 'zero
  15      (with-handlers ((zero? (lambda (x) 'zero))
  16		      (positive? (lambda (x) 'positive)))
  17		     (raise 0)))
  18(test 'positive 'positive
  19      (with-handlers ((zero? (lambda (x) 'zero))
  20		      (positive? (lambda (x) 'positive)))
  21		     (raise 1)))
  22(test 5 'with-handlers
  23      (with-handlers ([void (lambda (x) 5)])
  24	(with-handlers ((zero? (lambda (x) 'zero)))
  25	  (/ 0))))
  26
  27(error-test #'(with-handlers ()
  28	         (/ 0))
  29	    exn:fail:contract:divide-by-zero?)
  30(error-test #'(with-handlers ((zero? (lambda (x) 'zero)))
  31		 (/ 0))
  32	    exn:application:type?)
  33(error-test #'(with-handlers ((zero? (lambda (x) 'zero))
  34			     (boolean? (lambda (x) 'boolean)))
  35		 (/ 0))
  36	    exn:application:type?)
  37
  38(syntax-test #'with-handlers)
  39(syntax-test #'(with-handlers))
  40(syntax-test #'(with-handlers . 1))
  41(syntax-test #'(with-handlers ((zero? (lambda (x) 'zero)))))
  42(syntax-test #'(with-handlers ((zero? (lambda (x) 'zero))) . 1))
  43(syntax-test #'(with-handlers (zero?) 1))
  44(syntax-test #'(with-handlers ((zero?)) 1))
  45(syntax-test #'(with-handlers ((zero? . zero?)) 1))
  46(syntax-test #'(with-handlers ((zero? zero?) . 2) 1))
  47(syntax-test #'(with-handlers ((zero? zero?) zero?) 1))
  48(syntax-test #'(with-handlers ((zero? zero?) (zero?)) 1))
  49(syntax-test #'(with-handlers ((zero? zero?) (zero?)) 1))
  50(syntax-test #'(with-handlers ((zero? zero? zero?)) 1))
  51(syntax-test #'(with-handlers ((zero? zero? . zero?)) 1))
  52(syntax-test #'(with-handlers ((zero? zero?)) 1 . 2))
  53
  54(error-test #'(with-handlers ((0 void)) (/ 0)) 
  55	    exn:application:type?)
  56(error-test #'(with-handlers ((void 0)) (/ 0))
  57	    exn:application:type?)
  58(error-test #'(with-handlers ((unbound-variable void)) 0)
  59	    exn:fail:contract:variable?)
  60(error-test #'(with-handlers ((void unbound-variable)) 0)
  61	    exn:fail:contract:variable?)
  62(error-test #'(with-handlers (((values 1 2) void)) 0)
  63	    arity?)
  64(error-test #'(with-handlers ((void (values 1 2))) 0)
  65	    arity?)
  66
  67(test-values '(1 2) (lambda () (with-handlers ([void void])
  68				 (values 1 2))))
  69
  70(test 'c (#%plain-lambda () 'a (define-values (x) 'b) 'c))
  71
  72(test '(quote a) 'quote (quote 'a))
  73(test '(quote a) 'quote ''a)
  74(syntax-test #'quote)
  75(syntax-test #'(quote))
  76(syntax-test #'(quote 1 2))
  77
  78(test 12 (if #f + *) 3 4)
  79(syntax-test #'(+ 3 . 4))
  80(syntax-test #'(apply + 1 . 2))
  81
  82(test 8 (lambda (x) (+ x x)) 4)
  83(define reverse-subtract
  84  (lambda (x y) (- y x)))
  85(test 3 reverse-subtract 7 10)
  86(define add4
  87  (let ((x 4))
  88    (lambda (y) (+ x y))))
  89(test 10 add4 6)
  90(test (letrec([x x]) x) 'lambda (let ([x (lambda () (define d d) d)]) (x)))
  91(test (letrec([x x]) x) 'lambda ((lambda () (define d d) d)))
  92(test '(3 4 5 6) (lambda x x) 3 4 5 6)
  93(test '(5 6) (lambda (x y . z) z) 3 4 5 6)
  94(test 'second (lambda () (cons 'first 2) 'second))
  95(syntax-test #'lambda)
  96(syntax-test #'(lambda))
  97(syntax-test #'(lambda x))
  98(syntax-test #'(lambda ()))
  99(syntax-test #'(lambda () (begin)))
 100(syntax-test #'(lambda . x))
 101(syntax-test #'(lambda x . x))
 102(syntax-test #'(lambda x . 5))
 103(syntax-test #'(lambda ((x)) x))
 104(syntax-test #'(lambda 5 x))
 105(syntax-test #'(lambda (5) x))
 106(syntax-test #'(lambda (x (y)) x))
 107(syntax-test #'(lambda (x . 5) x))
 108(syntax-test #'(lambda (x) x . 5))
 109
 110(let ([f
 111       (case-lambda
 112	[() 'zero]
 113	[(x) (cons 1 1) 'one]
 114	[(x y) 'two]
 115	[(x y z . rest) 'three+]
 116	[x 'bad])]
 117      [g
 118       (case-lambda
 119	[(x y z) 'three]
 120	[(x y) (cons 2 2) 'two]
 121	[(x) 'one]
 122	[() 'zero]
 123	[x (cons 0 'more!) 'more])]
 124      [h
 125       (case-lambda
 126	[(x y) 'two]
 127	[(x y z w) 'four])])
 128  (test 'zero f)
 129  (test 'one f 1)
 130  (test 'two f 1 2)
 131  (test 'three+ f 1 2 3)
 132  (test 'three+ f 1 2 3 4)
 133  (test 'three+ f 1 2 3 4 5 6 7 8 9 10)
 134
 135  (test 'zero g)
 136  (test 'one g 1)
 137  (test 'two g 1 2)
 138  (test 'three g 1 2 3)
 139  (test 'more g 1 2 3 4 5 6 7 8 9 10)
 140
 141  (test 'two h 1 2)
 142  (test 'four h 1 2 3 4)
 143  (let ([h '(case-lambda
 144	     [(x y) 'two]
 145	     [(x y z w) 'four])])
 146    (error-test (datum->syntax #f (list h) #f) arity?)
 147    (error-test (datum->syntax #f (list* h '(1)) #f) arity?)
 148    (error-test (datum->syntax #f (list* h '(1 2 3)) #f) arity?)
 149    (error-test (datum->syntax #f (list* h '(1 2 3 4 5 6)) #f) arity?)))
 150
 151(error-test #'((case-lambda)) arity?)
 152
 153(syntax-test #'case-lambda)
 154(syntax-test #'(case-lambda . 1))
 155(syntax-test #'(case-lambda []))
 156(syntax-test #'(case-lambda 1))
 157(syntax-test #'(case-lambda x))
 158(syntax-test #'(case-lambda [x]))
 159(syntax-test #'(case-lambda [x 8][y]))
 160(syntax-test #'(case-lambda [x][y 9]))
 161(syntax-test #'(case-lambda [8 8]))
 162(syntax-test #'(case-lambda [((x)) 8]))
 163(syntax-test #'(case-lambda [(8) 8]))
 164(syntax-test #'(case-lambda [(x . 9) 8]))
 165(syntax-test #'(case-lambda [x . 8]))
 166(syntax-test #'(case-lambda [(x) . 8]))
 167(syntax-test #'(case-lambda . [(x) 8]))
 168(syntax-test #'(case-lambda [(x) 8] . y))
 169(syntax-test #'(case-lambda [(x) 8] . [y 7]))
 170(syntax-test #'(case-lambda [(x) 8] [8 7]))
 171(syntax-test #'(case-lambda [(x) 8] [((y)) 7]))
 172(syntax-test #'(case-lambda [(x) 8] [(8) 7]))
 173(syntax-test #'(case-lambda [(x) 8] [(y . 8) 7]))
 174(syntax-test #'(case-lambda [(x) 8] [y . 7]))
 175(syntax-test #'(case-lambda [(x) 8] [(y) . 7]))
 176(syntax-test #'(case-lambda [(x x) 8] [(y) 7]))
 177(syntax-test #'(case-lambda [(x . x) 8] [(y) 7]))
 178(syntax-test #'(case-lambda [(y) 7] [(x x) 8]))
 179(syntax-test #'(case-lambda [(y) 7] [(x . x) 8]))
 180
 181(test 'yes 'if (if (> 3 2) 'yes 'no))
 182(test 'no 'if (if (> 2 3) 'yes 'no))
 183(test '1 'if (if (> 3 2) (- 3 2) (+ 3 2)))
 184(test-values '(1 2) (lambda () (if (cons 1 2) (values 1 2) 0)))
 185(test-values '(1 2) (lambda () (if (not (cons 1 2)) 0 (values 1 2))))
 186(syntax-test #'if)
 187(syntax-test #'(if))
 188(syntax-test #'(if . #t))
 189(syntax-test #'(if #t . 1))
 190(syntax-test #'(if #t 1 . 2))
 191(syntax-test #'(if #t))
 192(syntax-test #'(if #t 1))
 193(syntax-test #'(if #t 1 2 3))
 194(syntax-test #'(if #t 1 2 . 3))
 195(error-test #'(if (values 1 2) 3 4) arity?)
 196
 197(test (void) 'when (when (> 1 2) 0))
 198(test (void) 'when (when (> 1 2) (cons 1 2) 0))
 199(test 0 'when (when (< 1 2) 0))
 200(test 0 'when (when (< 1 2) (cons 1 2) 0))
 201(test-values '(0 10) (lambda () (when (< 1 2) (values 0 10))))
 202(syntax-test #'when)
 203(syntax-test #'(when))
 204(syntax-test #'(when . 1))
 205(syntax-test #'(when 1))
 206(syntax-test #'(when 1 . 2))
 207(error-test #'(when (values 1 2) 0) arity?)
 208
 209(test (void) 'unless (unless (< 1 2) 0))
 210(test (void) 'unless (unless (< 1 2) (cons 1 2) 0))
 211(test 0 'unless (unless (> 1 2) 0))
 212(test 0 'unless (unless (> 1 2) (cons 1 2) 0))
 213(test-values '(0 10) (lambda () (unless (> 1 2) (values 0 10))))
 214(syntax-test #'unless)
 215(syntax-test #'(unless))
 216(syntax-test #'(unless . 1))
 217(syntax-test #'(unless 1))
 218(syntax-test #'(unless 1 . 2))
 219(error-test #'(unless (values 1 2) 0) arity?)
 220
 221(define x 2)
 222(test 3 'define (+ x 1))
 223(set! x 4)
 224(test 5 'set! (+ x 1))
 225(syntax-test #'set!)
 226(syntax-test #'(set!))
 227(syntax-test #'(set! x))
 228(syntax-test #'(set! x 1 2))
 229(syntax-test #'(set! 1 2))
 230(syntax-test #'(set! (x) 1))
 231(syntax-test #'(set! . x))
 232(syntax-test #'(set! x . 1))
 233(syntax-test #'(set! x 1 . 2))
 234
 235(define (set!-not-ever-defined) (set! not-ever-defined (add1 not-ever-defined)))
 236(err/rt-test (set!-not-ever-defined) exn:fail:contract:variable?)
 237
 238(set!-values (x) 9)
 239(test 9 'set!-values x)
 240(test (void) 'set!-values (set!-values () (values)))
 241(syntax-test #'set!-values)
 242(syntax-test #'(set!-values))
 243(syntax-test #'(set!-values . x))
 244(syntax-test #'(set!-values x))
 245(syntax-test #'(set!-values 8))
 246(syntax-test #'(set!-values (x)))
 247(syntax-test #'(set!-values (x) . 0))
 248(syntax-test #'(set!-values x 0))
 249(syntax-test #'(set!-values (x . y) 0))
 250(syntax-test #'(set!-values (x . 8) 0))
 251(syntax-test #'(set!-values (x 8) 0))
 252(syntax-test #'(set!-values (x) 0 1))
 253(syntax-test #'(set!-values (x) 0 . 1))
 254(syntax-test #'(set!-values (x x) 0))
 255(syntax-test #'(set!-values (x y x) 0))
 256(syntax-test #'(set!-values (y x x) 0))
 257
 258(error-test #'(set!-values () 1) arity?)
 259(error-test #'(set!-values () (values 1 2)) arity?)
 260(error-test #'(set!-values (x) (values)) arity?)
 261(error-test #'(set!-values (x) (values 1 2)) arity?)
 262(error-test #'(set!-values (x y) 1) arity?)
 263(error-test #'(set!-values (x y) (values 1 2 3)) arity?)
 264
 265(error-test #'(set! unbound-variable 5) exn:fail:contract:variable?)
 266
 267(test 'greater 'cond (cond ((> 3 2) 'greater)
 268			   ((< 3 2) 'less)))
 269(test 'equal 'cond (cond ((> 3 3) 'greater)
 270			 ((< 3 3) 'less)
 271			 (else 'equal)))
 272(test 2 'cond (cond ((assv 'b '((a 1) (b 2))) => cadr)
 273		     (else #f)))
 274(test #f 'cond (cond ((assv 'z '((a 1) (b 2))) => cadr)
 275		     (else #f)))
 276(syntax-test #'(cond ((assv 'z '((a 1) (b 2))) => cadr)
 277		    (else 8)
 278		    (else #f)))
 279(test #f 'cond (let ([else #f])
 280		 (cond ((assv 'z '((a 1) (b 2))) => cadr)
 281		       (else 8)
 282		       (#t #f))))
 283(test 'second 'cond (cond ((< 1 2) (cons 1 2) 'second)))
 284(test 'second-again 'cond (cond ((> 1 2) 'ok) (else (cons 1 2) 'second-again)))
 285(test 1 'cond (cond (1)))
 286(test 1 'cond (cond (#f) (1)))
 287(test 1 'cond (cond (#f 7) (1)))
 288(test 2 'cond (cond (#f 7) (1 => add1)))
 289(test add1 'cond (let ([=> 9]) (cond (#f 7) (1 => add1))))
 290(non-z '(test 0 'case (case (* 2 3)
 291		(6 0)
 292		(else 7))))
 293(test 'composite 'case (case (* 2 3)
 294			 ((2 3 5 7) 'prime)
 295			 ((1 4 6 8 9) 'composite)))
 296(test 'consonant 'case (case (car '(c d))
 297			 ((a e i o u) 'vowel)
 298			 ((w y) 'semivowel)
 299			 (else 'consonant)))
 300(test 'second 'case (case 10
 301		      [(10) (cons 1 2) 'second]
 302		      [else 5]))
 303(test 'second-again 'case (case 11
 304			    [(10) (cons 1 2) 'second]
 305			    [else (cons 1 2) 'second-again]))
 306(test-values '(10 9) (lambda ()
 307		       (cond
 308			[(positive? 0) 'a]
 309			[(positive? 10) (values 10 9)]
 310			[else #f])))
 311(test-values '(10 9) (lambda ()
 312		       (case (string->symbol "hello")
 313			[(bye) 'a]
 314			[(hello) (values 10 9)]
 315			[else #f])))
 316(error-test #'(cond [(values 1 2) 8]) arity?)
 317(error-test #'(case (values 1 2) [(a) 8]) arity?)
 318(syntax-test #'(case 1 []) #rx"ill-formed clause")
 319(syntax-test #'(case 1 [(y) 5] []) #rx"ill-formed clause")
 320(syntax-test #'(case 1 [x]) #rx"not a datum sequence")
 321(syntax-test #'(case 1 [(y) 5] [x]) #rx"not a datum sequence")
 322(syntax-test #'(case 1 [(y) 5] [x x]) #rx"not a datum sequence")
 323(syntax-test #'(case 1 [x x]) #rx"not a datum sequence")
 324(syntax-test #'(case 1 [(x)]) #rx"missing expression after datum sequence")
 325(syntax-test #'(case 1 [(y) 5] [(x)]) #rx"missing expression after datum sequence")
 326(syntax-test #'(case 1 [(x) . 8]) #rx"illegal use of `.'")
 327(syntax-test #'(case 1 [(x) 10] . 9) #rx"illegal use of `.'")
 328
 329;; test larger `case' dispatches to trigger for binary-search
 330;; and hash-table-based dispatch:
 331(let ()
 332  (define (f x)
 333    (case x
 334      [(1003) 'even-further]
 335      [(0 -1 -2) 'low]
 336      [(1) 'one]
 337      [(2 3 4 5 6) 'middle]
 338      [(100) 'super]
 339      [(7 8 9 10 11) 'upper]
 340      [(1001) 'youch]
 341      [(12) 'high]
 342      [(1002) 'further]
 343      [(13) 'extreme]
 344      [(14) 'more]))
 345  (test 'low f -2)
 346  (test 'low f -1)
 347  (test 'low f 0)
 348  (test 'one f 1)
 349  (test 'middle f 2)
 350  (test 'middle f 3)
 351  (test 'middle f 4)
 352  (test 'middle f 5)
 353  (test 'middle f 6)
 354  (test 'upper f 7)
 355  (test 'upper f 8)
 356  (test 'upper f 9)
 357  (test 'upper f 10)
 358  (test 'upper f 11)
 359  (test 'high f 12)
 360  (test 'extreme f 13)
 361  (test 'more f 14)
 362  (test 'super f 100)
 363  (test 'youch f 1001)
 364  (test 'further f 1002)
 365  (test 'even-further f 1003)
 366  (test (void) f 1004)
 367  (test (void) f 104)
 368  (test (void) f -104))
 369
 370(let ()
 371  (define (f x)
 372    (case x
 373      [(#\u1003) 'even-further]
 374      [(#\u0) 'low]
 375      [(#\u1) 'one]
 376      [(#\u2 #\u3 #\u4 #\u5 #\u6) 'middle]
 377      [(#\u100) 'super]
 378      [(#\u7 #\u8 #\u9 #\u10 #\u11) 'upper]
 379      [(#\u1001) 'youch]
 380      [(#\u12) 'high]
 381      [(#\u1002) 'further]
 382      [(#\u13) 'extreme]
 383      [(#\u14) 'more]))
 384  (test 'low f #\u0)
 385  (test 'one f #\u1)
 386  (test 'middle f #\u2)
 387  (test 'middle f #\u3)
 388  (test 'middle f #\u4)
 389  (test 'middle f #\u5)
 390  (test 'middle f #\u6)
 391  (test 'upper f #\u7)
 392  (test 'upper f #\u8)
 393  (test 'upper f #\u9)
 394  (test 'upper f #\u10)
 395  (test 'upper f #\u11)
 396  (test 'high f #\u12)
 397  (test 'extreme f #\u13)
 398  (test 'more f #\u14)
 399  (test 'super f #\u100)
 400  (test 'youch f #\u1001)
 401  (test 'further f #\u1002)
 402  (test 'even-further f #\u1003)
 403  (test (void) f #\u1004)
 404  (test (void) f #\u104))
 405
 406(let ()
 407  (define (f x)
 408    (case x
 409      [(low) 0]
 410      [(one) 1]
 411      [(middle) 2]
 412      [(upper #t) 3]
 413      [(high big up-there more) 4]
 414      [(extreme massive huge #f gigantic) 5]))
 415  (test 0 f 'low)
 416  (test 1 f 'one)
 417  (test 2 f 'middle)
 418  (test 3 f 'upper)
 419  (test 3 f #t)
 420  (test 4 f 'high)
 421  (test 4 f 'big)
 422  (test 4 f 'up-there)
 423  (test 4 f 'more)
 424  (test 5 f 'extreme)
 425  (test 5 f 'massive)
 426  (test 5 f 'huge)
 427  (test 5 f #f)
 428  (test 5 f 'gigantic)
 429  (test (void) f 'gigante)
 430  (test (void) f 0))
 431
 432(let ()
 433  ;; This test relies on interning of string literals.
 434  (define (f x)
 435    (case x
 436      [("low") 0]
 437      [("one") 1]
 438      [("middle") 2]
 439      [("upper" #t) 3]
 440      [("high" "big" "up-there" "more") 4]
 441      [("extreme" "massive" "huge" "gigantic" #f) 5]))
 442  (test 0 f "low")
 443  (test 1 f "one")
 444  (test 2 f "middle")
 445  (test 3 f "upper")
 446  (test 3 f #t)
 447  (test 4 f "high")
 448  (test 4 f "big")
 449  (test 4 f "up-there")
 450  (test 4 f "more")
 451  (test 5 f "extreme")
 452  (test 5 f "massive")
 453  (test 5 f "huge")
 454  (test 5 f #f)
 455  (test 5 f "gigantic")
 456  (test (void) f "gigante")
 457  (test (void) f 'gigante)
 458  (test (void) f 0))
 459
 460(let ()
 461  ;; This test uses string-copy to avoid interning string literals.
 462  (define (f x)
 463    (define y 
 464      (if (string? x)
 465          (string-copy x)
 466          x))
 467    (case y
 468      [("low") 0]
 469      [("one") 1]
 470      [("middle") 2]
 471      [("upper" #t) 3]
 472      [("high" "big" "up-there" "more") 4]
 473      [("extreme" "massive" "huge" "gigantic" #f) 5]))
 474  (test 0 f "low")
 475  (test 1 f "one")
 476  (test 2 f "middle")
 477  (test 3 f "upper")
 478  (test 3 f #t)
 479  (test 4 f "high")
 480  (test 4 f "big")
 481  (test 4 f "up-there")
 482  (test 4 f "more")
 483  (test 5 f "extreme")
 484  (test 5 f "massive")
 485  (test 5 f "huge")
 486  (test 5 f #f)
 487  (test 5 f "gigantic")
 488  (test (void) f "gigante")
 489  (test (void) f 'gigante)
 490  (test (void) f 0))
 491
 492(let ()
 493  (define (f x)
 494    (case x
 495      [("zero"  #"zero"  (z . 0) (z e r o)   #(z e r o)   #&zero 
 496                #hash((z . "z") (e . "e") (r . "r") (o . "o")) 
 497                #s(z e r o)) 
 498       0]
 499      [("one"   #"one"   (o . 1) (o n e)     #(o n e)     #&one 
 500                #hash((o . "o") (n . "n") (e . "e")) 
 501                #s(o n e)) 
 502       1]
 503      [("two"   #"two"   (t . 2) (t w o)     #(t w o)     #&two 
 504                #hash((t . "t") (w . "w") (o . "o")) 
 505                #s(t w o))
 506       2]
 507      [("three" #"three" (t . 3) (t h r e e) #(t h r e e) #&three 
 508                #hash((t . "t") (h . "h") (r . "e") (e . "e") (e . "e")) 
 509                #s(t h r e e)) 
 510       3]
 511      [("four"  #"four"  (f . 4) (f o u r)   #(f o u r)   #&four 
 512                #hash((f . "f") (o . "o") (u . "u") (r . "r"))
 513                #s(f o u r))
 514       4]
 515      [("five"  #"five"  (f . 5) (f i v e)   #(f i v e)   #&five 
 516                #hash((f . "f") (i . "i") (v . "v") (e . "e"))
 517                #s(f i v e)) 
 518       5]
 519      [("six"   #"six"   (s . 6) (s i x)     #(s i x)     #&six 
 520                #hash((s . "s") (i . "i") (x . "x")) 
 521                #s(s i x)) 
 522       6]
 523      [("seven" #"seven" (s . 7) (s e v e n) #(s e v e n) #&seven 
 524                #hash((s . "s") (e . "e") (v . "v") (e . "e") (n . "n"))
 525                #s(s e v e n))
 526       7]
 527      [("eight" #"eight" (e . 8) (e i g h t) #(e i g h t) #&eight 
 528                #hash((e . "e") (i . "i") (g . "g") (h . "h") (t . "t"))
 529                #s(e i g h t))
 530       8]))
 531  (test 8 f "eight")
 532  (test 7 f #"seven")
 533  (test 6 f (cons 's 6))
 534  (test 5 f '(f i v e))
 535  (test 4 f '#(f o u r))
 536  (test 3 f (box 'three))
 537  (test 2 f (hash 't "t" 'w "w" 'o "o"))
 538  (test 1 f #s(o n e))
 539  (test (void) f #f))
 540
 541(test #t 'and (and (= 2 2) (> 2 1)))
 542(test #f 'and (and (= 2 2) (< 2 1)))
 543(test '(f g) 'and (and 1 2 'c '(f g)))
 544(test #t 'and (and))
 545(test-values '(1 12) (lambda () (and (cons 1 2) (values 1 12))))
 546(test #t 'or (or (= 2 2) (> 2 1)))
 547(test #t 'or (or (= 2 2) (< 2 1)))
 548(test #f 'or (or #f #f #f))
 549(test #f 'or (or))
 550(test '(b c) 'or (or (memq 'b '(a b c)) (+ 3 0)))
 551(test-values '(1 12) (lambda () (or (not (cons 1 2)) (values 1 12))))
 552(syntax-test #'(cond #t))
 553(syntax-test #'(cond ())  )
 554(syntax-test #'(cond (1 =>))  )
 555(syntax-test #'(cond (1 => 3 4))  )
 556(syntax-test #'(cond . #t))
 557(syntax-test #'(cond (#t . 1)))
 558(syntax-test #'(cond (#t 1) #f))
 559(syntax-test #'(cond (#t 1) . #f))
 560(error-test #'(cond ((values #t #f) 1)) arity?)
 561(syntax-test #'case)
 562(syntax-test #'(case))
 563(syntax-test #'(case 0 #t))
 564(syntax-test #'(case . 0))
 565(syntax-test #'(case 0 . #t))
 566(syntax-test #'(case 0 (0 #t)))
 567(syntax-test #'(case 0 ()))
 568(syntax-test #'(case 0 (0)))
 569(syntax-test #'(case 0 (0 . 8)))
 570(syntax-test #'(case 0 ((0 . 1) 8)))
 571(syntax-test #'(case 0 (0 8) #f))
 572(syntax-test #'(case 0 (0 8) . #f))
 573(syntax-test #'(case 0 (else 1) (else 2)))
 574(syntax-test #'(case 0 ((0) =>)))
 575(syntax-test #'=>)
 576(syntax-test #'else)
 577(syntax-test #'(and . 1))
 578(syntax-test #'(and 1 . 2))
 579(syntax-test #'(or . 1))
 580(syntax-test #'(or 1 . 2))
 581(error-test #'(and #t (values 1 2) 8) arity?)
 582(error-test #'(or #f (values 1 2) 8) arity?)
 583
 584(test 6 'let (let ((x 2) (y 3)) (* x y)))
 585(test 'second 'let (let ((x 2) (y 3)) (* x y) 'second))
 586(test 6 'let-values (let-values (((x) 2) ((y) 3)) (* x y)))
 587(test 6 'let-values (let-values (((x y) (values 2 3))) (* x y)))
 588(test 35 'let (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x))))
 589(test 35 'let-values (let-values (((x y) (values 2 3))) (let-values (((x) 7) ((z) (+ x y))) (* z x))))
 590(test 70 'let* (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x))))
 591(test 70 'let*-values (let ((x 2) (y 3)) (let*-values (((x) 7) ((z) (+ x y))) (* z x))))
 592(test #t 'letrec (letrec ((-even?
 593                           (lambda (n) (if (zero? n) #t (-odd? (- n 1)))))
 594                          (-odd?
 595                           (lambda (n) (if (zero? n) #f (-even? (- n 1))))))
 596                   (-even? 88)))
 597(test #t 'letrec-values (letrec-values (((-even? -odd?)
 598					 (values
 599					  (lambda (n) (if (zero? n) #t (-odd? (- n 1))))
 600					  (lambda (n) (if (zero? n) #f (-even? (- n 1)))))))
 601				       (-even? 88)))
 602(define x 34)
 603(test 5 'let (let ((x 3)) (define x 5) x))
 604(test 5 'let (let ((x 3)) (define-values (x w) (values 5 8)) x))
 605(test 34 'let x)
 606(test 6 'let (let () (define x 6) x))
 607(test 34 'let x)
 608(test 7 'let* (let* ((x 3)) (define x 7) x))
 609(test 34 'let* x)
 610(test 8 'let* (let* () (define x 8) x))
 611(test 34 'let* x)
 612(test 9 'letrec (letrec () (define x 9) x))
 613(test 34 'letrec x)
 614(test 10 'letrec (letrec ((x 3)) (define x 10) x))
 615(test 34 'letrec x)
 616(teval '(test 5 'letrec (letrec ((x 5)(y x)) y)))
 617(test 3 'let (let ((y 'apple) (x 3) (z 'banana)) x))
 618(test 3 'let* (let* ((y 'apple) (x 3) (z 'banana)) x))
 619(test 3 'letrec (letrec ((y 'apple) (x 3) (z 'banana)) x))
 620(test 3 'let* (let* ((x 7) (y 'apple) (z (set! x 3))) x))
 621(test 3 'let* (let* ((x 7) (y 'apple) (z (if (not #f) (set! x 3) #f))) x))
 622(test 3 'let* (let* ((x 7) (y 'apple) (z (if (not #t) #t (set! x 3)))) x))
 623(test 3 'let-values (let-values (((y x z) (values 'apple 3 'banana))) x))
 624(test 3 'let*-values (let*-values (((y x z) (values 'apple 3 'banana))) x))
 625(test 3 'letrec-values (letrec-values (((y x z) (values 'apple 3 'banana))) x))
 626(test 3 'let*-values (let*-values (((x y) (values 7 'apple)) ((z) (set! x 3))) x))
 627(test 3 'let*-values (let*-values (((x y) (values 7 'apple)) ((z) (if (not #f) (set! x 3) #f))) x))
 628(test 3 'let*-values (let*-values (((x y) (values 7 'apple)) ((z) (if (not #t) #t (set! x 3)))) x))
 629(test 1 'named-let-scope (let ([f add1]) (let f ([n (f 0)]) n)))
 630
 631(test-values '(3 4) (lambda () (let ([x 3][y 4]) (values x y))))
 632(test-values '(3 -4) (lambda () (let loop ([x 3][y -4]) (values x y))))
 633(test-values '(3 14) (lambda () (let* ([x 3][y 14]) (values x y))))
 634(test-values '(3 24) (lambda () (letrec ([x 3][y 24]) (values x y))))
 635(test-values '(3 54) (lambda () (let-values ([(x y) (values 3 54)]) (values x y))))
 636(test-values '(3 64) (lambda () (let*-values ([(x y) (values 3 64)]) (values x y))))
 637(test-values '(3 74) (lambda () (letrec-values ([(x y) (values 3 74)]) (values x y))))
 638
 639(test 'one 'let-values (let-values ([() (values)]) 'one))
 640(test 'two 'let*-values (let*-values ([() (values)]) 'two))
 641(test 'three 'letrec-values (letrec-values ([() (values)]) 'three))
 642(test 'onex 'let-values (let-values ([() (values)][() (values)]) 'onex))
 643(test 'twox 'let*-values (let*-values ([() (values)][() (values)]) 'twox))
 644(test 'threex 'letrec-values (letrec-values ([() (values)][() (values)]) 'threex))
 645
 646(letrec ([undef undef])
 647  (test (list 1 undef undef) 'no-split-letrec (letrec-values ([(a b c) (values 1 a b)]) (list a b c))))
 648
 649(test '(10 11) 'letrec-values (letrec-values ([(names kps)
 650					       (letrec ([oloop 10])
 651						 (values oloop (add1 oloop)))])
 652					     (list names kps)))
 653
 654(define (error-test-let/no-* expr)
 655  (syntax-test (datum->syntax #f (cons 'let expr) #f))
 656  (syntax-test (datum->syntax #f (cons 'let (cons 'name expr)) #f))
 657  (syntax-test (datum->syntax #f (cons 'letrec expr) #f)))
 658(define (error-test-let expr)
 659  (error-test-let/no-* expr)
 660  (syntax-test (datum->syntax #f (cons 'let* expr) #f)))
 661(error-test-let #'x)
 662(error-test-let #'(x))
 663(error-test-let #'(()))
 664(error-test-let #'(x ()))
 665(syntax-test #'(let* x () 1))
 666(syntax-test #'(letrec x () 1))
 667(error-test-let #'(x . 1))
 668(error-test-let #'(() . 1))
 669(error-test-let #'(((x 1))))
 670(error-test-let #'(((x 1)) . 1))
 671(error-test-let #'(((x . 1)) 1))
 672(error-test-let #'(((1 1)) 1))
 673(error-test-let #'(((x 1) 1)  1))
 674(error-test-let #'(((x 1) . 1)  1))
 675(error-test-let #'(((x 1 1)) 1))
 676(error-test-let #'(((x 1 1)) 1))
 677(error-test-let #'(((x 1)) 1 . 2))
 678(error-test-let/no-* #'(((x 1) (x 2)) 1))
 679(error-test-let/no-* #'(((x 1) (y 3) (x 2)) 1))
 680(error-test-let/no-* #'(((y 3) (x 1) (x 2)) 1))
 681(error-test-let/no-* #'(((x 1) (x 2) (y 3)) 1))
 682(test 5 'let* (let* ([x 4][x 5]) x))
 683(error-test-let #'(() (define x 10)))
 684(error-test-let #'(() (define x 10) (define y 20)))
 685
 686(define (do-error-test-let-values/no-* expr syntax-test)
 687  (syntax-test (datum->syntax #f (cons 'let-values expr) #f))
 688  (syntax-test (datum->syntax #f (cons 'letrec-values expr) #f)))
 689(define (do-error-test-let-values expr syntax-test)
 690  (do-error-test-let-values/no-* expr syntax-test)
 691  (syntax-test (datum->syntax #f (cons 'let*-values expr) #f)))
 692(define (error-test-let-values/no-* expr)
 693  (do-error-test-let-values/no-* expr syntax-test))
 694(define (error-test-let-values expr)
 695  (do-error-test-let-values expr syntax-test))
 696(error-test-let-values #'x)
 697(error-test-let-values #'(x))
 698(error-test-let-values #'(()))
 699(error-test-let-values #'(x ()))
 700(syntax-test #'(let*-values x () 1))
 701(syntax-test #'(letrec-values x () 1))
 702(error-test-let-values #'(x . 1))
 703(error-test-let-values #'(() . 1))
 704(error-test-let-values #'((((x) 1))))
 705(error-test-let-values #'((((x) 1)) . 1))
 706(error-test-let-values #'((((x) . 1)) 1))
 707(error-test-let-values #'((((1) 1)) 1))
 708(error-test-let-values #'((((x 1) 1)) 1))
 709(error-test-let-values #'((((1 x) 1)) 1))
 710(error-test-let-values #'((((x) 1) . 1)  1))
 711(error-test-let-values #'((((x) 1 1)) 1))
 712(error-test-let-values #'((((x . y) 1)) 1))
 713(error-test-let-values #'((((x . 1) 1)) 1))
 714(error-test-let-values #'((((x) 1)) 1 . 2))
 715(error-test-let-values #'((((x x) 1)) 1))
 716(error-test-let-values #'((((y) 0) ((x x) 1)) 1))
 717(error-test-let-values #'((((x x) 1) ((y) 0)) 1))
 718(error-test-let-values/no-* #'((((x) 1) ((x) 2)) 1))
 719(error-test-let-values/no-* #'((((x) 1) ((y) 3) ((x) 2)) 1))
 720(error-test-let-values/no-* #'((((y) 3) ((x) 1) ((x) 2)) 1))
 721(error-test-let-values/no-* #'((((x) 1) ((x) 2) ((y) 3)) 1))
 722(test 5 'let* (let*-values ([(x) 4][(x) 5]) x))
 723
 724(do-error-test-let-values #'((((x y) 1)) 1) (lambda (x) (error-test x arity?)))
 725(do-error-test-let-values #'((((x) (values 1 2))) 1) (lambda (x) (error-test x arity?)))
 726(do-error-test-let-values #'(((() (values 1))) 1) (lambda (x) (error-test x arity?)))
 727(do-error-test-let-values #'((((x) (values))) 1) (lambda (x) (error-test x arity?)))
 728
 729(test 5 'embedded (let () (define y (lambda () x)) (define x 5) (y)))
 730
 731(let ([wrap (lambda (body)
 732	      (syntax-test (datum->syntax #f `(let () ,@body) #f))
 733	      (syntax-test (datum->syntax #f `(let () (begin ,@body)) #f)))])
 734  (wrap '((define x 7) (define x 8) x))
 735  (wrap '((define 3 8) x))
 736  (wrap '((define-values x 8) x)))
 737
 738(let ([wrap
 739       (lambda (val body)
 740	 (teval `(test ,val 'let-begin (let () ,@body)))
 741	 (teval `(test ,val 'let-begin (let ([xyzw 12]) ,@body)))
 742	 (teval `(test ,val (lambda () ,@body)))
 743	 (teval `(test ,val 'parameterize-begin
 744		       (parameterize () ,@body)))
 745	 (teval `(test ,val 'parameterize-begin
 746		       (parameterize ([current-directory (current-directory)])
 747			 ,@body)))
 748	 (teval `(test ,val 'with-handlers-begin
 749		       (with-handlers () ,@body)))
 750	 (teval `(test ,val 'with-handlers-begin
 751		       (with-handlers ([void void]) ,@body)))
 752	 (teval `(test ,val 'when-begin (when (positive? 1) ,@body)))
 753	 (teval `(test ,val 'unless-begin (unless (positive? -1) ,@body)))
 754	 (teval `(test ,val 'cons-begin (cond [(positive? 1) ,@body][else #f])))
 755	 (teval `(test ,val 'cons-else-begin (cond [(positive? -1) 0][else ,@body])))
 756         (teval `(test ,val 'case-begin (case (positive? 1) [(#t) ,@body][else -12])))
 757	 (teval `(test ,val 'cond-only-begin (cond [#t ,@body])))
 758	 (syntax-test (datum->syntax #f `(do ((x 1)) (#t ,@body) ,@body) #f))
 759	 (syntax-test (datum->syntax #f `(begin0 12 ,@body) #f)))])
 760  (wrap 5 '((begin (define x 5)) x))
 761  (wrap 5 '((begin (define x 5) x)))
 762  (wrap 15 '((begin (define x 5)) (begin (define y (+ x 10)) y)))
 763  (wrap 13 '((begin) 13))
 764  (wrap 7 '((begin) (begin) (begin (define x 7) (begin) x)))
 765  (wrap 7 '((begin (begin (begin (define x 7) (begin) x))))))
 766
 767(define x 0)
 768(define (test-begin bg nested-bg)
 769  (let* ([make-args
 770	  (lambda (bg b)
 771	    (if (eq? bg 'begin)
 772		b
 773		(let* ([len (length b)]
 774		       [last (list-ref b (sub1 len))])
 775		  (cons last
 776			(let loop ([l b])
 777			  (if (null? (cdr l))
 778			      null
 779			      (cons (car l) (loop (cdr l)))))))))]
 780	 [test-bg
 781	  (lambda (v b)
 782	    (let* ([args (make-args bg b)]
 783		   [expr (cons bg args)])
 784	      (printf "~s:\n" expr)
 785	      (teval `(test ,v (quote ,bg) ,expr))))]
 786	 [make-bg
 787	  (lambda (b)
 788	    (cons nested-bg (make-args nested-bg b)))]
 789	 [make-test-bg-d
 790	  (lambda (bg)
 791	    (lambda (v1 v2 b)
 792	      (test-bg (if (eq? bg 'begin)
 793			   v1
 794			   v2)
 795		       b)))]
 796	 [test-bg-d (make-test-bg-d bg)]
 797	 [test-bg-d2 (make-test-bg-d nested-bg)])
 798  (teval '(set! x 0))
 799  (test-bg-d 6 1 '((set! x 5) (+ x 1)))
 800  (test-bg 5 '(5))
 801  (test-bg 3 '(2 3))
 802  (test-bg 3 `(2 (,bg 3)))
 803  (test-bg 3 `(,(make-bg '(2)) ,(make-bg '(3))))
 804  (test-bg-d 7 6 '((set! x 6) 'a (+ x 1)))
 805  (test-bg ''w '((set! x 6) 'a (+ x 1) 'w))
 806  (test-bg-d 8 7 '('b (set! x 7) (+ x 1)))
 807  (test-bg-d 9 8 '('b (set! x 8) 'a (+ x 1)))
 808  (test-bg ''z '('b (set! x 8) 'a (+ x 1) 'z))
 809  (test-bg-d 7 9 `(,(make-bg '((set! x 6) 'a)) (+ x 1)))
 810  (test-bg 10 `(,(make-bg '((set! x 60) 'a)) 10))
 811  (teval '(test 60 'x x))
 812  (test-bg 10 `(,(make-bg '((set! x 65) 'a)) (add1 20) 10))
 813  (teval '(test 65 'x x))
 814  (test-bg ''a `(10 ,(make-bg '((set! x 66) 'a))))
 815  (teval '(test 66 'x x))
 816  (test-bg ''a `(10 (add1 32) ,(make-bg '((set! x 67) 'a))))
 817  (teval '(test 67 'x x))
 818  (teval '(set! x 6))
 819  (test-bg-d 8 7 `(,(make-bg '('b (set! x 7) 'a)) (+ x 1)))
 820  (test-bg-d 9 8 `(,(make-bg '('b (set! x 8))) ,(make-bg '('a (+ x 1)))))
 821  (test-bg-d2 10 9 `(,(make-bg `(,(make-bg `('b (set! x 9) ,(make-bg '('a (+ x 1)))))))))
 822  (test-bg ''s `(,(make-bg `(,(make-bg `('b (set! x 9) ,(make-bg '('a (+ x 1) 's))))))))
 823  (test-bg ''t `(,(make-bg `(,(make-bg `('b (set! x 9) ,(make-bg '('a (+ x 1))))))) 't))
 824  (teval `(test 5 call-with-values (lambda () ,(make-bg '((values 1 2) (values 1 3 1)))) +))
 825  (syntax-test (datum->syntax #f `(,bg . 1) #f))
 826  (syntax-test (datum->syntax #f `(,bg 1 . 2) #f))))
 827
 828(test-begin 'begin 'begin)
 829(test-begin 'begin0 'begin)
 830(test-begin 'begin0 'begin0)
 831(test-begin 'begin 'begin0)
 832
 833(syntax-test #'(begin0))
 834(begin) ; must succeed, but we can't wrap it
 835
 836(test 4 'implicit-begin (let ([x 4][y 7]) 'y x))
 837(test 4 'implicit-begin (let ([x 4][y 7]) y x))
 838
 839(test 5 'implicit-begin (let () (begin) 10 5))
 840
 841(error-test #'(begin (define foo (let/cc k k)) (foo 10)) exn:application:type?) ; not exn:application:continuation?
 842
 843(define f-check #t)
 844(define f (delay (begin (set! f-check #f) 5)))
 845(test #t (lambda () f-check))
 846(test 5 force f)
 847(test #f (lambda () f-check))
 848(test 5 force f)
 849(define f-check-2 (delay (values 1 5)))
 850(test-values '(1 5) (lambda () (force f-check-2)))
 851(values 1 2)
 852(test-values '(1 5) (lambda () (force f-check-2)))
 853(syntax-test #'delay)
 854(syntax-test #'(delay))
 855(syntax-test #'(delay . 1))
 856(syntax-test #'(delay 1 . 2))
 857
 858(let ([p (delay/sync 12)]
 859      [v #f])
 860  (thread (lambda () (set! v (force p))))
 861  (sync (system-idle-evt))
 862  (test 12 force p)
 863  (test 12 values v)
 864  (test (void) sync p)
 865  (test (list (void)) sync (wrap-evt p list)))
 866
 867(test '(list 3 4) 'quasiquote `(list ,(+ 1 2) 4))
 868(test '(list a (quote a)) 'quasiquote (let ((name 'a)) `(list ,name ',name)))
 869(test '(a 3 4 5 6 b) 'quasiquote `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b))
 870(test '((foo 7) . cons)
 871	'quasiquote
 872	`((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons))))
 873(test '#(10 5 2 4 3 8) 'quasiquote `#(10 5 ,(sqrt 4) ,@(map sqrt '(16 9)) 8))
 874(test 5 'quasiquote `,(+ 2 3))
 875(test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f)
 876      'quasiquote `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f))
 877(test '(a `(b ,x ,'y d) e) 'quasiquote
 878	(let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e)))
 879(test '(list 3 4) 'quasiquote (quasiquote (list (unquote (+ 1 2)) 4)))
 880(test '`(list ,(+ 1 2) 4) 'quasiquote '(quasiquote (list (unquote (+ 1 2)) 4)))
 881(test '(()) 'qq `((,@'())))
 882(define x 5)
 883(test '(quasiquote (unquote x)) 'qq ``,x)
 884(test '(quasiquote (unquote 5)) 'qq ``,,x)
 885(test '(quasiquote (unquote-splicing x)) 'qq ``,@x)
 886(test '(quasiquote (unquote-splicing 5)) 'qq ``,@,x)
 887(test '(quasiquote (quasiquote (quasiquote (unquote (unquote (unquote x)))))) 'qq ````,,,x)
 888(test '(quasiquote (quasiquote (quasiquote (unquote (unquote (unquote 5)))))) 'qq ````,,,,x)
 889
 890(test '#hash() 'qq `#hash())
 891(test '#hash(("apple" . 1) ("banana" . 2) ("coconut" . 3))
 892      'qq
 893      `#hash(("apple" . 1) ("banana" . 2) ("coconut" . 3)))
 894(test '#hash(("apple" . 1) ("banana" . 2) ("coconut" . 3))
 895      'qq
 896      `#hash(("apple" . ,1) ("banana" . ,(add1 1)) ("coconut" . ,(+ 1 2))))
 897(test '#hash(("foo" . (1 2 3 4 5)))
 898      'qq
 899      `#hash(("foo" . (1 2 ,(+ 1 2) 4 5))))
 900(test '#hash(("foo" . (1 2 (+ 1 2) 4 5)))
 901      'qq
 902      `#hash(("foo" . (1 2 (+ 1 2) 4 5))))
 903(test '#hash(("foo" . (1 2 3 4 5)))
 904      'qq
 905      `#hash(("foo" . (1 2 ,@(list 3 4 5)))))
 906(test '#hash((,(read) . 1) (,(+ 1 2) . 3))
 907      'qq
 908      `#hash((,(read) . 1) (,(+ 1 2) . ,(+ 1 2))))
 909(test '#hash((,(read) . 2))
 910      'qq
 911      `#hash((,(read) . 1) (,(read) . 2)))
 912(test '#hash(("moo" . 3) ("foo" . (1 2)))
 913      'qq
 914      `#hash(("moo" . ,(+ 1 2)) ("foo" . (1 2))))
 915(test '#hash(("moo" . (+ 1 2)) ("foo" . -1))
 916      'qq
 917      `#hash(("moo" . (+ 1 2)) ("foo" . ,(- 1 2))))
 918(syntax-test #'`#hash(("foo" . ,@(list 1 2 3 4 5))))
 919(error-test #'(read (open-input-string "`#hash((foo ,@(list 1 2 3 4 5)))")) exn:fail:read?)
 920
 921(test '(quasiquote (unquote result)) 'qq `(quasiquote ,result))
 922(test (list 'quasiquote car) 'qq `(,'quasiquote ,car))
 923
 924(syntax-test #'quasiquote)
 925(syntax-test #'(quasiquote))
 926(syntax-test #'(quasiquote . 5))
 927(syntax-test #'(quasiquote 1 . 2))
 928(syntax-test #'(quasiquote 1 2))
 929(syntax-test #'(unquote 7))
 930(syntax-test #'(unquote-splicing 7))
 931
 932(syntax-test #'`(1 . ,@5))
 933(test (cons 1 5) 'qq `(1 ,@5))
 934(error-test #'`(1 ,@5 2))
 935
 936(define (qq-test e)
 937  (syntax-test (datum->syntax #f e #f))
 938  (syntax-test (datum->syntax #f (list 'quasiquote e) #f))
 939  (syntax-test (datum->syntax #f (list 'quasiquote e) #f))
 940  (syntax-test (datum->syntax #f (list 'quasiquote (list 'quasiquote e)) #f))
 941  (syntax-test (datum->syntax #f (list 'quasiquote (list 'quasiquote (list 'unquote e))) #f))
 942  (syntax-test (datum->syntax #f (list 'quasiquote (list 'quasiquote (list 'unquote-splicing e))) #f)))
 943(qq-test #'(unquote))
 944(qq-test #'(unquote 7 8 9))
 945(qq-test #'(unquote-splicing))
 946(qq-test #'(unquote-splicing 7 8 9))
 947
 948(test '(unquote . 5) 'qq (quasiquote (unquote . 5)))
 949(test '(unquote 1 . 5) 'qq (quasiquote (unquote 1 . 5)))
 950(test '(unquote 1 2 . 5) 'qq (quasiquote (unquote 1 2 . 5)))
 951
 952(test '(unquote 1 2 7 . 5) 'qq (quasiquote (unquote 1 2 ,(+ 3 4) . 5)))
 953(test '(unquote 1 2 (unquote (+ 3 4)) . 5) 'qq (quasiquote (unquote 1 2 ,',(+ 3 4) . 5)))
 954
 955(test '(1 2 3 4 . 5) 'qq `(1 ,@'(2 3 4) . 5))
 956
 957(error-test #'`(10 ,(values 1 2)) arity?)
 958(error-test #'`(10 ,@(values 1 2)) arity?)
 959
 960(define add3 (lambda (x) (+ x 3)))
 961(test 6 'define (add3 3))
 962(define (add3 x) (+ x 3))
 963(test 6 'define (add3 3))
 964(define first car)
 965(test 1 'define (first '(1 2)))
 966(syntax-test #'define)
 967(syntax-test #'(define))
 968(syntax-test #'(define . x))
 969(syntax-test #'(define x))
 970(syntax-test #'(define x . 1))
 971(syntax-test #'(define 1 2))
 972(syntax-test #'(define (1) 1))
 973(syntax-test #'(define (x 1) 1))
 974(syntax-test #'(define (x a a) 1))
 975(syntax-test #'(define ((x 1) a) 1))
 976(syntax-test #'(define ((x b b) a) 1))
 977(syntax-test #'(define x 1 . 2))
 978(syntax-test #'(define x 1 2))
 979
 980(let ()
 981  (define ((f x) y z) (list x y z))
 982  (test '(1 2 3) (f 1) 2 3))
 983(let ()
 984  (define ((g a) a b) (list a b))
 985  (test '(2 3) (g 1) 2 3))
 986
 987(define-values (add3) (lambda (x) (+ x 3)))
 988(test 6 'define (add3 3))
 989(define-values (add3 another) (values (lambda (x) (+ x 3)) 9))
 990(test 6 'define (add3 3))
 991(test 9 'define another)
 992(define-values (first second third) (values car cadr caddr))
 993(test 1 'define (first '(1 2)))
 994(test 2 'define (second '(1 2)))
 995(test 3 'define (third '(1 2 3)))
 996(define-values () (values))
 997(syntax-test #'define-values)
 998(syntax-test #'(define-values))
 999(syntax-test #'(define-values . x))
1000(syntax-test #'(define-values x))
1001(syntax-test #'(define-values (x)))
1002(syntax-test #'(define-values x . 1))
1003(syntax-test #'(define-values (x) . 1))
1004(syntax-test #'(define-values 1 2))
1005(syntax-test #'(define-values (1) 2))
1006(syntax-test #'(define-values (x 1) 1))
1007(syntax-test #'(define-values (x . y) 1))
1008(syntax-test #'(define-values (x) 1 . 2))
1009(syntax-test #'(define-values (x) 1 2))
1010(syntax-test #'(define-values (x x) 10))
1011(syntax-test #'(define-values (x y x) 10))
1012
1013(syntax-test #'((define x 2) 0 1))
1014(syntax-test #'(+ (define x 2) 1))
1015(syntax-test #'(if (define x 2) 0 1))
1016(syntax-test #'(begin0 (define x 2)))
1017(syntax-test #'(begin0 (define x 2) 0))
1018(syntax-test #'(begin0 0 (define x 2)))
1019(syntax-test #'(begin0 0 (define x 2) (define x 12)))
1020(syntax-test #'(let () (define x 2)))
1021(syntax-test #'(letrec () (define x 2)))
1022(syntax-test #'(lambda () (define x 2)))
1023(syntax-test #'(lambda () (void (define x 2)) 1))
1024(syntax-test #'(cond [(< 2 3) (define x 2)] [else 5]))
1025(syntax-test #'(cond [else (define x 2)]))
1026
1027;; No good way to test in mzc:
1028(error-test #'(define x (values)) exn:application:arity?)
1029(error-test #'(define x (values 1 2)) exn:application:arity?)
1030(error-test #'(define-values () 3) exn:application:arity?)
1031(error-test #'(define-values () (values 1 3)) exn:application:arity?)
1032(error-test #'(define-values (x y) (values)) exn:application:arity?)
1033(error-test #'(define-values (x y) 3) exn:application:arity?)
1034(error-test #'(define-values (x y) (values 1 2 3)) exn:application:arity?)
1035
1036(begin (define ed-t1 1) (define ed-t2 2))
1037(test 1 'begin-define ed-t1)
1038(test 2 'begin-define ed-t2)
1039(begin (begin (begin (begin 10 (define ed-t2.5 2.5) 12))))
1040(test 2.5 'begin-define ed-t2.5)
1041(syntax-test #'(if (zero? 0) (define ed-t3 3) (define ed-t3 -3)))
1042(syntax-test #'(if #t (define ed-t3 3) (define ed-t3 -3)))
1043(syntax-test #'(if #f (define ed-t3 3) (define ed-t3 -3)))
1044
1045(test 45 'define
1046	(let ((x 5))
1047		(define foo (lambda (y) (bar x y)))
1048		(define bar (lambda (a b) (+ (* a b) a)))
1049		(foo (+ x 3))))
1050(define x 34)
1051(define (foo) (define x 5) x)
1052(test 5 foo)
1053(test 34 'define x)
1054(define foo (lambda () (define x 5) x))
1055(test 5 foo)
1056(test 34 'define x)
1057(define (foo x) ((lambda () (define x 5) x)) x)
1058(test 88 foo 88)
1059(test 4 foo 4)
1060(test 34 'define x)
1061
1062(test 5 'define
1063      (let ()
1064	(define x 5)
1065	(define define (lambda (a b) (+ a b)))
1066	8
1067	(define x 7)
1068	x))
1069(test 8 'define ; used to be 6
1070      (let ([y 8])
1071	(define (define z w) 5)
1072	(define y 6)
1073	y))
1074
1075(syntax-test #'(let ()
1076		(define x 5)))
1077(syntax-test #'(let ()
1078		(if #t
1079		    (define x 5))
1080		5))
1081
1082; Can shadow syntax/macros with embedded defines
1083(test 5 'intdef (let ()
1084		  (define lambda 5)
1085		  lambda))
1086(test 5 'intdef (let ()
1087		  (define define 5)
1088		  'ok
1089		  define))
1090
1091(syntax-test #'(lambda () (define x 10) (begin)))
1092(syntax-test #'(lambda () (define x 10) (begin) (begin)))
1093(syntax-test #'(lambda () (#%stratified-syntax (define x 10) (begin) (begin x) (begin))))
1094(syntax-test #'(lambda () (#%stratified-syntax (define x 10) x (define y 12) y)))
1095(syntax-test #'(lambda () (define-values (x) . 10) x))
1096(syntax-test #'(lambda () (define-values (x) 10) (begin 1 . 2) x))
1097(syntax-test #'(lambda () (begin (define-values (x) 10) . 2) x))
1098(syntax-test #'(lambda () (begin)))
1099(syntax-test #'(lambda () (define-values . 10) x))
1100(syntax-test #'(lambda () (define-values x 10) x))
1101(syntax-test #'(lambda () (define-values (1) 10) x))
1102
1103(test '(10 12) apply (lambda () (define x 10) (random 3) (define y 12) (list x y)) null)
1104(test 10 apply (lambda () (define x 10) (begin) (begin x) (begin)) null)
1105
1106(test '(11 18) apply (lambda () (define x 11) (values 1 2 3) (define y 18) (list x y)) null)
1107
1108(test 87 (lambda () (define x 87) (begin) (begin x)))
1109
1110(test '#(0 1 2 3 4) 'do (do ((vec (make-vector 5))
1111			     (i 0 (+ i 1)))
1112			    ((= i 5) vec)
1113			  (vector-set! vec i i)))
1114(test 25 'do (let ((x '(1 3 5 7 9)))
1115	       (do ((x x (cdr x))
1116		    (sum 0 (+ sum (car x))))
1117		   ((null? x) sum))))
1118(test 1 'let (let foo () 1))
1119(test '((6 1 3) (-5 -2)) 'let
1120      (let loop ((numbers '(3 -2 1 6 -5))
1121		 (nonneg '())
1122		 (neg '()))
1123	(cond ((null? numbers) (list nonneg neg))
1124	      ((negative? (car numbers))
1125	       (loop (cdr numbers)
1126		     nonneg
1127		     (cons (car numbers) neg)))
1128	      (else
1129	       (loop (cdr numbers)
1130		     (cons (car numbers) nonneg)
1131		     neg)))))
1132(test 5 'do (do ((x 1)) (#t 5)))
1133(test-values '(10 5) (lambda () (do ((x 1)) (#t (values 10 5)))))
1134(syntax-test #'do)
1135(syntax-test #'(do))
1136(syntax-test #'(do ()) )
1137(syntax-test #'(do () ()) )
1138(syntax-test #'(do (1) (#t 5) 5))
1139(syntax-test #'(do ((1)) (#t 5) 5))
1140(syntax-test #'(do ((1 7)) (#t 5) 5))
1141(syntax-test #'(do ((x . 1)) (#t 5) 5))
1142(syntax-test #'(do ((x 1) 2) (#t 5) 5))
1143(syntax-test #'(do ((x 1) . 2) (#t 5) 5))
1144(syntax-test #'(do ((x 1)) (#t . 5) 5))
1145(syntax-test #'(do ((x 1)) (#t 5) . 5))
1146
1147(test 0 'let/cc (let/cc k (k 0) 1))
1148(test 0 'let/cc (let/cc k 0))
1149(test 1 'let/cc (let/cc k (cons 1 2) 1))
1150(test-values '(2 1) (lambda () (let/cc k (values 2 1))))
1151(test-values '(2 1) (lambda () (let/cc k (k 2 1))))
1152(syntax-test #'(let/cc))
1153(syntax-test #'(let/cc . k))
1154(syntax-test #'(let/cc k))
1155(syntax-test #'(let/cc k . 1))
1156(syntax-test #'(let/cc 1 1))
1157
1158(test 0 'let/ec (let/ec k (k 0) 1))
1159(test 0 'let/ec (let/ec k 0))
1160(test 1 'let/ec (let/ec k (cons 1 2) 1))
1161(test-values '(2 1) (lambda () (let/ec k (values 2 1))))
1162(test-values '(2 1) (lambda () (let/ec k (k 2 1))))
1163(syntax-test #'(let/ec))
1164(syntax-test #'(let/ec . k))
1165(syntax-test #'(let/ec k))
1166(syntax-test #'(let/ec k . 1))
1167(syntax-test #'(let/ec 1 1))
1168
1169(define x 1)
1170(define y -1)
1171(define (get-x) x)
1172
1173(test 5 'parameterize (parameterize () 5))
1174(test 6 'parameterize (parameterize ([error-print-width 10]) 6))
1175(test 7 'parameterize (parameterize ([error-print-width 10]
1176				     [uncaught-exception-handler void]) 
1177                        7))
1178(define oepw (error-print-width))
1179(error-test #'(parameterize ([error-print-width 777]) (error 'bad)) exn:fail?)
1180(test oepw 'parameterize (error-print-width))
1181(error-test #'(parameterize ([error-print-width 777]
1182                             [current-output-port (current-error-port)])
1183                (error 'bad)) 
1184	    exn:fail?)
1185(error-test #'(parameterize ([error-print-width 'a]) 10))
1186
1187(define p (make-parameter 1))
1188(define q (make-parameter 2))
1189(test '1 'pz-order (parameterize ([p 3][q (p)]) (q)))
1190
1191(error-test #'(parameterize) syntaxe?)
1192(error-test #'(parameterize ()) syntaxe?)
1193(error-test #'(parameterize ((x y))) syntaxe?)
1194(error-test #'(parameterize ((x y)) . 8) syntaxe?)
1195(error-test #'(parameterize (x) 8) syntaxe?)
1196(error-test #'(parameterize (9) 8) syntaxe?)
1197(error-test #'(parameterize ((x z) . y) 8) syntaxe?)
1198(error-test #'(parameterize ((x . z)) 8) syntaxe?)
1199(error-test #'(parameterize ((x . 9)) 8) syntaxe?)
1200(error-test #'(parameterize ((x . 9)) 8) syntaxe?)
1201
1202(error-test #'(parameterize ([10 10]) 8))
1203(error-test #'(parameterize ([10 10]) 8) (lambda (exn) (not (regexp-match #rx"argument" (exn-message exn)))))
1204(error-test #'(parameterize ([(lambda () 10) 10]) 8))
1205(error-test #'(parameterize ([(lambda (a) 10) 10]) 8))
1206(error-test #'(parameterize ([(lambda (a b) 10) 10]) 8))
1207
1208(test 1 'time (time 1))
1209(test -1 'time (time (cons 1 2) -1))
1210(test-values '(-1 1) (lambda () (time (values -1 1))))
1211(syntax-test #'time)
1212(syntax-test #'(time))
1213(syntax-test #'(time . 1))
1214(syntax-test #'(time 1 . 2))
1215
1216; Tests specifically aimed at the compiler
1217(error-test #'(let ([x (values 1 2)]) x) exn:application:arity?)
1218; Known primitive
1219(error-test #'(let ([x (make-pipe)]) x) exn:application:arity?)
1220; Known local
1221(error-test #'(let* ([f (lambda () (values 1 2))][x (f)]) x) exn:application:arity?)
1222
1223; Known local with global in its closure
1224(test 15 'known (let ([g (lambda ()
1225			   (letrec ([f (lambda (x)
1226					 (+ x 5))])
1227			     (f 10)))])
1228		  (g)))
1229; Known local with a set!
1230(test 16 'known (let ([g (lambda ()
1231			   (letrec ([f (lambda (x)
1232					 (let ([y x])
1233					   (set! x 7)
1234					   (+ y 5)))])
1235			     (f 11)))])
1236		  (g)))
1237; Known local non-function
1238(error-test #'(apply (lambda () (let ([f 12]) (f))) null) exn:application:type?)
1239; Known local with revsed arguments:
1240(test 10 (letrec ([f (lambda (a b) (if (zero? a) b (f b a)))]) f) 10 0)
1241
1242(syntax-test #'#%datum)
1243(syntax-test #'(let ([#%datum 5])
1244		 1))
1245(test '(1) '#%datum (#%datum 1))
1246(test 1 '#%datum (#%datum . 1))
1247(test 'a '#%datum (#%datum . a))
1248
1249(syntax-test #'#%app)
1250(syntax-test #'(#%app . 1))
1251(syntax-test #'(#%app 2 . 1))
1252(syntax-test #'(#%app lambda 1))
1253(syntax-test #'(let ([#%app 5])
1254		 (+ 1 2)))
1255
1256(test 3 '#%app (#%app + 1 2))
1257(syntax-test #'())
1258(syntax-test #'(#%app))
1259
1260(syntax-test #'#%top)
1261(syntax-test #'(#%top 1))
1262(syntax-test #'(let ([#%top 5])
1263		 x))
1264(err/rt-test (#%top . lambda) exn:fail:contract:variable?)
1265(define x 5)
1266(test 5 '#%top (#%top . x))
1267
1268;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1269;; Tests related to bytecode optimizer.
1270;; The (if (let ([x M]) (if x x N)) ...)
1271;;   => (if (if M #t N) ...)
1272;; converter drops the variable `x', which means
1273;; that other mappings must adjust
1274
1275(let ([val 0])
1276  (let ([g (lambda ()
1277	     (letrec ([f (lambda (z x)
1278			   (if (let ([w (even? 81)])
1279				 (if w
1280				     w
1281				     (let ([y x])
1282				       (set! x 7)
1283				       (set! val (+ y 5)))))
1284			       'yes
1285			       'no))])
1286	       (f 0 11)))])
1287    (g))
1288  (test 16 values val))
1289
1290(let ([val 0])
1291  (let ([g (lambda ()
1292	     (letrec ([f (lambda (z x)
1293			   (if (let ([w (even? 81)])
1294				 (if w
1295				     w
1296				     (let ([y x])
1297				       (set! val (+ y 5)))))
1298			       'yes
1299			       'no))])
1300	       (f 0 11)))])
1301    (g))
1302  (test 16 values val))
1303
1304;; Function-inline test where (h (g v 10)) involves two inlines:
1305(letrec ([f (lambda (x) (h (g v 10)))]
1306	 [h (lambda (x) (list x x))]
1307	 [g (lambda (a b) a)]
1308	 [v (list 'hello)]
1309	 [w (list 'no!)]) 
1310  (test '((hello) (hello)) f 10))
1311
1312;; Inlining introduces a let binding that is immediately dropped:
1313(test '(1 . 2)
1314      (let ([x (cons 1 2)]) (let ([f (lambda (x) x)]) (f (lambda (y) x))))
1315      10)
1316
1317;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1318;; Check #%top-interaction
1319
1320(module quoting-top-interaction racket/base
1321  (require (for-syntax racket/base))
1322  (provide (except-out (all-from-out racket/base) #%top-interaction)
1323           (rename-out [top-interaction #%top-interaction]))
1324  (define-syntax top-interaction 
1325    (syntax-rules ()
1326      [(_ . e) (quote e)])))
1327
1328(dynamic-require ''quoting-top-interaction #f)
1329(let ([ns (make-empty-namespace)])
1330  (namespace-attach-module (current-namespace) ''quoting-top-interaction ns)
1331  (parameterize ([current-namespace ns])
1332    (namespace-require ''quoting-top-interaction))
1333  (test 3 'non-top
1334        (parameterize ([current-namespace ns])
1335          (eval '(+ 1 2))))
1336  (test ''(+ 1 2) 'repl-top
1337        (let ([s (open-output-bytes)])
1338          (parameterize ([current-input-port (open-input-string "(+ 1 2)")]
1339                         [current-namespace ns]
1340                         [current-output-port s])
1341            (read-eval-print-loop))
1342          (let ([p (open-input-bytes (get-output-bytes s))])
1343            (read p)
1344            (read p))))
1345  (let ([tmp-file (make-temporary-file)])
1346    (let-values ([(base tmp1 mbd?) (split-path tmp-file)])
1347    (with-output-to-file tmp-file (lambda () (display '(+ 1 2))) #:exists 'truncate/replace)
1348    (test '(+ 1 2) 'repl-top
1349          (parameterize ([current-namespace ns])
1350            (load tmp-file)))
1351    (with-output-to-file tmp-file (lambda () (display `(module ,tmp1 racket/base (provide x) (define x 12))))
1352                         #:exists 'truncate/replace)
1353    (test 12 'module
1354          (parameterize ([current-namespace ns])
1355            (dynamic-require tmp-file 'x)))
1356    (delete-file tmp-file))))
1357
1358;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1359
1360;; Check that locations for lambda arguments are created
1361;; one-by-one --- like `let*', and not like `letrec':
1362
1363(test '((1 10) (x1 10) (x2 z1))
1364      'lambda-loc
1365      (let ()
1366        (define procs null)
1367        (define again #f)
1368
1369        (define (f x 
1370                   [y (let/cc k
1371                        (unless again
1372                          (set! again k))
1373                        (lambda () 'done))]
1374                   [z 10])
1375          (set! procs
1376                (cons (lambda (xv zv)
1377                        (begin0
1378                         (list x z)
1379                         (set! x xv)
1380                         (set! z zv)))
1381                      procs))
1382          (y))
1383
1384        (f 1)
1385        (let/cc esc (again esc))
1386
1387        (list
1388         ((cadr procs) 'x1 'z1)
1389         ((car procs) 'x2 'z2)
1390         ((cadr procs) 'x10 'z10))))
1391
1392;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1393(require racket/splicing)
1394
1395(define abcdefg 10)
1396(test 12 'splicing-letrec-syntax (splicing-letrec-syntax ([abcdefg (syntax-rules ()
1397                                                                     [(_) 12])])
1398                                                         (abcdefg)))
1399(test 13 'splicing-letrec-syntax (splicing-letrec-syntax ([abcdefg (syntax-rules ()
1400                                                                     [(_) (abcdefg 10)]
1401                                                                     [(_ x) (+ 3 x)])])
1402                                                         (abcdefg)))
1403(test 13 'splicing-letrec-syntax (let ([abcdefg 9])
1404                                   (splicing-letrec-syntax ([abcdefg (syntax-rules ()
1405                                                                       [(_) (abcdefg 10)]
1406                                                                       [(_ x) (+ 3 x)])])
1407                                                           (abcdefg))))
1408(test 12 'splicing-let-syntax (splicing-let-syntax ([abcdefg (syntax-rules ()
1409                                                               [(_) 12])])
1410                                                   (abcdefg)))
1411(test 12 'splicing-let-syntax (let ([abcdefg (lambda () 9)])
1412                                (splicing-let-syntax ([abcdefg (syntax-rules ()
1413                                                                 [(_) 12])])
1414                                                     (abcdefg))))
1415(test 11 'splicing-let-syntax (let ([abcdefg (lambda (x) x)])
1416                                (splicing-let-syntax ([abcdefg (syntax-rules ()
1417                                                                 [(_) (+ 2 (abcdefg 9))]
1418                                                                 [(_ ?) 77])])
1419                                                     (abcdefg))))
1420(define expand-test-use-toplevel? #t)
1421(splicing-let-syntax ([abcdefg (syntax-rules ()
1422                                 [(_) 8])])
1423                     (define hijklmn (abcdefg)))
1424(define expand-test-use-toplevel? #f)
1425(test 8 'hijklmn hijklmn)
1426(test 30 'local-hijklmn (let ()
1427                          (splicing-let-syntax ([abcdefg (syntax-rules ()
1428                                                           [(_) 8])])
1429                                               (define hijklmn (abcdefg)))
1430                          (define other 22)
1431                          (+ other hijklmn)))
1432(test 8 'local-hijklmn (let ()
1433                         (splicing-let-syntax ([abcdefg (syntax-rules ()
1434                                                          [(_) 8])])
1435                                              (begin
1436                                                (define hijklmn (abcdefg))
1437                                                hijklmn))))
1438
1439(test 9 'splicing-letrec-syntax (let ([abcdefg (lambda () 9)])
1440                                  (splicing-letrec-syntax ([abcdefg (syntax-rules ()
1441                              

Large files files are truncated, but you can click here to view the full file