Add '*' PEG

The s-expression representation of PEG grammars now uses a '(* ...)' form
instead of '(body lit ... *)'.

diff --git a/doc/ref/api-peg.texi b/doc/ref/api-peg.texi
index 6d0a346..63387f4 100644 (file)
--- a/doc/ref/api-peg.texi
+++ b/doc/ref/api-peg.texi
@@ -69,7 +69,7 @@ succeeds.
 
 @code{"a*"}
 
-@code{(body lit a *)}
+@code{(* a)}
 @end deftp
 
 @deftp {PEG Pattern} {one or more} a

diff --git a/module/ice-9/peg/codegen.scm b/module/ice-9/peg/codegen.scm
index e08a44b..9ef3a40 100644 (file)
--- a/module/ice-9/peg/codegen.scm
+++ b/module/ice-9/peg/codegen.scm
@@ -237,6 +237,26 @@ return EXP."
                                  #,(cggr (baf accum) 'cg-body
                                          #'(reverse body) #'new-end)))))))))))))
 
+(define (cg-* args accum)
+  (syntax-case args ()
+    ((pat)
+     #`(lambda (str strlen at)
+         (let ((body '()))
+           (let lp ((end at) (count 0))
+             (let* ((match (#,(peg-sexp-compile #'pat (baf 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)
+                        #,#t)
+                   (lp new-end count)
+                   (let ((success #,#t))
+                     #,#`(and success
+                                 #,(cggr (baf accum) 'cg-body
+                                         #'(reverse body) #'new-end)))))))))))
+
 ;; Association list of functions to handle different expressions as PEGs
 (define peg-compiler-alist '())
 
@@ -250,6 +270,7 @@ return EXP."
 (add-peg-compiler! 'and cg-and)
 (add-peg-compiler! 'or cg-or)
 (add-peg-compiler! 'body cg-body)
+(add-peg-compiler! '* cg-*)
 
 ;; Takes an arbitrary expressions and accumulation variable, then parses it.
 ;; E.g.: (peg-sexp-compile syntax '(and "abc" (or "-" (range #\a #\z))) 'all)

diff --git a/module/ice-9/peg/string-peg.scm b/module/ice-9/peg/string-peg.scm
index ed09aae..3903946 100644 (file)
--- a/module/ice-9/peg/string-peg.scm
+++ b/module/ice-9/peg/string-peg.scm
@@ -68,11 +68,11 @@ RB < ']'
   (body lit (and peg-nonterminal (or "<--" "<-" "<") peg-sp peg-pattern) +))
 (define-sexp-parser peg-pattern all
   (and peg-alternative
-       (body lit (and (ignore "/") peg-sp peg-alternative) *)))
+       (* (and (ignore "/") peg-sp peg-alternative))))
 (define-sexp-parser peg-alternative all
   (body lit (and (body lit (or "!" "&") ?) peg-sp peg-suffix) +))
 (define-sexp-parser peg-suffix all
-  (and peg-primary (body lit (and (or "*" "+" "?") peg-sp) *)))
+  (and peg-primary (* (and (or "*" "+" "?") peg-sp))))
 (define-sexp-parser peg-primary all
   (or (and "(" peg-sp peg-pattern ")" peg-sp)
       (and "." peg-sp)
@@ -80,11 +80,11 @@ RB < ']'
       peg-charclass
       (and peg-nonterminal (body ! "<" 1))))
 (define-sexp-parser peg-literal all
-  (and "'" (body lit (and (body ! "'" 1) peg-any) *) "'" peg-sp))
+  (and "'" (* (and (body ! "'" 1) peg-any)) "'" peg-sp))
 (define-sexp-parser peg-charclass all
   (and (ignore "[")
-       (body lit (and (body ! "]" 1)
-                      (or charclass-range charclass-single)) *)
+       (* (and (body ! "]" 1)
+               (or charclass-range charclass-single)))
        (ignore "]")
        peg-sp))
 (define-sexp-parser charclass-range all (and peg-any "-" peg-any))
@@ -92,7 +92,7 @@ RB < ']'
 (define-sexp-parser peg-nonterminal all
   (and (body lit (or (range #\a #\z) (range #\A #\Z) (range #\0 #\9) "-") +) peg-sp))
 (define-sexp-parser peg-sp none
-  (body lit (or " " "\t" "\n") *))
+  (* (or " " "\t" "\n")))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;;; PARSE STRING PEGS