smalltalk-tng
view etng-r2/compile-to-scheme.scm @ 321:c4a0718c2d3c
Sketch of dependencies
| author | Tony Garnock-Jones <tonygarnockjones@gmail.com> |
|---|---|
| date | Sat Oct 08 15:36:03 2011 -0400 (3 months ago) |
| parents | 4d06e035b80e |
| children |
line source
1 (define previous-inspector (current-inspector))
2 (current-inspector (make-inspector))
4 (define-record-type etng-alternation
5 (make-etng-alternation clauses)
6 etng-alternation?
7 (clauses etng-alternation-clauses))
9 (current-inspector previous-inspector)
11 ;---------------------------------------------------------------------------
13 (define etng-namespaces '())
14 (define implicit-etng-namespace #f)
16 (define builtin-namespace-url "http://www.eighty-twenty.org/etng/r2/builtin#")
18 (define (set-etng-namespace! prefix url)
19 (cond
20 ((assq prefix etng-namespaces) =>
21 (lambda (cell) (set-box! (cdr cell) url)))
22 (else
23 (set! etng-namespaces (cons (cons prefix (box url)) etng-namespaces)))))
25 (set-etng-namespace! '|| builtin-namespace-url)
27 (define (mangle-etng-id* url localname)
28 (string->symbol (string-append "etng___" url (symbol->string localname))))
30 (define (mangle-etng-id id)
31 (cond
32 ((qname? id)
33 (cond
34 ((assq (qname-uri id) etng-namespaces) =>
35 (lambda (entry)
36 (mangle-etng-id* (unbox (cdr entry)) (qname-localname id))))
37 (else
38 (error 'unknown-qname-prefix id))))
39 ((symbol? id)
40 (if implicit-etng-namespace
41 (mangle-etng-id* implicit-etng-namespace id)
42 (mangle-etng-id* "" id)))
43 (else (error 'invalid-etng-id id))))
45 (define (etng-send-via-named-proxy receiver localname message)
46 (etng-send* receiver
47 (namespace-variable-value (mangle-etng-id* builtin-namespace-url localname))
48 message))
50 (define (etng-alternation->parser a)
51 (lambda (input ks kf)
52 (let loop ((clauses (etng-alternation-clauses a)))
53 (if (null? clauses)
54 (kf)
55 ((car clauses) input ks (lambda () (loop (cdr clauses))))))))
57 (define (make-parser-invocation first-message)
58 (let ((fragments-rev (make-parameter (list first-message))))
59 (define (fragment-following f)
60 (let search ((candidate #f)
61 (fs (fragments-rev)))
62 (cond
63 ((null? fs) (error 'should-not-reach-here 'fragment-following))
64 ((eq? (car fs) f) candidate)
65 (else (search (car fs) (cdr fs))))))
66 (define (remaining-input-following f)
67 (let search ((acc '())
68 (fs (fragments-rev)))
69 (cond
70 ((null? fs) (error 'should-not-reach-here 'fragment-following))
71 ((eq? (car fs) f) acc)
72 (else (search (append (car fs) acc) (cdr fs))))))
73 (define (stream-fragment f)
74 (let loop ((position f))
75 (lambda (op k)
76 (case op
77 ((next)
78 (if (null? position)
79 (let ((next-fragment (fragment-following f)))
80 (if next-fragment
81 ((stream-fragment next-fragment) 'next k)
82 (let ((so-far (fragments-rev)))
83 (lambda (ignored-receiver)
84 (lambda (message)
85 (parameterize ((fragments-rev (cons message so-far)))
86 ((stream-fragment message) 'next k)))))))
87 (k (car position) (loop (cdr position)))))
88 ((rest)
89 (k (append position (remaining-input-following f))))
90 (else
91 (error 'invalid-op op))))))
92 (stream-fragment first-message)))
94 (define (etng-lookup via message)
95 (cond
96 ((etng-alternation? via)
97 ((etng-alternation->parser via)
98 (make-parser-invocation message)
99 (lambda (rhs-thunk-waiting-for-self remaining-input)
100 (remaining-input 'rest
101 (lambda (remaining-message)
102 (if (null? remaining-message)
103 rhs-thunk-waiting-for-self
104 (lambda (receiver)
105 (etng-send (rhs-thunk-waiting-for-self receiver)
106 remaining-message))))))
107 (lambda () #f)))
108 ((procedure? via)
109 (via message))
110 (else 'invalid-via (list via message))))
112 (define (etng-directly-invokable? x)
113 (or (procedure? x) ;; a parser-invocation, (lambda (message) ...)
114 (etng-alternation? x) ;; a parser without invocation: see etng-lookup
115 ))
117 (define (etng-send* receiver via message)
118 (cond
119 ((etng-directly-invokable? via)
120 (let ((thunk (or (etng-lookup via message)
121 (error 'does-not-understand receiver via message))))
122 (thunk receiver)))
123 ((number? via) (etng-send-via-named-proxy receiver 'numberProxy message))
124 ((string? via) (etng-send-via-named-proxy receiver 'stringProxy message))
125 ((qname-or-symbol? via) (etng-send-via-named-proxy receiver 'symbolProxy message))
126 ((vector? via) (etng-send-via-named-proxy receiver 'tupleProxy message))
127 ((not via) (etng-send-via-named-proxy receiver 'falseProxy message))
128 ((eq? via #t) (etng-send-via-named-proxy receiver 'trueProxy message))
129 (else (error 'illegal-primitive-object receiver via message))))
131 (define (etng-send receiver message)
132 (etng-send* receiver receiver message))
134 (define (etng-merge-functions f1 f2)
135 (make-etng-alternation (append (etng-alternation-clauses f1) (etng-alternation-clauses f2))))
137 (define (compile-to-scheme ast)
139 (define (schemeify tng-sexp)
140 (if (pair? tng-sexp)
141 (case (car tng-sexp)
142 ((paren) (map schemeify (cdr tng-sexp)))
143 (else (error 'brack-and-brace-illegal-in-scheme-assembly)))
144 tng-sexp))
146 (define (make-definition id val)
147 `(namespace-set-variable-value! ',(mangle-etng-id id) ,val))
149 (define (toplevel ast)
150 (case (car ast)
151 ((define-namespace) `(set-etng-namespace! ',(cadr ast) ',(caddr ast)))
152 ((declare-default-namespace) `(set! implicit-etng-namespace ',(cadr ast)))
153 ((define-value) (make-definition (cadr ast) (expr (caddr ast))))
154 ((define-function) (make-definition (cadr ast) (expr `(function ,(caddr ast)))))
155 (else (expr ast))))
157 (define (expr ast)
158 (case (car ast)
159 ((ref) (mangle-etng-id (cadr ast)))
160 ((lit) `',(cadr ast))
161 ((object) `(make-etng-alternation (list ,@(map (method (cadr ast)) (cddr ast)))))
162 ((function) `(make-etng-alternation (list ,@(map (method #f) (cdr ast)))))
163 ((tuple) `(vector ,@(map expr (cdr ast))))
164 ((send) `(etng-send ,(expr (cadr ast)) (list ,@(map expr (cddr ast)))))
165 ((assemble) `(let ,(map (lambda (binding)
166 `(,(car binding) ,(expr (cadr binding))))
167 (cadr ast))
168 ,(schemeify (cadr (assq 'scheme (caddr ast))))))))
170 (define (pattern p on-success on-failure)
171 (case (car p)
172 ((discard) on-success)
173 ((bind) `(let ((,(mangle-etng-id (cadr p)) _arg)) ,on-success))
174 ((lit) `(if (equal? ',(cadr p) _arg)
175 ,on-success
176 ,on-failure))
177 ((tuple) `(if (and (vector? _arg)
178 (= (vector-length _arg) ,(length (cdr p))))
179 ,(let ((tuple-name (gensym '_argtuple)))
180 `(let ((,tuple-name _arg))
181 ,(let match-elts ((elts (cdr p))
182 (index 0))
183 (if (null? elts)
184 on-success
185 `(let ((_arg (vector-ref ,tuple-name ,index)))
186 ,(pattern (car elts)
187 (match-elts (cdr elts) (+ index 1))
188 on-failure))))))
189 ,on-failure))))
191 (define (method self-id)
192 (lambda (ast)
193 (let ((body (caddr ast)))
194 `(lambda (_stream _kt _kf)
195 ,(let loop ((patterns (cadr ast)))
196 `(_stream 'next
197 (lambda (_arg _stream)
198 ,(let* ((remaining-patterns (cdr patterns)))
199 (pattern (car patterns)
200 (if (null? remaining-patterns)
201 `(_kt (lambda (,(if self-id
202 (mangle-etng-id self-id)
203 '_self))
204 ,(expr body))
205 _stream)
206 (loop remaining-patterns))
207 `(_kf))))))))))
209 (toplevel ast))