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

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

Large files are truncated click here to view the full file

    

  1. (load-relative "loadtest.rktl")
    2. 

  2. 

  3. (Section 'syntax)
    4. 

    5. 

  5. ;; ----------------------------------------
    6. 

  6. 

  7. (test 0 'with-handlers (with-handlers () 0))
    8. 

  8. (test 1 'with-handlers (with-handlers ([void void]) 1))
    9. 

  9. (test 2 'with-handlers (with-handlers ([void void]) 1 2))
    10. 

  10. (test 'zero 'zero
    11. 

  11.       (with-handlers ((zero? (lambda (x) 'zero)))
    12. 

  12. 		     (raise 0)))
    13. 

  13. (test 'zero 'zero
    14. 

  14.       (with-handlers ((zero? (lambda (x) 'zero))
    15. 

  15. 		      (positive? (lambda (x) 'positive)))
    16. 

  16. 		     (raise 0)))
    17. 

  17. (test 'positive 'positive
    18. 

  18.       (with-handlers ((zero? (lambda (x) 'zero))
    19. 

  19. 		      (positive? (lambda (x) 'positive)))
    20. 

  20. 		     (raise 1)))
    21. 

  21. (test 5 'with-handlers
    22. 

  22.       (with-handlers ([void (lambda (x) 5)])
    23. 

  23. 	(with-handlers ((zero? (lambda (x) 'zero)))
    24. 

  24. 	  (/ 0))))
    25. 

  25. 

  26. (error-test #'(with-handlers ()
    27. 

  27. 	         (/ 0))
    28. 

  28. 	    exn:fail:contract:divide-by-zero?)
    29. 

  29. (error-test #'(with-handlers ((zero? (lambda (x) 'zero)))
    30. 

  30. 		 (/ 0))
    31. 

  31. 	    exn:application:type?)
    32. 

  32. (error-test #'(with-handlers ((zero? (lambda (x) 'zero))
    33. 

  33. 			     (boolean? (lambda (x) 'boolean)))
    34. 

  34. 		 (/ 0))
    35. 

  35. 	    exn:application:type?)
    36. 

  36. 

  37. (syntax-test #'with-handlers)
    38. 

  38. (syntax-test #'(with-handlers))
    39. 

  39. (syntax-test #'(with-handlers . 1))
    40. 

  40. (syntax-test #'(with-handlers ((zero? (lambda (x) 'zero)))))
    41. 

  41. (syntax-test #'(with-handlers ((zero? (lambda (x) 'zero))) . 1))
    42. 

  42. (syntax-test #'(with-handlers (zero?) 1))
    43. 

  43. (syntax-test #'(with-handlers ((zero?)) 1))
    44. 

  44. (syntax-test #'(with-handlers ((zero? . zero?)) 1))
    45. 

  45. (syntax-test #'(with-handlers ((zero? zero?) . 2) 1))
    46. 

  46. (syntax-test #'(with-handlers ((zero? zero?) zero?) 1))
    47. 

  47. (syntax-test #'(with-handlers ((zero? zero?) (zero?)) 1))
    48. 

  48. (syntax-test #'(with-handlers ((zero? zero?) (zero?)) 1))
    49. 

  49. (syntax-test #'(with-handlers ((zero? zero? zero?)) 1))
    50. 

  50. (syntax-test #'(with-handlers ((zero? zero? . zero?)) 1))
    51. 

  51. (syntax-test #'(with-handlers ((zero? zero?)) 1 . 2))
    52. 

    53. 

  53. (error-test #'(with-handlers ((0 void)) (/ 0)) 
    54. 

  54. 	    exn:application:type?)
    55. 

  55. (error-test #'(with-handlers ((void 0)) (/ 0))
    56. 

  56. 	    exn:application:type?)
    57. 

  57. (error-test #'(with-handlers ((unbound-variable void)) 0)
    58. 

  58. 	    exn:fail:contract:variable?)
    59. 

  59. (error-test #'(with-handlers ((void unbound-variable)) 0)
    60. 

  60. 	    exn:fail:contract:variable?)
    61. 

  61. (error-test #'(with-handlers (((values 1 2) void)) 0)
    62. 

  62. 	    arity?)
    63. 

  63. (error-test #'(with-handlers ((void (values 1 2))) 0)
    64. 

  64. 	    arity?)
    65. 

  65. 

  66. (test-values '(1 2) (lambda () (with-handlers ([void void])
    67. 

  67. 				 (values 1 2))))
    68. 

  68. 

  69. (test 'c (#%plain-lambda () 'a (define-values (x) 'b) 'c))
    70. 

  70. 

  71. (test '(quote a) 'quote (quote 'a))
    72. 

  72. (test '(quote a) 'quote ''a)
    73. 

  73. (syntax-test #'quote)
    74. 

  74. (syntax-test #'(quote))
    75. 

  75. (syntax-test #'(quote 1 2))
    76. 

    77. 

  77. (test 12 (if #f + *) 3 4)
    78. 

  78. (syntax-test #'(+ 3 . 4))
    79. 

  79. (syntax-test #'(apply + 1 . 2))
    80. 

    81. 

  81. (test 8 (lambda (x) (+ x x)) 4)
    82. 

  82. (define reverse-subtract
    83. 

  83.   (lambda (x y) (- y x)))
    84. 

  84. (test 3 reverse-subtract 7 10)
    85. 

  85. (define add4
    86. 

  86.   (let ((x 4))
    87. 

  87.     (lambda (y) (+ x y))))
    88. 

  88. (test 10 add4 6)
    89. 

  89. (test (letrec([x x]) x) 'lambda (let ([x (lambda () (define d d) d)]) (x)))
    90. 

  90. (test (letrec([x x]) x) 'lambda ((lambda () (define d d) d)))
    91. 

  91. (test '(3 4 5 6) (lambda x x) 3 4 5 6)
    92. 

  92. (test '(5 6) (lambda (x y . z) z) 3 4 5 6)
    93. 

  93. (test 'second (lambda () (cons 'first 2) 'second))
    94. 

  94. (syntax-test #'lambda)
    95. 

  95. (syntax-test #'(lambda))
    96. 

  96. (syntax-test #'(lambda x))
    97. 

  97. (syntax-test #'(lambda ()))
    98. 

  98. (syntax-test #'(lambda () (begin)))
    99. 

  99. (syntax-test #'(lambda . x))
    100. 

  100. (syntax-test #'(lambda x . x))
    101. 

  101. (syntax-test #'(lambda x . 5))
    102. 

  102. (syntax-test #'(lambda ((x)) x))
    103. 

  103. (syntax-test #'(lambda 5 x))
    104. 

  104. (syntax-test #'(lambda (5) x))
    105. 

  105. (syntax-test #'(lambda (x (y)) x))
    106. 

  106. (syntax-test #'(lambda (x . 5) x))
    107. 

  107. (syntax-test #'(lambda (x) x . 5))
    108. 

    109. 

  109. (let ([f
    110. 

  110.        (case-lambda
    111. 

  111. 	[() 'zero]
    112. 

  112. 	[(x) (cons 1 1) 'one]
    113. 

  113. 	[(x y) 'two]
    114. 

  114. 	[(x y z . rest) 'three+]
    115. 

  115. 	[x 'bad])]
    116. 

  116.       [g
    117. 

  117.        (case-lambda
    118. 

  118. 	[(x y z) 'three]
    119. 

  119. 	[(x y) (cons 2 2) 'two]
    120. 

  120. 	[(x) 'one]
    121. 

  121. 	[() 'zero]
    122. 

  122. 	[x (cons 0 'more!) 'more])]
    123. 

  123.       [h
    124. 

  124.        (case-lambda
    125. 

  125. 	[(x y) 'two]
    126. 

  126. 	[(x y z w) 'four])])
    127. 

  127.   (test 'zero f)
    128. 

  128.   (test 'one f 1)
    129. 

  129.   (test 'two f 1 2)
    130. 

  130.   (test 'three+ f 1 2 3)
    131. 

  131.   (test 'three+ f 1 2 3 4)
    132. 

  132.   (test 'three+ f 1 2 3 4 5 6 7 8 9 10)
    133. 

    134. 

  134.   (test 'zero g)
    135. 

  135.   (test 'one g 1)
    136. 

  136.   (test 'two g 1 2)
    137. 

  137.   (test 'three g 1 2 3)
    138. 

  138.   (test 'more g 1 2 3 4 5 6 7 8 9 10)
    139. 

    140. 

  140.   (test 'two h 1 2)
    141. 

  141.   (test 'four h 1 2 3 4)
    142. 

  142.   (let ([h '(case-lambda
    143. 

  143. 	     [(x y) 'two]
    144. 

  144. 	     [(x y z w) 'four])])
    145. 

  145.     (error-test (datum->syntax #f (list h) #f) arity?)
    146. 

  146.     (error-test (datum->syntax #f (list* h '(1)) #f) arity?)
    147. 

  147.     (error-test (datum->syntax #f (list* h '(1 2 3)) #f) arity?)
    148. 

  148.     (error-test (datum->syntax #f (list* h '(1 2 3 4 5 6)) #f) arity?)))
    149. 

    150. 

  150. (error-test #'((case-lambda)) arity?)
    151. 

    152. 

  152. (syntax-test #'case-lambda)
    153. 

  153. (syntax-test #'(case-lambda . 1))
    154. 

  154. (syntax-test #'(case-lambda []))
    155. 

  155. (syntax-test #'(case-lambda 1))
    156. 

  156. (syntax-test #'(case-lambda x))
    157. 

  157. (syntax-test #'(case-lambda [x]))
    158. 

  158. (syntax-test #'(case-lambda [x 8][y]))
    159. 

  159. (syntax-test #'(case-lambda [x][y 9]))
    160. 

  160. (syntax-test #'(case-lambda [8 8]))
    161. 

  161. (syntax-test #'(case-lambda [((x)) 8]))
    162. 

  162. (syntax-test #'(case-lambda [(8) 8]))
    163. 

  163. (syntax-test #'(case-lambda [(x . 9) 8]))
    164. 

  164. (syntax-test #'(case-lambda [x . 8]))
    165. 

  165. (syntax-test #'(case-lambda [(x) . 8]))
    166. 

  166. (syntax-test #'(case-lambda . [(x) 8]))
    167. 

  167. (syntax-test #'(case-lambda [(x) 8] . y))
    168. 

  168. (syntax-test #'(case-lambda [(x) 8] . [y 7]))
    169. 

  169. (syntax-test #'(case-lambda [(x) 8] [8 7]))
    170. 

  170. (syntax-test #'(case-lambda [(x) 8] [((y)) 7]))
    171. 

  171. (syntax-test #'(case-lambda [(x) 8] [(8) 7]))
    172. 

  172. (syntax-test #'(case-lambda [(x) 8] [(y . 8) 7]))
    173. 

  173. (syntax-test #'(case-lambda [(x) 8] [y . 7]))
    174. 

  174. (syntax-test #'(case-lambda [(x) 8] [(y) . 7]))
    175. 

  175. (syntax-test #'(case-lambda [(x x) 8] [(y) 7]))
    176. 

  176. (syntax-test #'(case-lambda [(x . x) 8] [(y) 7]))
    177. 

  177. (syntax-test #'(case-lambda [(y) 7] [(x x) 8]))
    178. 

  178. (syntax-test #'(case-lambda [(y) 7] [(x . x) 8]))
    179. 

    180. 

  180. (test 'yes 'if (if (> 3 2) 'yes 'no))
    181. 

  181. (test 'no 'if (if (> 2 3) 'yes 'no))
    182. 

  182. (test '1 'if (if (> 3 2) (- 3 2) (+ 3 2)))
    183. 

  183. (test-values '(1 2) (lambda () (if (cons 1 2) (values 1 2) 0)))
    184. 

  184. (test-values '(1 2) (lambda () (if (not (cons 1 2)) 0 (values 1 2))))
    185. 

  185. (syntax-test #'if)
    186. 

  186. (syntax-test #'(if))
    187. 

  187. (syntax-test #'(if . #t))
    188. 

  188. (syntax-test #'(if #t . 1))
    189. 

  189. (syntax-test #'(if #t 1 . 2))
    190. 

  190. (syntax-test #'(if #t))
    191. 

  191. (syntax-test #'(if #t 1))
    192. 

  192. (syntax-test #'(if #t 1 2 3))
    193. 

  193. (syntax-test #'(if #t 1 2 . 3))
    194. 

  194. (error-test #'(if (values 1 2) 3 4) arity?)
    195. 

    196. 

  196. (test (void) 'when (when (> 1 2) 0))
    197. 

  197. (test (void) 'when (when (> 1 2) (cons 1 2) 0))
    198. 

  198. (test 0 'when (when (< 1 2) 0))
    199. 

  199. (test 0 'when (when (< 1 2) (cons 1 2) 0))
    200. 

  200. (test-values '(0 10) (lambda () (when (< 1 2) (values 0 10))))
    201. 

  201. (syntax-test #'when)
    202. 

  202. (syntax-test #'(when))
    203. 

  203. (syntax-test #'(when . 1))
    204. 

  204. (syntax-test #'(when 1))
    205. 

  205. (syntax-test #'(when 1 . 2))
    206. 

  206. (error-test #'(when (values 1 2) 0) arity?)
    207. 

    208. 

  208. (test (void) 'unless (unless (< 1 2) 0))
    209. 

  209. (test (void) 'unless (unless (< 1 2) (cons 1 2) 0))
    210. 

  210. (test 0 'unless (unless (> 1 2) 0))
    211. 

  211. (test 0 'unless (unless (> 1 2) (cons 1 2) 0))
    212. 

  212. (test-values '(0 10) (lambda () (unless (> 1 2) (values 0 10))))
    213. 

  213. (syntax-test #'unless)
    214. 

  214. (syntax-test #'(unless))
    215. 

  215. (syntax-test #'(unless . 1))
    216. 

  216. (syntax-test #'(unless 1))
    217. 

  217. (syntax-test #'(unless 1 . 2))
    218. 

  218. (error-test #'(unless (values 1 2) 0) arity?)
    219. 

    220. 

  220. (define x 2)
    221. 

  221. (test 3 'define (+ x 1))
    222. 

  222. (set! x 4)
    223. 

  223. (test 5 'set! (+ x 1))
    224. 

  224. (syntax-test #'set!)
    225. 

  225. (syntax-test #'(set!))
    226. 

  226. (syntax-test #'(set! x))
    227. 

  227. (syntax-test #'(set! x 1 2))
    228. 

  228. (syntax-test #'(set! 1 2))
    229. 

  229. (syntax-test #'(set! (x) 1))
    230. 

  230. (syntax-test #'(set! . x))
    231. 

  231. (syntax-test #'(set! x . 1))
    232. 

  232. (syntax-test #'(set! x 1 . 2))
    233. 

    234. 

  234. (define (set!-not-ever-defined) (set! not-ever-defined (add1 not-ever-defined)))
    235. 

  235. (err/rt-test (set!-not-ever-defined) exn:fail:contract:variable?)
    236. 

  236. 

  237. (set!-values (x) 9)
    238. 

  238. (test 9 'set!-values x)
    239. 

  239. (test (void) 'set!-values (set!-values () (values)))
    240. 

  240. (syntax-test #'set!-values)
    241. 

  241. (syntax-test #'(set!-values))
    242. 

  242. (syntax-test #'(set!-values . x))
    243. 

  243. (syntax-test #'(set!-values x))
    244. 

  244. (syntax-test #'(set!-values 8))
    245. 

  245. (syntax-test #'(set!-values (x)))
    246. 

  246. (syntax-test #'(set!-values (x) . 0))
    247. 

  247. (syntax-test #'(set!-values x 0))
    248. 

  248. (syntax-test #'(set!-values (x . y) 0))
    249. 

  249. (syntax-test #'(set!-values (x . 8) 0))
    250. 

  250. (syntax-test #'(set!-values (x 8) 0))
    251. 

  251. (syntax-test #'(set!-values (x) 0 1))
    252. 

  252. (syntax-test #'(set!-values (x) 0 . 1))
    253. 

  253. (syntax-test #'(set!-values (x x) 0))
    254. 

  254. (syntax-test #'(set!-values (x y x) 0))
    255. 

  255. (syntax-test #'(set!-values (y x x) 0))
    256. 

    257. 

  257. (error-test #'(set!-values () 1) arity?)
    258. 

  258. (error-test #'(set!-values () (values 1 2)) arity?)
    259. 

  259. (error-test #'(set!-values (x) (values)) arity?)
    260. 

  260. (error-test #'(set!-values (x) (values 1 2)) arity?)
    261. 

  261. (error-test #'(set!-values (x y) 1) arity?)
    262. 

  262. (error-test #'(set!-values (x y) (values 1 2 3)) arity?)
    263. 

    264. 

  264. (error-test #'(set! unbound-variable 5) exn:fail:contract:variable?)
    265. 

    266. 

  266. (test 'greater 'cond (cond ((> 3 2) 'greater)
    267. 

  267. 			   ((< 3 2) 'less)))
    268. 

  268. (test 'equal 'cond (cond ((> 3 3) 'greater)
    269. 

  269. 			 ((< 3 3) 'less)
    270. 

  270. 			 (else 'equal)))
    271. 

  271. (test 2 'cond (cond ((assv 'b '((a 1) (b 2))) => cadr)
    272. 

  272. 		     (else #f)))
    273. 

  273. (test #f 'cond (cond ((assv 'z '((a 1) (b 2))) => cadr)
    274. 

  274. 		     (else #f)))
    275. 

  275. (syntax-test #'(cond ((assv 'z '((a 1) (b 2))) => cadr)
    276. 

  276. 		    (else 8)
    277. 

  277. 		    (else #f)))
    278. 

  278. (test #f 'cond (let ([else #f])
    279. 

  279. 		 (cond ((assv 'z '((a 1) (b 2))) => cadr)
    280. 

  280. 		       (else 8)
    281. 

  281. 		       (#t #f))))
    282. 

  282. (test 'second 'cond (cond ((< 1 2) (cons 1 2) 'second)))
    283. 

  283. (test 'second-again 'cond (cond ((> 1 2) 'ok) (else (cons 1 2) 'second-again)))
    284. 

  284. (test 1 'cond (cond (1)))
    285. 

  285. (test 1 'cond (cond (#f) (1)))
    286. 

  286. (test 1 'cond (cond (#f 7) (1)))
    287. 

  287. (test 2 'cond (cond (#f 7) (1 => add1)))
    288. 

  288. (test add1 'cond (let ([=> 9]) (cond (#f 7) (1 => add1))))
    289. 

  289. (non-z '(test 0 'case (case (* 2 3)
    290. 

  290. 		(6 0)
    291. 

  291. 		(else 7))))
    292. 

  292. (test 'composite 'case (case (* 2 3)
    293. 

  293. 			 ((2 3 5 7) 'prime)
    294. 

  294. 			 ((1 4 6 8 9) 'composite)))
    295. 

  295. (test 'consonant 'case (case (car '(c d))
    296. 

  296. 			 ((a e i o u) 'vowel)
    297. 

  297. 			 ((w y) 'semivowel)
    298. 

  298. 			 (else 'consonant)))
    299. 

  299. (test 'second 'case (case 10
    300. 

  300. 		      [(10) (cons 1 2) 'second]
    301. 

  301. 		      [else 5]))
    302. 

  302. (test 'second-again 'case (case 11
    303. 

  303. 			    [(10) (cons 1 2) 'second]
    304. 

  304. 			    [else (cons 1 2) 'second-again]))
    305. 

  305. (test-values '(10 9) (lambda ()
    306. 

  306. 		       (cond
    307. 

  307. 			[(positive? 0) 'a]
    308. 

  308. 			[(positive? 10) (values 10 9)]
    309. 

  309. 			[else #f])))
    310. 

  310. (test-values '(10 9) (lambda ()
    311. 

  311. 		       (case (string->symbol "hello")
    312. 

  312. 			[(bye) 'a]
    313. 

  313. 			[(hello) (values 10 9)]
    314. 

  314. 			[else #f])))
    315. 

  315. (error-test #'(cond [(values 1 2) 8]) arity?)
    316. 

  316. (error-test #'(case (values 1 2) [(a) 8]) arity?)
    317. 

  317. (syntax-test #'(case 1 []) #rx"ill-formed clause")
    318. 

  318. (syntax-test #'(case 1 [(y) 5] []) #rx"ill-formed clause")
    319. 

  319. (syntax-test #'(case 1 [x]) #rx"not a datum sequence")
    320. 

  320. (syntax-test #'(case 1 [(y) 5] [x]) #rx"not a datum sequence")
    321. 

  321. (syntax-test #'(case 1 [(y) 5] [x x]) #rx"not a datum sequence")
    322. 

  322. (syntax-test #'(case 1 [x x]) #rx"not a datum sequence")
    323. 

  323. (syntax-test #'(case 1 [(x)]) #rx"missing expression after datum sequence")
    324. 

  324. (syntax-test #'(case 1 [(y) 5] [(x)]) #rx"missing expression after datum sequence")
    325. 

  325. (syntax-test #'(case 1 [(x) . 8]) #rx"illegal use of `.'")
    326. 

  326. (syntax-test #'(case 1 [(x) 10] . 9) #rx"illegal use of `.'")
    327. 

    328. 

  328. ;; test larger `case' dispatches to trigger for binary-search
    329. 

  329. ;; and hash-table-based dispatch:
    330. 

  330. (let ()
    331. 

  331.   (define (f x)
    332. 

  332.     (case x
    333. 

  333.       [(1003) 'even-further]
    334. 

  334.       [(0 -1 -2) 'low]
    335. 

  335.       [(1) 'one]
    336. 

  336.       [(2 3 4 5 6) 'middle]
    337. 

  337.       [(100) 'super]
    338. 

  338.       [(7 8 9 10 11) 'upper]
    339. 

  339.       [(1001) 'youch]
    340. 

  340.       [(12) 'high]
    341. 

  341.       [(1002) 'further]
    342. 

  342.       [(13) 'extreme]
    343. 

  343.       [(14) 'more]))
    344. 

  344.   (test 'low f -2)
    345. 

  345.   (test 'low f -1)
    346. 

  346.   (test 'low f 0)
    347. 

  347.   (test 'one f 1)
    348. 

  348.   (test 'middle f 2)
    349. 

  349.   (test 'middle f 3)
    350. 

  350.   (test 'middle f 4)
    351. 

  351.   (test 'middle f 5)
    352. 

  352.   (test 'middle f 6)
    353. 

  353.   (test 'upper f 7)
    354. 

  354.   (test 'upper f 8)
    355. 

  355.   (test 'upper f 9)
    356. 

  356.   (test 'upper f 10)
    357. 

  357.   (test 'upper f 11)
    358. 

  358.   (test 'high f 12)
    359. 

  359.   (test 'extreme f 13)
    360. 

  360.   (test 'more f 14)
    361. 

  361.   (test 'super f 100)
    362. 

  362.   (test 'youch f 1001)
    363. 

  363.   (test 'further f 1002)
    364. 

  364.   (test 'even-further f 1003)
    365. 

  365.   (test (void) f 1004)
    366. 

  366.   (test (void) f 104)
    367. 

  367.   (test (void) f -104))
    368. 

    369. 

  369. (let ()
    370. 

  370.   (define (f x)
    371. 

  371.     (case x
    372. 

  372.       [(#\u1003) 'even-further]
    373. 

  373.       [(#\u0) 'low]
    374. 

  374.       [(#\u1) 'one]
    375. 

  375.       [(#\u2 #\u3 #\u4 #\u5 #\u6) 'middle]
    376. 

  376.       [(#\u100) 'super]
    377. 

  377.       [(#\u7 #\u8 #\u9 #\u10 #\u11) 'upper]
    378. 

  378.       [(#\u1001) 'youch]
    379. 

  379.       [(#\u12) 'high]
    380. 

  380.       [(#\u1002) 'further]
    381. 

  381.       [(#\u13) 'extreme]
    382. 

  382.       [(#\u14) 'more]))
    383. 

  383.   (test 'low f #\u0)
    384. 

  384.   (test 'one f #\u1)
    385. 

  385.   (test 'middle f #\u2)
    386. 

  386.   (test 'middle f #\u3)
    387. 

  387.   (test 'middle f #\u4)
    388. 

  388.   (test 'middle f #\u5)
    389. 

  389.   (test 'middle f #\u6)
    390. 

  390.   (test 'upper f #\u7)
    391. 

  391.   (test 'upper f #\u8)
    392. 

  392.   (test 'upper f #\u9)
    393. 

  393.   (test 'upper f #\u10)
    394. 

  394.   (test 'upper f #\u11)
    395. 

  395.   (test 'high f #\u12)
    396. 

  396.   (test 'extreme f #\u13)
    397. 

  397.   (test 'more f #\u14)
    398. 

  398.   (test 'super f #\u100)
    399. 

  399.   (test 'youch f #\u1001)
    400. 

  400.   (test 'further f #\u1002)
    401. 

  401.   (test 'even-further f #\u1003)
    402. 

  402.   (test (void) f #\u1004)
    403. 

  403.   (test (void) f #\u104))
    404. 

    405. 

  405. (let ()
    406. 

  406.   (define (f x)
    407. 

  407.     (case x
    408. 

  408.       [(low) 0]
    409. 

  409.       [(one) 1]
    410. 

  410.       [(middle) 2]
    411. 

  411.       [(upper #t) 3]
    412. 

  412.       [(high big up-there more) 4]
    413. 

  413.       [(extreme massive huge #f gigantic) 5]))
    414. 

  414.   (test 0 f 'low)
    415. 

  415.   (test 1 f 'one)
    416. 

  416.   (test 2 f 'middle)
    417. 

  417.   (test 3 f 'upper)
    418. 

  418.   (test 3 f #t)
    419. 

  419.   (test 4 f 'high)
    420. 

  420.   (test 4 f 'big)
    421. 

  421.   (test 4 f 'up-there)
    422. 

  422.   (test 4 f 'more)
    423. 

  423.   (test 5 f 'extreme)
    424. 

  424.   (test 5 f 'massive)
    425. 

  425.   (test 5 f 'huge)
    426. 

  426.   (test 5 f #f)
    427. 

  427.   (test 5 f 'gigantic)
    428. 

  428.   (test (void) f 'gigante)
    429. 

  429.   (test (void) f 0))
    430. 

    431. 

  431. (let ()
    432. 

  432.   ;; This test relies on interning of string literals.
    433. 

  433.   (define (f x)
    434. 

  434.     (case x
    435. 

  435.       [("low") 0]
    436. 

  436.       [("one") 1]
    437. 

  437.       [("middle") 2]
    438. 

  438.       [("upper" #t) 3]
    439. 

  439.       [("high" "big" "up-there" "more") 4]
    440. 

  440.       [("extreme" "massive" "huge" "gigantic" #f) 5]))
    441. 

  441.   (test 0 f "low")
    442. 

  442.   (test 1 f "one")
    443. 

  443.   (test 2 f "middle")
    444. 

  444.   (test 3 f "upper")
    445. 

  445.   (test 3 f #t)
    446. 

  446.   (test 4 f "high")
    447. 

  447.   (test 4 f "big")
    448. 

  448.   (test 4 f "up-there")
    449. 

  449.   (test 4 f "more")
    450. 

  450.   (test 5 f "extreme")
    451. 

  451.   (test 5 f "massive")
    452. 

  452.   (test 5 f "huge")
    453. 

  453.   (test 5 f #f)
    454. 

  454.   (test 5 f "gigantic")
    455. 

  455.   (test (void) f "gigante")
    456. 

  456.   (test (void) f 'gigante)
    457. 

  457.   (test (void) f 0))
    458. 

    459. 

  459. (let ()
    460. 

  460.   ;; This test uses string-copy to avoid interning string literals.
    461. 

  461.   (define (f x)
    462. 

  462.     (define y 
    463. 

  463.       (if (string? x)
    464. 

  464.           (string-copy x)
    465. 

  465.           x))
    466. 

  466.     (case y
    467. 

  467.       [("low") 0]
    468. 

  468.       [("one") 1]
    469. 

  469.       [("middle") 2]
    470. 

  470.       [("upper" #t) 3]
    471. 

  471.       [("high" "big" "up-there" "more") 4]
    472. 

  472.       [("extreme" "massive" "huge" "gigantic" #f) 5]))
    473. 

  473.   (test 0 f "low")
    474. 

  474.   (test 1 f "one")
    475. 

  475.   (test 2 f "middle")
    476. 

  476.   (test 3 f "upper")
    477. 

  477.   (test 3 f #t)
    478. 

  478.   (test 4 f "high")
    479. 

  479.   (test 4 f "big")
    480. 

  480.   (test 4 f "up-there")
    481. 

  481.   (test 4 f "more")
    482. 

  482.   (test 5 f "extreme")
    483. 

  483.   (test 5 f "massive")
    484. 

  484.   (test 5 f "huge")
    485. 

  485.   (test 5 f #f)
    486. 

  486.   (test 5 f "gigantic")
    487. 

  487.   (test (void) f "gigante")
    488. 

  488.   (test (void) f 'gigante)
    489. 

  489.   (test (void) f 0))
    490. 

    491. 

  491. (let ()
    492. 

  492.   (define (f x)
    493. 

  493.     (case x
    494. 

  494.       [("zero"  #"zero"  (z . 0) (z e r o)   #(z e r o)   #&zero 
    495. 

  495.                 #hash((z . "z") (e . "e") (r . "r") (o . "o")) 
    496. 

  496.                 #s(z e r o)) 
    497. 

  497.        0]
    498. 

  498.       [("one"   #"one"   (o . 1) (o n e)     #(o n e)     #&one 
    499. 

  499.                 #hash((o . "o") (n . "n") (e . "e")) 
    500. 

  500.                 #s(o n e)) 
    501. 

  501.        1]
    502. 

  502.       [("two"   #"two"   (t . 2) (t w o)     #(t w o)     #&two 
    503. 

  503.                 #hash((t . "t") (w . "w") (o . "o")) 
    504. 

  504.                 #s(t w o))
    505. 

  505.        2]
    506. 

  506.       [("three" #"three" (t . 3) (t h r e e) #(t h r e e) #&three 
    507. 

  507.                 #hash((t . "t") (h . "h") (r . "e") (e . "e") (e . "e")) 
    508. 

  508.                 #s(t h r e e)) 
    509. 

  509.        3]
    510. 

  510.       [("four"  #"four"  (f . 4) (f o u r)   #(f o u r)   #&four 
    511. 

  511.                 #hash((f . "f") (o . "o") (u . "u") (r . "r"))
    512. 

  512.                 #s(f o u r))
    513. 

  513.        4]
    514. 

  514.       [("five"  #"five"  (f . 5) (f i v e)   #(f i v e)   #&five 
    515. 

  515.                 #hash((f . "f") (i . "i") (v . "v") (e . "e"))
    516. 

  516.                 #s(f i v e)) 
    517. 

  517.        5]
    518. 

  518.       [("six"   #"six"   (s . 6) (s i x)     #(s i x)     #&six 
    519. 

  519.                 #hash((s . "s") (i . "i") (x . "x")) 
    520. 

  520.                 #s(s i x)) 
    521. 

  521.        6]
    522. 

  522.       [("seven" #"seven" (s . 7) (s e v e n) #(s e v e n) #&seven 
    523. 

  523.                 #hash((s . "s") (e . "e") (v . "v") (e . "e") (n . "n"))
    524. 

  524.                 #s(s e v e n))
    525. 

  525.        7]
    526. 

  526.       [("eight" #"eight" (e . 8) (e i g h t) #(e i g h t) #&eight 
    527. 

  527.                 #hash((e . "e") (i . "i") (g . "g") (h . "h") (t . "t"))
    528. 

  528.                 #s(e i g h t))
    529. 

  529.        8]))
    530. 

  530.   (test 8 f "eight")
    531. 

  531.   (test 7 f #"seven")
    532. 

  532.   (test 6 f (cons 's 6))
    533. 

  533.   (test 5 f '(f i v e))
    534. 

  534.   (test 4 f '#(f o u r))
    535. 

  535.   (test 3 f (box 'three))
    536. 

  536.   (test 2 f (hash 't "t" 'w "w" 'o "o"))
    537. 

  537.   (test 1 f #s(o n e))
    538. 

  538.   (test (void) f #f))
    539. 

    540. 

  540. (test #t 'and (and (= 2 2) (> 2 1)))
    541. 

  541. (test #f 'and (and (= 2 2) (< 2 1)))
    542. 

  542. (test '(f g) 'and (and 1 2 'c '(f g)))
    543. 

  543. (test #t 'and (and))
    544. 

  544. (test-values '(1 12) (lambda () (and (cons 1 2) (values 1 12))))
    545. 

  545. (test #t 'or (or (= 2 2) (> 2 1)))
    546. 

  546. (test #t 'or (or (= 2 2) (< 2 1)))
    547. 

  547. (test #f 'or (or #f #f #f))
    548. 

  548. (test #f 'or (or))
    549. 

  549. (test '(b c) 'or (or (memq 'b '(a b c)) (+ 3 0)))
    550. 

  550. (test-values '(1 12) (lambda () (or (not (cons 1 2)) (values 1 12))))
    551. 

  551. (syntax-test #'(cond #t))
    552. 

  552. (syntax-test #'(cond ())  )
    553. 

  553. (syntax-test #'(cond (1 =>))  )
    554. 

  554. (syntax-test #'(cond (1 => 3 4))  )
    555. 

  555. (syntax-test #'(cond . #t))
    556. 

  556. (syntax-test #'(cond (#t . 1)))
    557. 

  557. (syntax-test #'(cond (#t 1) #f))
    558. 

  558. (syntax-test #'(cond (#t 1) . #f))
    559. 

  559. (error-test #'(cond ((values #t #f) 1)) arity?)
    560. 

  560. (syntax-test #'case)
    561. 

  561. (syntax-test #'(case))
    562. 

  562. (syntax-test #'(case 0 #t))
    563. 

  563. (syntax-test #'(case . 0))
    564. 

  564. (syntax-test #'(case 0 . #t))
    565. 

  565. (syntax-test #'(case 0 (0 #t)))
    566. 

  566. (syntax-test #'(case 0 ()))
    567. 

  567. (syntax-test #'(case 0 (0)))
    568. 

  568. (syntax-test #'(case 0 (0 . 8)))
    569. 

  569. (syntax-test #'(case 0 ((0 . 1) 8)))
    570. 

  570. (syntax-test #'(case 0 (0 8) #f))
    571. 

  571. (syntax-test #'(case 0 (0 8) . #f))
    572. 

  572. (syntax-test #'(case 0 (else 1) (else 2)))
    573. 

  573. (syntax-test #'(case 0 ((0) =>)))
    574. 

  574. (syntax-test #'=>)
    575. 

  575. (syntax-test #'else)
    576. 

  576. (syntax-test #'(and . 1))
    577. 

  577. (syntax-test #'(and 1 . 2))
    578. 

  578. (syntax-test #'(or . 1))
    579. 

  579. (syntax-test #'(or 1 . 2))
    580. 

  580. (error-test #'(and #t (values 1 2) 8) arity?)
    581. 

  581. (error-test #'(or #f (values 1 2) 8) arity?)
    582. 

    583. 

  583. (test 6 'let (let ((x 2) (y 3)) (* x y)))
    584. 

  584. (test 'second 'let (let ((x 2) (y 3)) (* x y) 'second))
    585. 

  585. (test 6 'let-values (let-values (((x) 2) ((y) 3)) (* x y)))
    586. 

  586. (test 6 'let-values (let-values (((x y) (values 2 3))) (* x y)))
    587. 

  587. (test 35 'let (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x))))
    588. 

  588. (test 35 'let-values (let-values (((x y) (values 2 3))) (let-values (((x) 7) ((z) (+ x y))) (* z x))))
    589. 

  589. (test 70 'let* (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x))))
    590. 

  590. (test 70 'let*-values (let ((x 2) (y 3)) (let*-values (((x) 7) ((z) (+ x y))) (* z x))))
    591. 

  591. (test #t 'letrec (letrec ((-even?
    592. 

  592.                            (lambda (n) (if (zero? n) #t (-odd? (- n 1)))))
    593. 

  593.                           (-odd?
    594. 

  594.                            (lambda (n) (if (zero? n) #f (-even? (- n 1))))))
    595. 

  595.                    (-even? 88)))
    596. 

  596. (test #t 'letrec-values (letrec-values (((-even? -odd?)
    597. 

  597. 					 (values
    598. 

  598. 					  (lambda (n) (if (zero? n) #t (-odd? (- n 1))))
    599. 

  599. 					  (lambda (n) (if (zero? n) #f (-even? (- n 1)))))))
    600. 

  600. 				       (-even? 88)))
    601. 

  601. (define x 34)
    602. 

  602. (test 5 'let (let ((x 3)) (define x 5) x))
    603. 

  603. (test 5 'let (let ((x 3)) (define-values (x w) (values 5 8)) x))
    604. 

  604. (test 34 'let x)
    605. 

  605. (test 6 'let (let () (define x 6) x))
    606. 

  606. (test 34 'let x)
    607. 

  607. (test 7 'let* (let* ((x 3)) (define x 7) x))
    608. 

  608. (test 34 'let* x)
    609. 

  609. (test 8 'let* (let* () (define x 8) x))
    610. 

  610. (test 34 'let* x)
    611. 

  611. (test 9 'letrec (letrec () (define x 9) x))
    612. 

  612. (test 34 'letrec x)
    613. 

  613. (test 10 'letrec (letrec ((x 3)) (define x 10) x))
    614. 

  614. (test 34 'letrec x)
    615. 

  615. (teval '(test 5 'letrec (letrec ((x 5)(y x)) y)))
    616. 

  616. (test 3 'let (let ((y 'apple) (x 3) (z 'banana)) x))
    617. 

  617. (test 3 'let* (let* ((y 'apple) (x 3) (z 'banana)) x))
    618. 

  618. (test 3 'letrec (letrec ((y 'apple) (x 3) (z 'banana)) x))
    619. 

  619. (test 3 'let* (let* ((x 7) (y 'apple) (z (set! x 3))) x))
    620. 

  620. (test 3 'let* (let* ((x 7) (y 'apple) (z (if (not #f) (set! x 3) #f))) x))
    621. 

  621. (test 3 'let* (let* ((x 7) (y 'apple) (z (if (not #t) #t (set! x 3)))) x))
    622. 

  622. (test 3 'let-values (let-values (((y x z) (values 'apple 3 'banana))) x))
    623. 

  623. (test 3 'let*-values (let*-values (((y x z) (values 'apple 3 'banana))) x))
    624. 

  624. (test 3 'letrec-values (letrec-values (((y x z) (values 'apple 3 'banana))) x))
    625. 

  625. (test 3 'let*-values (let*-values (((x y) (values 7 'apple)) ((z) (set! x 3))) x))
    626. 

  626. (test 3 'let*-values (let*-values (((x y) (values 7 'apple)) ((z) (if (not #f) (set! x 3) #f))) x))
    627. 

  627. (test 3 'let*-values (let*-values (((x y) (values 7 'apple)) ((z) (if (not #t) #t (set! x 3)))) x))
    628. 

  628. (test 1 'named-let-scope (let ([f add1]) (let f ([n (f 0)]) n)))
    629. 

    630. 

  630. (test-values '(3 4) (lambda () (let ([x 3][y 4]) (values x y))))
    631. 

  631. (test-values '(3 -4) (lambda () (let loop ([x 3][y -4]) (values x y))))
    632. 

  632. (test-values '(3 14) (lambda () (let* ([x 3][y 14]) (values x y))))
    633. 

  633. (test-values '(3 24) (lambda () (letrec ([x 3][y 24]) (values x y))))
    634. 

  634. (test-values '(3 54) (lambda () (let-values ([(x y) (values 3 54)]) (values x y))))
    635. 

  635. (test-values '(3 64) (lambda () (let*-values ([(x y) (values 3 64)]) (values x y))))
    636. 

  636. (test-values '(3 74) (lambda () (letrec-values ([(x y) (values 3 74)]) (values x y))))
    637. 

    638. 

  638. (test 'one 'let-values (let-values ([() (values)]) 'one))
    639. 

  639. (test 'two 'let*-values (let*-values ([() (values)]) 'two))
    640. 

  640. (test 'three 'letrec-values (letrec-values ([() (values)]) 'three))
    641. 

  641. (test 'onex 'let-values (let-values ([() (values)][() (values)]) 'onex))
    642. 

  642. (test 'twox 'let*-values (let*-values ([() (values)][() (values)]) 'twox))
    643. 

  643. (test 'threex 'letrec-values (letrec-values ([() (values)][() (values)]) 'threex))
    644. 

    645. 

  645. (letrec ([undef undef])
    646. 

  646.   (test (list 1 undef undef) 'no-split-letrec (letrec-values ([(a b c) (values 1 a b)]) (list a b c))))
    647. 

    648. 

  648. (test '(10 11) 'letrec-values (letrec-values ([(names kps)
    649. 

  649. 					       (letrec ([oloop 10])
    650. 

  650. 						 (values oloop (add1 oloop)))])
    651. 

  651. 					     (list names kps)))
    652. 

    653. 

  653. (define (error-test-let/no-* expr)
    654. 

  654.   (syntax-test (datum->syntax #f (cons 'let expr) #f))
    655. 

  655.   (syntax-test (datum->syntax #f (cons 'let (cons 'name expr)) #f))
    656. 

  656.   (syntax-test (datum->syntax #f (cons 'letrec expr) #f)))
    657. 

  657. (define (error-test-let expr)
    658. 

  658.   (error-test-let/no-* expr)
    659. 

  659.   (syntax-test (datum->syntax #f (cons 'let* expr) #f)))
    660. 

  660. (error-test-let #'x)
    661. 

  661. (error-test-let #'(x))
    662. 

  662. (error-test-let #'(()))
    663. 

  663. (error-test-let #'(x ()))
    664. 

  664. (syntax-test #'(let* x () 1))
    665. 

  665. (syntax-test #'(letrec x () 1))
    666. 

  666. (error-test-let #'(x . 1))
    667. 

  667. (error-test-let #'(() . 1))
    668. 

  668. (error-test-let #'(((x 1))))
    669. 

  669. (error-test-let #'(((x 1)) . 1))
    670. 

  670. (error-test-let #'(((x . 1)) 1))
    671. 

  671. (error-test-let #'(((1 1)) 1))
    672. 

  672. (error-test-let #'(((x 1) 1)  1))
    673. 

  673. (error-test-let #'(((x 1) . 1)  1))
    674. 

  674. (error-test-let #'(((x 1 1)) 1))
    675. 

  675. (error-test-let #'(((x 1 1)) 1))
    676. 

  676. (error-test-let #'(((x 1)) 1 . 2))
    677. 

  677. (error-test-let/no-* #'(((x 1) (x 2)) 1))
    678. 

  678. (error-test-let/no-* #'(((x 1) (y 3) (x 2)) 1))
    679. 

  679. (error-test-let/no-* #'(((y 3) (x 1) (x 2)) 1))
    680. 

  680. (error-test-let/no-* #'(((x 1) (x 2) (y 3)) 1))
    681. 

  681. (test 5 'let* (let* ([x 4][x 5]) x))
    682. 

  682. (error-test-let #'(() (define x 10)))
    683. 

  683. (error-test-let #'(() (define x 10) (define y 20)))
    684. 

    685. 

  685. (define (do-error-test-let-values/no-* expr syntax-test)
    686. 

  686.   (syntax-test (datum->syntax #f (cons 'let-values expr) #f))
    687. 

  687.   (syntax-test (datum->syntax #f (cons 'letrec-values expr) #f)))
    688. 

  688. (define (do-error-test-let-values expr syntax-test)
    689. 

  689.   (do-error-test-let-values/no-* expr syntax-test)
    690. 

  690.   (syntax-test (datum->syntax #f (cons 'let*-values expr) #f)))
    691. 

  691. (define (error-test-let-values/no-* expr)
    692. 

  692.   (do-error-test-let-values/no-* expr syntax-test))
    693. 

  693. (define (error-test-let-values expr)
    694. 

  694.   (do-error-test-let-values expr syntax-test))
    695. 

  695. (error-test-let-values #'x)
    696. 

  696. (error-test-let-values #'(x))
    697. 

  697. (error-test-let-values #'(()))
    698. 

  698. (error-test-let-values #'(x ()))
    699. 

  699. (syntax-test #'(let*-values x () 1))
    700. 

  700. (syntax-test #'(letrec-values x () 1))
    701. 

  701. (error-test-let-values #'(x . 1))
    702. 

  702. (error-test-let-values #'(() . 1))
    703. 

  703. (error-test-let-values #'((((x) 1))))
    704. 

  704. (error-test-let-values #'((((x) 1)) . 1))
    705. 

  705. (error-test-let-values #'((((x) . 1)) 1))
    706. 

  706. (error-test-let-values #'((((1) 1)) 1))
    707. 

  707. (error-test-let-values #'((((x 1) 1)) 1))
    708. 

  708. (error-test-let-values #'((((1 x) 1)) 1))
    709. 

  709. (error-test-let-values #'((((x) 1) . 1)  1))
    710. 

  710. (error-test-let-values #'((((x) 1 1)) 1))
    711. 

  711. (error-test-let-values #'((((x . y) 1)) 1))
    712. 

  712. (error-test-let-values #'((((x . 1) 1)) 1))
    713. 

  713. (error-test-let-values #'((((x) 1)) 1 . 2))
    714. 

  714. (error-test-let-values #'((((x x) 1)) 1))
    715. 

  715. (error-test-let-values #'((((y) 0) ((x x) 1)) 1))
    716. 

  716. (error-test-let-values #'((((x x) 1) ((y) 0)) 1))
    717. 

  717. (error-test-let-values/no-* #'((((x) 1) ((x) 2)) 1))
    718. 

  718. (error-test-let-values/no-* #'((((x) 1) ((y) 3) ((x) 2)) 1))
    719. 

  719. (error-test-let-values/no-* #'((((y) 3) ((x) 1) ((x) 2)) 1))
    720. 

  720. (error-test-let-values/no-* #'((((x) 1) ((x) 2) ((y) 3)) 1))
    721. 

  721. (test 5 'let* (let*-values ([(x) 4][(x) 5]) x))
    722. 

    723. 

  723. (do-error-test-let-values #'((((x y) 1)) 1) (lambda (x) (error-test x arity?)))
    724. 

  724. (do-error-test-let-values #'((((x) (values 1 2))) 1) (lambda (x) (error-test x arity?)))
    725. 

  725. (do-error-test-let-values #'(((() (values 1))) 1) (lambda (x) (error-test x arity?)))
    726. 

  726. (do-error-test-let-values #'((((x) (values))) 1) (lambda (x) (error-test x arity?)))
    727. 

    728. 

  728. (test 5 'embedded (let () (define y (lambda () x)) (define x 5) (y)))
    729. 

    730. 

  730. (let ([wrap (lambda (body)
    731. 

  731. 	      (syntax-test (datum->syntax #f `(let () ,@body) #f))
    732. 

  732. 	      (syntax-test (datum->syntax #f `(let () (begin ,@body)) #f)))])
    733. 

  733.   (wrap '((define x 7) (define x 8) x))
    734. 

  734.   (wrap '((define 3 8) x))
    735. 

  735.   (wrap '((define-values x 8) x)))
    736. 

    737. 

  737. (let ([wrap
    738. 

  738.        (lambda (val body)
    739. 

  739. 	 (teval `(test ,val 'let-begin (let () ,@body)))
    740. 

  740. 	 (teval `(test ,val 'let-begin (let ([xyzw 12]) ,@body)))
    741. 

  741. 	 (teval `(test ,val (lambda () ,@body)))
    742. 

  742. 	 (teval `(test ,val 'parameterize-begin
    743. 

  743. 		       (parameterize () ,@body)))
    744. 

  744. 	 (teval `(test ,val 'parameterize-begin
    745. 

  745. 		       (parameterize ([current-directory (current-directory)])
    746. 

  746. 			 ,@body)))
    747. 

  747. 	 (teval `(test ,val 'with-handlers-begin
    748. 

  748. 		       (with-handlers () ,@body)))
    749. 

  749. 	 (teval `(test ,val 'with-handlers-begin
    750. 

  750. 		       (with-handlers ([void void]) ,@body)))
    751. 

  751. 	 (teval `(test ,val 'when-begin (when (positive? 1) ,@body)))
    752. 

  752. 	 (teval `(test ,val 'unless-begin (unless (positive? -1) ,@body)))
    753. 

  753. 	 (teval `(test ,val 'cons-begin (cond [(positive? 1) ,@body][else #f])))
    754. 

  754. 	 (teval `(test ,val 'cons-else-begin (cond [(positive? -1) 0][else ,@body])))
    755. 

  755.          (teval `(test ,val 'case-begin (case (positive? 1) [(#t) ,@body][else -12])))
    756. 

  756. 	 (teval `(test ,val 'cond-only-begin (cond [#t ,@body])))
    757. 

  757. 	 (syntax-test (datum->syntax #f `(do ((x 1)) (#t ,@body) ,@body) #f))
    758. 

  758. 	 (syntax-test (datum->syntax #f `(begin0 12 ,@body) #f)))])
    759. 

  759.   (wrap 5 '((begin (define x 5)) x))
    760. 

  760.   (wrap 5 '((begin (define x 5) x)))
    761. 

  761.   (wrap 15 '((begin (define x 5)) (begin (define y (+ x 10)) y)))
    762. 

  762.   (wrap 13 '((begin) 13))
    763. 

  763.   (wrap 7 '((begin) (begin) (begin (define x 7) (begin) x)))
    764. 

  764.   (wrap 7 '((begin (begin (begin (define x 7) (begin) x))))))
    765. 

    766. 

  766. (define x 0)
    767. 

  767. (define (test-begin bg nested-bg)
    768. 

  768.   (let* ([make-args
    769. 

  769. 	  (lambda (bg b)
    770. 

  770. 	    (if (eq? bg 'begin)
    771. 

  771. 		b
    772. 

  772. 		(let* ([len (length b)]
    773. 

  773. 		       [last (list-ref b (sub1 len))])
    774. 

  774. 		  (cons last
    775. 

  775. 			(let loop ([l b])
    776. 

  776. 			  (if (null? (cdr l))
    777. 

  777. 			      null
    778. 

  778. 			      (cons (car l) (loop (cdr l)))))))))]
    779. 

  779. 	 [test-bg
    780. 

  780. 	  (lambda (v b)
    781. 

  781. 	    (let* ([args (make-args bg b)]
    782. 

  782. 		   [expr (cons bg args)])
    783. 

  783. 	      (printf "~s:\n" expr)
    784. 

  784. 	      (teval `(test ,v (quote ,bg) ,expr))))]
    785. 

  785. 	 [make-bg
    786. 

  786. 	  (lambda (b)
    787. 

  787. 	    (cons nested-bg (make-args nested-bg b)))]
    788. 

  788. 	 [make-test-bg-d
    789. 

  789. 	  (lambda (bg)
    790. 

  790. 	    (lambda (v1 v2 b)
    791. 

  791. 	      (test-bg (if (eq? bg 'begin)
    792. 

  792. 			   v1
    793. 

  793. 			   v2)
    794. 

  794. 		       b)))]
    795. 

  795. 	 [test-bg-d (make-test-bg-d bg)]
    796. 

  796. 	 [test-bg-d2 (make-test-bg-d nested-bg)])
    797. 

  797.   (teval '(set! x 0))
    798. 

  798.   (test-bg-d 6 1 '((set! x 5) (+ x 1)))
    799. 

  799.   (test-bg 5 '(5))
    800. 

  800.   (test-bg 3 '(2 3))
    801. 

  801.   (test-bg 3 `(2 (,bg 3)))
    802. 

  802.   (test-bg 3 `(,(make-bg '(2)) ,(make-bg '(3))))
    803. 

  803.   (test-bg-d 7 6 '((set! x 6) 'a (+ x 1)))
    804. 

  804.   (test-bg ''w '((set! x 6) 'a (+ x 1) 'w))
    805. 

  805.   (test-bg-d 8 7 '('b (set! x 7) (+ x 1)))
    806. 

  806.   (test-bg-d 9 8 '('b (set! x 8) 'a (+ x 1)))
    807. 

  807.   (test-bg ''z '('b (set! x 8) 'a (+ x 1) 'z))
    808. 

  808.   (test-bg-d 7 9 `(,(make-bg '((set! x 6) 'a)) (+ x 1)))
    809. 

  809.   (test-bg 10 `(,(make-bg '((set! x 60) 'a)) 10))
    810. 

  810.   (teval '(test 60 'x x))
    811. 

  811.   (test-bg 10 `(,(make-bg '((set! x 65) 'a)) (add1 20) 10))
    812. 

  812.   (teval '(test 65 'x x))
    813. 

  813.   (test-bg ''a `(10 ,(make-bg '((set! x 66) 'a))))
    814. 

  814.   (teval '(test 66 'x x))
    815. 

  815.   (test-bg ''a `(10 (add1 32) ,(make-bg '((set! x 67) 'a))))
    816. 

  816.   (teval '(test 67 'x x))
    817. 

  817.   (teval '(set! x 6))
    818. 

  818.   (test-bg-d 8 7 `(,(make-bg '('b (set! x 7) 'a)) (+ x 1)))
    819. 

  819.   (test-bg-d 9 8 `(,(make-bg '('b (set! x 8))) ,(make-bg '('a (+ x 1)))))
    820. 

  820.   (test-bg-d2 10 9 `(,(make-bg `(,(make-bg `('b (set! x 9) ,(make-bg '('a (+ x 1)))))))))
    821. 

  821.   (test-bg ''s `(,(make-bg `(,(make-bg `('b (set! x 9) ,(make-bg '('a (+ x 1) 's))))))))
    822. 

  822.   (test-bg ''t `(,(make-bg `(,(make-bg `('b (set! x 9) ,(make-bg '('a (+ x 1))))))) 't))
    823. 

  823.   (teval `(test 5 call-with-values (lambda () ,(make-bg '((values 1 2) (values 1 3 1)))) +))
    824. 

  824.   (syntax-test (datum->syntax #f `(,bg . 1) #f))
    825. 

  825.   (syntax-test (datum->syntax #f `(,bg 1 . 2) #f))))
    826. 

  826. 

  827. (test-begin 'begin 'begin)
    828. 

  828. (test-begin 'begin0 'begin)
    829. 

  829. (test-begin 'begin0 'begin0)
    830. 

  830. (test-begin 'begin 'begin0)
    831. 

  831. 

  832. (syntax-test #'(begin0))
    833. 

  833. (begin) ; must succeed, but we can't wrap it
    834. 

    835. 

  835. (test 4 'implicit-begin (let ([x 4][y 7]) 'y x))
    836. 

  836. (test 4 'implicit-begin (let ([x 4][y 7]) y x))
    837. 

    838. 

  838. (test 5 'implicit-begin (let () (begin) 10 5))
    839. 

    840. 

  840. (error-test #'(begin (define foo (let/cc k k)) (foo 10)) exn:application:type?) ; not exn:application:continuation?
    841. 

    842. 

  842. (define f-check #t)
    843. 

  843. (define f (delay (begin (set! f-check #f) 5)))
    844. 

  844. (test #t (lambda () f-check))
    845. 

  845. (test 5 force f)
    846. 

  846. (test #f (lambda () f-check))
    847. 

  847. (test 5 force f)
    848. 

  848. (define f-check-2 (delay (values 1 5)))
    849. 

  849. (test-values '(1 5) (lambda () (force f-check-2)))
    850. 

  850. (values 1 2)
    851. 

  851. (test-values '(1 5) (lambda () (force f-check-2)))
    852. 

  852. (syntax-test #'delay)
    853. 

  853. (syntax-test #'(delay))
    854. 

  854. (syntax-test #'(delay . 1))
    855. 

  855. (syntax-test #'(delay 1 . 2))
    856. 

    857. 

  857. (let ([p (delay/sync 12)]
    858. 

  858.       [v #f])
    859. 

  859.   (thread (lambda () (set! v (force p))))
    860. 

  860.   (sync (system-idle-evt))
    861. 

  861.   (test 12 force p)
    862. 

  862.   (test 12 values v)
    863. 

  863.   (test (void) sync p)
    864. 

  864.   (test (list (void)) sync (wrap-evt p list)))
    865. 

  865. 

  866. (test '(list 3 4) 'quasiquote `(list ,(+ 1 2) 4))
    867. 

  867. (test '(list a (quote a)) 'quasiquote (let ((name 'a)) `(list ,name ',name)))
    868. 

  868. (test '(a 3 4 5 6 b) 'quasiquote `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b))
    869. 

  869. (test '((foo 7) . cons)
    870. 

  870. 	'quasiquote
    871. 

  871. 	`((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons))))
    872. 

  872. (test '#(10 5 2 4 3 8) 'quasiquote `#(10 5 ,(sqrt 4) ,@(map sqrt '(16 9)) 8))
    873. 

  873. (test 5 'quasiquote `,(+ 2 3))
    874. 

  874. (test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f)
    875. 

  875.       'quasiquote `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f))
    876. 

  876. (test '(a `(b ,x ,'y d) e) 'quasiquote
    877. 

  877. 	(let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e)))
    878. 

  878. (test '(list 3 4) 'quasiquote (quasiquote (list (unquote (+ 1 2)) 4)))
    879. 

  879. (test '`(list ,(+ 1 2) 4) 'quasiquote '(quasiquote (list (unquote (+ 1 2)) 4)))
    880. 

  880. (test '(()) 'qq `((,@'())))
    881. 

  881. (define x 5)
    882. 

  882. (test '(quasiquote (unquote x)) 'qq ``,x)
    883. 

  883. (test '(quasiquote (unquote 5)) 'qq ``,,x)
    884. 

  884. (test '(quasiquote (unquote-splicing x)) 'qq ``,@x)
    885. 

  885. (test '(quasiquote (unquote-splicing 5)) 'qq ``,@,x)
    886. 

  886. (test '(quasiquote (quasiquote (quasiquote (unquote (unquote (unquote x)))))) 'qq ````,,,x)
    887. 

  887. (test '(quasiquote (quasiquote (quasiquote (unquote (unquote (unquote 5)))))) 'qq ````,,,,x)
    888. 

    889. 

  889. (test '#hash() 'qq `#hash())
    890. 

  890. (test '#hash(("apple" . 1) ("banana" . 2) ("coconut" . 3))
    891. 

  891.       'qq
    892. 

  892.       `#hash(("apple" . 1) ("banana" . 2) ("coconut" . 3)))
    893. 

  893. (test '#hash(("apple" . 1) ("banana" . 2) ("coconut" . 3))
    894. 

  894.       'qq
    895. 

  895.       `#hash(("apple" . ,1) ("banana" . ,(add1 1)) ("coconut" . ,(+ 1 2))))
    896. 

  896. (test '#hash(("foo" . (1 2 3 4 5)))
    897. 

  897.       'qq
    898. 

  898.       `#hash(("foo" . (1 2 ,(+ 1 2) 4 5))))
    899. 

  899. (test '#hash(("foo" . (1 2 (+ 1 2) 4 5)))
    900. 

  900.       'qq
    901. 

  901.       `#hash(("foo" . (1 2 (+ 1 2) 4 5))))
    902. 

  902. (test '#hash(("foo" . (1 2 3 4 5)))
    903. 

  903.       'qq
    904. 

  904.       `#hash(("foo" . (1 2 ,@(list 3 4 5)))))
    905. 

  905. (test '#hash((,(read) . 1) (,(+ 1 2) . 3))
    906. 

  906.       'qq
    907. 

  907.       `#hash((,(read) . 1) (,(+ 1 2) . ,(+ 1 2))))
    908. 

  908. (test '#hash((,(read) . 2))
    909. 

  909.       'qq
    910. 

  910.       `#hash((,(read) . 1) (,(read) . 2)))
    911. 

  911. (test '#hash(("moo" . 3) ("foo" . (1 2)))
    912. 

  912.       'qq
    913. 

  913.       `#hash(("moo" . ,(+ 1 2)) ("foo" . (1 2))))
    914. 

  914. (test '#hash(("moo" . (+ 1 2)) ("foo" . -1))
    915. 

  915.       'qq
    916. 

  916.       `#hash(("moo" . (+ 1 2)) ("foo" . ,(- 1 2))))
    917. 

  917. (syntax-test #'`#hash(("foo" . ,@(list 1 2 3 4 5))))
    918. 

  918. (error-test #'(read (open-input-string "`#hash((foo ,@(list 1 2 3 4 5)))")) exn:fail:read?)
    919. 

    920. 

  920. (test '(quasiquote (unquote result)) 'qq `(quasiquote ,result))
    921. 

  921. (test (list 'quasiquote car) 'qq `(,'quasiquote ,car))
    922. 

    923. 

  923. (syntax-test #'quasiquote)
    924. 

  924. (syntax-test #'(quasiquote))
    925. 

  925. (syntax-test #'(quasiquote . 5))
    926. 

  926. (syntax-test #'(quasiquote 1 . 2))
    927. 

  927. (syntax-test #'(quasiquote 1 2))
    928. 

  928. (syntax-test #'(unquote 7))
    929. 

  929. (syntax-test #'(unquote-splicing 7))
    930. 

    931. 

  931. (syntax-test #'`(1 . ,@5))
    932. 

  932. (test (cons 1 5) 'qq `(1 ,@5))
    933. 

  933. (error-test #'`(1 ,@5 2))
    934. 

    935. 

  935. (define (qq-test e)
    936. 

  936.   (syntax-test (datum->syntax #f e #f))
    937. 

  937.   (syntax-test (datum->syntax #f (list 'quasiquote e) #f))
    938. 

  938.   (syntax-test (datum->syntax #f (list 'quasiquote e) #f))
    939. 

  939.   (syntax-test (datum->syntax #f (list 'quasiquote (list 'quasiquote e)) #f))
    940. 

  940.   (syntax-test (datum->syntax #f (list 'quasiquote (list 'quasiquote (list 'unquote e))) #f))
    941. 

  941.   (syntax-test (datum->syntax #f (list 'quasiquote (list 'quasiquote (list 'unquote-splicing e))) #f)))
    942. 

  942. (qq-test #'(unquote))
    943. 

  943. (qq-test #'(unquote 7 8 9))
    944. 

  944. (qq-test #'(unquote-splicing))
    945. 

  945. (qq-test #'(unquote-splicing 7 8 9))
    946. 

    947. 

  947. (test '(unquote . 5) 'qq (quasiquote (unquote . 5)))
    948. 

  948. (test '(unquote 1 . 5) 'qq (quasiquote (unquote 1 . 5)))
    949. 

  949. (test '(unquote 1 2 . 5) 'qq (quasiquote (unquote 1 2 . 5)))
    950. 

  950. 

  951. (test '(unquote 1 2 7 . 5) 'qq (quasiquote (unquote 1 2 ,(+ 3 4) . 5)))
    952. 

  952. (test '(unquote 1 2 (unquote (+ 3 4)) . 5) 'qq (quasiquote (unquote 1 2 ,',(+ 3 4) . 5)))
    953. 

    954. 

  954. (test '(1 2 3 4 . 5) 'qq `(1 ,@'(2 3 4) . 5))
    955. 

    956. 

  956. (error-test #'`(10 ,(values 1 2)) arity?)
    957. 

  957. (error-test #'`(10 ,@(values 1 2)) arity?)
    958. 

    959. 

  959. (define add3 (lambda (x) (+ x 3)))
    960. 

  960. (test 6 'define (add3 3))
    961. 

  961. (define (add3 x) (+ x 3))
    962. 

  962. (test 6 'define (add3 3))
    963. 

  963. (define first car)
    964. 

  964. (test 1 'define (first '(1 2)))
    965. 

  965. (syntax-test #'define)
    966. 

  966. (syntax-test #'(define))
    967. 

  967. (syntax-test #'(define . x))
    968. 

  968. (syntax-test #'(define x))
    969. 

  969. (syntax-test #'(define x . 1))
    970. 

  970. (syntax-test #'(define 1 2))
    971. 

  971. (syntax-test #'(define (1) 1))
    972. 

  972. (syntax-test #'(define (x 1) 1))
    973. 

  973. (syntax-test #'(define (x a a) 1))
    974. 

  974. (syntax-test #'(define ((x 1) a) 1))
    975. 

  975. (syntax-test #'(define ((x b b) a) 1))
    976. 

  976. (syntax-test #'(define x 1 . 2))
    977. 

  977. (syntax-test #'(define x 1 2))
    978. 

    979. 

  979. (let ()
    980. 

  980.   (define ((f x) y z) (list x y z))
    981. 

  981.   (test '(1 2 3) (f 1) 2 3))
    982. 

  982. (let ()
    983. 

  983.   (define ((g a) a b) (list a b))
    984. 

  984.   (test '(2 3) (g 1) 2 3))
    985. 

    986. 

  986. (define-values (add3) (lambda (x) (+ x 3)))
    987. 

  987. (test 6 'define (add3 3))
    988. 

  988. (define-values (add3 another) (values (lambda (x) (+ x 3)) 9))
    989. 

  989. (test 6 'define (add3 3))
    990. 

  990. (test 9 'define another)
    991. 

  991. (define-values (first second third) (values car cadr caddr))
    992. 

  992. (test 1 'define (first '(1 2)))
    993. 

  993. (test 2 'define (second '(1 2)))
    994. 

  994. (test 3 'define (third '(1 2 3)))
    995. 

  995. (define-values () (values))
    996. 

  996. (syntax-test #'define-values)
    997. 

  997. (syntax-test #'(define-values))
    998. 

  998. (syntax-test #'(define-values . x))
    999. 

  999. (syntax-test #'(define-values x))
    1000. 

  1000. (syntax-test #'(define-values (x)))
    1001. 

  1001. (syntax-test #'(define-values x . 1))
    1002. 

  1002. (syntax-test #'(define-values (x) . 1))
    1003. 

  1003. (syntax-test #'(define-values 1 2))
    1004. 

  1004. (syntax-test #'(define-values (1) 2))
    1005. 

  1005. (syntax-test #'(define-values (x 1) 1))
    1006. 

  1006. (syntax-test #'(define-values (x . y) 1))
    1007. 

  1007. (syntax-test #'(define-values (x) 1 . 2))
    1008. 

  1008. (syntax-test #'(define-values (x) 1 2))
    1009. 

  1009. (syntax-test #'(define-values (x x) 10))
    1010. 

  1010. (syntax-test #'(define-values (x y x) 10))
    1011. 

    1012. 

  1012. (syntax-test #'((define x 2) 0 1))
    1013. 

  1013. (syntax-test #'(+ (define x 2) 1))
    1014. 

  1014. (syntax-test #'(if (define x 2) 0 1))
    1015. 

  1015. (syntax-test #'(begin0 (define x 2)))
    1016. 

  1016. (syntax-test #'(begin0 (define x 2) 0))
    1017. 

  1017. (syntax-test #'(begin0 0 (define x 2)))
    1018. 

  1018. (syntax-test #'(begin0 0 (define x 2) (define x 12)))
    1019. 

  1019. (syntax-test #'(let () (define x 2)))
    1020. 

  1020. (syntax-test #'(letrec () (define x 2)))
    1021. 

  1021. (syntax-test #'(lambda () (define x 2)))
    1022. 

  1022. (syntax-test #'(lambda () (void (define x 2)) 1))
    1023. 

  1023. (syntax-test #'(cond [(< 2 3) (define x 2)] [else 5]))
    1024. 

  1024. (syntax-test #'(cond [else (define x 2)]))
    1025. 

    1026. 

  1026. ;; No good way to test in mzc:
    1027. 

  1027. (error-test #'(define x (values)) exn:application:arity?)
    1028. 

  1028. (error-test #'(define x (values 1 2)) exn:application:arity?)
    1029. 

  1029. (error-test #'(define-values () 3) exn:application:arity?)
    1030. 

  1030. (error-test #'(define-values () (values 1 3)) exn:application:arity?)
    1031. 

  1031. (error-test #'(define-values (x y) (values)) exn:application:arity?)
    1032. 

  1032. (error-test #'(define-values (x y) 3) exn:application:arity?)
    1033. 

  1033. (error-test #'(define-values (x y) (values 1 2 3)) exn:application:arity?)
    1034. 

    1035. 

  1035. (begin (define ed-t1 1) (define ed-t2 2))
    1036. 

  1036. (test 1 'begin-define ed-t1)
    1037. 

  1037. (test 2 'begin-define ed-t2)
    1038. 

  1038. (begin (begin (begin (begin 10 (define ed-t2.5 2.5) 12))))
    1039. 

  1039. (test 2.5 'begin-define ed-t2.5)
    1040. 

  1040. (syntax-test #'(if (zero? 0) (define ed-t3 3) (define ed-t3 -3)))
    1041. 

  1041. (syntax-test #'(if #t (define ed-t3 3) (define ed-t3 -3)))
    1042. 

  1042. (syntax-test #'(if #f (define ed-t3 3) (define ed-t3 -3)))
    1043. 

    1044. 

  1044. (test 45 'define
    1045. 

  1045. 	(let ((x 5))
    1046. 

  1046. 		(define foo (lambda (y) (bar x y)))
    1047. 

  1047. 		(define bar (lambda (a b) (+ (* a b) a)))
    1048. 

  1048. 		(foo (+ x 3))))
    1049. 

  1049. (define x 34)
    1050. 

  1050. (define (foo) (define x 5) x)
    1051. 

  1051. (test 5 foo)
    1052. 

  1052. (test 34 'define x)
    1053. 

  1053. (define foo (lambda () (define x 5) x))
    1054. 

  1054. (test 5 foo)
    1055. 

  1055. (test 34 'define x)
    1056. 

  1056. (define (foo x) ((lambda () (define x 5) x)) x)
    1057. 

  1057. (test 88 foo 88)
    1058. 

  1058. (test 4 foo 4)
    1059. 

  1059. (test 34 'define x)
    1060. 

    1061. 

  1061. (test 5 'define
    1062. 

  1062.       (let ()
    1063. 

  1063. 	(define x 5)
    1064. 

  1064. 	(define define (lambda (a b) (+ a b)))
    1065. 

  1065. 	8
    1066. 

  1066. 	(define x 7)
    1067. 

  1067. 	x))
    1068. 

  1068. (test 8 'define ; used to be 6
    1069. 

  1069.       (let ([y 8])
    1070. 

  1070. 	(define (define z w) 5)
    1071. 

  1071. 	(define y 6)
    1072. 

  1072. 	y))
    1073. 

  1073. 

  1074. (syntax-test #'(let ()
    1075. 

  1075. 		(define x 5)))
    1076. 

  1076. (syntax-test #'(let ()
    1077. 

  1077. 		(if #t
    1078. 

  1078. 		    (define x 5))
    1079. 

  1079. 		5))
    1080. 

  1080. 

  1081. ; Can shadow syntax/macros with embedded defines
    1082. 

  1082. (test 5 'intdef (let ()
    1083. 

  1083. 		  (define lambda 5)
    1084. 

  1084. 		  lambda))
    1085. 

  1085. (test 5 'intdef (let ()
    1086. 

  1086. 		  (define define 5)
    1087. 

  1087. 		  'ok
    1088. 

  1088. 		  define))
    1089. 

  1089. 

  1090. (syntax-test #'(lambda () (define x 10) (begin)))
    1091. 

  1091. (syntax-test #'(lambda () (define x 10) (begin) (begin)))
    1092. 

  1092. (syntax-test #'(lambda () (#%stratified-syntax (define x 10) (begin) (begin x) (begin))))
    1093. 

  1093. (syntax-test #'(lambda () (#%stratified-syntax (define x 10) x (define y 12) y)))
    1094. 

  1094. (syntax-test #'(lambda () (define-values (x) . 10) x))
    1095. 

  1095. (syntax-test #'(lambda () (define-values (x) 10) (begin 1 . 2) x))
    1096. 

  1096. (syntax-test #'(lambda () (begin (define-values (x) 10) . 2) x))
    1097. 

  1097. (syntax-test #'(lambda () (begin)))
    1098. 

  1098. (syntax-test #'(lambda () (define-values . 10) x))
    1099. 

  1099. (syntax-test #'(lambda () (define-values x 10) x))
    1100. 

  1100. (syntax-test #'(lambda () (define-values (1) 10) x))
    1101. 

    1102. 

  1102. (test '(10 12) apply (lambda () (define x 10) (random 3) (define y 12) (list x y)) null)
    1103. 

  1103. (test 10 apply (lambda () (define x 10) (begin) (begin x) (begin)) null)
    1104. 

  1104. 

  1105. (test '(11 18) apply (lambda () (define x 11) (values 1 2 3) (define y 18) (list x y)) null)
    1106. 

    1107. 

  1107. (test 87 (lambda () (define x 87) (begin) (begin x)))
    1108. 

  1108. 

  1109. (test '#(0 1 2 3 4) 'do (do ((vec (make-vector 5))
    1110. 

  1110. 			     (i 0 (+ i 1)))
    1111. 

  1111. 			    ((= i 5) vec)
    1112. 

  1112. 			  (vector-set! vec i i)))
    1113. 

  1113. (test 25 'do (let ((x '(1 3 5 7 9)))
    1114. 

  1114. 	       (do ((x x (cdr x))
    1115. 

  1115. 		    (sum 0 (+ sum (car x))))
    1116. 

  1116. 		   ((null? x) sum))))
    1117. 

  1117. (test 1 'let (let foo () 1))
    1118. 

  1118. (test '((6 1 3) (-5 -2)) 'let
    1119. 

  1119.       (let loop ((numbers '(3 -2 1 6 -5))
    1120. 

  1120. 		 (nonneg '())
    1121. 

  1121. 		 (neg '()))
    1122. 

  1122. 	(cond ((null? numbers) (list nonneg neg))
    1123. 

  1123. 	      ((negative? (car numbers))
    1124. 

  1124. 	       (loop (cdr numbers)
    1125. 

  1125. 		     nonneg
    1126. 

  1126. 		     (cons (car numbers) neg)))
    1127. 

  1127. 	      (else
    1128. 

  1128. 	       (loop (cdr numbers)
    1129. 

  1129. 		     (cons (car numbers) nonneg)
    1130. 

  1130. 		     neg)))))
    1131. 

  1131. (test 5 'do (do ((x 1)) (#t 5)))
    1132. 

  1132. (test-values '(10 5) (lambda () (do ((x 1)) (#t (values 10 5)))))
    1133. 

  1133. (syntax-test #'do)
    1134. 

  1134. (syntax-test #'(do))
    1135. 

  1135. (syntax-test #'(do ()) )
    1136. 

  1136. (syntax-test #'(do () ()) )
    1137. 

  1137. (syntax-test #'(do (1) (#t 5) 5))
    1138. 

  1138. (syntax-test #'(do ((1)) (#t 5) 5))
    1139. 

  1139. (syntax-test #'(do ((1 7)) (#t 5) 5))
    1140. 

  1140. (syntax-test #'(do ((x . 1)) (#t 5) 5))
    1141. 

  1141. (syntax-test #'(do ((x 1) 2) (#t 5) 5))
    1142. 

  1142. (syntax-test #'(do ((x 1) . 2) (#t 5) 5))
    1143. 

  1143. (syntax-test #'(do ((x 1)) (#t . 5) 5))
    1144. 

  1144. (syntax-test #'(do ((x 1)) (#t 5) . 5))
    1145. 

    1146. 

  1146. (test 0 'let/cc (let/cc k (k 0) 1))
    1147. 

  1147. (test 0 'let/cc (let/cc k 0))
    1148. 

  1148. (test 1 'let/cc (let/cc k (cons 1 2) 1))
    1149. 

  1149. (test-values '(2 1) (lambda () (let/cc k (values 2 1))))
    1150. 

  1150. (test-values '(2 1) (lambda () (let/cc k (k 2 1))))
    1151. 

  1151. (syntax-test #'(let/cc))
    1152. 

  1152. (syntax-test #'(let/cc . k))
    1153. 

  1153. (syntax-test #'(let/cc k))
    1154. 

  1154. (syntax-test #'(let/cc k . 1))
    1155. 

  1155. (syntax-test #'(let/cc 1 1))
    1156. 

    1157. 

  1157. (test 0 'let/ec (let/ec k (k 0) 1))
    1158. 

  1158. (test 0 'let/ec (let/ec k 0))
    1159. 

  1159. (test 1 'let/ec (let/ec k (cons 1 2) 1))
    1160. 

  1160. (test-values '(2 1) (lambda () (let/ec k (values 2 1))))
    1161. 

  1161. (test-values '(2 1) (lambda () (let/ec k (k 2 1))))
    1162. 

  1162. (syntax-test #'(let/ec))
    1163. 

  1163. (syntax-test #'(let/ec . k))
    1164. 

  1164. (syntax-test #'(let/ec k))
    1165. 

  1165. (syntax-test #'(let/ec k . 1))
    1166. 

  1166. (syntax-test #'(let/ec 1 1))
    1167. 

    1168. 

  1168. (define x 1)
    1169. 

  1169. (define y -1)
    1170. 

  1170. (define (get-x) x)
    1171. 

  1171. 

  1172. (test 5 'parameterize (parameterize () 5))
    1173. 

  1173. (test 6 'parameterize (parameterize ([error-print-width 10]) 6))
    1174. 

  1174. (test 7 'parameterize (parameterize ([error-print-width 10]
    1175. 

  1175. 				     [uncaught-exception-handler void]) 
    1176. 

  1176.                         7))
    1177. 

  1177. (define oepw (error-print-width))
    1178. 

  1178. (error-test #'(parameterize ([error-print-width 777]) (error 'bad)) exn:fail?)
    1179. 

  1179. (test oepw 'parameterize (error-print-width))
    1180. 

  1180. (error-test #'(parameterize ([error-print-width 777]
    1181. 

  1181.                              [current-output-port (current-error-port)])
    1182. 

  1182.                 (error 'bad)) 
    1183. 

  1183. 	    exn:fail?)
    1184. 

  1184. (error-test #'(parameterize ([error-print-width 'a]) 10))
    1185. 

  1185. 

  1186. (define p (make-parameter 1))
    1187. 

  1187. (define q (make-parameter 2))
    1188. 

  1188. (test '1 'pz-order (parameterize ([p 3][q (p)]) (q)))
    1189. 

  1189. 

  1190. (error-test #'(parameterize) syntaxe?)
    1191. 

  1191. (error-test #'(parameterize ()) syntaxe?)
    1192. 

  1192. (error-test #'(parameterize ((x y))) syntaxe?)
    1193. 

  1193. (error-test #'(parameterize ((x y)) . 8) syntaxe?)
    1194. 

  1194. (error-test #'(parameterize (x) 8) syntaxe?)
    1195. 

  1195. (error-test #'(parameterize (9) 8) syntaxe?)
    1196. 

  1196. (error-test #'(parameterize ((x z) . y) 8) syntaxe?)
    1197. 

  1197. (error-test #'(parameterize ((x . z)) 8) syntaxe?)
    1198. 

  1198. (error-test #'(parameterize ((x . 9)) 8) syntaxe?)
    1199. 

  1199. (error-test #'(parameterize ((x . 9)) 8) syntaxe?)
    1200. 

    1201. 

  1201. (error-test #'(parameterize ([10 10]) 8))
    1202. 

  1202. (error-test #'(parameterize ([10 10]) 8) (lambda (exn) (not (regexp-match #rx"argument" (exn-message exn)))))
    1203. 

  1203. (error-test #'(parameterize ([(lambda () 10) 10]) 8))
    1204. 

  1204. (error-test #'(parameterize ([(lambda (a) 10) 10]) 8))
    1205. 

  1205. (error-test #'(parameterize ([(lambda (a b) 10) 10]) 8))
    1206. 

    1207. 

  1207. (test 1 'time (time 1))
    1208. 

  1208. (test -1 'time (time (cons 1 2) -1))
    1209. 

  1209. (test-values '(-1 1) (lambda () (time (values -1 1))))
    1210. 

  1210. (syntax-test #'time)
    1211. 

  1211. (syntax-test #'(time))
    1212. 

  1212. (syntax-test #'(time . 1))
    1213. 

  1213. (syntax-test #'(time 1 . 2))
    1214. 

    1215. 

  1215. ; Tests specifically aimed at the compiler
    1216. 

  1216. (error-test #'(let ([x (values 1 2)]) x) exn:application:arity?)
    1217. 

  1217. ; Known primitive
    1218. 

  1218. (error-test #'(let ([x (make-pipe)]) x) exn:application:arity?)
    1219. 

  1219. ; Known local
    1220. 

  1220. (error-test #'(let* ([f (lambda () (values 1 2))][x (f)]) x) exn:application:arity?)
    1221. 

    1222. 

  1222. ; Known local with global in its closure
    1223. 

  1223. (test 15 'known (let ([g (lambda ()
    1224. 

  1224. 			   (letrec ([f (lambda (x)
    1225. 

  1225. 					 (+ x 5))])
    1226. 

  1226. 			     (f 10)))])
    1227. 

  1227. 		  (g)))
    1228. 

  1228. ; Known local with a set!
    1229. 

  1229. (test 16 'known (let ([g (lambda ()
    1230. 

  1230. 			   (letrec ([f (lambda (x)
    1231. 

  1231. 					 (let ([y x])
    1232. 

  1232. 					   (set! x 7)
    1233. 

  1233. 					   (+ y 5)))])
    1234. 

  1234. 			     (f 11)))])
    1235. 

  1235. 		  (g)))
    1236. 

  1236. ; Known local non-function
    1237. 

  1237. (error-test #'(apply (lambda () (let ([f 12]) (f))) null) exn:application:type?)
    1238. 

  1238. ; Known local with revsed arguments:
    1239. 

  1239. (test 10 (letrec ([f (lambda (a b) (if (zero? a) b (f b a)))]) f) 10 0)
    1240. 

  1240. 

  1241. (syntax-test #'#%datum)
    1242. 

  1242. (syntax-test #'(let ([#%datum 5])
    1243. 

  1243. 		 1))
    1244. 

  1244. (test '(1) '#%datum (#%datum 1))
    1245. 

  1245. (test 1 '#%datum (#%datum . 1))
    1246. 

  1246. (test 'a '#%datum (#%datum . a))
    1247. 

  1247. 

  1248. (syntax-test #'#%app)
    1249. 

  1249. (syntax-test #'(#%app . 1))
    1250. 

  1250. (syntax-test #'(#%app 2 . 1))
    1251. 

  1251. (syntax-test #'(#%app lambda 1))
    1252. 

  1252. (syntax-test #'(let ([#%app 5])
    1253. 

  1253. 		 (+ 1 2)))
    1254. 

  1254. 

  1255. (test 3 '#%app (#%app + 1 2))
    1256. 

  1256. (syntax-test #'())
    1257. 

  1257. (syntax-test #'(#%app))
    1258. 

    1259. 

  1259. (syntax-test #'#%top)
    1260. 

  1260. (syntax-test #'(#%top 1))
    1261. 

  1261. (syntax-test #'(let ([#%top 5])
    1262. 

  1262. 		 x))
    1263. 

  1263. (err/rt-test (#%top . lambda) exn:fail:contract:variable?)
    1264. 

  1264. (define x 5)
    1265. 

  1265. (test 5 '#%top (#%top . x))
    1266. 

    1267. 

  1267. ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1268. 

  1268. ;; Tests related to bytecode optimizer.
    1269. 

  1269. ;; The (if (let ([x M]) (if x x N)) ...)
    1270. 

  1270. ;;   => (if (if M #t N) ...)
    1271. 

  1271. ;; converter drops the variable `x', which means
    1272. 

  1272. ;; that other mappings must adjust
    1273. 

    1274. 

  1274. (let ([val 0])
    1275. 

  1275.   (let ([g (lambda ()
    1276. 

  1276. 	     (letrec ([f (lambda (z x)
    1277. 

  1277. 			   (if (let ([w (even? 81)])
    1278. 

  1278. 				 (if w
    1279. 

  1279. 				     w
    1280. 

  1280. 				     (let ([y x])
    1281. 

  1281. 				       (set! x 7)
    1282. 

  1282. 				       (set! val (+ y 5)))))
    1283. 

  1283. 			       'yes
    1284. 

  1284. 			       'no))])
    1285. 

  1285. 	       (f 0 11)))])
    1286. 

  1286.     (g))
    1287. 

  1287.   (test 16 values val))
    1288. 

    1289. 

  1289. (let ([val 0])
    1290. 

  1290.   (let ([g (lambda ()
    1291. 

  1291. 	     (letrec ([f (lambda (z x)
    1292. 

  1292. 			   (if (let ([w (even? 81)])
    1293. 

  1293. 				 (if w
    1294. 

  1294. 				     w
    1295. 

  1295. 				     (let ([y x])
    1296. 

  1296. 				       (set! val (+ y 5)))))
    1297. 

  1297. 			       'yes
    1298. 

  1298. 			       'no))])
    1299. 

  1299. 	       (f 0 11)))])
    1300. 

  1300.     (g))
    1301. 

  1301.   (test 16 values val))
    1302. 

    1303. 

  1303. ;; Function-inline test where (h (g v 10)) involves two inlines:
    1304. 

  1304. (letrec ([f (lambda (x) (h (g v 10)))]
    1305. 

  1305. 	 [h (lambda (x) (list x x))]
    1306. 

  1306. 	 [g (lambda (a b) a)]
    1307. 

  1307. 	 [v (list 'hello)]
    1308. 

  1308. 	 [w (list 'no!)]) 
    1309. 

  1309.   (test '((hello) (hello)) f 10))
    1310. 

    1311. 

  1311. ;; Inlining introduces a let binding that is immediately dropped:
    1312. 

  1312. (test '(1 . 2)
    1313. 

  1313.       (let ([x (cons 1 2)]) (let ([f (lambda (x) x)]) (f (lambda (y) x))))
    1314. 

  1314.       10)
    1315. 

    1316. 

  1316. ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1317. 

  1317. ;; Check #%top-interaction
    1318. 

    1319. 

  1319. (module quoting-top-interaction racket/base
    1320. 

  1320.   (require (for-syntax racket/base))
    1321. 

  1321.   (provide (except-out (all-from-out racket/base) #%top-interaction)
    1322. 

  1322.            (rename-out [top-interaction #%top-interaction]))
    1323. 

  1323.   (define-syntax top-interaction 
    1324. 

  1324.     (syntax-rules ()
    1325. 

  1325.       [(_ . e) (quote e)])))
    1326. 

    1327. 

  1327. (dynamic-require ''quoting-top-interaction #f)
    1328. 

  1328. (let ([ns (make-empty-namespace)])
    1329. 

  1329.   (namespace-attach-module (current-namespace) ''quoting-top-interaction ns)
    1330. 

  1330.   (parameterize ([current-namespace ns])
    1331. 

  1331.     (namespace-require ''quoting-top-interaction))
    1332. 

  1332.   (test 3 'non-top
    1333. 

  1333.         (parameterize ([current-namespace ns])
    1334. 

  1334.           (eval '(+ 1 2))))
    1335. 

  1335.   (test ''(+ 1 2) 'repl-top
    1336. 

  1336.         (let ([s (open-output-bytes)])
    1337. 

  1337.           (parameterize ([current-input-port (open-input-string "(+ 1 2)")]
    1338. 

  1338.                          [current-namespace ns]
    1339. 

  1339.                          [current-output-port s])
    1340. 

  1340.             (read-eval-print-loop))
    1341. 

  1341.           (let ([p (open-input-bytes (get-output-bytes s))])
    1342. 

  1342.             (read p)
    1343. 

  1343.             (read p))))
    1344. 

  1344.   (let ([tmp-file (make-temporary-file)])
    1345. 

  1345.     (let-values ([(base tmp1 mbd?) (split-path tmp-file)])
    1346. 

  1346.     (with-output-to-file tmp-file (lambda () (display '(+ 1 2))) #:exists 'truncate/replace)
    1347. 

  1347.     (test '(+ 1 2) 'repl-top
    1348. 

  1348.           (parameterize ([current-namespace ns])
    1349. 

  1349.             (load tmp-file)))
    1350. 

  1350.     (with-output-to-file tmp-file (lambda () (display `(module ,tmp1 racket/base (provide x) (define x 12))))
    1351. 

  1351.                          #:exists 'truncate/replace)
    1352. 

  1352.     (test 12 'module
    1353. 

  1353.           (parameterize ([current-namespace ns])
    1354. 

  1354.             (dynamic-require tmp-file 'x)))
    1355. 

  1355.     (delete-file tmp-file))))
    1356. 

  1356. 

  1357. ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1358. 

  1358. 

  1359. ;; Check that locations for lambda arguments are created
    1360. 

  1360. ;; one-by-one --- like `let*', and not like `letrec':
    1361. 

    1362. 

  1362. (test '((1 10) (x1 10) (x2 z1))
    1363. 

  1363.       'lambda-loc
    1364. 

  1364.       (let ()
    1365. 

  1365.         (define procs null)
    1366. 

  1366.         (define again #f)
    1367. 

  1367. 

  1368.         (define (f x 
    1369. 

  1369.                    [y (let/cc k
    1370. 

  1370.                         (unless again
    1371. 

  1371.                           (set! again k))
    1372. 

  1372.                         (lambda () 'done))]
    1373. 

  1373.                    [z 10])
    1374. 

  1374.           (set! procs
    1375. 

  1375.                 (cons (lambda (xv zv)
    1376. 

  1376.                         (begin0
    1377. 

  1377.                          (list x z)
    1378. 

  1378.                          (set! x xv)
    1379. 

  1379.                          (set! z zv)))
    1380. 

  1380.                       procs))
    1381. 

  1381.           (y))
    1382. 

  1382. 

  1383.         (f 1)
    1384. 

  1384.         (let/cc esc (again esc))
    1385. 

  1385. 

  1386.         (list
    1387. 

  1387.          ((cadr procs) 'x1 'z1)
    1388. 

  1388.          ((car procs) 'x2 'z2)
    1389. 

  1389.          ((cadr procs) 'x10 'z10))))
    1390. 

  1390. 

  1391. ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1392. 

  1392. (require racket/splicing)
    1393. 

  1393. 

  1394. (define abcdefg 10)
    1395. 

  1395. (test 12 'splicing-letrec-syntax (splicing-letrec-syntax ([abcdefg (syntax-rules ()
    1396. 

  1396.                                                                      [(_) 12])])
    1397. 

  1397.                                                          (abcdefg)))
    1398. 

  1398. (test 13 'splicing-letrec-syntax (splicing-letrec-syntax ([abcdefg (syntax-rules ()
    1399. 

  1399.                                                                      [(_) (abcdefg 10)]
    1400. 

  1400.                                                                      [(_ x) (+ 3 x)])])
    1401. 

  1401.                                                          (abcdefg)))
    1402. 

  1402. (test 13 'splicing-letrec-syntax (let ([abcdefg 9])
    1403. 

  1403.                                    (splicing-letrec-syntax ([abcdefg (syntax-rules ()
    1404. 

  1404.                                                                        [(_) (abcdefg 10)]
    1405. 

  1405.                                                                        [(_ x) (+ 3 x)])])
    1406. 

  1406.                                                            (abcdefg))))
    1407. 

  1407. (test 12 'splicing-let-syntax (splicing-let-syntax ([abcdefg (syntax-rules ()
    1408. 

  1408.                                                                [(_) 12])])
    1409. 

  1409.                                                    (abcdefg)))
    1410. 

  1410. (test 12 'splicing-let-syntax (let ([abcdefg (lambda () 9)])
    1411. 

  1411.                                 (splicing-let-syntax ([abcdefg (syntax-rules ()
    1412. 

  1412.                                                                  [(_) 12])])
    1413. 

  1413.                                                      (abcdefg))))
    1414. 

  1414. (test 11 'splicing-let-syntax (let ([abcdefg (lambda (x) x)])
    1415. 

  1415.                                 (splicing-let-syntax ([abcdefg (syntax-rules ()
    1416. 

  1416.                                                                  [(_) (+ 2 (abcdefg 9))]
    1417. 

  1417.                                                                  [(_ ?) 77])])
    1418. 

  1418.                                                      (abcdefg))))
    1419. 

  1419. (define expand-test-use-toplevel? #t)
    1420. 

  1420. (splicing-let-syntax ([abcdefg (syntax-rules ()
    1421. 

  1421.                                  [(_) 8])])
    1422. 

  1422.                      (define hijklmn (abcdefg)))
    1423. 

  1423. (define expand-test-use-toplevel? #f)
    1424. 

  1424. (test 8 'hijklmn hijklmn)
    1425. 

  1425. (test 30 'local-hijklmn (let ()
    1426. 

  1426.                           (splicing-let-syntax ([abcdefg (syntax-rules ()
    1427. 

  1427.                                                            [(_) 8])])
    1428. 

  1428.                                                (define hijklmn (abcdefg)))
    1429. 

  1429.                           (define other 22)
    1430. 

  1430.                           (+ other hijklmn)))
    1431. 

  1431. (test 8 'local-hijklmn (let ()
    1432. 

  1432.                          (splicing-let-syntax ([abcdefg (syntax-rules ()
    1433. 

  1433.                                                           [(_) 8])])
    1434. 

  1434.                                               (begin
    1435. 

  1435.                                                 (define hijklmn (abcdefg))
    1436. 

  1436.                                                 hijklmn))))
    1437. 

  1437. 

  1438. (test 9 'splicing-letrec-syntax (let ([abcdefg (lambda () 9)])
    1439. 

  1439.                                   (splicing-letrec-syntax ([abcdefg (syntax-rules ()…
    1440.