Work in progress, recovered from old crybaby.

[sod] / src / parse-lexical.lisp

diff --git a/src/parse-lexical.lisp b/src/parse-lexical.lisp
index 9fe6bb8..1e9a76c 100644 (file)
--- a/src/parse-lexical.lisp
+++ b/src/parse-lexical.lisp
@@ -37,6 +37,11 @@
    Not a lot here, apart from a character scanner to read from and the
    standard token scanner infrastructure."))
 
+(defmethod shared-initialize :after
+    ((scanner sod-token-scanner) slot-names &key)
+  (default-slot (scanner 'sod-parser::filename slot-names)
+    (scanner-filename (token-scanner-char-scanner scanner))))
+
 ;;;--------------------------------------------------------------------------
 ;;; Utilities.
 
@@ -65,9 +70,19 @@
                    (skip-many () (not #\newline))
                    (? #\newline))))))
 
+(defmethod make-scanner-stream ((scanner sod-token-scanner))
+  (make-scanner-stream (token-scanner-char-scanner scanner)))
+
 ;;;--------------------------------------------------------------------------
 ;;; Error reporting.
 
+(defvar *indicator-map* (make-hash-table)
+  "Hash table mapping indicator objects to human-readable descriptions.")
+
+(defun define-indicator (indicator description)
+  (setf (gethash indicator *indicator-map*) description)
+  indicator)
+
 (export 'syntax-error)
 (defun syntax-error (scanner expected &key (continuep t))
   "Signal a (maybe) continuable syntax error."
@@ -82,17 +97,39 @@
                   (:ellipsis "`...'")
                   (t (format nil "<? ~S~@[ ~S~]>" type value)))))
           (show-expected (thing)
-            (cond ((atom thing) (show-token thing nil))
-                  ((eq (car thing) :id)
-                   (format nil "`~A'" (cadr thing)))
-                  (t (format nil "<? ~S>" 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, ~]~} ~
+             expected ~{~#[<bug>~;~A~;~A or ~A~:;~A, ~]~} ~
              but found ~A"
             (mapcar #'show-expected expected)
             (show-token (token-type scanner) (token-value scanner)))))
 
+(export 'lexer-error)
+(defun lexer-error (char-scanner expected consumedp)
+  "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))))
+
 ;;;--------------------------------------------------------------------------
 ;;; Token scanner protocol implementation.
 
@@ -105,29 +142,7 @@
               (parse (many (acc init (+ (* acc radix) it) :min min)
                        (label (list :digit radix)
                               (filter (lambda (ch)
-                                        (digit-char-p ch radix)))))))
-
-            (lexer-error (expected consumedp)
-              ;; Report a 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)))))
+                                        (digit-char-p ch radix))))))))
 
        ;; Skip initial junk, and remember the place.
        (loop
@@ -136,7 +151,7 @@
          (cond-parse (:consumedp cp :expected exp)
            ((satisfies whitespace-char-p) (parse :whitespace))
            ((scan-comment char-scanner))
-           (t (if cp (lexer-error exp cp) (return)))))
+           (t (if cp (lexer-error char-scanner exp cp) (return)))))
 
        ;; Now parse something.
        (cond-parse (:consumedp cp :expected exp)
@@ -193,6 +208,9 @@
          ;; Report errors and try again.  Because we must have consumed some
          ;; input in order to get here (we've matched both :any and :eof) we
          ;; must make progress on every call.
-         (t (assert cp) (lexer-error exp cp) (scanner-token scanner)))))))
+         (t
+          (assert cp)
+          (lexer-error char-scanner exp cp)
+          (scanner-token scanner)))))))
 
 ;;;----- That's all, folks --------------------------------------------------