From: Mark Wooding Date: Sun, 26 Mar 2017 14:16:18 +0000 (+0100) Subject: src/{lexer-{proto,impl},parser/floc-proto}.lisp: Conditionify parse errors. X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~mdw/git/sod/commitdiff_plain/40d95de71fca4c3b7b145d5ba73d1420e8854673 src/{lexer-{proto,impl},parser/floc-proto}.lisp: Conditionify parse errors. * Introduce condition classes for parse errors. * Introduce `classify-condition' to describe the different reportable conditions to the user, and change `count-and-report-errors*' to use this rather than having special knowledge. Now it pretty much just counts and prints. * Move the complicated error-message printing machinery from the `syntax-error' and `lexer-error' functions into the condition reporting functions. (Now they don't actually need to be formatted until they're just about to be presented to a user.) --- diff --git a/doc/SYMBOLS b/doc/SYMBOLS index f77f549..16e763a 100644 --- a/doc/SYMBOLS +++ b/doc/SYMBOLS @@ -469,12 +469,12 @@ fragment-parse.lisp lexer-proto.lisp define-indicator function cl:error function class parser - lexer-error function + lexer-error function class must parser scan-comment function skip-until function parser sod-token-scanner class - syntax-error function + syntax-error function class method-aggregate.lisp aggregating-effective-method class @@ -641,8 +641,22 @@ Classes: cl:t sb-pcl::slot-object cl:condition + sod-parser:condition-with-location + sod-parser:error-with-location [cl:error] + sod-parser:base-lexer-error + lexer-error [sod-parser:parser-error] + sod-parser:base-syntax-error + syntax-error [sod-parser:parser-error] cl:serious-condition cl:error + sod-parser:error-with-location [sod-parser:condition-with-location] + sod-parser:base-lexer-error + lexer-error [sod-parser:parser-error] + sod-parser:base-syntax-error + syntax-error [sod-parser:parser-error] + sod-parser:parser-error + lexer-error [sod-parser:base-lexer-error] + syntax-error [sod-parser:base-syntax-error] cl:standard-object alignas-storage-specifier base-offset @@ -1581,9 +1595,12 @@ Methods: Package `sod-parser' floc-proto.lisp + base-lexer-error class + base-syntax-error class cerror* function cerror*-with-location function cerror-with-location function + classify-condition generic condition-with-location class count-and-report-errors macro enclosed-condition generic @@ -1606,10 +1623,16 @@ floc-proto.lisp make-condition-with-location function make-file-location function noted function + parser-error class + parser-error-expected generic + parser-error-found generic + report-parser-error function simple-condition-with-location class simple-error-with-location class simple-information class simple-information-with-location class + simple-lexer-error class + simple-syntax-error class simple-warning-with-location class warn-with-location function warning-with-location class @@ -1751,7 +1774,13 @@ cl:t enclosing-information-with-location [information] enclosing-warning-with-location [cl:warning] error-with-location [cl:error] + base-lexer-error + simple-lexer-error [simple-error-with-location] + base-syntax-error + simple-syntax-error [simple-error-with-location] simple-error-with-location [cl:simple-error] + simple-lexer-error [base-lexer-error] + simple-syntax-error [base-syntax-error] information-with-location [information] simple-information-with-location [simple-information] simple-condition-with-location [cl:simple-condition] @@ -1772,13 +1801,24 @@ cl:t cl:error enclosing-error-with-location [enclosing-condition-with-location] error-with-location [condition-with-location] + base-lexer-error + simple-lexer-error [simple-error-with-location] + base-syntax-error + simple-syntax-error [simple-error-with-location] simple-error-with-location [cl:simple-error] + simple-lexer-error [base-lexer-error] + simple-syntax-error [base-syntax-error] + parser-error cl:simple-error [cl:simple-condition] simple-error-with-location [error-with-location] + simple-lexer-error [base-lexer-error] + simple-syntax-error [base-syntax-error] cl:simple-condition simple-condition-with-location [condition-with-location] cl:simple-error [cl:error] simple-error-with-location [error-with-location] + simple-lexer-error [base-lexer-error] + simple-syntax-error [base-syntax-error] simple-information [information] simple-information-with-location [information-with-location] cl:simple-warning [cl:warning] @@ -1891,6 +1931,12 @@ apply-operator simple-unary-operator sod-parser::expression-parse-state charbuf-scanner-map charbuf-scanner t +classify-condition + cl:error + cl:warning + base-lexer-error + base-syntax-error + information enclosed-condition enclosing-condition enclosing-condition-with-location-type @@ -1989,6 +2035,10 @@ parser-capture-place parser-current-char character-scanner-context string-parser +parser-error-expected + parser-error +parser-error-found + parser-error parser-places-must-be-released-p t list-parser diff --git a/doc/parsing.tex b/doc/parsing.tex index 0d3487d..c91c74b 100644 --- a/doc/parsing.tex +++ b/doc/parsing.tex @@ -145,11 +145,47 @@ consumed any input items. \dhead{fun}{warn-with-location @ @ \&rest @}} \end{describe*} +\begin{describe*} + {\dhead{cls}{parser-error (error) \\ \ind + \&key :expected :found \-} + \dhead{gf}{parser-error-expected @ @> @} + \dhead{gf}{parser-error-found @ @> @}} +\end{describe*} + +\begin{describe}{fun} + {report-parser-error @ @ @ @} +\end{describe} + +\begin{describe*} + {\quad\=\kill + \dhead{cls}{base-lexer-error (error-with-location) \&key :location} + \dhead{cls}{simple-lexer-error + (base-lexer-error simple-error-with-location) \\\> + \&key :format-control :format-arguments :location} + \dhead{cls}{base-syntax-error (error-with-location) \&key :location} + \dhead{cls}{simple-syntax-error + (base-syntax-error simple-error-with-location) \\\> + \&key :format-control :format-arguments :location}} +\end{describe*} + \begin{describe}{mac} {with-default-error-location (@) @^* @
^* @> @^*} \end{describe} +\begin{describe}{gf}{classify-condition @ @> @} + \begin{describe*} + {\dhead{meth}{classify-condition (@ error) @> @} + \dhead{meth}{classify-condition (@ warning) @> @} + \dhead{meth}{classify-condition (@ information) + @> @} + \dhead{meth}{classify-condition (@ base-lexer-error) + @> @} + \dhead{meth}{classify-condition (@ base-syntax-error) + @> @}} + \end{describe*} +\end{describe} + \begin{describe}{mac} {count-and-report-errors () @^* @^* @> @ @ @} @@ -779,6 +815,13 @@ file-location protocols. \begin{describe}{fun}{define-indicator @ @} \end{describe} +\begin{describe*} + {\dhead{cls}{lexer-error (parser-error base-lexer-error) \\ \ind + \&key :expected :found :location \-} + \dhead{cls}{syntax-error (parser-error base-syntax-error) \\ \ind + \&key :expected :found :location \-}} +\end{describe*} + \begin{describe}{fun} {syntax-error @ @ \&key :continuep :location} \end{describe} diff --git a/src/lexer-impl.lisp b/src/lexer-impl.lisp index 48109b1..42370c0 100644 --- a/src/lexer-impl.lisp +++ b/src/lexer-impl.lisp @@ -39,15 +39,12 @@ (defmethod make-scanner-stream ((scanner sod-token-scanner)) ;;;-------------------------------------------------------------------------- ;;; Indicators and error messages. -(defun show-char (stream char &optional colonp atsignp) - "Format CHAR to STREAM in a readable way. - - Usable in `format''s ~/.../ command." - (declare (ignore colonp atsignp)) - (cond ((null char) (write-string "" stream)) +(defun show-char (char) + "Format CHAR as a string in a readable way." + (cond ((null char) "") ((and (graphic-char-p char) (char/= char #\space)) - (format stream "`~C'" char)) - (t (format stream "<~(~:C~)>" char)))) + (format nil "`~C'" char)) + (t (format nil "<~(~:C~)>" char)))) (defun skip-until (scanner token-types &key keep-end) "This is the implementation of the `skip-until' parser." @@ -149,13 +146,15 @@ (defmethod scanner-token ((scanner sod-token-scanner)) (#\' (case (length contents) (1 (char contents 0)) (0 (cerror*-with-location (start-floc) - "Lexical error: ~ - empty character literal") + 'simple-lexer-error + :format-control + "Empty character literal") #\?) (t (cerror*-with-location (start-floc) - "Lexical error: ~ - too many characters ~ - in literal") + 'simple-lexer-error + :format-control + "Too many characters ~ + in character literal") (char contents 0)))))) (values (etypecase it (character :char) 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 "" + value)) + (:int "") + (:string "") + (:char "") + (:eof "") + (:ellipsis "`...'") + (t (format nil "" 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 "" 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 "" value)) - (:int "") - (:string "") - (:char "") - (:eof "") - (:ellipsis "`...'") - (t (format nil "" 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 "" thing))))) - (funcall (if continuep #'cerror*-with-location #'error-with-location) - (or location scanner) - "Syntax error: ~ - expected ~{~#[~;~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 "" (cadr exp))) + ((eql :eof) "") + ((eql :any) "") + (t (format nil "" 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 "" - (cadr exp))) - ((eql :eof) "") - ((eql :any) "") - (t (format nil "" 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) diff --git a/src/parser/floc-proto.lisp b/src/parser/floc-proto.lisp index 3a11123..f645bb1 100644 --- 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)))))