smalltalk-tng
view r3/evaltng.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 | 0415292cf581 |
| children |
line source
1 '(tng-cst-grammar
2 (<datum> (or <value>
3 (tuple <value> ...)))
4 (<value> (or (atom <symbol>)
5 (lit <literal>)
6 (adj <value> <value>)
7 (fun (<value> <value>) ...)
8 (eval <value>)
9 (quote <value>)
10 (meta-quote <value>)
11 (discard)))
12 (<literal> (or <integer>)))
14 (define-record-type tng-promise
15 (make-tng-promise* id defined? value)
16 tng-promise?
17 (id tng-promise-id)
18 (defined? tng-promise-defined? set-tng-promise-defined?!)
19 (value tng-promise-value set-tng-promise-value!))
21 (define-record-type tng-closure
22 (make-tng-closure clauses outer-env)
23 tng-closure?
24 (clauses tng-closure-clauses)
25 (outer-env tng-closure-outer-env))
27 (define-record-printer (tng-promise p out)
28 (for-each (cut display <> out)
29 (list "#<tng-promise "(tng-promise-id p)" "(tng-promise-defined? p)" "(tng-promise-value p)">")))
31 (define make-promise-id
32 (let ((counter 0))
33 (lambda ()
34 (let ((val counter))
35 (set! counter (+ counter 1))
36 val))))
38 (define-syntax tng
39 (syntax-rules ()
40 ((_ interp arg ...)
41 (make-tng-promise* (make-promise-id) #f (list interp arg ...)))))
43 (define (force-tng t)
44 (if (tng-promise? t)
45 (if (tng-promise-defined? t)
46 (tng-promise-value t)
47 (let ((closure (tng-promise-value t)))
48 ;; I am unsure about this recursive force call! Can't things be arranged
49 ;; so that we never promise a promise? %%%
50 (let ((v (force-tng (apply (car closure) (map force-tng (cdr closure))))))
51 (set-tng-promise-defined?! t #t)
52 (set-tng-promise-value! t v)
53 v)))
54 t))
56 (define (eval-error . x) (apply error x))
58 (define (quote-layer forced-term env)
59 (case (car forced-term)
60 ((tuple) `(tuple ,@(map (cut eval-ThiNG <> env) (cdr forced-term))))
61 ((atom) forced-term)
62 ((lit) forced-term)
63 ((adj) `(adj ,(eval-ThiNG (cadr forced-term) env)
64 ,(tng quote-layer (caddr forced-term) env)))
65 ((fun) (make-tng-closure (cdr forced-term) env))
66 ((var quote meta-quote discard)
67 (eval-error "quote-layer: pointless quoting" forced-term env))
68 (else
69 (eval-error "quote-layer: unknown term" forced-term env))))
71 (define (match-quoted p v b)
72 (case (car p)
73 ((atom var lit discard) (match-one p v b))
74 ((quote) (eval-error "match-quoted: pointless quoting" p v b))
75 ((meta-quote) (eval-error "meta-quote unimplemented (in match-quoted)" p v b))
76 (else
77 (let ((vv (force-tng v)))
78 (case (car p)
79 ((tuple) (and (eq? (car vv) 'tuple)
80 (let match-each ((ps (cdr p))
81 (vs (cdr vv))
82 (b b))
83 (if (null? ps)
84 (and (null? vs) b)
85 (and (not (null? vs))
86 (let ((b1 (match-one (car ps) (car vs) b)))
87 (and b1 (match-each (cdr ps) (cdr vs) b1))))))))
88 ((adj) (and (eq? (car vv) 'adj)
89 (and-let* ((b1 (match-one (cadr p) (cadr vv) b)))
90 (match-quoted (caddr p) (caddr vv) b1))))
91 ;; Variables alternate roles when quoted, and the roles are
92 ;; flipped in pattern context when compared to value context.
93 ;;
94 ;; In a pattern, a variable is a binding occurrence unless
95 ;; it's in a quoted-subpattern, in which case it's a
96 ;; referencing occurrence; In a value, a variable is a
97 ;; referencing occurrence unless it's in a quoted-subvalue,
98 ;; in which case it's a binding occurrence.
99 ;;
100 ;; %%% FIXME: get the scoping right for references in
101 ;; quoted-subpatterns.
102 ;;
103 ((fun) (and (tng-closure? vv)
104 (let ((env b)) ;; see FIXME above
105 (let match-each ((clauses (cdr p))
106 (b b))
107 (if (null? clauses)
108 b
109 (let ((pv (caar clauses))
110 (pp (cadar clauses)))
111 (eval-app vv
112 pv
113 env
114 (lambda (code new-env)
115 (let ((result (eval-ThiNG code new-env)))
116 (and-let* ((b1 (match-one pp result b)))
117 (match-each (cdr clauses) b1))))
118 (lambda ()
119 #f))))))))
120 (else (eval-error "match-quoted: unknown term" p vv b)))))))
122 (define (match-one p v b)
123 (case (car p)
124 ((var) (cons (cons (cadr p) v) b))
125 ((quote) (match-quoted (cadr p) v b))
126 ((meta-quote) (eval-error "meta-quote unimplemented (in match-one)" p v b))
127 ((discard) b)
128 ((adj tuple fun) (eval-error "match-one: missing quoting" p v b))
129 (else
130 (let ((vv (force-tng v)))
131 (case (car p)
132 ((atom) (and (eq? (car vv) 'atom)
133 (eq? (cadr p) (cadr vv))
134 b))
135 ((lit) (and (eq? (car vv) 'lit)
136 (equal? (cadr p) (cadr vv))
137 b))
138 (else (eval-error "match-one: unknown term" p vv b)))))))
140 (define (match-clause clauses arg outer-env sk fk)
141 (let search ((clauses clauses))
142 (if (null? clauses)
143 (fk)
144 (let ((new-env (match-one (caar clauses) arg outer-env)))
145 (if new-env
146 (sk (cadar clauses) new-env)
147 (search (cdr clauses)))))))
149 (define (eval-app fn arg env sk fk)
150 (let ((fn (force-tng fn)))
151 (if (tng-closure? fn)
152 (let* ((arg (eval-ThiNG arg env)))
153 (match-clause (tng-closure-clauses fn)
154 arg
155 (tng-closure-outer-env fn)
156 sk
157 fk))
158 (eval-error "eval-app: attempt to apply non-function" fn arg env))))
160 (define (eval-ThiNG-inner term env)
161 (case (car term)
162 ((tuple) ;; Parallel evaluation? sigh
163 `(tuple ,@(map (cut eval-ThiNG <> env) (cdr term))))
164 ((atom) term)
165 ((var) (cond
166 ((assq (cadr term) env) => cdr)
167 (else (eval-error "Unbound variable" term env))))
168 ((lit) term)
169 ((adj) (eval-app (eval-ThiNG (cadr term) env)
170 (caddr term)
171 env
172 eval-ThiNG
173 (lambda ()
174 (eval-error "no match found" term env))))
175 ((fun) (eval-error "Situations unimplemented" term env))
176 ((quote) (if #f ;; disable quoting through one layer of tupling
177 (let ((v (force-tng (cadr term))))
178 (if (eq? (car v) 'tuple)
179 `(tuple ,@(map (lambda (x) (tng quote-layer x env)) (cdr v)))
180 (quote-layer v env)))
181 (quote-layer (force-tng (cadr term)) env)))
182 ((meta-quote) (eval-error "meta-quote unimplemented" term env))
183 ((discard) (eval-error "Discard appeared on the right" term env))
184 (else (eval-error "Unknown term" term env))))
186 (define (eval-ThiNG term env)
187 (tng eval-ThiNG-inner term env))
189 (define (call-with-stupid-error-handler f)
190 (call-with-current-continuation
191 (lambda (escape)
192 (fluid-let ((error (lambda x (escape `(ERROR ,@x)))))
193 (f)))))
195 (define (pretty-print-ThiNG x)
196 (let ((x (call-with-stupid-error-handler
197 (lambda ()
198 (let walk ((x x))
199 (cond
200 ((pair? x) (cons (walk (car x))
201 (walk (cdr x))))
202 ((tng-closure? x) `(fun-closure ,(tng-closure-clauses x)
203 ,(walk (tng-closure-outer-env x))))
204 ((tng-promise? x) (walk (force-tng x)))
205 (else x)))))))
206 (pretty-print x)))
208 (define (repl-ThiNG)
209 (display "\":ThiNG:\" ")
210 (let ((x (call-with-stupid-error-handler read-ThiNG)))
211 (newline)
212 (pretty-print x)
213 (newline)
214 (if (eq? (car x) 'ERROR)
215 (repl-ThiNG)
216 (if (not (equal? x '(quote (atom quit))))
217 (let ((r x)) ;(call-with-stupid-error-handler (lambda () (eval-ThiNG x '())))))
218 ;;(pretty-print-ThiNG r)
219 (print-tng r 'eval)
220 (newline)
221 (repl-ThiNG))))))
223 ;(trace match-one)
224 ;(trace match-quoted)
225 ;(trace match-clause)
226 ;(trace force-tng)
227 ;(trace eval-app)
228 ;(trace eval-ThiNG-inner)