build: Separate Mes and Guile modules.
[mes.git] / mes / module / mes / peg / codegen.scm
1 ;;;; codegen.scm --- code generation for composable parsers
2 ;;;;
3 ;;;;    Copyright (C) 2011 Free Software Foundation, Inc.
4 ;;;;
5 ;;;; This library is free software; you can redistribute it and/or
6 ;;;; modify it under the terms of the GNU Lesser General Public
7 ;;;; License as published by the Free Software Foundation; either
8 ;;;; version 3 of the License, or (at your option) any later version.
9 ;;;; 
10 ;;;; This library is distributed in the hope that it will be useful,
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
13 ;;;; Lesser General Public License for more details.
14 ;;;; 
15 ;;;; You should have received a copy of the GNU Lesser General Public
16 ;;;; License along with this library; if not, write to the Free Software
17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
18 ;;;;
19
20 (define-module (ice-9 peg codegen)
21   #:export (compile-peg-pattern wrap-parser-for-users add-peg-compiler!)
22   #:use-module (ice-9 pretty-print)
23   #:use-module (system base pmatch))
24
25 (define-syntax single?
26   (syntax-rules ()
27     ;;"Return #t if X is a list of one element."
28     ((_ x)
29      (pmatch x
30        ((_) #t)
31        (else #f)))))
32
33 (define-syntax single-filter
34   (syntax-rules ()
35     ;;"If EXP is a list of one element, return the element.  Otherwise return EXP."
36     ((_ exp)
37      (pmatch exp
38        ((,elt) elt)
39        (,elts elts)))))
40
41 (define-syntax push-not-null!
42   (syntax-rules ()
43     ;;"If OBJ is non-null, push it onto LST, otherwise do nothing."
44     ((_ lst obj)
45      (if (not (null? obj))
46          (push! lst obj)))))
47
48 (define-syntax push!
49   (syntax-rules ()
50     ;;"Push an object onto a list."
51     ((_ lst obj)
52      (set! lst (cons obj lst)))))
53
54
55 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
56 ;;;;; CODE GENERATORS
57 ;; These functions generate scheme code for parsing PEGs.
58 ;; Conventions:
59 ;;   accum: (all name body none)
60 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
61
62 ;; Code we generate will have a certain return structure depending on how we're
63 ;; accumulating (the ACCUM variable).
64 (define (cg-generic-ret accum name body-uneval at)
65   ;; name, body-uneval and at are syntax
66   #`(let ((body #,body-uneval))
67      #,(cond
68         ((and (eq? accum 'all) name)
69          #`(list #,at
70                  (cond
71                   ((not (list? body)) (list '#,name body))
72                   ((null? body) '#,name)
73                   ((symbol? (car body)) (list '#,name body))
74                   (else (cons '#,name body)))))
75         ((eq? accum 'name)
76          #`(list #,at '#,name))
77         ((eq? accum 'body)
78          #`(list #,at
79                  (cond
80                   ((single? body) (car body))
81                   (else body))))
82         ((eq? accum 'none)
83          #`(list #,at '()))
84         (else
85          (begin
86            (pretty-print `(cg-generic-ret-error ,accum ,name ,body-uneval ,at))
87            (pretty-print "Defaulting to accum of none.\n")
88            #`(list #,at '()))))))
89
90 ;; The short name makes the formatting below much easier to read.
91 (define cggr cg-generic-ret)
92
93 ;; Generates code that matches a particular string.
94 ;; E.g.: (cg-string syntax "abc" 'body)
95 (define (cg-string pat accum)
96   (let ((plen (string-length pat)))
97     #`(lambda (str len pos)
98         (let ((end (+ pos #,plen)))
99           (and (<= end len)
100                (string= str #,pat pos end)
101                #,(case accum
102                    ((all) #`(list end (list 'cg-string #,pat)))
103                    ((name) #`(list end 'cg-string))
104                    ((body) #`(list end #,pat))
105                    ((none) #`(list end '()))
106                    (else (error "bad accum" accum))))))))
107
108 ;; Generates code for matching any character.
109 ;; E.g.: (cg-peg-any syntax 'body)
110 (define (cg-peg-any accum)
111   #`(lambda (str len pos)
112       (and (< pos len)
113            #,(case accum
114                ((all) #`(list (1+ pos)
115                               (list 'cg-peg-any (substring str pos (1+ pos)))))
116                ((name) #`(list (1+ pos) 'cg-peg-any))
117                ((body) #`(list (1+ pos) (substring str pos (1+ pos))))
118                ((none) #`(list (1+ pos) '()))
119                (else (error "bad accum" accum))))))
120
121 ;; Generates code for matching a range of characters between start and end.
122 ;; E.g.: (cg-range syntax #\a #\z 'body)
123 (define (cg-range pat accum)
124   (syntax-case pat ()
125     ((start end)
126      (if (not (and (char? (syntax->datum #'start))
127                    (char? (syntax->datum #'end))))
128          (error "range PEG should have characters after it; instead got"
129                 #'start #'end))
130      #`(lambda (str len pos)
131          (and (< pos len)
132               (let ((c (string-ref str pos)))
133                 (and (char>=? c start)
134                      (char<=? c end)
135                      #,(case accum
136                          ((all) #`(list (1+ pos) (list 'cg-range (string c))))
137                          ((name) #`(list (1+ pos) 'cg-range))
138                          ((body) #`(list (1+ pos) (string c)))
139                          ((none) #`(list (1+ pos) '()))
140                          (else (error "bad accum" accum))))))))))
141
142 ;; Generate code to match a pattern and do nothing with the result
143 (define (cg-ignore pat accum)
144   (syntax-case pat ()
145     ((inner)
146      (compile-peg-pattern #'inner 'none))))
147
148 (define (cg-capture pat accum)
149   (syntax-case pat ()
150     ((inner)
151      (compile-peg-pattern #'inner 'body))))
152
153 ;; Filters the accum argument to compile-peg-pattern for buildings like string
154 ;; literals (since we don't want to tag them with their name if we're doing an
155 ;; "all" accum).
156 (define (builtin-accum-filter accum)
157   (cond
158    ((eq? accum 'all) 'body)
159    ((eq? accum 'name) 'name)
160    ((eq? accum 'body) 'body)
161    ((eq? accum 'none) 'none)))
162 (define baf builtin-accum-filter)
163
164 ;; Top-level function builder for AND.  Reduces to a call to CG-AND-INT.
165 (define (cg-and clauses accum)
166   #`(lambda (str len pos)
167       (let ((body '()))
168         #,(cg-and-int clauses (baf accum) #'str #'len #'pos #'body))))
169
170 ;; Internal function builder for AND (calls itself).
171 (define (cg-and-int clauses accum str strlen at body)
172   (syntax-case clauses ()
173     (()
174      (cggr accum 'cg-and #`(reverse #,body) at))
175     ((first rest ...)
176      #`(let ((res (#,(compile-peg-pattern #'first accum) #,str #,strlen #,at)))
177          (and res 
178               ;; update AT and BODY then recurse
179               (let ((newat (car res))
180                     (newbody (cadr res)))
181                 (set! #,at newat)
182                 (push-not-null! #,body (single-filter newbody))
183                 #,(cg-and-int #'(rest ...) accum str strlen at body)))))))
184
185 ;; Top-level function builder for OR.  Reduces to a call to CG-OR-INT.
186 (define (cg-or clauses accum)
187   #`(lambda (str len pos)
188       #,(cg-or-int clauses (baf accum) #'str #'len #'pos)))
189
190 ;; Internal function builder for OR (calls itself).
191 (define (cg-or-int clauses accum str strlen at)
192   (syntax-case clauses ()
193     (()
194      #f)
195     ((first rest ...)
196      #`(or (#,(compile-peg-pattern #'first accum) #,str #,strlen #,at)
197            #,(cg-or-int #'(rest ...) accum str strlen at)))))
198
199 (define (cg-* args accum)
200   (syntax-case args ()
201     ((pat)
202      #`(lambda (str strlen at)
203          (let ((body '()))
204            (let lp ((end at) (count 0))
205              (let* ((match (#,(compile-peg-pattern #'pat (baf accum))
206                             str strlen end))
207                     (new-end (if match (car match) end))
208                     (count (if (> new-end end) (1+ count) count)))
209                (if (> new-end end)
210                    (push-not-null! body (single-filter (cadr match))))
211                (if (and (> new-end end)
212                         #,#t)
213                    (lp new-end count)
214                    (let ((success #,#t))
215                      #,#`(and success
216                                  #,(cggr (baf accum) 'cg-body
217                                          #'(reverse body) #'new-end)))))))))))
218
219 (define (cg-+ args accum)
220   (syntax-case args ()
221     ((pat)
222      #`(lambda (str strlen at)
223          (let ((body '()))
224            (let lp ((end at) (count 0))
225              (let* ((match (#,(compile-peg-pattern #'pat (baf accum))
226                             str strlen end))
227                     (new-end (if match (car match) end))
228                     (count (if (> new-end end) (1+ count) count)))
229                (if (> new-end end)
230                    (push-not-null! body (single-filter (cadr match))))
231                (if (and (> new-end end)
232                         #,#t)
233                    (lp new-end count)
234                    (let ((success #,#'(>= count 1)))
235                      #,#`(and success
236                                  #,(cggr (baf accum) 'cg-body
237                                          #'(reverse body) #'new-end)))))))))))
238
239 (define (cg-? args accum)
240   (syntax-case args ()
241     ((pat)
242      #`(lambda (str strlen at)
243          (let ((body '()))
244            (let lp ((end at) (count 0))
245              (let* ((match (#,(compile-peg-pattern #'pat (baf accum))
246                             str strlen end))
247                     (new-end (if match (car match) end))
248                     (count (if (> new-end end) (1+ count) count)))
249                (if (> new-end end)
250                    (push-not-null! body (single-filter (cadr match))))
251                (if (and (> new-end end)
252                         #,#'(< count 1))
253                    (lp new-end count)
254                    (let ((success #,#t))
255                      #,#`(and success
256                                  #,(cggr (baf accum) 'cg-body
257                                          #'(reverse body) #'new-end)))))))))))
258
259 (define (cg-followed-by args accum)
260   (syntax-case args ()
261     ((pat)
262      #`(lambda (str strlen at)
263          (let ((body '()))
264            (let lp ((end at) (count 0))
265              (let* ((match (#,(compile-peg-pattern #'pat (baf accum))
266                             str strlen end))
267                     (new-end (if match (car match) end))
268                     (count (if (> new-end end) (1+ count) count)))
269                (if (> new-end end)
270                    (push-not-null! body (single-filter (cadr match))))
271                (if (and (> new-end end)
272                         #,#'(< count 1))
273                    (lp new-end count)
274                    (let ((success #,#'(= count 1)))
275                      #,#`(and success
276                               #,(cggr (baf accum) 'cg-body #''() #'at)))))))))))
277
278 (define (cg-not-followed-by args accum)
279   (syntax-case args ()
280     ((pat)
281      #`(lambda (str strlen at)
282          (let ((body '()))
283            (let lp ((end at) (count 0))
284              (let* ((match (#,(compile-peg-pattern #'pat (baf accum))
285                             str strlen end))
286                     (new-end (if match (car match) end))
287                     (count (if (> new-end end) (1+ count) count)))
288                (if (> new-end end)
289                    (push-not-null! body (single-filter (cadr match))))
290                (if (and (> new-end end)
291                         #,#'(< count 1))
292                    (lp new-end count)
293                    (let ((success #,#'(= count 1)))
294                      #,#`(if success
295                                 #f
296                                 #,(cggr (baf accum) 'cg-body #''() #'at)))))))))))
297
298 ;; Association list of functions to handle different expressions as PEGs
299 (define peg-compiler-alist '())
300
301 (define (add-peg-compiler! symbol function)
302   (set! peg-compiler-alist
303         (assq-set! peg-compiler-alist symbol function)))
304
305 (add-peg-compiler! 'range cg-range)
306 (add-peg-compiler! 'ignore cg-ignore)
307 (add-peg-compiler! 'capture cg-capture)
308 (add-peg-compiler! 'and cg-and)
309 (add-peg-compiler! 'or cg-or)
310 (add-peg-compiler! '* cg-*)
311 (add-peg-compiler! '+ cg-+)
312 (add-peg-compiler! '? cg-?)
313 (add-peg-compiler! 'followed-by cg-followed-by)
314 (add-peg-compiler! 'not-followed-by cg-not-followed-by)
315
316 ;; Takes an arbitrary expressions and accumulation variable, then parses it.
317 ;; E.g.: (compile-peg-pattern syntax '(and "abc" (or "-" (range #\a #\z))) 'all)
318 (define (compile-peg-pattern pat accum)
319   (syntax-case pat (peg-any)
320     (peg-any
321      (cg-peg-any (baf accum)))
322     (sym (identifier? #'sym) ;; nonterminal
323      #'sym)
324     (str (string? (syntax->datum #'str)) ;; literal string
325      (cg-string (syntax->datum #'str) (baf accum)))
326     ((name . args) (let* ((nm (syntax->datum #'name))
327                           (entry (assq-ref peg-compiler-alist nm)))
328                      (if entry
329                          (entry #'args accum)
330                          (error "Bad peg form" nm #'args
331                                 "Not one of" (map car peg-compiler-alist)))))))
332
333 ;; Packages the results of a parser
334 (define (wrap-parser-for-users for-syntax parser accumsym s-syn)
335    #`(lambda (str strlen at)
336       (let ((res (#,parser str strlen at)))
337         ;; Try to match the nonterminal.
338         (if res
339             ;; If we matched, do some post-processing to figure out
340             ;; what data to propagate upward.
341             (let ((at (car res))
342                   (body (cadr res)))
343               #,(cond
344                  ((eq? accumsym 'name)
345                   #`(list at '#,s-syn))
346                  ((eq? accumsym 'all)
347                   #`(list (car res)
348                           (cond
349                            ((not (list? body))
350                             (list '#,s-syn body))
351                            ((null? body) '#,s-syn)
352                            ((symbol? (car body))
353                             (list '#,s-syn body))
354                            (else (cons '#,s-syn body)))))
355                  ((eq? accumsym 'none) #`(list (car res) '()))
356                  (else #`(begin res))))
357             ;; If we didn't match, just return false.
358             #f))))