Abandoned atoms work: hardly any performance benefit.

[sod] / src / lexer-impl.lisp

diff --git a/src/lexer-impl.lisp b/src/lexer-impl.lisp
index 7e953ef..de76371 100644 (file)
--- a/src/lexer-impl.lisp
+++ b/src/lexer-impl.lisp
@@ -39,27 +39,35 @@
 ;;;--------------------------------------------------------------------------
 ;;; 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 "<eof>" 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)
+(defun %skip-until (scanner token-types
+                   &key (keep-end (not (null (cdr token-types)))))
   "This is the implementation of the `skip-until' parser."
   (do ((consumedp nil t))
-      ((member (token-type scanner) token-types)
+      ((let ((type (token-type scanner))
+            (value (token-value scanner)))
+        (some (lambda (spec)
+                (multiple-value-bind (want-type want-value)
+                    (cond ((listp spec) (values (car spec) (cadr spec)))
+                          (t (values spec t)))
+                  (and (eq want-type type)
+                       (or (eq want-value t)
+                           (equal want-value value)))))
+              token-types))
        (unless keep-end (scanner-step scanner))
        (values nil t (or keep-end consumedp)))
     (when (scanner-at-eof-p scanner)
       (return (values token-types nil consumedp)))
     (scanner-step scanner)))
 
-(defun parse-error-recover (scanner parser recover &key ignore-unconsumed)
+(defun parse-error-recover (scanner parser recover
+                           &key ignore-unconsumed force-progress action)
   "This is the implementation of the `error' parser."
   (multiple-value-bind (result win consumedp) (funcall parser)
     (cond ((or win
@@ -84,8 +92,9 @@
           ;; current token.  Finally, if we are at EOF then our best bet is
           ;; simply to propagate the current failure back to the caller, but
           ;; we handled that case above.
-          (syntax-error scanner result :continuep t)
-          (unless consumedp (scanner-step scanner))
+          (syntax-error scanner result)
+          (when action (funcall action))
+          (when (and force-progress (not consumedp)) (scanner-step scanner))
           (funcall recover)))))
 
 ;;;--------------------------------------------------------------------------
@@ -100,7 +109,18 @@
               (parse (many (acc init (+ (* acc radix) it) :min min)
                        (label (list :digit radix)
                               (filter (lambda (ch)
-                                        (digit-char-p ch radix))))))))
+                                        (digit-char-p ch radix)))))))
+            (start-floc ()
+              ;; This is a little nasty.  We scan the first token during
+              ;; instance initialization, as a result of `shared-initialize'
+              ;; on `token-scanner'.  Unfortunately, this happens before
+              ;; we've had a chance to initialize our own `filename' slot.
+              ;; This means that we can't use the SCANNER as a file
+              ;; location, however tempting it might be.  So we have this
+              ;; hack.
+              (make-file-location (scanner-filename char-scanner)
+                                  (scanner-line scanner)
+                                  (scanner-column scanner))))
 
        ;; Skip initial junk, and remember the place.
        (loop
@@ -109,7 +129,7 @@
          (cond-parse (:consumedp cp :expected exp)
            ((satisfies whitespace-char-p) (parse :whitespace))
            ((scan-comment char-scanner))
-           (t (if cp (lexer-error char-scanner exp cp) (return)))))
+           (t (if cp (lexer-error char-scanner exp) (return)))))
 
        ;; Now parse something.
        (cond-parse (:consumedp cp :expected exp)
@@ -127,13 +147,25 @@
                                      (progn (write-char it out) out)
                                      :final (get-output-stream-string out))
                             (or (and #\\ :any) (not quote))))
-                (nil (char quote)))
+                (nil (or (char quote)
+                         (seq (:eof)
+                           (lexer-error char-scanner (list quote))
+                           (info-with-location
+                            (start-floc) "Literal started here")))))
             (ecase quote
               (#\" contents)
               (#\' (case (length contents)
                      (1 (char contents 0))
-                     (0 (cerror* "Empty character literal") #\?)
-                     (t (cerror* "Too many characters in literal")
+                     (0 (cerror*-with-location (start-floc)
+                                               'simple-lexer-error
+                                               :format-control
+                                               "Empty character literal")
+                        #\?)
+                     (t (cerror*-with-location (start-floc)
+                                               'simple-lexer-error
+                                               :format-control
+                                               "Too many characters ~
+                                                in character literal")
                         (char contents 0))))))
           (values (etypecase it
                     (character :char)
@@ -168,7 +200,7 @@
          ;; must make progress on every call.
          (t
           (assert cp)
-          (lexer-error char-scanner exp cp)
+          (lexer-error char-scanner exp)
           (scanner-token scanner)))))))
 
 ;;;----- That's all, folks --------------------------------------------------