blob: 9f409f0411c53b41d1f0bd19e1df7f2909b55606 (
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
|
;;; 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 objects"
(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"
(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 "lambdas"
(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"
(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)))))
|
