author | Tony Garnock-Jones <tonyg@kcbbs.gen.nz> |
Sun, 18 Jan 2009 11:22:02 +0000 | |
changeset 221 | eb2506613052 |
parent 220 | 4678e8460b28 |
child 229 | a08dfaf5fa1b |
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 |
|
221
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
14 |
(define etng-namespaces '()) |
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
15 |
(define implicit-etng-namespace #f) |
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
16 |
|
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
17 |
(define builtin-namespace-url "http://www.eighty-twenty.org/etng/r2/builtin#") |
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
18 |
|
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
19 |
(define (set-etng-namespace! prefix url) |
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
20 |
(cond |
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
21 |
((assq prefix etng-namespaces) => |
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
22 |
(lambda (cell) (set-box! (cdr cell) url))) |
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
23 |
(else |
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
24 |
(set! etng-namespaces (cons (cons prefix (box url)) etng-namespaces))))) |
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
25 |
|
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
26 |
(set-etng-namespace! '|| builtin-namespace-url) |
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
27 |
|
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
28 |
(define (mangle-etng-id* url localname) |
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
29 |
(string->symbol (string-append "etng___" url (symbol->string localname)))) |
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
30 |
|
217
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
31 |
(define (mangle-etng-id id) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
32 |
(cond |
221
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
33 |
((qname? id) |
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
34 |
(cond |
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
35 |
((assq (qname-uri id) etng-namespaces) => |
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
36 |
(lambda (entry) |
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
37 |
(mangle-etng-id* (unbox (cdr entry)) (qname-localname id)))) |
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
38 |
(else |
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
39 |
(error 'unknown-qname-prefix id)))) |
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
40 |
((symbol? id) |
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
41 |
(if implicit-etng-namespace |
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
42 |
(mangle-etng-id* implicit-etng-namespace id) |
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
43 |
(mangle-etng-id* "" id))) |
217
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
44 |
(else (error 'invalid-etng-id id)))) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
45 |
|
221
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
46 |
(define (etng-send-via-named-proxy receiver localname message) |
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
47 |
(etng-send* receiver |
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
48 |
(namespace-variable-value (mangle-etng-id* builtin-namespace-url localname)) |
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
49 |
message)) |
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
50 |
|
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
51 |
(define (etng-lookup receiver via message) |
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
52 |
(let lookup ((clauses (etng-function-clauses via))) |
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
53 |
(if (null? clauses) |
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
54 |
#f |
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
55 |
((car clauses) message |
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
56 |
(lambda (thunk) thunk) |
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
57 |
(lambda () (lookup (cdr clauses))))))) |
217
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
58 |
|
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
59 |
(define (etng-send* receiver via message) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
60 |
(cond |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
61 |
((etng-function? via) |
221
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
62 |
(let ((thunk (or (etng-lookup receiver via message) |
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
63 |
(error 'does-not-understand receiver via message)))) |
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
64 |
(thunk receiver))) |
217
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
65 |
((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
|
66 |
((string? via) (etng-send-via-named-proxy receiver 'stringProxy message)) |
221
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
67 |
((symbol? via) (etng-send-via-named-proxy receiver 'symbolProxy message)) |
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
68 |
((vector? via) (etng-send-via-named-proxy receiver 'tupleProxy message)) |
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
69 |
((not via) (etng-send-via-named-proxy receiver 'falseProxy message)) |
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
70 |
((eq? via #t) (etng-send-via-named-proxy receiver 'trueProxy message)) |
217
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
71 |
(else (error 'illegal-primitive-object receiver via message)))) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
72 |
|
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
73 |
(define (etng-send receiver message) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
74 |
(etng-send* receiver receiver message)) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
75 |
|
219 | 76 |
(define (etng-merge-functions f1 f2) |
77 |
(make-etng-function (append (etng-function-sources f1) (etng-function-sources f2)) |
|
78 |
(append (etng-function-clauses f1) (etng-function-clauses f2)))) |
|
79 |
||
217
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
80 |
(define (compile-to-scheme ast) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
81 |
|
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
82 |
(define (schemeify tng-sexp) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
83 |
(if (pair? tng-sexp) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
84 |
(case (car tng-sexp) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
85 |
((paren) (map schemeify (cdr tng-sexp))) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
86 |
(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
|
87 |
tng-sexp)) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
88 |
|
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
89 |
(define (make-definition id val) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
90 |
`(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
|
91 |
|
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
92 |
(define (toplevel ast) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
93 |
(case (car ast) |
221
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
94 |
((define-namespace) `(set-etng-namespace! ',(cadr ast) ',(caddr ast))) |
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
95 |
((declare-default-namespace) `(set! implicit-etng-namespace ',(cadr ast))) |
217
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
96 |
((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
|
97 |
((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
|
98 |
(else (expr ast)))) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
99 |
|
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
100 |
(define (expr ast) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
101 |
(case (car ast) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
102 |
((ref) (mangle-etng-id (cadr ast))) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
103 |
((lit) `',(cadr ast)) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
104 |
((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
|
105 |
((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
|
106 |
((tuple) `(vector ,@(map expr (cdr ast)))) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
107 |
((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
|
108 |
((assemble) `(let ,(map (lambda (binding) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
109 |
`(,(car binding) ,(expr (cadr binding)))) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
110 |
(cadr ast)) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
111 |
,(schemeify (cadr (assq 'scheme (caddr ast)))))))) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
112 |
|
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
113 |
(define (method should-capture-self) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
114 |
(lambda (ast) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
115 |
`(lambda (_arg _kt _kf) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
116 |
,(let* ((patterns (cadr ast)) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
117 |
(body (caddr ast)) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
118 |
(remaining-patterns (cdr patterns)) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
119 |
(continuation (if (null? remaining-patterns) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
120 |
(expr body) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
121 |
(expr `(function (method ,remaining-patterns ,body)))))) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
122 |
(define (pattern p on-success on-failure) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
123 |
(case (car p) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
124 |
((discard) on-success) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
125 |
((bind) `(let ((,(mangle-etng-id (cadr p)) _arg)) ,on-success)) |
221
eb2506613052
Identifier namespaces, and some interesting code for boot.tng.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
220
diff
changeset
|
126 |
((lit) `(if (equal? ',(cadr p) _arg) |
217
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
127 |
,on-success |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
128 |
,on-failure)) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
129 |
((tuple) `(if (and (vector? _arg) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
130 |
(= (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
|
131 |
,(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
|
132 |
`(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
|
133 |
,(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
|
134 |
(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
|
135 |
(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
|
136 |
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
|
137 |
`(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
|
138 |
,(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
|
139 |
(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
|
140 |
on-failure)))))) |
217
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
141 |
,on-failure)))) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
142 |
(pattern (car patterns) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
143 |
`(_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
|
144 |
,continuation)) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
145 |
`(_kf)))))) |
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
146 |
|
99d5b8250c37
Compile to scheme and evaluate.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
147 |
(toplevel ast)) |