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

[sod] / src / lexer-proto.lisp

diff --git a/src/lexer-proto.lisp b/src/lexer-proto.lisp
index b045be75589e8e243b011bcf92673eae7fa39f8b..d5f25fd5d9c5df5100895f546cfe5871d6b25978 100644 (file)
--- 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 "<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)