author | Tony Garnock-Jones <tonygarnockjones@gmail.com> |
Tue, 25 May 2010 08:09:57 +1200 | |
changeset 285 | 034958cf32d9 |
parent 161 | 08de2e3e81e5 |
permissions | -rw-r--r-- |
150 | 1 |
(define etng-naked-id-terminators (string->list "`.()[]{}:;,'\"")) |
2 |
||
3 |
(define (char-etng-id-alpha? ch) |
|
4 |
(or (char-alphabetic? ch) |
|
5 |
(eqv? ch #\_))) |
|
6 |
||
7 |
(define (char-etng-id-punct? ch) |
|
8 |
(not (or (char-alphabetic? ch) |
|
9 |
(char-whitespace? ch) |
|
10 |
(char-numeric? ch) |
|
11 |
(memv ch etng-naked-id-terminators)))) |
|
12 |
||
13 |
(define EMPTY-SYMBOL (string->symbol "")) |
|
155
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
14 |
(define QUOTE-QNAME (make-qname EMPTY-SYMBOL 'quote)) |
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
15 |
(define UNQUOTE-QNAME (make-qname EMPTY-SYMBOL 'unquote)) |
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
16 |
(define SEMI-QNAME (make-qname #f (string->symbol ";"))) |
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
17 |
(define COMMA-QNAME (make-qname #f (string->symbol ","))) |
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
18 |
(define EQUAL-QNAME (make-qname #f '=)) |
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
19 |
(define ARROW-QNAME (make-qname #f '->)) |
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
20 |
(define NAMESPACE-QNAME (make-qname #f 'namespace)) |
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
21 |
(define DO-QNAME (make-qname #f 'do)) |
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
22 |
(define LET-QNAME (make-qname #f 'let)) |
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
23 |
|
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
24 |
(define (list-interleave x xs) |
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
25 |
(cond |
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
26 |
((null? xs) '()) |
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
27 |
((null? (cdr xs)) xs) |
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
28 |
(else (cons (car xs) (cons x (list-interleave x (cdr xs))))))) |
150 | 29 |
|
152
a18c95337f5a
Rename parse-etng -> read-etng
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
150
diff
changeset
|
30 |
(define read-etng |
150 | 31 |
(let () |
32 |
(define read-etng |
|
33 |
(let* ((non-eol (lambda (ch) (not (or (eqv? ch #\return) |
|
34 |
(eqv? ch #\newline))))) |
|
35 |
(non-string-quote (lambda (ch) (not (eqv? ch #\")))) |
|
36 |
(non-id-quote (lambda (ch) (not (eqv? ch #\')))) |
|
37 |
||
38 |
(reader |
|
39 |
(packrat-parse |
|
40 |
`( |
|
41 |
(entry-point sexp) |
|
42 |
||
43 |
(sexp (/ (ws #\. s <- sexp |
|
155
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
44 |
,(packrat-lambda (s) `(paren ,QUOTE-QNAME ,s))) |
150 | 45 |
(ws #\` s <- sexp |
155
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
46 |
,(packrat-lambda (s) `(paren ,UNQUOTE-QNAME ,s))) |
150 | 47 |
(ws #\( ss <- sexps ws #\) |
48 |
,(packrat-lambda (ss) `(paren ,@ss))) |
|
49 |
(ws #\[ ss <- sexps ws #\] |
|
50 |
,(packrat-lambda (ss) `(brack ,@ss))) |
|
51 |
(ws #\{ ss <- sexps ws #\} |
|
52 |
,(packrat-lambda (ss) `(brace ,@ss))) |
|
53 |
(l <- leaf |
|
54 |
,(packrat-lambda (l) l)))) |
|
55 |
||
56 |
(sexps (/ (s <- sexp ss <- sexps ,(packrat-lambda (s ss) (cons s ss))) |
|
57 |
,(packrat-lambda () '()))) |
|
58 |
||
59 |
(leaf (/ qname |
|
60 |
word |
|
61 |
string)) |
|
62 |
||
63 |
(qname (/ (lhs <- id #\: rhs <- id ,(packrat-lambda (lhs rhs) |
|
64 |
(make-qname lhs rhs))) |
|
65 |
(ws #\: rhs <- id ,(packrat-lambda (rhs) |
|
66 |
(make-qname EMPTY-SYMBOL rhs))) |
|
67 |
(rhs <- id ,(packrat-lambda (rhs) |
|
155
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
68 |
(make-qname #f rhs))))) |
150 | 69 |
|
70 |
(id (/ (ws i <- id1 ,(packrat-lambda (i) |
|
71 |
(string->symbol |
|
72 |
(string-concatenate (list-interleave "'" i))))) |
|
155
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
73 |
(ws #\; ,(packrat-lambda () (string->symbol ";"))) |
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
74 |
(ws #\, ,(packrat-lambda () (string->symbol ","))) |
150 | 75 |
(ws (a <- id-alpha) (r <- (/ id-alpha digit))* |
76 |
,(packrat-lambda (a r) (string->symbol (list->string (cons a r))))) |
|
77 |
(ws (p <- id-punct)+ |
|
78 |
,(packrat-lambda (p) (string->symbol (list->string p)))))) |
|
79 |
(id1 (/ (i <- id-subunit is <- id1 |
|
80 |
,(packrat-lambda (i is) (cons i is))) |
|
81 |
(i <- id-subunit |
|
82 |
,(packrat-lambda (i) (list i))))) |
|
83 |
(id-subunit (#\' (cs <- (/: ,non-id-quote "escaped-identifier-character"))* #\' |
|
84 |
,(packrat-lambda (cs) (list->string cs)))) |
|
85 |
||
86 |
(word (/ positive-word |
|
87 |
(ws #\- w <- positive-word ,(packrat-lambda (w) (- w))))) |
|
88 |
(positive-word (ws (d <- digit)+ |
|
89 |
,(packrat-lambda (d) (string->number (list->string d))))) |
|
90 |
||
91 |
(string (ws s <- string1 ,(packrat-lambda (s) |
|
92 |
(string-concatenate (list-interleave "\"" s))))) |
|
93 |
(string1 (/ (s <- string-subunit ss <- string1 |
|
94 |
,(packrat-lambda (s ss) (cons s ss))) |
|
95 |
(s <- string-subunit |
|
96 |
,(packrat-lambda (s) (list s))))) |
|
97 |
(string-subunit (#\" (cs <- (/: ,non-string-quote "string character"))* #\" |
|
98 |
,(packrat-lambda (cs) (list->string cs)))) |
|
99 |
||
100 |
(id-alpha (/: ,char-etng-id-alpha? "identifier-character")) |
|
101 |
(id-punct (/: ,char-etng-id-punct? "punctuation-character")) |
|
102 |
(digit (/: ,char-numeric? "digit")) |
|
103 |
||
104 |
(ws (/ ((/: ,char-whitespace? "whitespace")+ ws) |
|
105 |
(#\- #\- (/: ,non-eol "comment character")* (/ #\return #\newline) ws) |
|
106 |
())) |
|
107 |
||
108 |
)))) |
|
109 |
(lambda (results k-ok k-fail) |
|
110 |
(try-packrat-parse-pattern |
|
111 |
(reader 'entry-point) '() results |
|
112 |
(lambda (bindings result) (k-ok (parse-result-semantic-value result) |
|
113 |
(parse-result-next result))) |
|
114 |
(lambda (err) (k-fail (list (parse-position->string (parse-error-position err)) |
|
115 |
(parse-error-expected err) |
|
116 |
(parse-error-messages err)))))))) |
|
117 |
||
118 |
(lambda (results k-ok k-fail) |
|
119 |
(read-etng results |
|
120 |
k-ok |
|
121 |
k-fail)))) |
|
122 |
||
155
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
123 |
(define (etng-sexp-special-match? sexps qname) |
150 | 124 |
(and (pair? sexps) |
125 |
(let ((tok (car sexps))) |
|
155
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
126 |
(equal? tok qname)))) |
150 | 127 |
|
157
d75556d42df4
Introduce paren?, brack? and brace?.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
155
diff
changeset
|
128 |
(define (paren? n) (and (pair? n) (eq? (car n) 'paren))) |
d75556d42df4
Introduce paren?, brack? and brace?.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
155
diff
changeset
|
129 |
(define (brack? n) (and (pair? n) (eq? (car n) 'brack))) |
d75556d42df4
Introduce paren?, brack? and brace?.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
155
diff
changeset
|
130 |
(define (brace? n) (and (pair? n) (eq? (car n) 'brace))) |
d75556d42df4
Introduce paren?, brack? and brace?.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
155
diff
changeset
|
131 |
|
150 | 132 |
(define (etng-sexp->string namespace-env n) |
133 |
(let () |
|
134 |
(define (x n tail) |
|
135 |
(cond |
|
157
d75556d42df4
Introduce paren?, brack? and brace?.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
155
diff
changeset
|
136 |
((paren? n) |
d75556d42df4
Introduce paren?, brack? and brace?.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
155
diff
changeset
|
137 |
(cond |
d75556d42df4
Introduce paren?, brack? and brace?.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
155
diff
changeset
|
138 |
((etng-sexp-special-match? (cdr n) QUOTE-QNAME) |
d75556d42df4
Introduce paren?, brack? and brace?.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
155
diff
changeset
|
139 |
(cons #\. (x (caddr n) tail))) |
d75556d42df4
Introduce paren?, brack? and brace?.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
155
diff
changeset
|
140 |
((etng-sexp-special-match? (cdr n) UNQUOTE-QNAME) |
d75556d42df4
Introduce paren?, brack? and brace?.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
155
diff
changeset
|
141 |
(cons #\` (x (caddr n) tail))) |
d75556d42df4
Introduce paren?, brack? and brace?.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
155
diff
changeset
|
142 |
(else |
d75556d42df4
Introduce paren?, brack? and brace?.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
155
diff
changeset
|
143 |
(wrap #\( #\) (cdr n) tail)))) |
d75556d42df4
Introduce paren?, brack? and brace?.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
155
diff
changeset
|
144 |
((brack? n) (wrap #\[ #\] (cdr n) tail)) |
d75556d42df4
Introduce paren?, brack? and brace?.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
155
diff
changeset
|
145 |
((brace? n) (wrap #\{ #\} (cdr n) tail)) |
150 | 146 |
((qname? n) (x-qname n tail)) |
147 |
((string? n) (x-string n tail)) |
|
148 |
((number? n) (append (string->list (number->string n)) tail)))) |
|
149 |
||
150 |
(define (wrap o c ns tail) |
|
151 |
(cons o (let loop ((ns ns) |
|
152 |
(tail (cons c tail))) |
|
153 |
(cond |
|
154 |
((null? ns) tail) |
|
155 |
((null? (cdr ns)) (x (car ns) tail)) |
|
156 |
(else (x (car ns) (cons #\space (loop (cdr ns) tail)))))))) |
|
157 |
||
158 |
(define (x-qname q tail) |
|
159 |
(if (qname-uri q) |
|
160 |
(x-base-id (lookup-namespace (qname-uri q)) |
|
161 |
(cons #\: (x-base-id (qname-localname q) tail))) |
|
162 |
(x-base-id (qname-localname q) tail))) |
|
163 |
||
164 |
(define (lookup-namespace u) |
|
165 |
(cond |
|
166 |
((assoc u namespace-env) => cadr) |
|
167 |
(else u))) |
|
168 |
||
169 |
(define (x-base-id str tail) |
|
170 |
(if (symbol? str) |
|
171 |
(x-base-id (symbol->string str) tail) |
|
172 |
(let ((chars (string->list str))) |
|
173 |
(if (or (every char-etng-id-punct? chars) |
|
174 |
(every char-etng-id-alpha? chars) |
|
175 |
(member str '(";" ","))) |
|
176 |
(append chars tail) |
|
177 |
(cons #\' (quote-string #\' chars (cons #\' tail))))))) |
|
178 |
||
179 |
(define (x-string str tail) |
|
180 |
(cons #\" (quote-string #\" (string->list str) (cons #\" tail)))) |
|
181 |
||
182 |
(define (quote-string needs-escaping chars tail) |
|
183 |
(cond |
|
184 |
((null? chars) tail) |
|
185 |
((eqv? (car chars) needs-escaping) |
|
186 |
(cons needs-escaping |
|
187 |
(cons needs-escaping |
|
188 |
(quote-string needs-escaping (cdr chars) tail)))) |
|
189 |
(else (cons (car chars) (quote-string needs-escaping (cdr chars) tail))))) |
|
190 |
||
191 |
(list->string (x n '())))) |
|
192 |
||
155
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
193 |
(define (etng-sexp-parse n nsenv) |
150 | 194 |
(let () |
195 |
(define (x n) |
|
196 |
(cond |
|
157
d75556d42df4
Introduce paren?, brack? and brace?.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
155
diff
changeset
|
197 |
((paren? n) (x-seq (cdr n))) |
d75556d42df4
Introduce paren?, brack? and brace?.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
155
diff
changeset
|
198 |
((brack? n) (x-obj 'core-object (cdr n))) |
d75556d42df4
Introduce paren?, brack? and brace?.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
155
diff
changeset
|
199 |
((brace? n) (x-obj 'core-function (cdr n))) |
155
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
200 |
((qname? n) (make-node 'core-ref 'name (expand-qnames n nsenv))) |
150 | 201 |
((string? n) (make-node 'core-lit 'value n)) |
157
d75556d42df4
Introduce paren?, brack? and brace?.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
155
diff
changeset
|
202 |
((number? n) (make-node 'core-lit 'value n)) |
d75556d42df4
Introduce paren?, brack? and brace?.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
155
diff
changeset
|
203 |
(else (error "Bad etng-sexp" n)))) |
150 | 204 |
|
205 |
(define (split elts sep) |
|
206 |
(let loop ((elts elts) |
|
207 |
(current '()) |
|
208 |
(acc '())) |
|
209 |
(cond |
|
210 |
((null? elts) (reverse (cons (reverse current) acc))) |
|
155
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
211 |
((equal? (car elts) sep) (loop (cdr elts) '() (cons (reverse current) acc))) |
150 | 212 |
(else (loop (cdr elts) (cons (car elts) current) acc))))) |
213 |
||
214 |
(define (split-semi xs) |
|
215 |
(filter (lambda (x) (not (null? x))) |
|
155
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
216 |
(split xs SEMI-QNAME))) |
150 | 217 |
|
218 |
(define (x-seq elts) |
|
219 |
(let ((segments (split-semi elts))) |
|
220 |
(if (null? segments) |
|
221 |
(make-node 'core-tuple 'elements '()) |
|
222 |
(x-expr segments |
|
223 |
(lambda (node remaining) |
|
224 |
(if (null? remaining) |
|
225 |
node |
|
226 |
(error "Remaining elements in sequence" elts))))))) |
|
227 |
||
228 |
(define (x-obj kind elts) |
|
229 |
(let loop ((segments (split-semi elts)) |
|
230 |
(methodsrev '())) |
|
231 |
(if (null? segments) |
|
232 |
(make-node kind 'methods (reverse methodsrev)) |
|
155
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
233 |
(x-method segments ARROW-QNAME 'core-method |
150 | 234 |
(lambda (method remaining) |
235 |
(loop remaining (cons method methodsrev))) |
|
236 |
(lambda () |
|
155
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
237 |
(x-method segments EQUAL-QNAME 'core-constant |
150 | 238 |
(lambda (method remaining) |
239 |
(loop remaining (cons method methodsrev))) |
|
240 |
(lambda () |
|
241 |
(x-expr segments |
|
242 |
(lambda (body remaining) |
|
243 |
(if (null? remaining) |
|
244 |
(loop '() |
|
245 |
(cons (make-node 'core-method |
|
246 |
'patterns (list |
|
247 |
(make-node |
|
248 |
'pat-discard)) |
|
249 |
'body body) |
|
250 |
methodsrev)) |
|
251 |
(error "Unexpected continuation of body" |
|
252 |
segments))))))))))) |
|
253 |
||
254 |
(define (x-method segments split-symbol method-kind k-yes k-no) |
|
255 |
(if (special-segment? (car segments)) |
|
256 |
(k-no) |
|
257 |
(let ((maybe-header (split (car segments) split-symbol))) |
|
258 |
(cond |
|
259 |
((= (length maybe-header) 2) |
|
260 |
(x-expr (cons (cadr maybe-header) (cdr segments)) |
|
261 |
(lambda (body remaining) |
|
262 |
(k-yes (make-node method-kind |
|
263 |
'patterns (x-method-patterns (car maybe-header)) |
|
264 |
'body body) |
|
265 |
remaining)))) |
|
266 |
((= (length maybe-header) 1) |
|
267 |
(k-no)) |
|
268 |
(else |
|
269 |
(error "Too many method-header-separators" segments)))))) |
|
270 |
||
271 |
(define (x-method-patterns segment) |
|
155
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
272 |
(let ((parts (split segment COMMA-QNAME))) |
150 | 273 |
(if (= (length parts) 1) |
274 |
(map x-pattern-atom segment) |
|
275 |
(list (x-pattern segment))))) |
|
276 |
||
277 |
(define (special-segment? segment) |
|
278 |
(and (pair? segment) |
|
155
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
279 |
(or (etng-sexp-special-match? segment QUOTE-QNAME) |
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
280 |
(etng-sexp-special-match? segment UNQUOTE-QNAME) |
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
281 |
(etng-sexp-special-match? segment NAMESPACE-QNAME) |
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
282 |
(etng-sexp-special-match? segment DO-QNAME) |
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
283 |
(etng-sexp-special-match? segment LET-QNAME)))) |
150 | 284 |
|
285 |
(define (special-pattern-segment? segment) |
|
286 |
(and (pair? segment) |
|
155
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
287 |
(or (etng-sexp-special-match? segment QUOTE-QNAME)))) |
150 | 288 |
|
289 |
(define (special-localname n) |
|
290 |
(if (qname? n) |
|
291 |
(qname-localname n) |
|
292 |
n)) |
|
293 |
||
294 |
(define (fun pat body) |
|
295 |
(make-node 'core-function |
|
296 |
'methods (list (make-node 'core-method |
|
297 |
'patterns (list pat) |
|
298 |
'body body)))) |
|
299 |
||
300 |
(define (x-expr segments k) |
|
301 |
(let ((segment (car segments)) |
|
302 |
(remaining (cdr segments))) |
|
303 |
(cond |
|
304 |
((null? segment) (error "Empty segment in sequence" segments)) |
|
305 |
((special-segment? segment) |
|
306 |
(case (special-localname (car segment)) |
|
155
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
307 |
((quote) (k (make-node 'core-lit 'value (expand-qnames (cadr segment) nsenv)) |
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
308 |
remaining)) |
150 | 309 |
((unquote) (error "Naked unquote" segments)) |
153
b0e3753802e1
Parse namespace prefix declarations
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
152
diff
changeset
|
310 |
((namespace) (x-namespace-declaration segment remaining k)) |
150 | 311 |
((do) (x-expr remaining |
312 |
(lambda (tail remaining1) |
|
313 |
(k (make-node 'core-send |
|
314 |
'receiver (fun (make-node 'pat-discard) tail) |
|
315 |
'message (x-tuple (cdr segment))) |
|
316 |
remaining1)))) |
|
155
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
317 |
((let) (let ((parts (split (cdr segment) EQUAL-QNAME))) |
150 | 318 |
(if (not (= (length parts) 2)) |
319 |
(error "Invalid let clause" segment) |
|
320 |
(x-expr remaining |
|
321 |
(lambda (tail remaining1) |
|
322 |
(k (make-node 'core-send |
|
323 |
'receiver (fun (x-pattern (car parts)) tail) |
|
324 |
'message (x-tuple (cadr parts))) |
|
325 |
remaining1)))))))) |
|
326 |
(else (k (x-tuple segment) remaining))))) |
|
327 |
||
153
b0e3753802e1
Parse namespace prefix declarations
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
152
diff
changeset
|
328 |
(define (x-namespace-declaration segment remaining k) |
b0e3753802e1
Parse namespace prefix declarations
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
152
diff
changeset
|
329 |
(define (ns-wrap prefix uri) |
155
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
330 |
(k (etng-sexp-parse `(paren ,@(concatenate (list-interleave (list SEMI-QNAME) remaining))) |
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
331 |
(extend-qname-env nsenv prefix uri)) |
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
332 |
'())) |
153
b0e3753802e1
Parse namespace prefix declarations
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
152
diff
changeset
|
333 |
(cond |
b0e3753802e1
Parse namespace prefix declarations
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
152
diff
changeset
|
334 |
((and (= (length segment) 4) |
155
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
335 |
(qname? (cadr segment)) |
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
336 |
(not (qname-uri (cadr segment))) |
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
337 |
(equal? (caddr segment) EQUAL-QNAME) |
153
b0e3753802e1
Parse namespace prefix declarations
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
152
diff
changeset
|
338 |
(string? (cadddr segment))) |
155
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
339 |
(ns-wrap (qname-localname (cadr segment)) (cadddr segment))) |
153
b0e3753802e1
Parse namespace prefix declarations
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
152
diff
changeset
|
340 |
((and (= (length segment) 2) |
b0e3753802e1
Parse namespace prefix declarations
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
152
diff
changeset
|
341 |
(string? (cadr segment))) |
b0e3753802e1
Parse namespace prefix declarations
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
152
diff
changeset
|
342 |
(ns-wrap #f (cadr segment))) |
b0e3753802e1
Parse namespace prefix declarations
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
152
diff
changeset
|
343 |
(else |
b0e3753802e1
Parse namespace prefix declarations
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
152
diff
changeset
|
344 |
(error "Invalid namespace declaration" segment)))) |
b0e3753802e1
Parse namespace prefix declarations
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
152
diff
changeset
|
345 |
|
150 | 346 |
(define (x-tuple segment) |
347 |
(parse-tuple segment 'core-tuple x-send)) |
|
348 |
||
349 |
(define (parse-tuple segment kind k) |
|
155
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
350 |
(let ((elements (split segment COMMA-QNAME))) |
150 | 351 |
(if (null? (cdr elements)) |
352 |
(k (car elements)) |
|
353 |
(make-node kind 'elements (map k elements))))) |
|
354 |
||
355 |
(define (x-send seq) |
|
356 |
(cond |
|
357 |
((null? seq) (error "Empty send" seq)) |
|
358 |
((eq? (car seq) '<) |
|
359 |
(let-values (((parts rest) (break (lambda (x) (eq? x '>)) (cdr seq)))) |
|
360 |
(x-send-core (cdr rest) (make-node 'core-message |
|
361 |
'parts (map x parts))))) |
|
362 |
(else |
|
363 |
(x-send-core (cdr seq) (x (car seq)))))) |
|
364 |
||
365 |
(define (x-send-core messages receiver) |
|
366 |
(if (null? messages) |
|
367 |
receiver |
|
368 |
(x-send-core (cdr messages) |
|
369 |
(make-node 'core-send |
|
370 |
'receiver receiver |
|
371 |
'message (x (car messages)))))) |
|
372 |
||
373 |
(define (x-pattern segment) |
|
374 |
(parse-tuple segment 'pat-tuple x-pattern-element)) |
|
375 |
||
376 |
(define (x-pattern-element seq) |
|
377 |
(if (special-pattern-segment? seq) |
|
378 |
(case (special-localname (car seq)) |
|
155
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
379 |
((quote) (make-node 'pat-lit 'value (expand-qnames (cadr seq) nsenv)))) |
150 | 380 |
(case (length seq) |
158
d63dc6c7b1b2
Partially-implement and disable pat-and syntax
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
157
diff
changeset
|
381 |
;; ((3) (if (equal? (cadr seq) HASH-QNAME) |
d63dc6c7b1b2
Partially-implement and disable pat-and syntax
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
157
diff
changeset
|
382 |
;; (make-node 'pat-and |
d63dc6c7b1b2
Partially-implement and disable pat-and syntax
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
157
diff
changeset
|
383 |
;; 'left (x-pattern-atom (car seq)) |
d63dc6c7b1b2
Partially-implement and disable pat-and syntax
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
157
diff
changeset
|
384 |
;; 'right (x-pattern-atom (caddr seq))))) |
150 | 385 |
((1) (x-pattern-atom (car seq))) |
386 |
((0) (make-node 'pat-tuple 'elements '())) |
|
387 |
(else |
|
388 |
(error "Invalid pattern syntax" seq))))) |
|
389 |
||
390 |
(define (x-pattern-atom n) |
|
391 |
(cond |
|
157
d75556d42df4
Introduce paren?, brack? and brace?.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
155
diff
changeset
|
392 |
((paren? n) (x-pattern (cdr n))) |
155
55b1a3a813eb
Expand namespaces during parse step
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
153
diff
changeset
|
393 |
((qname? n) (make-node 'pat-binding 'name (expand-qnames n nsenv))) |
150 | 394 |
((eq? n '_) (make-node 'pat-discard)) |
161
08de2e3e81e5
Don't support strings/streams in patterns yet
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
158
diff
changeset
|
395 |
((string? n) |
08de2e3e81e5
Don't support strings/streams in patterns yet
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
158
diff
changeset
|
396 |
;;(make-node 'pat-lit 'value n) |
08de2e3e81e5
Don't support strings/streams in patterns yet
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
158
diff
changeset
|
397 |
(error "Strings or streams in patterns not yet supported")) |
157
d75556d42df4
Introduce paren?, brack? and brace?.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
155
diff
changeset
|
398 |
((number? n) (make-node 'pat-lit 'value n)) |
d75556d42df4
Introduce paren?, brack? and brace?.
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
155
diff
changeset
|
399 |
(else (error "Invalid pattern atom" n)))) |
150 | 400 |
|
401 |
(x n))) |
|
402 |
||
403 |
;;; Local Variables: |
|
404 |
;;; eval: (put 'packrat-lambda 'scheme-indent-function 1) |
|
405 |
;;; End: |