smalltalk-tng
view etng-r1/alternaparse.scm @ 321:c4a0718c2d3c
Sketch of dependencies
| author | Tony Garnock-Jones <tonygarnockjones@gmail.com> |
|---|---|
| date | Sat Oct 08 15:36:03 2011 -0400 (7 months ago) |
| parents | d63dc6c7b1b2 |
| children |
line source
1 (define etng-naked-id-terminators (string->list "`.()[]{}:;,'\""))
3 (define (char-etng-id-alpha? ch)
4 (or (char-alphabetic? ch)
5 (eqv? ch #\_)))
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))))
13 (define EMPTY-SYMBOL (string->symbol ""))
14 (define QUOTE-QNAME (make-qname EMPTY-SYMBOL 'quote))
15 (define UNQUOTE-QNAME (make-qname EMPTY-SYMBOL 'unquote))
16 (define SEMI-QNAME (make-qname #f (string->symbol ";")))
17 (define COMMA-QNAME (make-qname #f (string->symbol ",")))
18 (define EQUAL-QNAME (make-qname #f '=))
19 (define ARROW-QNAME (make-qname #f '->))
20 (define NAMESPACE-QNAME (make-qname #f 'namespace))
21 (define DO-QNAME (make-qname #f 'do))
22 (define LET-QNAME (make-qname #f 'let))
24 (define (list-interleave x xs)
25 (cond
26 ((null? xs) '())
27 ((null? (cdr xs)) xs)
28 (else (cons (car xs) (cons x (list-interleave x (cdr xs)))))))
30 (define read-etng
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 #\'))))
38 (reader
39 (packrat-parse
40 `(
41 (entry-point sexp)
43 (sexp (/ (ws #\. s <- sexp
44 ,(packrat-lambda (s) `(paren ,QUOTE-QNAME ,s)))
45 (ws #\` s <- sexp
46 ,(packrat-lambda (s) `(paren ,UNQUOTE-QNAME ,s)))
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))))
56 (sexps (/ (s <- sexp ss <- sexps ,(packrat-lambda (s ss) (cons s ss)))
57 ,(packrat-lambda () '())))
59 (leaf (/ qname
60 word
61 string))
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)
68 (make-qname #f rhs)))))
70 (id (/ (ws i <- id1 ,(packrat-lambda (i)
71 (string->symbol
72 (string-concatenate (list-interleave "'" i)))))
73 (ws #\; ,(packrat-lambda () (string->symbol ";")))
74 (ws #\, ,(packrat-lambda () (string->symbol ",")))
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))))
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)))))
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))))
100 (id-alpha (/: ,char-etng-id-alpha? "identifier-character"))
101 (id-punct (/: ,char-etng-id-punct? "punctuation-character"))
102 (digit (/: ,char-numeric? "digit"))
104 (ws (/ ((/: ,char-whitespace? "whitespace")+ ws)
105 (#\- #\- (/: ,non-eol "comment character")* (/ #\return #\newline) ws)
106 ()))
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))))))))
118 (lambda (results k-ok k-fail)
119 (read-etng results
120 k-ok
121 k-fail))))
123 (define (etng-sexp-special-match? sexps qname)
124 (and (pair? sexps)
125 (let ((tok (car sexps)))
126 (equal? tok qname))))
128 (define (paren? n) (and (pair? n) (eq? (car n) 'paren)))
129 (define (brack? n) (and (pair? n) (eq? (car n) 'brack)))
130 (define (brace? n) (and (pair? n) (eq? (car n) 'brace)))
132 (define (etng-sexp->string namespace-env n)
133 (let ()
134 (define (x n tail)
135 (cond
136 ((paren? n)
137 (cond
138 ((etng-sexp-special-match? (cdr n) QUOTE-QNAME)
139 (cons #\. (x (caddr n) tail)))
140 ((etng-sexp-special-match? (cdr n) UNQUOTE-QNAME)
141 (cons #\` (x (caddr n) tail)))
142 (else
143 (wrap #\( #\) (cdr n) tail))))
144 ((brack? n) (wrap #\[ #\] (cdr n) tail))
145 ((brace? n) (wrap #\{ #\} (cdr n) tail))
146 ((qname? n) (x-qname n tail))
147 ((string? n) (x-string n tail))
148 ((number? n) (append (string->list (number->string n)) tail))))
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))))))))
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)))
164 (define (lookup-namespace u)
165 (cond
166 ((assoc u namespace-env) => cadr)
167 (else u)))
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)))))))
179 (define (x-string str tail)
180 (cons #\" (quote-string #\" (string->list str) (cons #\" tail))))
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)))))
191 (list->string (x n '()))))
193 (define (etng-sexp-parse n nsenv)
194 (let ()
195 (define (x n)
196 (cond
197 ((paren? n) (x-seq (cdr n)))
198 ((brack? n) (x-obj 'core-object (cdr n)))
199 ((brace? n) (x-obj 'core-function (cdr n)))
200 ((qname? n) (make-node 'core-ref 'name (expand-qnames n nsenv)))
201 ((string? n) (make-node 'core-lit 'value n))
202 ((number? n) (make-node 'core-lit 'value n))
203 (else (error "Bad etng-sexp" n))))
205 (define (split elts sep)
206 (let loop ((elts elts)
207 (current '())
208 (acc '()))
209 (cond
210 ((null? elts) (reverse (cons (reverse current) acc)))
211 ((equal? (car elts) sep) (loop (cdr elts) '() (cons (reverse current) acc)))
212 (else (loop (cdr elts) (cons (car elts) current) acc)))))
214 (define (split-semi xs)
215 (filter (lambda (x) (not (null? x)))
216 (split xs SEMI-QNAME)))
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)))))))
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))
233 (x-method segments ARROW-QNAME 'core-method
234 (lambda (method remaining)
235 (loop remaining (cons method methodsrev)))
236 (lambda ()
237 (x-method segments EQUAL-QNAME 'core-constant
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)))))))))))
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))))))
271 (define (x-method-patterns segment)
272 (let ((parts (split segment COMMA-QNAME)))
273 (if (= (length parts) 1)
274 (map x-pattern-atom segment)
275 (list (x-pattern segment)))))
277 (define (special-segment? segment)
278 (and (pair? segment)
279 (or (etng-sexp-special-match? segment QUOTE-QNAME)
280 (etng-sexp-special-match? segment UNQUOTE-QNAME)
281 (etng-sexp-special-match? segment NAMESPACE-QNAME)
282 (etng-sexp-special-match? segment DO-QNAME)
283 (etng-sexp-special-match? segment LET-QNAME))))
285 (define (special-pattern-segment? segment)
286 (and (pair? segment)
287 (or (etng-sexp-special-match? segment QUOTE-QNAME))))
289 (define (special-localname n)
290 (if (qname? n)
291 (qname-localname n)
292 n))
294 (define (fun pat body)
295 (make-node 'core-function
296 'methods (list (make-node 'core-method
297 'patterns (list pat)
298 'body body))))
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))
307 ((quote) (k (make-node 'core-lit 'value (expand-qnames (cadr segment) nsenv))
308 remaining))
309 ((unquote) (error "Naked unquote" segments))
310 ((namespace) (x-namespace-declaration segment remaining k))
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))))
317 ((let) (let ((parts (split (cdr segment) EQUAL-QNAME)))
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)))))
328 (define (x-namespace-declaration segment remaining k)
329 (define (ns-wrap prefix uri)
330 (k (etng-sexp-parse `(paren ,@(concatenate (list-interleave (list SEMI-QNAME) remaining)))
331 (extend-qname-env nsenv prefix uri))
332 '()))
333 (cond
334 ((and (= (length segment) 4)
335 (qname? (cadr segment))
336 (not (qname-uri (cadr segment)))
337 (equal? (caddr segment) EQUAL-QNAME)
338 (string? (cadddr segment)))
339 (ns-wrap (qname-localname (cadr segment)) (cadddr segment)))
340 ((and (= (length segment) 2)
341 (string? (cadr segment)))
342 (ns-wrap #f (cadr segment)))
343 (else
344 (error "Invalid namespace declaration" segment))))
346 (define (x-tuple segment)
347 (parse-tuple segment 'core-tuple x-send))
349 (define (parse-tuple segment kind k)
350 (let ((elements (split segment COMMA-QNAME)))
351 (if (null? (cdr elements))
352 (k (car elements))
353 (make-node kind 'elements (map k elements)))))
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))))))
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))))))
373 (define (x-pattern segment)
374 (parse-tuple segment 'pat-tuple x-pattern-element))
376 (define (x-pattern-element seq)
377 (if (special-pattern-segment? seq)
378 (case (special-localname (car seq))
379 ((quote) (make-node 'pat-lit 'value (expand-qnames (cadr seq) nsenv))))
380 (case (length seq)
381 ;; ((3) (if (equal? (cadr seq) HASH-QNAME)
382 ;; (make-node 'pat-and
383 ;; 'left (x-pattern-atom (car seq))
384 ;; 'right (x-pattern-atom (caddr seq)))))
385 ((1) (x-pattern-atom (car seq)))
386 ((0) (make-node 'pat-tuple 'elements '()))
387 (else
388 (error "Invalid pattern syntax" seq)))))
390 (define (x-pattern-atom n)
391 (cond
392 ((paren? n) (x-pattern (cdr n)))
393 ((qname? n) (make-node 'pat-binding 'name (expand-qnames n nsenv)))
394 ((eq? n '_) (make-node 'pat-discard))
395 ((string? n)
396 ;;(make-node 'pat-lit 'value n)
397 (error "Strings or streams in patterns not yet supported"))
398 ((number? n) (make-node 'pat-lit 'value n))
399 (else (error "Invalid pattern atom" n))))
401 (x n)))
403 ;;; Local Variables:
404 ;;; eval: (put 'packrat-lambda 'scheme-indent-function 1)
405 ;;; End: