blob: 16013293ee8866eabaf00f5b167ebbb81cf1e69f (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
|
;;; XXX: These tests depend on the properties of gensym. A proper test
;;; would consider the passed structures up to alpha conversion but
;;; that would be time consuming.
(load "gamma-scheme.cps.sld")
(import (gamma-scheme cps) test)
(define (wnl x)
(write (cps->sexpr (core->cps x)))
(newline))
(test-group "atomic object syntax"
(test "constant"
'(pass (5) () __toplevel)
(cps->sexpr (core->cps 5)))
(test "symbol"
'(pass (x) () __toplevel)
(cps->sexpr (core->cps 'x)))
(test "quote"
'(pass ((quote x)) () __toplevel)
(cps->sexpr (core->cps ''x)))
(test "multiple quotes on a symbol"
'(pass ((quote (quote (quote x)))) () __toplevel)
(cps->sexpr (core->cps ''''x)))
(test "quoted constant"
'(pass (#f) () __toplevel)
(cps->sexpr (core->cps ''#f)))
(test "multiple quotes on a constant"
'(pass ((quote (quote #f))) () __toplevel)
(cps->sexpr (core->cps '''#f))))
(test-group "function application syntax"
(test "thunk"
'(apply x () () __toplevel)
(cps->sexpr (core->cps '(x))))
(test "one symbol arg"
'(apply x (y) () __toplevel)
(cps->sexpr (core->cps '(x y))))
(test "one constant arg"
'(apply x (5) () __toplevel)
(cps->sexpr (core->cps '(x 5))))
(test "one quoted arg"
'(apply x ((quote y)) () __toplevel)
(cps->sexpr (core->cps '(x 'y))))
(test "one quoted constant arg"
'(apply x (#t) () __toplevel)
(cps->sexpr (core->cps '(x '#t))))
(test "one compound arg"
'(apply f (x) () (kappa (__v2) __γ1 (apply x (__v2) __γ1 __toplevel)))
(cps->sexpr (core->cps '(x (f x)))))
(test "one constant one compound arg"
'(apply g (x) () (kappa (__v2) __γ1 (apply f (__v2 10) __γ1 __toplevel)))
(cps->sexpr (core->cps '(f (g x) 10))))
(test "sequencing"
'(apply t1 () ()
(kappa (__v2) __γ1
(apply t2 () __γ1
(kappa (__v4) __γ3
(apply t3 () __γ3
(kappa (__v6) __γ5
(apply f
(__v2 __v4 __v6)
__γ5
__toplevel)))))))
(cps->sexpr (core->cps '(f (t1) (t2) (t3))))))
(test-group "lambda syntax"
(test "identity"
'(pass ((lambda ((__γ1 __κ2) (x)) (pass (x) __γ1 __κ2))) () __toplevel)
(cps->sexpr (core->cps '(lambda (x) x))))
(test "let bind"
'(pass ((lambda ((__γ3 __κ4) (x))
(pass (x) __γ3 __κ4))) ()
(kappa (__v2) __γ1
(apply __v2 (y) __γ1 __toplevel)))
(cps->sexpr (core->cps '((lambda (x) x) y)))))
(test-group "if syntax"
(test "if #t"
'(pass (y) () __toplevel)
(cps->sexpr (core->cps '(if #t y z))))
(test "if (quote #t)"
'(pass (y) () __toplevel)
(cps->sexpr (core->cps '(if '#t y z))))
(test "if #f"
'(pass (z) () __toplevel)
(cps->sexpr (core->cps '(if #f y z))))
(test "if (quote #f)"
'(pass (z) () __toplevel)
(cps->sexpr (core->cps '(if '#f y z))))
(test "if ''#f"
'(pass (y) () __toplevel)
(cps->sexpr (core->cps '(if ''#f y z))))
(test "if truthy number"
'(pass (y) () __toplevel)
(cps->sexpr (core->cps '(if 5 y z))))
(test "if symbol"
'(pass (y) () __toplevel)
(cps->sexpr (core->cps '(if 'x y z)))))
(test-group "delimited continuation syntax"
(test "push-prompt"
'(pass (x) ()
(kappa (__p1) __γ2
(apply cons* (__p1 __toplevel __γ2) __γ2
(kappa (__γ3) ignored
(pass (y) __γ3 __unwind)))))
(cps->sexpr (core->cps '(push-prompt x y))))
(test "push-sub-continuation"
'(pass (x) ()
(kappa __γ1 __γ2
(apply in-middle (__γ1 __toplevel __γ2) __γ2
(kappa (__γ3) ignored
(pass (y) __γ3 __unwind)))))
(cps->sexpr (core->cps '(push-sub-continuation x y)))))
(define (e1 expr)
(let-values (((v . rest) (eval-core expr)))
v))
(test-group "atom eval"
(test "constant"
'(5)
(e1 5))
(test "quote"
'('x)
(e1 ''x))
(test "multiple quotes on a symbol"
'('''x)
(e1 ''''x))
(test "quoted constant"
'(#f)
(e1 ''#f))
(test "multiple quotes on a constant"
'(''#f)
(e1 '''#f)))
(test-group "procedures"
(test-assert "closure"
(cps-closure?
(car (e1 '(lambda (x) x)))))
(test "apply closure"
'(5)
(e1 '((lambda (x) x) 5))))
|
