author | Tony Garnock-Jones <tonyg@lshift.net> |
Fri, 28 Oct 2005 06:05:41 +1300 | |
changeset 39 | c65febbb1877 |
parent 35 | 0415292cf581 |
permissions | -rw-r--r-- |
33 | 1 |
'(tng-cst-grammar |
39
c65febbb1877
Correct grammar pseudo-definition
Tony Garnock-Jones <tonyg@lshift.net>
parents:
35
diff
changeset
|
2 |
(<datum> (or <value> |
33 | 3 |
(tuple <value> ...))) |
4 |
(<value> (or (atom <symbol>) |
|
5 |
(lit <literal>) |
|
6 |
(adj <value> <value>) |
|
7 |
(fun (<value> <value>) ...) |
|
35
0415292cf581
Printer for ThiNG CST; improved emacs mode, including comint run-tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
34
diff
changeset
|
8 |
(eval <value>) |
33 | 9 |
(quote <value>) |
10 |
(meta-quote <value>) |
|
11 |
(discard))) |
|
39
c65febbb1877
Correct grammar pseudo-definition
Tony Garnock-Jones <tonyg@lshift.net>
parents:
35
diff
changeset
|
12 |
(<literal> (or <integer>))) |
33 | 13 |
|
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!)) |
|
20 |
||
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)) |
|
26 |
||
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)">"))) |
|
30 |
||
31 |
(define make-promise-id |
|
32 |
(let ((counter 0)) |
|
33 |
(lambda () |
|
34 |
(let ((val counter)) |
|
35 |
(set! counter (+ counter 1)) |
|
36 |
val)))) |
|
37 |
||
38 |
(define-syntax tng |
|
39 |
(syntax-rules () |
|
40 |
((_ interp arg ...) |
|
41 |
(make-tng-promise* (make-promise-id) #f (list interp arg ...))))) |
|
42 |
||
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)) |
|
55 |
||
56 |
(define (eval-error . x) (apply error x)) |
|
57 |
||
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)))) |
|
70 |
||
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))))))) |
|
121 |
||
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))))))) |
|
139 |
||
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))))))) |
|
148 |
||
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)))) |
|
159 |
||
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)))) |
|
185 |
||
186 |
(define (eval-ThiNG term env) |
|
187 |
(tng eval-ThiNG-inner term env)) |
|
188 |
||
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))))) |
|
194 |
||
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))) |
|
207 |
||
208 |
(define (repl-ThiNG) |
|
35
0415292cf581
Printer for ThiNG CST; improved emacs mode, including comint run-tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
34
diff
changeset
|
209 |
(display "\":ThiNG:\" ") |
33 | 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) |
|
34
570a02bb7a27
New, more uniform syntax. Evaluator needs updating.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
33
diff
changeset
|
216 |
(if (not (equal? x '(quote (atom quit)))) |
570a02bb7a27
New, more uniform syntax. Evaluator needs updating.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
33
diff
changeset
|
217 |
(let ((r x)) ;(call-with-stupid-error-handler (lambda () (eval-ThiNG x '()))))) |
35
0415292cf581
Printer for ThiNG CST; improved emacs mode, including comint run-tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
34
diff
changeset
|
218 |
;;(pretty-print-ThiNG r) |
0415292cf581
Printer for ThiNG CST; improved emacs mode, including comint run-tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
34
diff
changeset
|
219 |
(print-tng r 'eval) |
33 | 220 |
(newline) |
221 |
(repl-ThiNG)))))) |
|
222 |
||
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) |