X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/db6c3279edc260e3e301df1c9b082b374cd002c7..3a774b55edfea441c1715994924c2999e9202143:/src/parser/floc-proto.lisp?ds=sidebyside

diff --git a/src/parser/floc-proto.lisp b/src/parser/floc-proto.lisp
index f65ed73..f645bb1 100644
--- a/src/parser/floc-proto.lisp
+++ b/src/parser/floc-proto.lisp
@@ -134,7 +134,7 @@
 (define-condition simple-information (simple-condition information)
   ())
 
-(export '(info noted))
+(export 'info)
 (defun info (datum &rest arguments)
   "Report some useful diagnostic information.
 
@@ -145,6 +145,11 @@
       (signal (designated-condition 'simple-information datum arguments))
     (noted () :report "Noted." t)))
 
+(export 'noted)
+(defun noted (&optional condition)
+  "Invoke the `noted' restart, possibly associated with the given CONDITION."
+  (invoke-associated-restart 'noted condition))
+
 (export 'simple-information-with-location)
 (define-condition simple-information-with-location
     (information-with-location simple-information)
@@ -318,8 +323,57 @@
   `(with-default-error-location* ,floc (lambda () ,@body)))
 
 ;;;--------------------------------------------------------------------------
+;;; Custom errors for parsers.
+
+;; Resolve dependency cycle.
+(export '(parser-error-expected parser-error-found))
+(defgeneric parser-error-expected (condition))
+(defgeneric parser-error-found (condition))
+
+(export 'report-parser-error)
+(defun report-parser-error (error stream show-expected show-found)
+  (format stream "~:[Unexpected~;~
+		     Expected ~:*~{~#[~;~A~;~A or ~A~:;~
+				      ~@{~A, ~#[~;or ~A~]~}~]~} but found~] ~
+		  ~A"
+	  (mapcar show-expected (parser-error-expected error))
+	  (funcall show-found (parser-error-found error))))
+
+(export 'parser-error)
+(define-condition parser-error (error)
+  ((expected :initarg :expected :reader parser-error-expected :type list)
+   (found :initarg :found :reader parser-error-found :type t))
+  (:documentation "Standard error from a parser.
+
+   Supports the usual kinds of parser failure, where the parser was expecting
+   some kinds of things but found something else.")
+  (:report (lambda (error stream)
+	     (report-parser-error error stream
+				  #'prin1-to-string #'prin1-to-string))))
+
+(export '(base-lexer-error simple-lexer-error))
+(define-condition base-lexer-error (error-with-location) ())
+(define-condition simple-lexer-error
+    (base-lexer-error simple-error-with-location)
+  ())
+
+(export '(base-syntax-error simple-syntax-error))
+(define-condition base-syntax-error (error-with-location) ())
+(define-condition simple-syntax-error
+    (base-syntax-error simple-error-with-location)
+  ())
+
+;;;--------------------------------------------------------------------------
 ;;; Front-end error reporting.
 
+(export 'classify-condition)
+(defgeneric classify-condition (condition)
+  (:method ((condition error)) "error")
+  (:method ((condition base-lexer-error)) "lexical error")
+  (:method ((condition base-syntax-error)) "syntax error")
+  (:method ((condition warning)) "warning")
+  (:method ((condition information)) "note"))
+
 (defun count-and-report-errors* (thunk)
   "Invoke THUNK in a dynamic environment which traps and reports errors.
 
@@ -329,34 +383,33 @@
 	(warnings 0))
     (restart-case
 	(let ((our-continue-restart (find-restart 'continue)))
-	  (handler-bind
-	      ((error (lambda (error)
-			(let ((fatal (eq (find-restart 'continue error)
-					 our-continue-restart)))
-			  (format *error-output*
-				  "~&~A: ~:[~;Fatal error: ~]~A~%"
-				  (file-location error)
-				  fatal
-				  error)
-			  (incf errors)
-			  (if fatal
-			      (return-from count-and-report-errors*
-				(values nil errors warnings))
-			      (invoke-restart 'continue)))))
-	       (warning (lambda (warning)
-			  (format *error-output* "~&~A: Warning: ~A~%"
-				  (file-location warning)
-				  warning)
-			  (incf warnings)
-			  (invoke-restart 'muffle-warning)))
-	       (information (lambda (info)
-			      (format *error-output* "~&~A: Info: ~A~%"
-				      (file-location info)
-				      info)
-			  (invoke-restart 'noted))))
-	    (values (funcall thunk)
-		    errors
-		    warnings)))
+	  (flet ((report (condition &optional indicator)
+		   (let ((*print-pretty* nil))
+		     (format *error-output*
+			     "~&~A: ~@[~A ~]~A: ~A~%"
+			     (file-location condition)
+			     indicator (classify-condition condition)
+			     condition))))
+	    (handler-bind
+		((error (lambda (error)
+			  (let ((fatal (eq (find-restart 'continue error)
+					   our-continue-restart)))
+			    (report error (and fatal "fatal"))
+			    (incf errors)
+			    (if fatal
+				(return-from count-and-report-errors*
+				  (values nil errors warnings))
+				(continue error)))))
+		 (warning (lambda (warning)
+			    (report warning)
+			    (incf warnings)
+			    (muffle-warning warning)))
+		 (information (lambda (info)
+				(report info)
+				(noted info))))
+	      (values (funcall thunk)
+		      errors
+		      warnings))))
       (continue ()
 	:report (lambda (stream) (write-string "Exit to top-level" stream))
 	(values nil errors warnings)))))