X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/ae7a3c8fb42e457933efbbb9127d5a745096825a..00d59354c311fb28730b7c9b117b0d91aac092cc:/src/lexer-proto.lisp

diff --git a/src/lexer-proto.lisp b/src/lexer-proto.lisp
index b045be7..a237a92 100644
--- a/src/lexer-proto.lisp
+++ b/src/lexer-proto.lisp
@@ -52,55 +52,67 @@
   indicator)
 
 (export 'syntax-error)
+(define-condition syntax-error (parser-error base-syntax-error)
+  ((found :type cons))
+  (:report (lambda (error stream)
+	     (labels ((show-token (type value)
+			(if (characterp type) (show-char type)
+			    (case type
+			      (:id (format nil "<identifier~@[ `~A'~]>"
+					   value))
+			      (:int "<integer-literal>")
+			      (:string "<string-literal>")
+			      (:char "<character-literal>")
+			      (:eof "<end-of-file>")
+			      (:ellipsis "`...'")
+			      (:shl "`<<'")
+			      (:shr "`>>'")
+			      (:eq "`=='")
+			      (:ne "`!='")
+			      (:le "`<='")
+			      (:ge "`>='")
+			      (:and "`&&'")
+			      (:or "`||'")
+			      (t (format nil "<? ~S~@[ ~S~]>" type value)))))
+		      (show-expected (thing)
+			(acond ((gethash thing *indicator-map*) it)
+			       ((atom thing) (show-token thing nil))
+			       ((eq (car thing) :id)
+				(format nil "`~A'" (cadr thing)))
+			       (t (format nil "<? ~S>" thing)))))
+	       (report-parser-error error stream
+				    #'show-expected
+				    (lambda (found)
+				      (show-token (car found)
+						  (cdr found))))))))
 (defun syntax-error (scanner expected &key (continuep t) location)
   "Signal a (maybe) continuable syntax error."
-  (labels ((show-token (type value)
-	     (if (characterp type)
-		 (format nil "~/sod::show-char/" type)
-		 (case type
-		   (:id (format nil "<identifier~@[ `~A'~]>" value))
-		   (:int "<integer-literal>")
-		   (:string "<string-literal>")
-		   (:char "<character-literal>")
-		   (:eof "<end-of-file>")
-		   (:ellipsis "`...'")
-		   (t (format nil "<? ~S~@[ ~S~]>" type value)))))
-	   (show-expected (thing)
-	     (acond ((gethash thing *indicator-map*) it)
-		    ((atom thing) (show-token thing nil))
-		    ((eq (car thing) :id)
-		     (format nil "`~A'" (cadr thing)))
-		    (t (format nil "<? ~S>" thing)))))
-    (funcall (if continuep #'cerror*-with-location #'error-with-location)
-	     (or location scanner)
-	     "Syntax error: ~
-	      expected ~{~#[<bug>~;~A~;~A or ~A~:;~A, ~]~} ~
-	      but found ~A"
-	     (mapcar #'show-expected expected)
-	     (show-token (token-type scanner) (token-value scanner)))))
+  (funcall (if continuep #'cerror*-with-location #'error-with-location)
+	   (or location scanner) 'syntax-error
+	   :expected expected
+	   :found (cons (token-type scanner) (token-value scanner))))
 
 (export 'lexer-error)
+(define-condition lexer-error (parser-error base-lexer-error)
+  ((found :type (or character nil)))
+  (:report (lambda (error stream)
+	     (flet ((show-expected (exp)
+		      (typecase exp
+			(character (show-char exp))
+			(string (format nil "`~A'" exp))
+			((cons (eql :digit) *)
+			 (format nil "<radix-~A digit>" (cadr exp)))
+			((eql :eof) "<end-of-file>")
+			((eql :any) "<character>")
+			(t (format nil "<? ~S>" exp)))))
+	       (report-parser-error error stream
+				    #'show-expected #'show-char)))))
 (defun lexer-error (char-scanner expected &key location)
   "Signal a continuable lexical error."
-  (cerror*-with-location (or location char-scanner)
-			 "Lexical error: ~
-			  ~:[unexpected~;~
-			     expected ~:*~{~#[~;~A~;~A or ~A~:;~
-					      ~@{~A, ~#[~;or ~A~]~}~]~} ~
-			     but found~] ~
-			  ~/sod::show-char/"
-	   (mapcar (lambda (exp)
-		     (typecase exp
-		       (character (format nil "~/sod::show-char/" exp))
-		       (string (format nil "`~A'" exp))
-		       ((cons (eql :digit) *) (format nil "<radix-~A digit>"
-						      (cadr exp)))
-		       ((eql :eof) "<end-of-file>")
-		       ((eql :any) "<character>")
-		       (t (format nil "<? ~S>" exp))))
-		   expected)
-	   (and (not (scanner-at-eof-p char-scanner))
-		(scanner-current-char char-scanner))))
+  (cerror*-with-location (or location char-scanner) 'lexer-error
+			 :expected expected
+			 :found (and (not (scanner-at-eof-p char-scanner))
+				     (scanner-current-char char-scanner))))
 
 (export 'skip-until)
 (defparse skip-until (:context (context token-scanner-context)
@@ -108,11 +120,16 @@
 		      &rest token-types)
   "Discard tokens until we find one listed in TOKEN-TYPES.
 
+   Each of the TOKEN-TYPES is an expression which evaluates to either a
+   two-item list (TYPE VALUE), or a singleton TYPE; the latter is equivalent
+   to a list (TYPE t).  Such a pair matches a token with the corresponding
+   TYPE and VALUE, except that a VALUE of `t' matches any token value.
+
    If KEEP-END is true then retain the found token for later; otherwise
    discard it.  KEEP-END defaults to true if multiple TOKEN-TYPES are given;
    otherwise false.  If end-of-file is encountered then the indicator list is
    simply the list of TOKEN-TYPES; otherwise the result is `nil'."
-  `(skip-until ,(parser-scanner context)
+  `(%skip-until ,(parser-scanner context)
 	       (list ,@token-types)
 	       :keep-end ,(if keep-end-p keep-end
 			      (> (length token-types) 1))))
@@ -120,7 +137,7 @@
 (export 'error)
 (defparse error (:context (context token-scanner-context)
 		 (&key ignore-unconsumed force-progress)
-		 sub &optional (recover t))
+		 sub &optional (recover t) &body body)
   "Try to parse SUB; if it fails then report an error, and parse RECOVER.
 
    This is the main way to recover from errors and continue parsing.  Even
@@ -139,7 +156,8 @@
 			(parser () ,sub)
 			(parser () ,recover)
 			:ignore-unconsumed ,ignore-unconsumed
-			:force-progress ,force-progress))
+			:force-progress ,force-progress
+			:action ,(and body `(lambda () ,@body))))
 
 (export 'must)
 (defparse must (:context (context token-scanner-context)