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