smalltalk-tng
view r1/packrat.scm @ 323:454c18798969
merger
| author | Tony Garnock-Jones <tonygarnockjones@gmail.com> |
|---|---|
| date | Tue Feb 07 11:34:20 2012 -0500 (3 months ago) |
| parents | |
| children |
line source
1 ;; Packrat Parser Library
3 (require 'srfi-1)
5 (define-record-type parse-result
6 (make-parse-result successful? semantic-value next error)
7 parse-result?
8 (successful? parse-result-successful?)
9 (semantic-value parse-result-semantic-value)
10 (next parse-result-next) ;; #f, if eof or error; otherwise a parse-results
11 (error parse-result-error)
12 ;; ^^ #f if none, but usually a parse-error structure
13 )
15 (define-record-type parse-results
16 (make-parse-results position base next map)
17 parse-results?
18 (position parse-results-position) ;; a parse-position or #f if unknown
19 (base parse-results-base) ;; a value, #f indicating 'none' or 'eof'
20 (next parse-results-next* set-parse-results-next!)
21 ;; ^^ a parse-results, or a nullary function delivering same, or #f for nothing next (eof)
22 (map parse-results-map set-parse-results-map!)
23 ;; ^^ an alist mapping a nonterminal to a parse-result
24 )
26 (define-record-type parse-error
27 (make-parse-error position expected-strings messages)
28 parse-error?
29 (position parse-error-position) ;; a parse-position or #f if unknown
30 (expected-strings parse-error-expected-strings) ;; set of strings (lset)
31 (messages parse-error-messages) ;; list of strings
32 )
34 (define-record-type parse-position
35 (make-parse-position file line column)
36 parse-position?
37 (file parse-position-file)
38 (line parse-position-line)
39 (column parse-position-column))
41 (define (top-parse-position filename)
42 (make-parse-position filename 1 0))
44 (define (update-parse-position pos ch)
45 (if (not pos)
46 #f
47 (let ((file (parse-position-file pos))
48 (line (parse-position-line pos))
49 (column (parse-position-column pos)))
50 (cond
51 ((eq? ch #\return) (make-parse-position file line 0))
52 ((eq? ch #\newline) (make-parse-position file (+ line 1) 0))
53 ((eq? ch #\tab) (make-parse-position file line (* (quotient (+ column 8) 8) 8)))
54 (else (make-parse-position file line (+ column 1)))))))
56 (define (parse-position->string pos)
57 (if (not pos)
58 "<??>"
59 (string-append (parse-position-file pos) ":"
60 (number->string (parse-position-line pos)) ":"
61 (number->string (parse-position-column pos)))))
63 (define (empty-results pos)
64 (make-parse-results pos #f #f '()))
66 (define (make-results pos base next-generator)
67 (make-parse-results pos base next-generator '()))
69 (define (make-error-expected pos str)
70 (make-parse-error pos (list str) '()))
72 (define (make-error-message pos msg)
73 (make-parse-error pos '() (list msg)))
75 (define (make-result semantic-value next)
76 (make-parse-result #t semantic-value next #f))
78 (define (make-expected-result pos str)
79 (make-parse-result #f #f #f (make-error-expected pos str)))
81 (define (make-message-result pos msg)
82 (make-parse-result #f #f #f (make-error-message pos msg)))
84 (define (prepend-base pos base next)
85 (make-parse-results pos base next '()))
87 (define (prepend-semantic-value pos key result next)
88 (make-parse-results pos #f #f
89 (list (cons key (make-result result next)))))
91 (define (base-generator->results generator)
92 ;; Note: applies first next-generator, to get first result
93 (define (results-generator)
94 (let-values (((pos base) (generator)))
95 (if (not base)
96 (empty-results pos)
97 (make-results pos base results-generator))))
98 (results-generator))
100 (define (parse-results-next results)
101 (let ((next (parse-results-next* results)))
102 (if (procedure? next)
103 (let ((next-value (next)))
104 (set-parse-results-next! results next-value)
105 next-value)
106 next)))
108 (define (results->result results key fn)
109 (let ((results-map (parse-results-map results)))
110 (cond
111 ((assq key results-map) => cdr)
112 (else (let ((result (fn)))
113 (set-parse-results-map! results (cons (cons key result) results-map))
114 result)))))
116 (define (parse-position>? a b)
117 (cond
118 ((not a) #f)
119 ((not b) #t)
120 (else (let ((la (parse-position-line a)) (lb (parse-position-line b)))
121 (or (> la lb)
122 (and (= la lb)
123 (> (parse-position-column a) (parse-position-column b))))))))
125 (define (parse-error-empty? e)
126 (and (null? (parse-error-expected-strings e))
127 (null? (parse-error-messages e))))
129 (define (merge-parse-errors e1 e2)
130 (cond
131 ((not e1) e2)
132 ((not e2) e1)
133 (else
134 (let ((p1 (parse-error-position e1))
135 (p2 (parse-error-position e2)))
136 (cond
137 ((or (parse-position>? p1 p2) (parse-error-empty? e2)) e1)
138 ((or (parse-position>? p2 p1) (parse-error-empty? e1)) e2)
139 (else (make-parse-error p1
140 (lset-union string=?
141 (parse-error-expected-strings e1)
142 (parse-error-expected-strings e2))
143 (append (parse-error-messages e1) (parse-error-messages e2)))))))))
145 (define (merge-result-errors result errs)
146 (make-parse-result (parse-result-successful? result)
147 (parse-result-semantic-value result)
148 (parse-result-next result)
149 (merge-parse-errors (parse-result-error result) errs)))
151 ;---------------------------------------------------------------------------
153 (define (parse-results-token-kind results)
154 (let ((base (parse-results-base results)))
155 (and base (car base))))
157 (define (parse-results-token-value results)
158 (let ((base (parse-results-base results)))
159 (and base (cdr base))))
161 (define (packrat-check-base token-kind k)
162 (lambda (results)
163 (let ((base (parse-results-base results)))
164 (if (eq? (and base (car base)) token-kind)
165 ((k (and base (cdr base))) (parse-results-next results))
166 (make-expected-result (parse-results-position results)
167 (if (not token-kind)
168 "end-of-file"
169 (symbol->string token-kind)))))))
171 (define (packrat-check parser k)
172 (lambda (results)
173 (let ((result (parser results)))
174 (if (parse-result-successful? result)
175 (merge-result-errors ((k (parse-result-semantic-value result))
176 (parse-result-next result))
177 (parse-result-error result))
178 result))))
180 (define (packrat-or p1 p2)
181 (lambda (results)
182 (let ((result (p1 results)))
183 (if (parse-result-successful? result)
184 result
185 (merge-result-errors (p2 results)
186 (parse-result-error result))))))
188 (define (packrat-unless explanation p1 p2)
189 (lambda (results)
190 (let ((result (p1 results)))
191 (if (parse-result-successful? result)
192 (make-message-result (parse-results-position results)
193 explanation)
194 (p2 results)))))
196 ;---------------------------------------------------------------------------
198 (define (object->external-representation o)
199 (let ((s (open-output-string)))
200 (write o s)
201 (get-output-string s)))
203 (define-syntax packrat-parser
204 (syntax-rules (<- quote ! @ /)
205 ((_ start (nonterminal (alternative body0 body ...) ...) ...)
206 (let ()
207 (define nonterminal
208 (lambda (results)
209 (results->result results 'nonterminal
210 (lambda ()
211 ((packrat-parser #f "alts" nonterminal
212 ((begin body0 body ...) alternative) ...)
213 results)))))
214 ...
215 start))
217 ((_ #f "alts" nt (body alternative))
218 (packrat-parser #f "altD" nt body alternative))
220 ((_ #f "alts" nt (body alternative) rest0 rest ...)
221 (packrat-or (packrat-parser #f "altD" nt body alternative)
222 (packrat-parser #f "alts" nt rest0 rest ...)))
224 ((_ #f "altD" nt body alternative)
225 (lambda (results)
226 ;;(write (list (parse-position->string (parse-results-position results))
227 ;;'trying- 'nt 'alternative))
228 ;;(newline)
229 (let ((result ((packrat-parser #f "alt" nt body alternative) results)))
230 ;;(write (list (parse-position->string
231 ;;(parse-results-position results))
232 ;;(if (parse-result-successful? result)
233 ;;'success
234 ;;'failing)
235 ;;'nt 'alternative))
236 ;;(newline)
237 result)))
239 ((_ #f "alt" nt body ())
240 (lambda (results) (make-result body results)))
242 ((_ #f "alt" nt body ((! fails ...) rest ...))
243 (packrat-unless (string-append "Nonterminal " (symbol->string 'nt)
244 " expected to fail "
245 (object->external-representation '(fails ...)))
246 (packrat-parser #f "alt" nt #t (fails ...))
247 (packrat-parser #f "alt" nt body (rest ...))))
249 ((_ #f "alt" nt body ((/ alternative ...) rest ...))
250 (packrat-check (packrat-parser #f "alts" nt (#t alternative) ...)
251 (lambda (result) (packrat-parser #f "alt" nt body (rest ...)))))
253 ((_ #f "alt" nt body (var <- 'val rest ...))
254 (packrat-check-base 'val
255 (lambda (var)
256 (packrat-parser #f "alt" nt body (rest ...)))))
258 ((_ #f "alt" nt body (var <- @ rest ...))
259 (lambda (results)
260 (let ((var (parse-results-position results)))
261 ((packrat-parser #f "alt" nt body (rest ...)) results))))
263 ((_ #f "alt" nt body (var <- val rest ...))
264 (packrat-check val
265 (lambda (var)
266 (packrat-parser #f "alt" nt body (rest ...)))))
268 ((_ #f "alt" nt body ('val rest ...))
269 (packrat-check-base 'val
270 (lambda (dummy)
271 (packrat-parser #f "alt" nt body (rest ...)))))
273 ((_ #f "alt" nt body (val rest ...))
274 (packrat-check val
275 (lambda (dummy)
276 (packrat-parser #f "alt" nt body (rest ...)))))))
278 '(define (x)
279 (sc-expand
280 '(packrat-parser expr
281 (expr ((a <- 'num '+ b <- 'num)
282 (+ a b))
283 ((a <- mulexp) a))
284 (mulexp ((a <- 'num '* b <- 'num)
285 (* a b))))))