blob: 99bfa70f20ff003b18333fd60ea32451f70aa38c (
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
|
(test-group "dup"
(test-equal "'x dup"
'(x x)
(RPSlist->list (interpret '(x)
(list->RPSlist inline-dup))))
(test-equal "'y 'x dup"
'(y y x)
(RPSlist->list (interpret '(y x)
(list->RPSlist inline-dup)))))
(test-group "drop"
(test-equal "'x drop"
'()
(RPSlist->list (interpret '(x) (list->RPSlist inline-drop))))
(test-equal "'x 'y drop"
'(y)
(RPSlist->list
(interpret '(x y)
(list->RPSlist inline-drop)))))
(test-group "dropn"
(test-equal "'x {dropn 0}"
'()
(RPSlist->list (interpret '(x) (list->RPSlist
(inline-dropn 0)))))
(test-equal "'y 'x {dropn 0}"
'(y)
(RPSlist->list (interpret '(x y) (list->RPSlist
(inline-dropn 0)))))
(test-equal "'y 'x {dropn 1}"
'(x)
(RPSlist->list (interpret '(x y) (list->RPSlist
(inline-dropn 1)))))
(test-equal "'z 'y 'x {dropn 1}"
'(x z)
(RPSlist->list (interpret '(x y z)
(list->RPSlist
(inline-dropn 1)))))
(test-equal "'z 'y 'x {dropn 2}"
'(x y)
(RPSlist->list (interpret '(x y z)
(list->RPSlist
(inline-dropn 2))))))
(test-group "pick"
(test-equal "'x {pick 0}"
'(x x)
(RPSlist->list (interpret '(x) (list->RPSlist
(inline-pick 0)))))
(test-equal "'y 'x {pick 0}"
'(x x y)
(RPSlist->list (interpret '(x y) (list->RPSlist
(inline-pick 0)))))
(test-equal "'y 'x {pick 1}"
'(y x y)
(RPSlist->list (interpret '(x y) (list->RPSlist
(inline-pick 1)))))
(test-equal "'z 'y 'x {pick 1}"
'(y x y z)
(RPSlist->list (interpret '(x y z) (list->RPSlist
(inline-pick 1)))))
(test-equal "'z 'y 'x {pick 2}"
'(z x y z)
(RPSlist->list (interpret '(x y z) (list->RPSlist
(inline-pick 2))))))
(test-group "roll"
(test-equal "'x {roll 0}"
'(x)
(RPSlist->list (interpret '(x) (list->RPSlist
(inline-roll 0)))))
(test-equal "'y 'x {roll 0}"
'(x y)
(RPSlist->list (interpret '(x y) (list->RPSlist
(inline-roll 0)))))
(test-equal "'y 'x {roll 1}"
'(y x)
(RPSlist->list (interpret '(x y) (list->RPSlist
(inline-roll 1)))))
(test-equal "'z 'y 'x {roll 1}"
'(y x z)
(RPSlist->list (interpret '(x y z) (list->RPSlist
(inline-roll 1)))))
(test-equal "'z 'y 'x {roll 2}"
'(z x y)
(RPSlist->list (interpret '(x y z) (list->RPSlist
(inline-roll 2))))))
(test-group "stack-closure"
(let* ((push-values
`(#f ; [returnK N self values ...]
,@(inline-dropn 1) ,@(inline-dropn 1)
#f ,@(inline-roll 1) jump))
(program
`(0 ,@(stack-closure push-values 0 #f) ; [proc 0]
(#f ; [K proc 0]
0 ,@(inline-roll 1) ; [K 0 proc 0]
,@(inline-pick 2) ; [proc K 0 proc 0]
jump)
#f 1 call/cc)))
(test-equal "0 {stack-closure 0 #f} jump"
'(0 0)
(RPSlist->list
(interpret '() (list->RPSlist program))))))
|
