src/parser/: Allow parsers to commit to a parse while peeking.

[sod] / src / parser / parser-proto.lisp

diff --git a/src/parser/parser-proto.lisp b/src/parser/parser-proto.lisp
index b97cd4b..189e503 100644 (file)
--- a/src/parser/parser-proto.lisp
+++ b/src/parser/parser-proto.lisp
@@ -646,7 +646,8 @@
           `(let ((,,place ,(parser-capture-place ,context)))
              ,(if (parser-places-must-be-released-p ,context)
                   `(unwind-protect ,(,bodyfunc)
-                       ,(parser-release-place ,context ,place))
+                     (when ,,place
+                       ,(parser-release-place ,context ,place)))
                   (,bodyfunc))))))))
 
 (export 'peek)
@@ -654,12 +655,30 @@
   "Attempt to run PARSER, but rewind the underlying source if it fails."
   (with-gensyms (value win consumedp)
     (with-parser-place (place context)
-      `(multiple-value-bind (,value ,win ,consumedp) (parse ,parser)
-        (cond (,win
-               (values ,value ,win ,consumedp))
-              (t
-               ,(parser-restore-place context place)
-               (values ,value ,win nil)))))))
+      `(macrolet ((commit-peeked-place ()
+                   `(progn
+                      ,',(parser-release-place context place)
+                      (setf ,',place nil))))
+        (multiple-value-bind (,value ,win ,consumedp) (parse ,parser)
+          (cond ((or ,win (null ,place))
+                 (values ,value ,win ,consumedp))
+                (t
+                 ,(parser-restore-place context place)
+                 (values ,value ,win nil))))))))
+
+(defun commit-peeked-place ()
+  "Called by `commit' not lexically within `peek'."
+  (error "`commit' is not within `peek'."))
+
+(export 'commit)
+(defparse commit ()
+  "Commit to the current parse.
+
+   This releases the place captured by the innermost lexically enclosing
+  `peek'."
+  '(progn
+     (commit-peeked-place)
+     (values nil t nil)))
 
 ;;;--------------------------------------------------------------------------
 ;;; Character parser context protocol.