author | Tony Garnock-Jones <tonyg@kcbbs.gen.nz> |
Sun, 18 Jan 2009 11:21:10 +0000 | |
changeset 220 | 4678e8460b28 |
parent 219 | 3a2c53019601 |
child 221 | eb2506613052 |
permissions | -rw-r--r-- |
217
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
1 |
(define previous-inspector (current-inspector)) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
2 |
(current-inspector (make-inspector)) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
3 |
|
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
4 |
(define-record-type etng-function |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
5 |
(make-etng-function sources clauses) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
6 |
etng-function? |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
7 |
(sources etng-function-sources) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
8 |
(clauses etng-function-clauses)) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
9 |
|
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
10 |
(current-inspector previous-inspector) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
11 |
|
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
12 |
;--------------------------------------------------------------------------- |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
13 |
|
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
14 |
(define (mangle-etng-id id) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
15 |
(cond |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
16 |
((qname? id) (error 'implement-qnames-please)) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
17 |
((symbol? id) (string->symbol (string-append "etng___" (symbol->string id)))) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
18 |
(else (error 'invalid-etng-id id)))) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
19 |
|
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
20 |
(define (etng-send-via-named-proxy receiver name message) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
21 |
(etng-send* receiver (namespace-variable-value (mangle-etng-id name)) message)) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
22 |
|
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
23 |
(define (etng-send* receiver via message) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
24 |
(cond |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
25 |
((etng-function? via) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
26 |
(let lookup ((clauses (etng-function-clauses via))) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
27 |
(if (null? clauses) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
28 |
(error 'does-not-understand receiver via message) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
29 |
((car clauses) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
30 |
message |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
31 |
(lambda (thunk) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
32 |
(thunk receiver)) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
33 |
(lambda () |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
34 |
(lookup (cdr clauses))))))) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
35 |
((number? via) (etng-send-via-named-proxy receiver 'numberProxy message)) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
36 |
((string? via) (etng-send-via-named-proxy receiver 'stringProxy message)) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
37 |
(else (error 'illegal-primitive-object receiver via message)))) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
38 |
|
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
39 |
(define (etng-send receiver message) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
40 |
(etng-send* receiver receiver message)) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
41 |
|
219 | 42 |
(define (etng-merge-functions f1 f2) |
43 |
(make-etng-function (append (etng-function-sources f1) (etng-function-sources f2)) |
|
44 |
(append (etng-function-clauses f1) (etng-function-clauses f2)))) |
|
45 |
||
217
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
46 |
(define (compile-to-scheme ast) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
47 |
|
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
48 |
(define (schemeify tng-sexp) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
49 |
(if (pair? tng-sexp) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
50 |
(case (car tng-sexp) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
51 |
((paren) (map schemeify (cdr tng-sexp))) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
52 |
(else (error 'brack-and-brace-illegal-in-scheme-assembly))) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
53 |
tng-sexp)) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
54 |
|
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
55 |
(define (make-definition id val) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
56 |
`(namespace-set-variable-value! ',(mangle-etng-id id) ,val)) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
57 |
|
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
58 |
(define (toplevel ast) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
59 |
(case (car ast) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
60 |
((define-value) (make-definition (cadr ast) (expr (caddr ast)))) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
61 |
((define-function) (make-definition (cadr ast) (expr `(function ,(caddr ast))))) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
62 |
(else (expr ast)))) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
63 |
|
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
64 |
(define (expr ast) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
65 |
(case (car ast) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
66 |
((ref) (mangle-etng-id (cadr ast))) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
67 |
((lit) `',(cadr ast)) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
68 |
((object) `(make-etng-function ',(cdr ast) (list ,@(map (method #t) (cdr ast))))) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
69 |
((function) `(make-etng-function ',(cdr ast) (list ,@(map (method #f) (cdr ast))))) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
70 |
((tuple) `(vector ,@(map expr (cdr ast)))) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
71 |
((send) `(etng-send ,(expr (cadr ast)) ,(expr (caddr ast)))) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
72 |
((assemble) `(let ,(map (lambda (binding) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
73 |
`(,(car binding) ,(expr (cadr binding)))) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
74 |
(cadr ast)) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
75 |
,(schemeify (cadr (assq 'scheme (caddr ast)))))))) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
76 |
|
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
77 |
(define (method should-capture-self) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
78 |
(lambda (ast) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
79 |
`(lambda (_arg _kt _kf) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
80 |
,(let* ((patterns (cadr ast)) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
81 |
(body (caddr ast)) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
82 |
(remaining-patterns (cdr patterns)) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
83 |
(continuation (if (null? remaining-patterns) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
84 |
(expr body) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
85 |
(expr `(function (method ,remaining-patterns ,body)))))) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
86 |
(define (pattern p on-success on-failure) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
87 |
(case (car p) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
88 |
((discard) on-success) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
89 |
((bind) `(let ((,(mangle-etng-id (cadr p)) _arg)) ,on-success)) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
90 |
((lit) `(if (eqv? ',(cadr p) _arg) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
91 |
,on-success |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
92 |
,on-failure)) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
93 |
((tuple) `(if (and (vector? _arg) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
94 |
(= (vector-length _arg) ,(length (cdr p)))) |
220
4678e8460b28
Fix a severe aliasing bug in the generated code -- _arg was being used too
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
219
diff
changeset
|
95 |
,(let ((tuple-name (gensym '_argtuple))) |
4678e8460b28
Fix a severe aliasing bug in the generated code -- _arg was being used too
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
219
diff
changeset
|
96 |
`(let ((,tuple-name _arg)) |
4678e8460b28
Fix a severe aliasing bug in the generated code -- _arg was being used too
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
219
diff
changeset
|
97 |
,(let match-elts ((elts (cdr p)) |
4678e8460b28
Fix a severe aliasing bug in the generated code -- _arg was being used too
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
219
diff
changeset
|
98 |
(index 0)) |
4678e8460b28
Fix a severe aliasing bug in the generated code -- _arg was being used too
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
219
diff
changeset
|
99 |
(if (null? elts) |
4678e8460b28
Fix a severe aliasing bug in the generated code -- _arg was being used too
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
219
diff
changeset
|
100 |
on-success |
4678e8460b28
Fix a severe aliasing bug in the generated code -- _arg was being used too
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
219
diff
changeset
|
101 |
`(let ((_arg (vector-ref ,tuple-name ,index))) |
4678e8460b28
Fix a severe aliasing bug in the generated code -- _arg was being used too
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
219
diff
changeset
|
102 |
,(pattern (car elts) |
4678e8460b28
Fix a severe aliasing bug in the generated code -- _arg was being used too
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
219
diff
changeset
|
103 |
(match-elts (cdr elts) (+ index 1)) |
4678e8460b28
Fix a severe aliasing bug in the generated code -- _arg was being used too
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
219
diff
changeset
|
104 |
on-failure)))))) |
217
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
105 |
,on-failure)))) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
106 |
(pattern (car patterns) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
107 |
`(_kt (lambda (,(if should-capture-self (mangle-etng-id 'self) '_self)) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
108 |
,continuation)) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
109 |
`(_kf)))))) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
110 |
|
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
111 |
(toplevel ast)) |