Re: PEG Parser

[Noah Lavine <noah.b.lavine@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 2220 bytes --]

Hello,

I tried looking at it a bit. First of all, your cleanups are awesome. :)

Unfortunately, I need to ask for help in order to work on this more. I
thought I would first move the code-generating functions to their own
module. It seems like this should be a simple and obviously-correct
transformation, because I didn't change any code - just moved it to
its own module, and replaced its definition by a (use-modules ...)
clause. Yet I have somehow created an error, and I don't see why. If
you have time, could someone please explain why the attached patch
does not work? I am afraid there is some interaction between modules
and syntax generators that I don't understand.

The patch will apply to the wip-mlucy branch.

Thanks,
Noah

On Fri, Feb 18, 2011 at 5:03 PM, Andy Wingo <wingo@pobox.com> wrote:
> On Wed 02 Feb 2011 01:26, Noah Lavine <noah.b.lavine@gmail.com> writes:
>
>> Here it is! All of the unhygienic syntax is gone, is a series of only
>> 20 commits. :-) The peg.test tests should all pass after each one of
>> these commits.
>
> Thanks!  You've probably seen that I've applied this to wip-mlucy, which
> we should probably rename wip-peg.  I've also added on a number of
> cleanups of my own, some of which I will push out shortly when my ISP
> figures out the route to git.sv.gnu.org again (hah).
>
> The branch still needs some work before it can go in.  I have a feeling
> that it should probably be split into two modules -- one providing the
> things that peg-sexp-compile needs (minus `peg' patterns perhaps?) and
> another that uses the "base" library to define a PEG grammar.  Perhaps?
> In any case we need to not have the entire thing in one big ol'
> eval-when.
>
> Also, the documentation needs some help, and perhaps the patterns need
> some tweaking -- for example (& pat) makes more sense than (body & pat
> 1) or the like.
>
> I think Michael's work was pretty great, especially considering the
> scope of the problem.  It has the potential to have so wide an impact
> that we should focus on making it have exactly the right interface
> before we merge it in.
>
> Onwards, upwards, etc.!
>
> Andy
> --
> http://wingolog.org/
>

[-- Attachment #2: 0001-Move-PEG-code-generators-into-their-own-module.patch --]
[-- Type: application/octet-stream, Size: 19365 bytes --]

From 20692168cdb84c51bdcf3266572ed6619fd9c9cc Mon Sep 17 00:00:00 2001
From: Noah Lavine <nlavine@haverford.edu>
Date: Wed, 23 Feb 2011 10:03:45 -0500
Subject: [PATCH] Move PEG code generators into their own module

 * module/ice-9/peg.scm: take out the cg-* functions and peg-sexp-compile
 * module/ice-9/peg/codegen.scm: and put them in here.
---
 module/ice-9/peg.scm         |  214 +-------------------------------------
 module/ice-9/peg/codegen.scm |  237 ++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 242 insertions(+), 209 deletions(-)
 create mode 100644 module/ice-9/peg/codegen.scm

diff --git a/module/ice-9/peg.scm b/module/ice-9/peg.scm
index d91a74e..0d60e73 100644
--- a/module/ice-9/peg.scm
+++ b/module/ice-9/peg.scm
@@ -18,8 +18,7 @@
 ;;;;
 
 (define-module (ice-9 peg)
-  #:export (peg-sexp-compile
-            peg-string-compile
+  #:export (peg-string-compile
             context-flatten
             peg-parse
             define-nonterm
@@ -35,7 +34,9 @@
             peg-record?
             keyword-flatten)
   #:use-module (system base pmatch)
-  #:use-module (ice-9 pretty-print))
+  #:use-module (ice-9 pretty-print)
+  #:use-module (ice-9 peg codegen)
+  #:re-export (peg-sexp-compile))
 
 ;;;
 ;;; Helper Macros
@@ -64,214 +65,9 @@ execute the STMTs and try again."
     ((_ lst obj)
      (set! lst (cons obj lst)))))
 
-(define-syntax single-filter
-  (syntax-rules ()
-    "If EXP is a list of one element, return the element.  Otherwise
-return EXP."
-    ((_ exp)
-     (pmatch exp
-       ((,elt) elt)
-       (,elts elts)))))
-
-(define-syntax push-not-null!
-  (syntax-rules ()
-    "If OBJ is non-null, push it onto LST, otherwise do nothing."
-    ((_ lst obj)
-     (if (not (null? obj))
-         (push! lst obj)))))
-
 (eval-when (compile load eval)
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;; CODE GENERATORS
-;; These functions generate scheme code for parsing PEGs.
-;; Conventions:
-;;   accum: (all name body none)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; Code we generate will have a certain return structure depending on how we're
-;; accumulating (the ACCUM variable).
-(define (cg-generic-ret accum name body-uneval at)
-  ;; name, body-uneval and at are syntax
-  #`(let ((body #,body-uneval))
-     #,(cond
-        ((and (eq? accum 'all) name)
-         #`(list #,at
-                 (cond
-                  ((not (list? body)) (list '#,name body))
-                  ((null? body) '#,name)
-                  ((symbol? (car body)) (list '#,name body))
-                  (else (cons '#,name body)))))
-        ((eq? accum 'name)
-         #`(list #,at '#,name))
-        ((eq? accum 'body)
-         #`(list #,at
-                 (cond
-                  ((single? body) (car body))
-                  (else body))))
-        ((eq? accum 'none)
-         #`(list #,at '()))
-        (else
-         (begin
-           (pretty-print `(cg-generic-ret-error ,accum ,name ,body-uneval ,at))
-           (pretty-print "Defaulting to accum of none.\n")
-           #`(list #,at '()))))))
-
-;; The short name makes the formatting below much easier to read.
-(define cggr cg-generic-ret)
-
-;; Generates code that matches a particular string.
-;; E.g.: (cg-string syntax "abc" 'body)
-(define (cg-string pat accum)
-  (let ((plen (string-length pat)))
-    #`(lambda (str len pos)
-        (let ((end (+ pos #,plen)))
-          (and (<= end len)
-               (string= str #,pat pos end)
-               #,(case accum
-                   ((all) #`(list end (list 'cg-string #,pat)))
-                   ((name) #`(list end 'cg-string))
-                   ((body) #`(list end #,pat))
-                   ((none) #`(list end '()))
-                   (else (error "bad accum" accum))))))))
-
-;; Generates code for matching any character.
-;; E.g.: (cg-peg-any syntax 'body)
-(define (cg-peg-any accum)
-  #`(lambda (str len pos)
-      (and (< pos len)
-           #,(case accum
-               ((all) #`(list (1+ pos)
-                              (list 'cg-peg-any (substring str pos (1+ pos)))))
-               ((name) #`(list (1+ pos) 'cg-peg-any))
-               ((body) #`(list (1+ pos) (substring str pos (1+ pos))))
-               ((none) #`(list (1+ pos) '()))
-               (else (error "bad accum" accum))))))
-
-;; Generates code for matching a range of characters between start and end.
-;; E.g.: (cg-range syntax #\a #\z 'body)
-(define (cg-range start end accum)
-  #`(lambda (str len pos)
-      (and (< pos len)
-           (let ((c (string-ref str pos)))
-             (and (char>=? c #,start)
-                  (char<=? c #,end)
-                  #,(case accum
-                      ((all) #`(list (1+ pos) (list 'cg-range (string c))))
-                      ((name) #`(list (1+ pos) 'cg-range))
-                      ((body) #`(list (1+ pos) (string c)))
-                      ((none) #`(list (1+ pos) '()))
-                      (else (error "bad accum" accum))))))))
-
-;; Filters the accum argument to peg-sexp-compile for buildings like string
-;; literals (since we don't want to tag them with their name if we're doing an
-;; "all" accum).
-(define (builtin-accum-filter accum)
-  (cond
-   ((eq? accum 'all) 'body)
-   ((eq? accum 'name) 'name)
-   ((eq? accum 'body) 'body)
-   ((eq? accum 'none) 'none)))
-(define baf builtin-accum-filter)
-
-;; Takes an arbitrary expressions and accumulation variable, then parses it.
-;; E.g.: (peg-sexp-compile syntax '(and "abc" (or "-" (range #\a #\z))) 'all)
-(define (peg-sexp-compile pat accum)
-  (syntax-case pat (peg-any range ignore capture peg and or body)
-    (peg-any
-     (cg-peg-any (baf accum)))
-    (sym (identifier? #'sym) ;; nonterminal
-     #'sym)
-    (str (string? (syntax->datum #'str)) ;; literal string
-     (cg-string (syntax->datum #'str) (baf accum)))
-    ((range start end) ;; range of characters (e.g. [a-z])
-     (and (char? (syntax->datum #'start)) (char? (syntax->datum #'end)))
-     (cg-range (syntax->datum #'start) (syntax->datum #'end) (baf accum)))
-    ((ignore pat) ;; match but don't parse
-     (peg-sexp-compile #'pat 'none))
-    ((capture pat) ;; parse
-     (peg-sexp-compile #'pat 'body))
-    ((peg pat)  ;; embedded PEG string
-     (string? (syntax->datum #'pat))
-     (peg-string-compile #'pat (baf accum)))
-    ((and pat ...)
-     (cg-and #'(pat ...) (baf accum)))
-    ((or pat ...)
-     (cg-or #'(pat ...) (baf accum)))
-    ((body type pat num)
-     (cg-body (baf accum) #'type #'pat #'num))))
-
-;; Top-level function builder for AND.  Reduces to a call to CG-AND-INT.
-(define (cg-and clauses accum)
-  #`(lambda (str len pos)
-      (let ((body '()))
-        #,(cg-and-int clauses accum #'str #'len #'pos #'body))))
-
-;; Internal function builder for AND (calls itself).
-(define (cg-and-int clauses accum str strlen at body)
-  (syntax-case clauses ()
-    (()
-     (cggr accum 'cg-and #`(reverse #,body) at))
-    ((first rest ...)
-     #`(let ((res (#,(peg-sexp-compile #'first accum) #,str #,strlen #,at)))
-         (and res 
-              ;; update AT and BODY then recurse
-              (let ((newat (car res))
-                    (newbody (cadr res)))
-                (set! #,at newat)
-                (push-not-null! #,body (single-filter newbody))
-                #,(cg-and-int #'(rest ...) accum str strlen at body)))))))
-
-;; Top-level function builder for OR.  Reduces to a call to CG-OR-INT.
-(define (cg-or clauses accum)
-  #`(lambda (str len pos)
-      #,(cg-or-int clauses accum #'str #'len #'pos)))
-
-;; Internal function builder for OR (calls itself).
-(define (cg-or-int clauses accum str strlen at)
-  (syntax-case clauses ()
-    (()
-     #f)
-    ((first rest ...)
-     #`(or (#,(peg-sexp-compile #'first accum) #,str #,strlen #,at)
-           #,(cg-or-int #'(rest ...) accum str strlen at)))))
-
-;; Returns a function that parses a BODY element.
-(define (cg-body accum type pat num)
-  #`(lambda (str strlen at)
-      (let ((body '()))
-        (let lp ((end at) (count 0))
-          (let* ((match (#,(peg-sexp-compile pat accum) str strlen end))
-                 (new-end (if match (car match) end))
-                 (count (if (> new-end end) (1+ count) count)))
-            (if (> new-end end)
-                (push-not-null! body (single-filter (cadr match))))
-            (if (and (> new-end end)
-                     #,(syntax-case num (+ * ?)
-                         (n (number? (syntax->datum #'n))
-                            #'(< count n))
-                         (+ #t)
-                         (* #t)
-                         (? #'(< count 1))))
-                (lp new-end count)
-                (let ((success #,(syntax-case num (+ * ?)
-                                   (n (number? (syntax->datum #'n))
-                                      #'(= count n))
-                                   (+ #'(>= count 1))
-                                   (* #t)
-                                   (? #t))))
-                  #,(syntax-case type (! & lit)
-                      (!
-                       #`(if success
-                             #f
-                             #,(cggr accum 'cg-body #''() #'at)))
-                      (&
-                       #`(and success
-                              #,(cggr accum 'cg-body #''() #'at)))
-                      (lit
-                       #`(and success
-                              #,(cggr accum 'cg-body #'(reverse body) #'new-end)))))))))))
-
+(use-modules (ice-9 peg codegen))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;;; FOR DEFINING AND USING NONTERMINALS
diff --git a/module/ice-9/peg/codegen.scm b/module/ice-9/peg/codegen.scm
new file mode 100644
index 0000000..879e2cb
--- /dev/null
+++ b/module/ice-9/peg/codegen.scm
@@ -0,0 +1,237 @@
+;;;; codegen.scm --- code generation for PEG parsers
+;;;;
+;;;; 	Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+
+(define-module (ice-9 peg codegen)
+  #:export (peg-sexp-compile)
+  #:use-module (ice-9 peg)
+  #:use-module (ice-9 pretty-print))
+
+(define-syntax single?
+  (syntax-rules ()
+    "Return #t if X is a list of one element."
+    ((_ x)
+     (pmatch x
+       ((_) #t)
+       (else #f)))))
+
+(define-syntax single-filter
+  (syntax-rules ()
+    "If EXP is a list of one element, return the element.  Otherwise
+return EXP."
+    ((_ exp)
+     (pmatch exp
+       ((,elt) elt)
+       (,elts elts)))))
+
+(define-syntax push-not-null!
+  (syntax-rules ()
+    "If OBJ is non-null, push it onto LST, otherwise do nothing."
+    ((_ lst obj)
+     (if (not (null? obj))
+         (push! lst obj)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;; CODE GENERATORS
+;; These functions generate scheme code for parsing PEGs.
+;; Conventions:
+;;   accum: (all name body none)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Code we generate will have a certain return structure depending on how we're
+;; accumulating (the ACCUM variable).
+(define (cg-generic-ret accum name body-uneval at)
+  ;; name, body-uneval and at are syntax
+  #`(let ((body #,body-uneval))
+     #,(cond
+        ((and (eq? accum 'all) name)
+         #`(list #,at
+                 (cond
+                  ((not (list? body)) (list '#,name body))
+                  ((null? body) '#,name)
+                  ((symbol? (car body)) (list '#,name body))
+                  (else (cons '#,name body)))))
+        ((eq? accum 'name)
+         #`(list #,at '#,name))
+        ((eq? accum 'body)
+         #`(list #,at
+                 (cond
+                  ((single? body) (car body))
+                  (else body))))
+        ((eq? accum 'none)
+         #`(list #,at '()))
+        (else
+         (begin
+           (pretty-print `(cg-generic-ret-error ,accum ,name ,body-uneval ,at))
+           (pretty-print "Defaulting to accum of none.\n")
+           #`(list #,at '()))))))
+
+;; The short name makes the formatting below much easier to read.
+(define cggr cg-generic-ret)
+
+;; Generates code that matches a particular string.
+;; E.g.: (cg-string syntax "abc" 'body)
+(define (cg-string pat accum)
+  (let ((plen (string-length pat)))
+    #`(lambda (str len pos)
+        (let ((end (+ pos #,plen)))
+          (and (<= end len)
+               (string= str #,pat pos end)
+               #,(case accum
+                   ((all) #`(list end (list 'cg-string #,pat)))
+                   ((name) #`(list end 'cg-string))
+                   ((body) #`(list end #,pat))
+                   ((none) #`(list end '()))
+                   (else (error "bad accum" accum))))))))
+
+;; Generates code for matching any character.
+;; E.g.: (cg-peg-any syntax 'body)
+(define (cg-peg-any accum)
+  #`(lambda (str len pos)
+      (and (< pos len)
+           #,(case accum
+               ((all) #`(list (1+ pos)
+                              (list 'cg-peg-any (substring str pos (1+ pos)))))
+               ((name) #`(list (1+ pos) 'cg-peg-any))
+               ((body) #`(list (1+ pos) (substring str pos (1+ pos))))
+               ((none) #`(list (1+ pos) '()))
+               (else (error "bad accum" accum))))))
+
+;; Generates code for matching a range of characters between start and end.
+;; E.g.: (cg-range syntax #\a #\z 'body)
+(define (cg-range start end accum)
+  #`(lambda (str len pos)
+      (and (< pos len)
+           (let ((c (string-ref str pos)))
+             (and (char>=? c #,start)
+                  (char<=? c #,end)
+                  #,(case accum
+                      ((all) #`(list (1+ pos) (list 'cg-range (string c))))
+                      ((name) #`(list (1+ pos) 'cg-range))
+                      ((body) #`(list (1+ pos) (string c)))
+                      ((none) #`(list (1+ pos) '()))
+                      (else (error "bad accum" accum))))))))
+
+;; Filters the accum argument to peg-sexp-compile for buildings like string
+;; literals (since we don't want to tag them with their name if we're doing an
+;; "all" accum).
+(define (builtin-accum-filter accum)
+  (cond
+   ((eq? accum 'all) 'body)
+   ((eq? accum 'name) 'name)
+   ((eq? accum 'body) 'body)
+   ((eq? accum 'none) 'none)))
+(define baf builtin-accum-filter)
+
+;; Takes an arbitrary expressions and accumulation variable, then parses it.
+;; E.g.: (peg-sexp-compile syntax '(and "abc" (or "-" (range #\a #\z))) 'all)
+(define (peg-sexp-compile pat accum)
+  (syntax-case pat (peg-any range ignore capture peg and or body)
+    (peg-any
+     (cg-peg-any (baf accum)))
+    (sym (identifier? #'sym) ;; nonterminal
+     #'sym)
+    (str (string? (syntax->datum #'str)) ;; literal string
+     (cg-string (syntax->datum #'str) (baf accum)))
+    ((range start end) ;; range of characters (e.g. [a-z])
+     (and (char? (syntax->datum #'start)) (char? (syntax->datum #'end)))
+     (cg-range (syntax->datum #'start) (syntax->datum #'end) (baf accum)))
+    ((ignore pat) ;; match but don't parse
+     (peg-sexp-compile #'pat 'none))
+    ((capture pat) ;; parse
+     (peg-sexp-compile #'pat 'body))
+    ((peg pat)  ;; embedded PEG string
+     (string? (syntax->datum #'pat))
+     (peg-string-compile #'pat (baf accum)))
+    ((and pat ...)
+     (cg-and #'(pat ...) (baf accum)))
+    ((or pat ...)
+     (cg-or #'(pat ...) (baf accum)))
+    ((body type pat num)
+     (cg-body (baf accum) #'type #'pat #'num))))
+
+;; Top-level function builder for AND.  Reduces to a call to CG-AND-INT.
+(define (cg-and clauses accum)
+  #`(lambda (str len pos)
+      (let ((body '()))
+        #,(cg-and-int clauses accum #'str #'len #'pos #'body))))
+
+;; Internal function builder for AND (calls itself).
+(define (cg-and-int clauses accum str strlen at body)
+  (syntax-case clauses ()
+    (()
+     (cggr accum 'cg-and #`(reverse #,body) at))
+    ((first rest ...)
+     #`(let ((res (#,(peg-sexp-compile #'first accum) #,str #,strlen #,at)))
+         (and res 
+              ;; update AT and BODY then recurse
+              (let ((newat (car res))
+                    (newbody (cadr res)))
+                (set! #,at newat)
+                (push-not-null! #,body (single-filter newbody))
+                #,(cg-and-int #'(rest ...) accum str strlen at body)))))))
+
+;; Top-level function builder for OR.  Reduces to a call to CG-OR-INT.
+(define (cg-or clauses accum)
+  #`(lambda (str len pos)
+      #,(cg-or-int clauses accum #'str #'len #'pos)))
+
+;; Internal function builder for OR (calls itself).
+(define (cg-or-int clauses accum str strlen at)
+  (syntax-case clauses ()
+    (()
+     #f)
+    ((first rest ...)
+     #`(or (#,(peg-sexp-compile #'first accum) #,str #,strlen #,at)
+           #,(cg-or-int #'(rest ...) accum str strlen at)))))
+
+;; Returns a function that parses a BODY element.
+(define (cg-body accum type pat num)
+  #`(lambda (str strlen at)
+      (let ((body '()))
+        (let lp ((end at) (count 0))
+          (let* ((match (#,(peg-sexp-compile pat accum) str strlen end))
+                 (new-end (if match (car match) end))
+                 (count (if (> new-end end) (1+ count) count)))
+            (if (> new-end end)
+                (push-not-null! body (single-filter (cadr match))))
+            (if (and (> new-end end)
+                     #,(syntax-case num (+ * ?)
+                         (n (number? (syntax->datum #'n))
+                            #'(< count n))
+                         (+ #t)
+                         (* #t)
+                         (? #'(< count 1))))
+                (lp new-end count)
+                (let ((success #,(syntax-case num (+ * ?)
+                                   (n (number? (syntax->datum #'n))
+                                      #'(= count n))
+                                   (+ #'(>= count 1))
+                                   (* #t)
+                                   (? #t))))
+                  #,(syntax-case type (! & lit)
+                      (!
+                       #`(if success
+                             #f
+                             #,(cggr accum 'cg-body #''() #'at)))
+                      (&
+                       #`(and success
+                              #,(cggr accum 'cg-body #''() #'at)))
+                      (lit
+                       #`(and success
+                              #,(cggr accum 'cg-body #'(reverse body) #'new-end)))))))))))
-- 
1.7.4