Add '+' PEG

The PEG s-expression syntax now uses '(+ ...)' instead of '(body lit ... +)'.

2 files changed, 24 insertions, 3 deletions

diff --git a/module/ice-9/peg/codegen.scm b/module/ice-9/peg/codegen.scm
index 9ef3a407c..2a61324f6 100644
--- a/module/ice-9/peg/codegen.scm
+++ b/module/ice-9/peg/codegen.scm
@@ -257,6 +257,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 #,#'(>= count 1)))
+                     #,#`(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 '())
 
@@ -271,6 +291,7 @@ return EXP."
 (add-peg-compiler! 'or cg-or)
 (add-peg-compiler! 'body cg-body)
 (add-peg-compiler! '* cg-*)
+(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 390394649..4f6c6cd53 100644
--- a/module/ice-9/peg/string-peg.scm
+++ b/module/ice-9/peg/string-peg.scm
@@ -65,12 +65,12 @@ RB < ']'
            #`(define sym #,syn))))))
 
 (define-sexp-parser peg-grammar all
-  (body lit (and peg-nonterminal (or "<--" "<-" "<") peg-sp peg-pattern) +))
+  (+ (and peg-nonterminal (or "<--" "<-" "<") peg-sp peg-pattern)))
 (define-sexp-parser peg-pattern all
   (and peg-alternative
        (* (and (ignore "/") peg-sp peg-alternative))))
 (define-sexp-parser peg-alternative all
-  (body lit (and (body lit (or "!" "&") ?) peg-sp peg-suffix) +))
+  (+ (and (body lit (or "!" "&") ?) peg-sp peg-suffix)))
 (define-sexp-parser peg-suffix all
   (and peg-primary (* (and (or "*" "+" "?") peg-sp))))
 (define-sexp-parser peg-primary all
@@ -90,7 +90,7 @@ RB < ']'
 (define-sexp-parser charclass-range all (and peg-any "-" peg-any))
 (define-sexp-parser charclass-single all peg-any)
 (define-sexp-parser peg-nonterminal all
-  (and (body lit (or (range #\a #\z) (range #\A #\Z) (range #\0 #\9) "-") +) peg-sp))
+  (and (+ (or (range #\a #\z) (range #\A #\Z) (range #\0 #\9) "-")) peg-sp))
 (define-sexp-parser peg-sp none
   (* (or " " "\t" "\n")))