X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~mdw/git/sod/blobdiff_plain/e43bd9558b80d9d92db3f39b5f77a2fa184fb467..40d95de71fca4c3b7b145d5ba73d1420e8854673:/src/lexer-proto.lisp

diff --git a/src/lexer-proto.lisp b/src/lexer-proto.lisp
index b045be7..d5f25fd 100644
--- a/src/lexer-proto.lisp
+++ b/src/lexer-proto.lisp
@@ -52,55 +52,59 @@ (defun define-indicator (indicator description)
   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 "`...'")
+			      (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)