smalltalk-tng
view etng-r2/evaluator.scm @ 321:c4a0718c2d3c
Sketch of dependencies
| author | Tony Garnock-Jones <tonygarnockjones@gmail.com> |
|---|---|
| date | Sat Oct 08 15:36:03 2011 -0400 (7 months ago) |
| parents | f61a9e12aa39 |
| children |
line source
1 (define-syntax define-global!
2 (syntax-rules ()
3 ((_ 'name value) (define name value))))
5 (define gensym
6 (let ((counter 14641))
7 (lambda ()
8 (let ((v (string->symbol (string-append "g" (number->string counter)))))
9 (set! counter (+ counter 1))
10 v))))
12 (define-global! 'global-env
13 (let ()
14 (define (munge-entry entry) (cons (car entry) (cons (box (cadr entry)) (box (caddr entry)))))
15 (map munge-entry
16 `((quote macro ,(lambda (x env exp) x))
17 (define macro ,(lambda (x env exp) `(define ,(cadr x) ,@(map exp (cddr x)))))
18 (lambda macro ,(lambda (x env exp) `(lambda ,(cadr x) ,@(map exp (cddr x)))))
19 (begin macro ,(lambda (x env exp) `(begin ,@(map exp (cdr x)))))
20 (if macro ,(lambda (x env exp) `(if ,@(map exp (cdr x)))))
21 (set! macro ,(lambda (x env exp) `(set! ,(cadr x) ,(exp (caddr x)))))
22 (%assemble macro ,(lambda (x env exp) `(%assemble ,(cadr x) ,(map exp (caddr x))
23 ,@(cdddr x))))
25 (let macro ,(lambda (x env exp)
26 (let ((names (map car (cadr x)))
27 (inits (map cadr (cadr x)))
28 (exps (cddr x)))
29 (exp `((lambda ,names ,@exps) ,@inits)))))
30 (cond macro ,(lambda (x env exp)
31 (exp (cond
32 ((null? (cdr x)) `(begin))
33 ((eq? (caadr x) 'else) `(begin ,@(cdadr x)))
34 (else `(if ,(caadr x) (begin ,@(cdadr x)) (cond ,@(cddr x))))))))
35 (case macro ,(lambda (x env exp)
36 (let ((v (gensym)))
37 (exp `(let ((,v ,(cadr x)))
38 (cond
39 ,@(map (lambda (clause)
40 (cond
41 ((eq? (car clause) 'else) clause)
42 ((null? (cdar clause))
43 `((eq? ,v ',(caar clause)) ,@(cdr clause)))
44 (else (12345678 'multi-case-not-supported clause))))
45 (cddr x))))))))
46 (and macro ,(lambda (x env exp)
47 (exp (cond
48 ((null? (cdr x)) `(begin))
49 ((null? (cddr x)) (cadr x))
50 (else `(if ,(cadr x) (and ,@(cddr x)) #f))))))
51 (,'quasiquote macro
52 ,(lambda (x env exp)
53 (define (qq exp depth)
54 (cond
55 ((not (pair? exp)) `(quote ,exp))
56 ((eq? (car exp) 'quasiquote)
57 `(cons ','quasiquote (cons ,(qq (cadr exp) (+ depth 1)) '())))
58 ((eq? (car exp) 'unquote)
59 (if (= depth 1)
60 (cadr exp)
61 `(cons ','unquote (cons ,(qq (cadr exp) (- depth 1)) '()))))
62 ((and (pair? (car exp))
63 (eq? (caar exp) 'unquote-splicing))
64 (if (= depth 1)
65 `(append ,(cadar exp) ,(qq (cdr exp) depth))
66 `(cons ,(qq (car exp) (- depth 1))
67 ,(qq (cdr exp) depth))))
68 (else `(cons ,(qq (car exp) depth)
69 ,(qq (cdr exp) depth)))))
70 (exp (qq (cadr x) 1))))
71 (define-macro macro ,(lambda (x env exp)
72 (let ((name (cadr x))
73 (transformer (eval (exp (caddr x)))))
74 (set! global-env (cons (munge-entry
75 (cons name
76 (cons 'macro
77 (cons transformer '()))))
78 global-env))
79 `',name)))
80 (define-global! global ,(lambda (arguments k)
81 (let ((name (car arguments))
82 (value (cadr arguments)))
83 ;; FIXME: should set if entry already exists!
84 (set! global-env (cons (munge-entry
85 (cons name
86 (cons 'global
87 (cons value '()))))
88 global-env))
89 (k name))))))))
91 (define-global! 'make-eval
92 (lambda (
93 error
94 undefined
95 allocate-env
96 update-env
97 load-env
98 unbound-variable-read
99 load-literal
100 load-closure
101 do-if
102 push-frame
103 update-frame
104 do-primitive
105 do-call
106 push-continuation
107 )
108 (define (env-null? env) (null? env))
109 (define (env-name env) (caar env))
110 (define (env-annotation env) (unbox (cadar env)))
111 (define (env-value env) (unbox (cddar env)))
112 (define (set-env-value! env value)
113 (set-box! (cadar env) (update-env (env-name env) (env-annotation env) value))
114 (set-box! (cddar env) value))
115 (define (env-next env) (cdr env))
116 (define (make-env name value next)
117 (cons (cons name (cons (box (allocate-env name value)) (box value))) next))
118 (define (search-one-env env n k fk)
119 (cond
120 ((env-null? env) (fk))
121 ((eq? (env-name env) n) (k (env-annotation env) (env-value env) env))
122 (else (search-one-env (env-next env) n k fk))))
123 (define (search-env env n k fk)
124 (search-one-env env n k (lambda () (search-one-env global-env n k fk))))
125 (define (expand x env)
126 (define (exp x) (expand x env))
127 (if (pair? x)
128 (if (symbol? (car x))
129 (search-env env (car x)
130 (lambda (annotation v cell) (if (eq? annotation 'macro)
131 (v x env exp)
132 (map exp x)))
133 (lambda () (map exp x)))
134 (map exp x))
135 x))
136 (define (make-recursive-env defs env)
137 (if (null? defs)
138 env
139 (make-env (caar defs) #f (make-recursive-env (cdr defs) env))))
140 (define (e-recursive-definitions defs xs env k)
141 (let ((new-env (make-recursive-env defs env)))
142 (define (fill-init defs pos)
143 (if (null? defs)
144 (e (cons 'begin xs) new-env k)
145 (e (cdar defs) new-env
146 (push-continuation
147 (lambda (v)
148 (set-env-value! pos v)
149 (fill-init (cdr defs) (env-next pos)))))))
150 (fill-init defs new-env)))
151 (define (e-body defs xs env k)
152 (if (null? xs)
153 (e-recursive-definitions defs xs env k)
154 (let ((x (car xs)))
155 (if (not (pair? x))
156 (e-recursive-definitions defs (cons x (cdr xs)) env k)
157 (case (car x)
158 ((begin) (e-body defs (append (cdr x) (cdr xs)) env k))
159 ((define) (if (pair? (cadr x))
160 (e-body (cons (cons (caadr x)
161 `(lambda ,(cdadr x) ,@(cddr x)))
162 defs) (cdr xs) env k)
163 (e-body (cons (cons (cadr x) (caddr x)) defs) (cdr xs) env k)))
164 (else (e-recursive-definitions defs (cons x (cdr xs)) env k)))))))
165 (define (extend-env-with-actuals formals actuals env)
166 (if (null? formals)
167 env
168 (make-env (car formals) (car actuals)
169 (extend-env-with-actuals (cdr formals) (cdr actuals) env))))
170 (define (e-operands index unevaluated evaluated env k)
171 (if (null? unevaluated)
172 (k (reverse evaluated))
173 (e (car unevaluated) env
174 (push-continuation
175 (lambda (newly-evaluated)
176 (e-operands (+ index 1)
177 (cdr unevaluated)
178 (cons (update-frame index newly-evaluated) evaluated)
179 env
180 k))))))
181 (define (e x env k)
182 (cond
183 ((symbol? x) (search-env env x
184 (lambda (annotation v cell)
185 (if (eq? annotation 'macro)
186 (error 'macro-in-variable-position x)
187 (k (load-env x annotation v))))
188 (lambda ()
189 (k (unbound-variable-read x)))))
190 ((not (pair? x)) (k (load-literal x)))
191 (else
192 (case (car x)
193 ((quote) (k (load-literal (cadr x))))
194 ((define) (error 'internal-definition-in-invalid-position x))
195 ((lambda) (k (load-closure
196 (cadr x)
197 (lambda (actuals k)
198 (let ((new-env (extend-env-with-actuals (cadr x) actuals env)))
199 (e-body '() (cddr x) new-env k))))))
200 ((begin) (cond ((null? (cdr x)) (k (undefined)))
201 ((null? (cddr x)) (e (cadr x) env k))
202 (else (e (cadr x) env
203 (push-continuation
204 (lambda (v)
205 (e (cons 'begin (cddr x)) env k)))))))
206 ((if) (e (cadr x) env
207 (push-continuation
208 (lambda (v)
209 (do-if v
210 (lambda () (e (caddr x) env k))
211 (lambda () (e (cadddr x) env k)))))))
212 ((set!) (search-env env (cadr x)
213 (lambda (annotation v cell)
214 (if (eq? annotation 'macro)
215 (error 'macro-in-variable-position x)
216 (e (caddr x) env
217 (push-continuation
218 (lambda (v)
219 (set-env-value! cell v)
220 (k v))))))
221 (lambda () (error 'unbound-variable x))))
222 ((%assemble) (e-operands 0 (caddr x) '() env
223 (push-frame (length (caddr x))
224 (lambda (operands)
225 (do-primitive (cadr x)
226 operands
227 (cdddr x)
228 k)))))
229 (else (e-operands 0 (cdr x) '() env
230 (push-frame (length (cdr x))
231 (lambda (operands)
232 (e (car x) env
233 (push-continuation
234 (lambda (operator)
235 (do-call operator operands k))))))))))))
236 (lambda (x)
237 (let ((expanded (expand x '())))
238 (e expanded '() (lambda (v) v))))))
240 (define primitive-eval eval)
242 (define-global! 'eval
243 (let ()
244 (define (error key val) (12345678 'magic-error-procedure key val))
245 (define (undefined) 17)
246 (define (allocate-env name v) 'local)
247 (define (update-env name old-annotation v) old-annotation)
248 (define (load-env name annotation v) v)
249 (define (unbound-variable-read x) (error 'unbound-variable-read x))
250 (define (load-literal x) x)
251 (define (load-closure formals f) f)
252 (define (do-if v tk fk) (if v (tk) (fk)))
253 (define (push-frame count k) k)
254 (define (update-frame index v) v)
255 (define (do-primitive names vals expressions k)
256 (define (search expressions)
257 ;;(write `(do-primitive:search ,names ,vals ,expressions)) (newline)
258 (cond
259 ((null? expressions)
260 (error 'missing-scheme-assembly-expression `(%assemble ,names ,vals ,@expressions)))
261 ((eq? (caar expressions) 'scheme)
262 (k ((primitive-eval `(lambda (actuals) (apply (lambda ,names ,@(cdar expressions))
263 actuals)))
264 vals)))
265 (else (search (cdr expressions)))))
266 (search expressions))
267 (define (do-call operator operands k) (operator operands k))
268 (define (push-continuation k) k)
269 (make-eval error undefined allocate-env update-env load-env unbound-variable-read
270 load-literal load-closure do-if push-frame update-frame
271 do-primitive do-call push-continuation)))
273 (define-global! 'compile
274 (lambda (exp)
275 (let ((continuation-depth (make-parameter 0)))
276 (define (error key val) (12345678 'magic-error-procedure key val))
277 (define (undefined) (load-literal 17))
278 (define (allocate-env name v)
279 (write `(allocate-env ,name ,v)) (newline)
280 'local)
281 (define (update-env name old-annotation v)
282 (write `(update-env ,name ,old-annotation)) (newline)
283 old-annotation)
284 (define (load-env name annotation v)
285 (write `(load-env ,name ,annotation)) (newline)
286 v)
287 (define (unbound-variable-read name)
288 (write `(load-implicit-global ,name)) (newline)
289 'implicit-global-value)
290 (define (load-literal x)
291 (write `(load-literal ,x)) (newline)
292 x)
293 (define (load-closure formals f)
294 (write `(load-closure ,formals)) (newline)
295 (parameterize ((continuation-depth 0))
296 (write `(IN================)) (newline)
297 (f formals (lambda (v)
298 (write `(return)) (newline)
299 v))
300 (write `(OUT===============)) (newline)
301 'closure-result))
302 (define (do-if v tk fk)
303 (write `(do-if ,v)) (newline)
304 (write `tk) (newline)
305 (tk)
306 (write `fk) (newline)
307 (fk))
308 (define (push-frame count k)
309 (write `(push-frame ,count)) (newline)
310 k)
311 (define (update-frame index v)
312 (write `(update-frame ,index ,v)) (newline)
313 v)
314 (define (do-primitive names vals expressions k)
315 (write `(%assemble ,names ,vals ,expressions))
316 (k 'primitive-result))
317 (define (do-call operator operands k)
318 (write `(do-call ,(if (= (continuation-depth) 0)
319 'tailcall
320 'normalcall) ,operator ,operands))
321 (newline)
322 (k 'do-call-result))
323 (define (push-continuation k)
324 ;;(write `(push-continuation)) (newline)
325 (continuation-depth (+ (continuation-depth) 1))
326 (lambda (v)
327 ;;(write `(pop-continuation ,v)) (newline)
328 (continuation-depth (- (continuation-depth) 1))
329 (k v)))
330 ((make-eval error undefined allocate-env update-env load-env unbound-variable-read
331 load-literal load-closure do-if push-frame update-frame
332 do-primitive do-call push-continuation)
333 exp))))
335 (define (read-file filename)
336 (call-with-input-file filename
337 (lambda (handle)
338 (let loop ()
339 (let ((sexp (read handle)))
340 (if (eof-object? sexp)
341 '()
342 (cons sexp (loop))))))))
344 (define-global! 'base-load*
345 (lambda (filename evaluator)
346 (for-each evaluator (read-file filename))))
348 (define-global! 'base-load
349 (lambda (filename)
350 (base-load* filename eval)))
352 (base-load "evaluator-base-library.scm")
354 (define (syms x)
355 (cond
356 ((pair? x) (syms (car x)) (syms (cdr x)))
357 ((null? x))
358 (else (write x) (newline))))
360 (define (r* repl-eval)
361 (display ">>> ")
362 (let ((x (read)))
363 (if (eof-object? x)
364 'done
365 (begin (write (repl-eval x))
366 (newline)
367 (r* repl-eval)))))
369 (define (r) (r* eval))
371 ;;(eval `(define-global! 'global-env ',global-env))
372 (r)
374 ;;; Local Variables:
375 ;;; eval: (put '%assemble 'scheme-indent-function 2)
376 ;;; End: