smalltalk-tng
view r2/parsetng.scm @ 323:454c18798969
merger
| author | Tony Garnock-Jones <tonygarnockjones@gmail.com> |
|---|---|
| date | Tue Feb 07 11:34:20 2012 -0500 (3 months ago) |
| parents | 647b42f45a3f |
| children |
line source
1 (define (port-results filename p)
2 (base-generator->results
3 (let ((ateof #f)
4 (pos (top-parse-position filename)))
5 (lambda ()
6 (if ateof
7 (values pos #f)
8 (let ((x (read-char p)))
9 (if (eof-object? x)
10 (begin
11 (set! ateof #t)
12 (values pos #f))
13 (let ((old-pos pos))
14 (set! pos (update-parse-position pos x))
15 (values old-pos (cons x x))))))))))
17 (define (string-results filename s)
18 (base-generator->results
19 (let ((idx 0)
20 (len (string-length s))
21 (pos (top-parse-position filename)))
22 (lambda ()
23 (if (= idx len)
24 (values pos #f)
25 (let ((x (string-ref s idx))
26 (old-pos pos))
27 (set! pos (update-parse-position pos x))
28 (set! idx (+ idx 1))
29 (values old-pos (cons x x))))))))
31 (define (parse-result->value error-text result)
32 (if (parse-result-successful? result)
33 (parse-result-semantic-value result)
34 (error error-text
35 (let ((e (parse-result-error result)))
36 (list error-text
37 (parse-position->string (parse-error-position e))
38 (parse-error-expected e)
39 (parse-error-messages e))))))
41 (define (packrat-token str)
42 (lambda (starting-results)
43 (let loop ((pos 0) (results starting-results))
44 (if (= pos (string-length str))
45 (make-result str results)
46 (if (and results (char=? (parse-results-token-value results) (string-ref str pos)))
47 (loop (+ pos 1) (parse-results-next results))
48 (make-expected-result (parse-results-position starting-results) str))))))
50 (define (parse-results-take results n)
51 (let loop ((acc '())
52 (results results)
53 (n n))
54 (if (zero? n)
55 (values (list->string (reverse acc))
56 results)
57 (loop (cons (parse-results-token-value results) acc)
58 (parse-results-next results)
59 (- n 1)))))
61 (define (parse-results->pregexp-stream results)
62 (pregexp-make-stream (lambda (r)
63 (if r
64 (cons (parse-results-token-value r)
65 (parse-results-next r))
66 (cons #f #f)))
67 results))
69 (define (packrat-regex name . string-fragments)
70 (let* ((exp (string-concatenate string-fragments))
71 (re (pregexp exp)))
72 (lambda (results)
73 (let* ((stream (parse-results->pregexp-stream results))
74 (match (pregexp-match-head re stream)))
75 (if match
76 (let-values (((str next) (parse-results-take results (cdar match))))
77 (make-result str next))
78 (make-expected-result (parse-results-position results) name))))))
80 (define (packrat-cache key parser)
81 (lambda (results)
82 (results->result results key
83 (lambda ()
84 (parser results)))))
86 (define-syntax define-packrat-cached
87 (syntax-rules ()
88 ((_ (fnname results) body ...)
89 (define fnname
90 (packrat-cache 'fnname
91 (letrec ((fnname (lambda (results) body ...)))
92 fnname))))
93 ((_ fnname exp)
94 (define fnname
95 (packrat-cache 'fnname exp)))))
97 (define-values (parse-ThiNG parse-ThiNG-toplevel)
98 (let* ((p "[-+=_|/?.<>*&^%$#@!`~]")
99 (midsym (string-append "([a-zA-Z0-9]|"p")")))
100 (packrat-parser (begin
101 (define-packrat-cached (white results)
102 (if (and-let* ((ch (parse-results-token-value results)))
103 (char-whitespace? ch))
104 (white (parse-results-next results))
105 (comment results)))
106 (define-packrat-cached (comment results)
107 (if (eq? (parse-results-token-value results) #\")
108 (skip-comment-body (parse-results-next results))
109 (make-result 'whitespace results)))
110 (define (skip-comment-body results)
111 (if (eq? (parse-results-token-value results) #\")
112 (white (parse-results-next results))
113 (skip-comment-body (parse-results-next results))))
114 (define (string-body results)
115 (string-body* results '()))
116 (define (string-body* results acc)
117 (let ((ch (parse-results-token-value results))
118 (next (parse-results-next results)))
119 (if (eq? ch #\')
120 (string-body-quote next acc)
121 (string-body* next (cons ch acc)))))
122 (define (string-body-quote results acc)
123 (if (eq? (parse-results-token-value results) #\')
124 (string-body* (parse-results-next results) (cons #\' acc))
125 (make-result (list->string (reverse acc)) results)))
126 (define-packrat-cached atom (packrat-regex 'atom "[A-Z]"midsym"*"))
127 (define-packrat-cached var (packrat-regex 'var "[a-z]"midsym"*"))
128 (define-packrat-cached infixop-raw (packrat-regex 'infixop p midsym"*"))
129 (define-packrat-cached integer (packrat-regex 'integer "[0-9]+"))
130 (define (make-binary op left right)
131 `(adj ,op (tuple ,left ,right)))
132 (values tuple1 toplevel))
133 (toplevel ((d <- tuple1 white '#\; '#\;) d)
134 ((white '#f) `(atom |Quit|)))
135 (datum ((s <- tuple0) s))
136 (tuple0 ((s <- tuple1) s)
137 (() '(tuple)))
138 (tuple1 ((s <- tuple1*) (if (= (length s) 2) (cadr s) s)))
139 (tuple1* ((d <- fun white '#\, s <- tuple1*) `(tuple ,d ,@(cdr s)))
140 ((d <- fun) `(tuple ,d)))
141 (fun ((f <- fun*) f)
142 ((v <- funcall f <- fun*) `(adj ,v (quote ,f)))
143 ((v <- funcall) v))
144 (fun* ((e <- entry white d <- fun*) `(fun ,e ,@(cdr d)))
145 ((e <- entry) `(fun ,e)))
146 (entry ((k <- simple colon v <- funcall) (list k v)))
147 (semi ((white '#\; (! '#\;)) 'semi))
148 (colon ((white '#\:) 'colon))
149 (funcall ((a <- adj f <- funcall*) (f a)))
150 (funcall* ((o <- infixop b <- adj f <- funcall*)
151 (lambda (a) (f (make-binary o a b))))
152 (() (lambda (a) a)))
153 (infixop ((white r <- infixop-raw) `(var ,(string->symbol r))))
154 (adj ((left <- adj-leaf f <- adj-tail) (f left)))
155 (adj-tail ((white right <- adj-leaf f <- adj-tail)
156 (lambda (left) (f `(adj ,left ,right))))
157 (() (lambda (left) left)))
158 (adj-leaf ((v <- simple (! colon)) v))
159 (simple ((white d1 <- simple1) d1))
160 (simple1 (('#\( o <- infixop white '#\)) o)
161 (('#\( d <- datum white '#\)) d)
162 (('#\[ d <- datum white '#\]) `(quote ,d))
163 (('#\{ d <- datum white '#\}) `(meta-quote ,d))
164 ((l <- literal) `(lit ,l))
165 ((a <- var) `(var ,(string->symbol a)))
166 ((a <- atom) `(atom ,(string->symbol a)))
167 (('#\' s <- string-body) `(atom ,(string->symbol s)))
168 (('#\_) `(discard)))
169 (literal ((i <- integer) (string->number i))
170 (('#\- i <- integer) (- (string->number i)))))))
172 (define read-ThiNG
173 (lambda ()
174 (parse-result->value "While parsing ThiNG"
175 (parse-ThiNG-toplevel (port-results "stdin" (current-input-port))))))
177 (define string->ThiNG
178 (lambda (s)
179 (parse-result->value "While parsing ThiNG"
180 (parse-ThiNG (string-results "<string>" s)))))