* 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.)
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
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
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
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
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]
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]
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
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
\dhead{fun}{warn-with-location @<floc> @<datum> \&rest @<arguments>}}
\end{describe*}
+\begin{describe*}
+ {\dhead{cls}{parser-error (error) \\ \ind
+ \&key :expected :found \-}
+ \dhead{gf}{parser-error-expected @<condition> @> @<list>}
+ \dhead{gf}{parser-error-found @<condition> @> @<value>}}
+\end{describe*}
+
+\begin{describe}{fun}
+ {report-parser-error @<error> @<stream> @<show-expected> @<show-found>}
+\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 (@<floc>) @<declaration>^* @<form>^*
@> @<value>^*}
\end{describe}
+\begin{describe}{gf}{classify-condition @<condition> @> @<string>}
+ \begin{describe*}
+ {\dhead{meth}{classify-condition (@<condition> error) @> @<string>}
+ \dhead{meth}{classify-condition (@<condition> warning) @> @<string>}
+ \dhead{meth}{classify-condition (@<condition> information)
+ @> @<string>}
+ \dhead{meth}{classify-condition (@<condition> base-lexer-error)
+ @> @<string>}
+ \dhead{meth}{classify-condition (@<condition> base-syntax-error)
+ @> @<string>}}
+ \end{describe*}
+\end{describe}
+
\begin{describe}{mac}
{count-and-report-errors () @<declaration>^* @<form>^*
@> @<value> @<n-errors> @<n-warnings>}
\begin{describe}{fun}{define-indicator @<indicator> @<description>}
\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 @<scanner> @<expected> \&key :continuep :location}
\end{describe}
;;;--------------------------------------------------------------------------
;;; 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 "<end-of-file>" stream))
+(defun show-char (char)
+ "Format CHAR as a string in a readable way."
+ (cond ((null char) "<end-of-file>")
((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."
(#\' (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)
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)
`(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.
(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)))))
~mdw / sod / commitdiff