src/{lexer-{proto,impl},parser/floc-proto}.lisp: Conditionify parse errors.

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

diff --git a/src/parser/floc-proto.lisp b/src/parser/floc-proto.lisp
index 3a111237cd8a76ba585011157c30e65b77b6a8a3..f645bb183c70c1fa80a0f3a78d5c59e5c470f186 100644 (file)
--- a/src/parser/floc-proto.lisp
+++ b/src/parser/floc-proto.lisp
@@ -322,9 +322,58 @@ (defmacro with-default-error-location ((floc) &body body)
 
   `(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.
 
@@ -334,34 +383,33 @@ (defun count-and-report-errors* (thunk)
        (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))
-                             (continue error)))))
-              (warning (lambda (warning)
-                         (format *error-output* "~&~A: Warning: ~A~%"
-                                 (file-location warning)
-                                 warning)
-                         (incf warnings)
-                         (muffle-warning warning)))
-              (information (lambda (info)
-                             (format *error-output* "~&~A: Info: ~A~%"
-                                     (file-location info)
-                                     info)
-                             (noted info))))
-           (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)))))