blob: 16e569ef869eac78dde3a1c6f77d11a13a6bda81 (
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
146
147
148
149
150
151
152
153
154
155
|
;;; Reverse Polish Scheme interpeter in Polish Scheme.
(define take
(lambda (stack number)
(do ((stack stack (cdr stack))
(number number (- number 1))
(return '() (cons (car stack) return)))
((zero? number) (reverse return)))))
(define continuation-invoker
(lambda (drop-number save-number old-stack continuation)
(let* ((dropped (list-tail old-stack drop-number))
(old-stack (if (not (eq? save-number #f))
(take dropped save-number)
dropped)))
(lambda (stack)
(let ((values (car stack)))
(interpret (append (if (not (eq? values #f))
(take (cdr stack) values)
(cdr stack))
old-stack)
continuation))))))
(define list->RPSlist
(lambda (source)
(cond
((pair? source)
(letrec ((loop
(lambda (source)
(if (pair? source)
(vector (list->RPSlist (car source))
(loop (cdr source)))
'()))))
(loop source)))
(else source))))
(define vector-map
(lambda (proc vector)
(list->vector (map proc (vector->list vector)))))
(define RPSlist->list
(lambda (source)
(cond
((pair? source)
(cons (RPSlist->list (car source))
(RPSlist->list (cdr source))))
((and (vector? source)
(= (vector-length source) 2)
(or (vector? (vector-ref source 1))
(null? (vector-ref source 1))))
(cons (RPSlist->list (vector-ref source 0))
(RPSlist->list (vector-ref source 1))))
((vector? source) (vector-map RPSlist->list source))
(else source))))
(define RPScar (lambda (v) (vector-ref v 0)))
(define RPScdr (lambda (v) (vector-ref v 1)))
(define interpret
(lambda (stack source)
;; (pretty-print (list (list 'stack stack) (list 'source (RPSlist->list source))) 'data)
(cond
((null? source) stack)
((or (number? (RPScar source))
(string? (RPScar source))
(null? (RPScar source))
(boolean? (RPScar source))
(vector? (RPScar source)))
(interpret (cons (RPScar source) stack)
(RPScdr source)))
((eq? (RPScar source) 'call/cc)
(let ((procedure (caddr stack))
(drop-number (car stack))
(save-number (cadr stack))
(rest-of-stack (cdddr stack)))
(interpret (cons (continuation-invoker
drop-number
save-number
rest-of-stack
(RPScdr source))
rest-of-stack)
(RPScdr procedure))))
((eq? (RPScar source) 'vector)
(let ((size (car stack)))
(interpret (cons (make-vector size #f) (cdr stack))
(RPScdr source))))
((eq? (RPScar source) 'vector-length)
(let ((vector (car stack)))
(interpret (cons (if (vector? vector)
(vector-length vector)
#f)
(cdr stack))
(RPScdr source))))
((eq? (RPScar source) 'ref)
(let ((vector (cadr stack))
(slot (car stack)))
(interpret (cons (vector-ref vector slot) (cddr stack))
(RPScdr source))))
((eq? (RPScar source) 'set!)
(let ((vector (caddr stack))
(slot (car stack))
(value (cadr stack)))
(vector-set! vector slot value)
(interpret (cdddr stack)
(RPScdr source))))
((eq? (RPScar source) 'jump)
(let ((subroutine (car stack)))
(if (procedure? subroutine)
(subroutine (cdr stack))
(interpret (cdr stack)
(RPScdr subroutine)))))
((eq? (RPScar source) 'if)
(let ((on-true (car stack))
(on-false (cadr stack))
(conditional (caddr stack)))
(interpret (cdddr stack)
(if (not (eq? conditional #f))
(RPScdr on-true)
(RPScdr on-false)))))
((eq? (RPScar source) 'eqv?)
(let ((x (car stack))
(y (cadr stack)))
(interpret (cons (eqv? x y) (cddr stack)) (RPScdr source))))
((eq? (RPScar source) 'symbol?)
(interpret (cons (symbol? (car stack)) (cdr stack))
(RPScdr source)))
((eq? (RPScar source) 'integer?)
(let ((x (car stack)))
(interpret (cons (and (integer? x)
(exact? x))
(cdr stack))
(RPScdr source))))
((eq? (RPScar source) 'real?)
(let ((x (car stack)))
(interpret (cons (and (real? x)
(inexact? x))
(cdr stack))
(RPScdr source))))
((eq? (RPScar source) '+)
(let ((x (car stack))
(y (cadr stack))
(rest (cddr stack)))
(interpret (cons (+ x y) rest) (RPScdr source))))
((eq? (RPScar source) '*)
(let ((x (car stack))
(y (cadr stack))
(rest (cddr stack)))
(interpret (cons (* x y) rest) (RPScdr source))))
((eq? (RPScar source) 'debug-print)
(pretty-print `((stack ,(map RPSlist->list stack))
(source ,(cdr (RPSlist->list source))))
'data)
(interpret stack (RPScdr source)))
(else (error "invalid source"
(list stack source))))))
|
