Add '?' PEG

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

3 files changed, 23 insertions, 2 deletions

diff --git a/doc/ref/api-peg.texi b/doc/ref/api-peg.texi
index c2b4cfc2d..b05a2cf85 100644
--- a/doc/ref/api-peg.texi
+++ b/doc/ref/api-peg.texi
@@ -87,7 +87,7 @@ Tries to parse @var{a}.  Succeeds if @var{a} succeeds.
 
 @code{"a?"}
 
-@code{(body lit a ?)}
+@code{(? a)}
 @end deftp
 
 @deftp {PEG Pattern} {and predicate} a
diff --git a/module/ice-9/peg/codegen.scm b/module/ice-9/peg/codegen.scm
index 2a61324f6..91e499d0c 100644
--- a/module/ice-9/peg/codegen.scm
+++ b/module/ice-9/peg/codegen.scm
@@ -277,6 +277,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)
+                        #,#'(< count 1))
+                   (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 '())
 
@@ -292,6 +312,7 @@ return EXP."
 (add-peg-compiler! 'body cg-body)
 (add-peg-compiler! '* cg-*)
 (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 4f6c6cd53..ccd405656 100644
--- a/module/ice-9/peg/string-peg.scm
+++ b/module/ice-9/peg/string-peg.scm
@@ -70,7 +70,7 @@ RB < ']'
   (and peg-alternative
        (* (and (ignore "/") peg-sp peg-alternative))))
 (define-sexp-parser peg-alternative all
-  (+ (and (body lit (or "!" "&") ?) peg-sp peg-suffix)))
+  (+ (and (? (or "!" "&")) peg-sp peg-suffix)))
 (define-sexp-parser peg-suffix all
   (and peg-primary (* (and (or "*" "+" "?") peg-sp))))
 (define-sexp-parser peg-primary all