/pkgs/racket-pkgs/racket-test/tests/racket/syntax.rktl
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)