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
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
|
; Copyright (c) 1993-2008 by Richard Kelsey. See file COPYING.
; Evaluator for nodes.
; This doesn't handle n-ary procedures.
; (NAME-NODE-BINDING name-node) is used as an EQ? key in local environments,
; and passed as-is to the global-environment arguments.
; Exports:
; (EVAL-NODE node global-ref global-set! eval-primitive)
; CLOSURE? (CLOSURE-NODE closure) (CLOSURE-ENV closure)
; (UNSPECIFIC? thing)
(define (eval-node node global-ref global-set! eval-primitive)
(eval node (make-env '()
(make-eval-data global-ref
global-set!
eval-primitive))))
(define-record-type eval-data :eval-data
(make-eval-data global-ref global-set! eval-primitive)
eval-data?
(global-ref eval-data-global-ref)
(global-set! eval-data-global-set!)
(eval-primitive eval-data-eval-primitive))
; Environments
(define-record-type env :env
(make-env alist eval-data)
env?
(alist env-alist)
(eval-data env-eval-data))
(define (env-ref env name-node)
(let ((cell (assq name-node (env-alist env))))
(if cell
(cdr cell)
((eval-data-global-ref (env-eval-data env)) name-node))))
(define (env-set! env name-node value)
(let ((cell (assq name-node (env-alist env))))
(if cell
(set-cdr! cell value)
((eval-data-global-set! (env-eval-data env))
name-node
value))))
(define (extend-env env ids vals)
(make-env (append (map cons ids vals)
(env-alist env))
(env-eval-data env)))
(define (eval-primitive primitive args env)
((eval-data-eval-primitive (env-eval-data env)) primitive args))
; Closures
(define-record-type closure :closure
(make-closure node env)
closure?
(node closure-node)
(env real-closure-env)
(temp closure-temp set-closure-temp!))
(define (closure-env closure) ; exported
(env-alist (real-closure-env closure)))
(define (make-top-level-closure exp)
(make-closure exp the-empty-env))
(define the-empty-env (make-env '() #f))
; Main dispatch
(define (eval node env)
((operator-table-ref evaluators (node-operator-id node))
node
env))
; Particular operators
(define evaluators
(make-operator-table
(lambda (node env)
(error "no evaluator for node ~S" node))))
(define (define-evaluator name proc)
(operator-define! evaluators name #f proc))
(define (eval-list nodes env)
(map (lambda (node)
(eval node env))
nodes))
(define-evaluator 'literal
(lambda (node env)
(node-form node)))
(define-evaluator 'unspecific
(lambda (node env)
(unspecific)))
(define-evaluator 'unassigned
(lambda (node env)
(unspecific)))
(define-evaluator 'real-external
(lambda (node env)
(let* ((exp (node-form node))
(type (expand-type-spec (cadr (node-form (caddr exp))))))
(make-external-value (node-form (cadr exp))
type))))
(define-evaluator 'quote
(lambda (node env)
(cadr (node-form node))))
(define-evaluator 'lambda
(lambda (node env)
(make-closure node env)))
(define (apply-closure closure args)
(let ((node (closure-node closure))
(env (real-closure-env closure)))
(eval (caddr (node-form node))
(extend-env env (cadr (node-form node)) args))))
(define-evaluator 'name
(lambda (node env)
(env-ref env node)))
(define-evaluator 'set!
(lambda (node env)
(let ((exp (node-form node)))
(env-set! env (cadr exp) (eval (caddr exp) env))
(unspecific))))
(define-evaluator 'call
(lambda (node env)
(eval-call (car (node-form node))
(cdr (node-form node))
env)))
(define-evaluator 'goto
(lambda (node env)
(eval-call (cadr (node-form node))
(cddr (node-form node))
env)))
(define (eval-call proc args env)
(let ((proc (eval proc env))
(args (eval-list args env)))
(if (closure? proc)
(apply-closure proc args)
(eval-primitive proc args env))))
(define-evaluator 'begin
(lambda (node env)
(let ((exps (cdr (node-form node))))
(if (null? exps)
(unspecific)
(let loop ((exps exps))
(cond ((null? (cdr exps))
(eval (car exps) env))
(else
(eval (car exps) env)
(loop (cdr exps)))))))))
(define-evaluator 'if
(lambda (node env)
(let* ((form (node-form node))
(test (cadr form))
(arms (cddr form)))
(cond ((eval test env)
(eval (car arms) env))
((null? (cdr arms))
(unspecific))
(else
(eval (cadr arms) env))))))
(define-evaluator 'loophole
(lambda (node env)
(eval (caddr (node-form node)) env)))
(define-evaluator 'letrec
(lambda (node env)
(let ((form (node-form node)))
(let ((vars (map car (cadr form)))
(vals (map cadr (cadr form)))
(body (caddr form)))
(let ((env (extend-env env
vars
(map (lambda (ignore)
(unspecific))
vars))))
(for-each (lambda (var val)
(env-set! env var (eval val env)))
vars
vals)
(eval body env))))))
(define (unspecific? x)
(eq? x (unspecific)))
; Used by our clients but not by us.
(define (constant? x)
(or (number? x)
(symbol? x)
(external-constant? x)
(external-value? x)
(boolean? x)))
|
