src/fragment-parse.lisp, src/lexer-{impl,proto}.lisp: Better errors.

[sod] / src / lexer-proto.lisp

diff --git a/src/lexer-proto.lisp b/src/lexer-proto.lisp
index a70addc853d5fed9ce74c627df574e7e46e7cef7..122da753d99051275570d4f62ac457c32eefd169 100644 (file)
--- a/src/lexer-proto.lisp
+++ b/src/lexer-proto.lisp
@@ -52,7 +52,7 @@ (defun define-indicator (indicator description)
   indicator)
 
 (export 'syntax-error)
-(defun syntax-error (scanner expected &key (continuep t))
+(defun syntax-error (scanner expected &key (continuep t) location)
   "Signal a (maybe) continuable syntax error."
   (labels ((show-token (type value)
             (if (characterp type)
@@ -71,7 +71,8 @@ (defun syntax-error (scanner expected &key (continuep t))
                    ((eq (car thing) :id)
                     (format nil "`~A'" (cadr thing)))
                    (t (format nil "<? ~S>" thing)))))
-    (funcall (if continuep #'cerror* #'error)
+    (funcall (if continuep #'cerror*-with-location #'error-with-location)
+            (or location scanner)
             "Syntax error: ~
              expected ~{~#[<bug>~;~A~;~A or ~A~:;~A, ~]~} ~
              but found ~A"
@@ -79,11 +80,15 @@ (defun syntax-error (scanner expected &key (continuep t))
             (show-token (token-type scanner) (token-value scanner)))))
 
 (export 'lexer-error)
-(defun lexer-error (char-scanner expected)
+(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/"
+  (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))
@@ -114,7 +119,7 @@ (defparse skip-until (:context (context token-scanner-context)
 
 (export 'error)
 (defparse error (:context (context token-scanner-context)
-                (&key ignore-unconsumed)
+                (&key ignore-unconsumed force-progress)
                 sub &optional (recover t))
   "Try to parse SUB; if it fails then report an error, and parse RECOVER.
 
@@ -133,7 +138,8 @@ (defparse error (:context (context token-scanner-context)
   `(parse-error-recover ,(parser-scanner context)
                        (parser () ,sub)
                        (parser () ,recover)
-                       :ignore-unconsumed ,ignore-unconsumed))
+                       :ignore-unconsumed ,ignore-unconsumed
+                       :force-progress ,force-progress))
 
 ;;;--------------------------------------------------------------------------
 ;;; Lexical analysis utilities.
@@ -144,14 +150,31 @@ (defun scan-comment (char-scanner)
 
    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 --------------------------------------------------