From 72287411e9cd2c43afe061d2b4f07f4f7c577268 Mon Sep 17 00:00:00 2001
From: Noah Lavine <nlavine@haverford.edu>
Date: Mon, 19 Sep 2011 10:33:09 -0400
Subject: [PATCH] Add 'not-followed-by' PEG

The PEG s-expression syntax now uses '(not-followed-by ...)' instead of
'(body ! ... 1)'.
---
 doc/ref/api-peg.texi            |  4 ++--
 module/ice-9/peg/codegen.scm    | 21 +++++++++++++++++++++
 module/ice-9/peg/string-peg.scm |  6 +++---
 3 files changed, 26 insertions(+), 5 deletions(-)

diff --git a/doc/ref/api-peg.texi b/doc/ref/api-peg.texi
index 4976b59c9..111f1501c 100644
--- a/doc/ref/api-peg.texi
+++ b/doc/ref/api-peg.texi
@@ -99,13 +99,13 @@ it.  Succeeds if @var{a} would succeed.
 @code{(followed-by a)}
 @end deftp
 
-@deftp {PEG Pattern} {not predicate} a
+@deftp {PEG Pattern} {not followed by} a
 Makes sure it is impossible to parse @var{a}, but does not actually
 parse it.  Succeeds if @var{a} would fail.
 
 @code{"!a"}
 
-@code{(body ! a 1)}
+@code{(not-followed-by a)}
 @end deftp
 
 @deftp {PEG Pattern} {string literal} ``abc''
diff --git a/module/ice-9/peg/codegen.scm b/module/ice-9/peg/codegen.scm
index 22fb1953d..3cdf4ccfe 100644
--- a/module/ice-9/peg/codegen.scm
+++ b/module/ice-9/peg/codegen.scm
@@ -316,6 +316,26 @@ return EXP."
                      #,#`(and success
                               #,(cggr (baf accum) 'cg-body #''() #'at)))))))))))
 
+(define (cg-not-followed-by 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 #,#'(= count 1)))
+                     #,#`(if success
+                                #f
+                                #,(cggr (baf accum) 'cg-body #''() #'at)))))))))))
+
 ;; Association list of functions to handle different expressions as PEGs
 (define peg-compiler-alist '())
 
@@ -333,6 +353,7 @@ return EXP."
 (add-peg-compiler! '+ cg-+)
 (add-peg-compiler! '? cg-?)
 (add-peg-compiler! 'followed-by cg-followed-by)
+(add-peg-compiler! 'not-followed-by cg-not-followed-by)
 
 ;; 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 ccd405656..c776d1d75 100644
--- a/module/ice-9/peg/string-peg.scm
+++ b/module/ice-9/peg/string-peg.scm
@@ -78,12 +78,12 @@ RB < ']'
       (and "." peg-sp)
       peg-literal
       peg-charclass
-      (and peg-nonterminal (body ! "<" 1))))
+      (and peg-nonterminal (not-followed-by "<"))))
 (define-sexp-parser peg-literal all
-  (and "'" (* (and (body ! "'" 1) peg-any)) "'" peg-sp))
+  (and "'" (* (and (not-followed-by "'") peg-any)) "'" peg-sp))
 (define-sexp-parser peg-charclass all
   (and (ignore "[")
-       (* (and (body ! "]" 1)
+       (* (and (not-followed-by "]")
                (or charclass-range charclass-single)))
        (ignore "]")
        peg-sp))