X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/sod/blobdiff_plain/388ab3827ab7c584c30723f5044c2a38cf6fe55d..2bc73f786f7dc35ecff3e1484a6376aae1de4962:/src/parser/floc-proto.lisp?ds=sidebyside diff --git a/src/parser/floc-proto.lisp b/src/parser/floc-proto.lisp index e3dca32..f645bb1 100644 --- a/src/parser/floc-proto.lisp +++ b/src/parser/floc-proto.lisp @@ -83,6 +83,10 @@ (define-condition enclosing-condition-with-location (condition-with-location enclosing-condition) ()) +(export 'information) +(define-condition information (condition) + ()) + (export 'error-with-location) (define-condition error-with-location (condition-with-location error) ()) @@ -91,6 +95,11 @@ (export 'warning-with-location) (define-condition warning-with-location (condition-with-location warning) ()) +(export 'information-with-location) +(define-condition information-with-location + (condition-with-location information) + ()) + (export 'enclosing-error-with-location) (define-condition enclosing-error-with-location (enclosing-condition-with-location error) @@ -101,6 +110,11 @@ (define-condition enclosing-warning-with-location (enclosing-condition-with-location warning) ()) +(export 'enclosing-information-with-location) +(define-condition enclosing-information-with-location + (enclosing-condition-with-location information) + ()) + (export 'simple-condition-with-location) (define-condition simple-condition-with-location (condition-with-location simple-condition) @@ -116,6 +130,31 @@ (define-condition simple-warning-with-location (warning-with-location simple-warning) ()) +(export 'simple-information) +(define-condition simple-information (simple-condition information) + ()) + +(export 'info) +(defun info (datum &rest arguments) + "Report some useful diagnostic information. + + Establish a simple restart named `noted', and signal the condition of type + `information' designated by DATUM and ARGUMENTS. Return non-nil if the + restart was invoked, otherwise nil." + (restart-case + (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) + ()) + ;;;-------------------------------------------------------------------------- ;;; Reporting errors. @@ -128,6 +167,7 @@ (defgeneric enclosing-condition-with-location-type (condition) with-location' suitable to enclose CONDITION.") (:method ((condition error)) 'enclosing-error-with-location) (:method ((condition warning)) 'enclosing-warning-with-location) + (:method ((condition information)) 'enclosing-information-with-location) (:method ((condition condition)) 'enclosing-condition-with-location)) (export 'make-condition-with-location) @@ -196,6 +236,13 @@ (defun warn-with-location (floc datum &rest arguments) 'simple-warning-with-location floc datum arguments))) +(export 'info-with-location) +(defun info-with-location (floc datum &rest arguments) + "Report some information with attached location information." + (info (apply #'make-condition-with-location + 'simple-information-with-location + floc datum arguments))) + (defun my-cerror (continue-string datum &rest arguments) "Like standard `cerror', but robust against sneaky changes of conditions. @@ -275,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. @@ -287,29 +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)) - (invoke-restart 'continue))))) - (warning (lambda (warning) - (format *error-output* "~&~A: Warning: ~A~%" - (file-location warning) - warning) - (incf warnings) - (invoke-restart 'muffle-warning)))) - (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)))))