indicator)
(export 'syntax-error)
-(defun syntax-error (scanner expected &key (continuep t))
+(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 "`...'")
+ (:shl "`<<'")
+ (:shr "`>>'")
+ (:eq "`=='")
+ (:ne "`!='")
+ (:le "`<='")
+ (:ge "`>='")
+ (:and "`&&'")
+ (:or "`||'")
+ (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* #'error)
- "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)
-(defun lexer-error (char-scanner expected consumedp)
+(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* "Lexical error: ~
- expected ~{~#[<bug>~;~A~;~A or ~A~:;~A, ~]~} ~
- but found ~/sod::show-char/~
- ~@[ at ~A~]"
- (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))
- (and consumedp (file-location 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)
&rest token-types)
"Discard tokens until we find one listed in TOKEN-TYPES.
+ Each of the TOKEN-TYPES is an expression which evaluates to either a
+ two-item list (TYPE VALUE), or a singleton TYPE; the latter is equivalent
+ to a list (TYPE t). Such a pair matches a token with the corresponding
+ TYPE and VALUE, except that a VALUE of `t' matches any token value.
+
If KEEP-END is true then retain the found token for later; otherwise
discard it. KEEP-END defaults to true if multiple TOKEN-TYPES are given;
otherwise false. If end-of-file is encountered then the indicator list is
simply the list of TOKEN-TYPES; otherwise the result is `nil'."
- `(skip-until ,(parser-scanner context)
+ `(%skip-until ,(parser-scanner context)
(list ,@token-types)
:keep-end ,(if keep-end-p keep-end
(> (length token-types) 1))))
(export 'error)
(defparse error (:context (context token-scanner-context)
- (&key ignore-unconsumed)
- sub &optional (recover t))
+ (&key ignore-unconsumed force-progress)
+ sub &optional (recover t) &body body)
"Try to parse SUB; if it fails then report an error, and parse RECOVER.
This is the main way to recover from errors and continue parsing. Even
`(parse-error-recover ,(parser-scanner context)
(parser () ,sub)
(parser () ,recover)
- :ignore-unconsumed ,ignore-unconsumed))
+ :ignore-unconsumed ,ignore-unconsumed
+ :force-progress ,force-progress
+ :action ,(and body `(lambda () ,@body))))
+
+(export 'must)
+(defparse must (:context (context token-scanner-context)
+ sub &optional default)
+ "Try to parse SUB; if it fails, report an error, and return DEFAULT.
+
+ This parser can't actually fail."
+ `(parse (error () ,sub (t ,default))))
;;;--------------------------------------------------------------------------
;;; Lexical analysis utilities.
The result isn't interesting."
(with-parser-context (character-scanner-context :scanner char-scanner)
- (parse (or (and "/*"
- (and (skip-many ()
- (and (skip-many () (not #\*))
- (label "*/" (skip-many (:min 1) #\*)))
- (not #\/))
- #\/))
- (and "//"
- (skip-many () (not #\newline))
- (? #\newline))))))
+ (let ((start (file-location char-scanner)))
+ (parse (or (and "/*"
+ (lisp (let ((state nil))
+ (loop (cond ((scanner-at-eof-p char-scanner)
+ (lexer-error char-scanner
+ (list "*/"))
+ (info-with-location
+ start "Comment started here")
+ (return (values nil t t)))
+ ((char= (scanner-current-char
+ char-scanner)
+ #\*)
+ (setf state '*)
+ (scanner-step char-scanner))
+ ((and (eq state '*)
+ (char= (scanner-current-char
+ char-scanner)
+ #\/))
+ (scanner-step char-scanner)
+ (return (values nil t t)))
+ (t
+ (setf state nil)
+ (scanner-step char-scanner)))))))
+ (and "//"
+ (skip-many () (not #\newline))
+ (? #\newline)))))))
;;;----- That's all, folks --------------------------------------------------