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