PageRenderTime 403ms CodeModel.GetById 2ms app.highlight 385ms RepoModel.GetById 1ms app.codeStats 0ms

/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
   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                                                                      [(_) 0])])
1442                                                          (define x 10))
1443                                  (abcdefg)))
1444
1445
1446;; ----------------------------------------
1447
1448(test 79 'splicing-let (let ()
1449                         (splicing-let ([x 79])
1450                           (define (y) x))
1451                         (y)))
1452(test 77 'splicing-let (let ()
1453                         (define q 77)
1454                         (splicing-let ([q 8]
1455                                        [x q])
1456                           (define (z) x))
1457                         (z)))
1458(test 81 'splicing-letrec (let ()
1459                            (define q 77)
1460                            (splicing-letrec ([q 81]
1461                                              [x q])
1462                              (define (z) x))
1463                            (z)))
1464(test 82 'splicing-letrec (let ()
1465                            (define q 77)
1466                            (splicing-letrec ([x (lambda () (q))]
1467                                              [q (lambda () 82)])
1468                              (define (z) x))
1469                            ((z))))
1470(test 81 'splicing-letrec (eval
1471                            '(begin
1472                               (define q 77)
1473                               (splicing-letrec ([q 81]
1474                                                 [x q])
1475                                                (define (z) x))
1476                               (z))))
1477(test 82 'splicing-letrec (eval
1478                            '(begin
1479                               (define q 77)
1480                               (splicing-letrec ([x (lambda () (q))]
1481                                                 [q (lambda () 82)])
1482                                                (define (z) x))
1483                               ((z)))))
1484(err/rt-test (eval
1485              '(begin
1486                 (splicing-letrec ([x q]
1487                                   [q 81])
1488                  x)))
1489             exn:fail:contract:variable?)
1490
1491(test 82 'splicing-letrec-syntaxes+values
1492      (let ()
1493        (define q 77)
1494        (splicing-letrec-syntaxes+values
1495           ([(mx) (lambda (stx) (quote-syntax (x)))]
1496            [(m) (lambda (stx) (quote-syntax (mx)))])
1497           ([(x) (lambda () (q))]
1498            [(q) (lambda () 82)])
1499          (define (a) (m)))
1500        (a)))
1501
1502(test 82 'splicing-letrec-syntaxes+values
1503      (eval
1504       '(begin
1505          (define q 77)
1506          (splicing-letrec-syntaxes+values
1507              ([(mx) (lambda (stx) (quote-syntax (x)))]
1508               [(m) (lambda (stx) (quote-syntax (mx)))])
1509              ([(x) (lambda () (q))]
1510               [(q) (lambda () 82)])
1511            (define (a) (m)))
1512          (a))))
1513
1514(test 82 'splicing-local
1515      (let ()
1516        (define (x) q)
1517        (define q 77)
1518        (define-syntax (m stx) (quote-syntax (x)))
1519        (splicing-local
1520            [(define-syntax (m stx) (quote-syntax (mx)))
1521             (define (x) (q))
1522             (define-syntax (mx stx) (quote-syntax (x)))
1523             (define (q) 82)]
1524          (define (a) (m)))
1525        (a)))
1526
1527(test 82 'splicing-local
1528      (eval
1529       '(begin
1530          (define (x) q)
1531          (define q 77)
1532          (define-syntax (m stx) (quote-syntax (x)))
1533          (splicing-local
1534              [(define-syntax (m stx) (quote-syntax (mx)))
1535               (define (x) (q))
1536               (define-syntax (mx stx) (quote-syntax (x)))
1537               (define (q) 82)]
1538            (define (a) (m)))
1539          (a))))
1540
1541;; local names are not visible outside
1542(test 77 'splicing-local
1543      (let ()
1544        (define q 77)
1545        (define-syntax (m stx) (quote-syntax (x)))
1546        (splicing-local
1547            [(define-syntax (m stx) (quote-syntax (q)))
1548             (define (q) 82)]
1549          (define (a) (m)))
1550        (m)))
1551(test 77 'splicing-local
1552      (eval
1553       '(begin
1554          (define q 77)
1555          (define-syntax (m stx) (quote-syntax (x)))
1556          (splicing-local
1557              [(define-syntax (m stx) (quote-syntax (q)))
1558               (define (q) 82)]
1559            (define (a) (m)))
1560          (m))))
1561
1562;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1563;; Check keyword & optionals for define-syntax 
1564;; and define-syntax-for-values:
1565
1566(test (list 7 #f)
1567      'dfs/kw
1568      (eval
1569       '(begin
1570          (define-for-syntax (kw/f #:x a b)
1571            `(list ,a ,b))
1572          (define-syntax (kw/g stx #:opt [opt #f])
1573            (syntax-case stx ()
1574              [(_ v) (datum->syntax stx (kw/f #:x #'v opt))]))
1575          (kw/g 7))))
1576
1577;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1578;; Check mutation of local define-for-syntax in let-syntax:
1579
1580(module set-local-dfs racket/base
1581  (require (for-syntax racket/base))
1582  (provide ten)
1583
1584  (define-for-syntax tl-var 9)
1585
1586  (define ten
1587    (let-syntax ([x1 (lambda (stx)
1588                       (set! tl-var (add1 tl-var))
1589                       (datum->syntax stx tl-var))])
1590      (x1))))
1591
1592(test 10 dynamic-require ''set-local-dfs 'ten)
1593
1594;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1595;; Test single-result checking in `begin0':
1596
1597(let ()
1598  (define (twice x) (printf "ouch\n") (values x x))
1599  
1600  (define (pipeline2 . rfuns)
1601    (let ([x (begin0 ((car rfuns) 1) 123)])
1602      x))
1603  
1604  (define (try f)
1605    (call-with-values
1606        (lambda () (with-handlers ([void values]) (f twice)))
1607      (lambda xs xs)))
1608  
1609  (test #t exn? (caar (map try (list pipeline2)))))
1610
1611;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1612;; Semantics of internal definitions != R5RS
1613
1614(test 0 'racket-int-def (call-with-continuation-prompt
1615                         (lambda ()
1616                           (let ([v 0]
1617                                 [k #f]
1618                                 [q void])
1619                             (define f (let/cc _k (set! k _k)))
1620                             (define g v) ; fresh location each evaluation
1621                             (if f
1622                                 (begin
1623                                   (set! q (lambda () g))
1624                                   (set! v 1)
1625                                   (k #f))
1626                                 (q))))))
1627(test 1 'racket-int-def (call-with-continuation-prompt
1628                         (lambda ()
1629                           (let ([v 0]
1630                                 [k #f]
1631                                 [q void])
1632                             (#%stratified-body
1633                              (define f (let/cc _k (set! k _k)))
1634                              (define g v) ; same location both evaluations
1635                              (if f
1636                                  (begin
1637                                    (set! q (lambda () g))
1638                                    (set! v 1)
1639                                    (k #f))
1640                                  (q)))))))
1641
1642;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1643;; check that the compiler is not too agressive with `letrec' -> `let*'
1644
1645(test "#<undefined>\nready\n"
1646      get-output-string
1647      (let ([p (open-output-string)])
1648        (parameterize ([current-output-port p])
1649          (let ([restart void])
1650            (letrec ([dummy1 (let/cc k (set! restart k))]
1651                     [dummy2 (displayln maybe-ready)]
1652                     [maybe-ready 'ready])
1653              (let ([rs restart])
1654                (set! restart void)
1655                (rs #f)))))
1656        p))
1657
1658
1659;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1660;; Check that `syntax/loc' preserves the 'parent-shape property
1661
1662(test #\[ syntax-property (syntax/loc #'a [b c]) 'paren-shape)
1663
1664;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1665;; Check that inlining expansion of keyword-argument calls
1666;; attaches 'alias-of and 'converted-arguments-variant-of
1667;; syntax properties:
1668
1669(parameterize ([current-namespace (make-base-namespace)])
1670  (eval '(require (for-syntax racket/base
1671                              racket/keyword-transform)))
1672  (eval '(module m racket/base (provide f) (define (f #:x [x 2]) x)))
1673  (eval '(require 'm))
1674  (eval '(define-syntax (extract stx)
1675           (syntax-case stx ()
1676             [(_ form pattern var alias?)
1677              (with-syntax ([e (local-expand #'form 'top-level '())])
1678                #'(let-syntax ([m (lambda (stx)
1679                                    (syntax-case (quote-syntax e) ()
1680                                      [pattern
1681                                       #`(quote-syntax (var
1682                                                        .
1683                                                        #,((if alias?
1684                                                               syntax-procedure-alias-property
1685                                                               syntax-procedure-converted-arguments-property)
1686                                                           #'var)))]))])
1687                    (define p (m))
1688                    (and (free-identifier=? (car (syntax-e p))
1689                                            (cdr (syntax-e (cdr (syntax-e p)))))
1690                         (car (syntax-e (cdr (syntax-e p)))))))])))
1691  (define f-id (eval '(quote-syntax f)))
1692  (test
1693   #t
1694   free-identifier=?
1695   f-id
1696   (eval '(extract (f #:x 8)
1697                   (lv ([(proc) f2] . _) (if const? (app f3 . _) . _))
1698                   f3
1699                   #f)))
1700  (test
1701   #t
1702   free-identifier=?
1703   f-id
1704   (eval '(extract (f #:x 8)
1705                   (lv ([(proc) f2] . _) (if const? (app f3 . _) . _))
1706                   f2
1707                   #t)))
1708  (test
1709   #t
1710   free-identifier=?
1711   f-id
1712   (eval '(extract (f #:y 9)
1713                   (lv ([(proc) f2] . _) . _)
1714                   f2
1715                   #t)))
1716  (test
1717   #t
1718   free-identifier=?
1719   f-id
1720   (eval '(extract f f2 f2 #t))))
1721
1722
1723;; Check that alias & converted-argument information is
1724;; cross-phase:
1725(require racket/keyword-transform)
1726(let ([e (parameterize ([current-namespace (make-base-namespace)])
1727           (expand '(module m racket/base
1728                      (define (f #:x [x 10]) x)
1729                      (f #:x 8))))])
1730  (define (find get)
1731    (let loop ([e e])
1732      (or (and (syntax? e)
1733               (or (get e)
1734                   (loop (syntax-e e))))
1735          (and (pair? e)
1736               (or (loop (car e))
1737                   (loop (cdr e)))))))
1738  (test #t 'cross-phase-alias
1739        (and (find syntax-procedure-converted-arguments-property)
1740             (find syntax-procedure-alias-property)
1741             #t)))
1742
1743;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1744;; Check interaction of marks, `rename-out', and `free-identifier=?' 
1745
1746(module check-free-eq-with-rename racket/base
1747  (require (for-syntax racket/base))
1748  (provide (rename-out [prefix:quote quote])
1749           check)
1750  (define-syntax (check stx)
1751    (syntax-case stx ()
1752      [(_ id) #`#,(free-identifier=? #'id #'prefix:quote)]))
1753  (define-syntax-rule (prefix:quote x) (quote x)))
1754
1755(module use-rename-checker racket/base
1756  (define-syntax-rule (body)
1757    (begin
1758      (provide v)
1759      (require 'check-free-eq-with-rename)
1760      (define v (check quote))))
1761  (body))
1762
1763(test #t dynamic-require ''use-rename-checker 'v)
1764
1765;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1766;; Check `let` error messages
1767
1768(syntax-test #'(let*) #rx"missing binding")
1769(syntax-test #'(let* ([x 10])) #rx"missing body")
1770(syntax-test #'(let) #rx"missing name or")
1771(syntax-test #'(let x) #rx"missing binding pairs or")
1772(syntax-test #'(let ([10 10])) #rx"missing binding pairs or")
1773(syntax-test #'(let x ([10 10])) #rx"missing body")
1774(syntax-test #'(letrec) #rx"missing binding")
1775(syntax-test #'(letrec ([x 3])) #rx"missing body")
1776
1777;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1778;; Check that expansion generated for internal definitions
1779;; introduces `values' and `begin' as if by macros:
1780
1781(let ()
1782  (define (int-def-check)
1783    (define (values) (error 'hygiene "is broken"))
1784    1 ; expansion uses `values' and `begin'
1785    (define x 2)
1786    3)
1787  (test 3 int-def-check)
1788
1789  (define (int-def-check2)
1790    (define (begin) (error 'hygiene "is broken"))
1791    1
1792    (define x 2)
1793    30)
1794  (test 30 int-def-check2))
1795
1796;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1797;; Make sure `#%variable-reference' can be compiled and expanded
1798
1799(compile '(#%variable-reference))
1800(expand '(#%variable-reference))
1801
1802;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1803;; Check marshal & unmarshal of a syntax object
1804;; containing a list with a hash table
1805
1806(let ([v #'(quote-syntax (#hash((1 . 2))))])
1807  (define-values (i o) (make-pipe))
1808  (write (compile v) o)
1809  (close-output-port o)
1810  (define e
1811    (parameterize ([read-accept-compiled #t])
1812      (read i)))
1813  (test (syntax->datum (eval v)) syntax->datum (eval e)))
1814
1815;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1816
1817(report-errs)