src/: Error message cleanup.

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

diff --git a/src/parser/parser-proto.lisp b/src/parser/parser-proto.lisp
index 4bd1ae4..ed439f9 100644 (file)
--- a/src/parser/parser-proto.lisp
+++ b/src/parser/parser-proto.lisp
@@ -7,7 +7,7 @@
 
 ;;;----- Licensing notice ---------------------------------------------------
 ;;;
-;;; This file is part of the Sensble Object Design, an object system for C.
+;;; This file is part of the Sensible Object Design, an object system for C.
 ;;;
 ;;; SOD is free software; you can redistribute it and/or modify
 ;;; it under the terms of the GNU General Public License as published by
@@ -87,6 +87,21 @@
          failures
          :initial-value nil))
 
+(export 'parse-empty)
+(defun parse-empty (&optional value)
+  "Return a parser which parses nothing, successfully.
+
+   The parser returns VALUE and consumes nothing."
+  (lambda () (values value t nil)))
+
+(export 'parse-fail)
+(defun parse-fail (indicator &optional consumedp)
+  "Return a parser which fails.
+
+   The parser reports the INDICATOR and (falsely) claims to have consumed
+   input if CONSUMEDP is true."
+  (lambda () (values indicator nil consumedp)))
+
 ;;;--------------------------------------------------------------------------
 ;;; Basic protocol.
 
@@ -152,10 +167,9 @@
             ((,context ,ctxclass) (,head (eql ',name)) ,tail)
           ,@doc
           (declare (ignorable ,context))
-          (block ,name
-            (destructuring-bind ,bvl ,tail
-              ,@decls
-              ,@body)))))))
+          (destructuring-bind ,bvl ,tail
+            ,@decls
+            (block ,name ,@body)))))))
 
 (export '(with-parser-context parse))
 (defmacro with-parser-context ((class &rest initargs) &body body)
@@ -573,7 +587,11 @@
    If a parser with the given TAG is already attached to SYMBOL then the new
    parser replaces the old one; otherwise it is added to the collection."
 
-  `(pluggable-parser-add ',symbol ',tag (lambda ,bvl ,@body)))
+  (multiple-value-bind (docs decls body) (parse-body body)
+    `(pluggable-parser-add ',symbol ',tag
+                          (lambda ,bvl
+                            ,@docs ,@decls
+                            (block ,symbol ,@body)))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Rewindable parser context protocol.
@@ -588,7 +606,7 @@
    The return value may later be used with `parser-restore-place'.  Be
    careful: all of this is happening at macro-expansion time.")
     (:method (context)
-      (error "Parser context ~S doesn't support rewinding." context)))
+      (error "Parser context ~S doesn't support rewinding" context)))
 
   (export 'parser-restore-place)
   (defgeneric parser-restore-place (context place)
@@ -643,7 +661,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)
@@ -651,12 +670,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.