read: add object encapsulating identifier

3 files changed, 49 insertions, 24 deletions

diff --git a/chez-compat.scm b/chez-compat.scm
index f400a3e..39cb31a 100644
--- a/chez-compat.scm
+++ b/chez-compat.scm
@@ -47,8 +47,3 @@
                               (begin evaluated ...)
                               (cond-expand rest ...)))))
 
-(define %r6rs-error error)
-
-(define (error . rest)
-  (apply %r6rs-error (cons "UNSLISP" rest)))
-
diff --git a/linked-list.scm b/linked-list.scm
index 356b2b2..fb71fe0 100644
--- a/linked-list.scm
+++ b/linked-list.scm
@@ -62,7 +62,7 @@
                (%set-cdr!
                 (lambda (val)
                   (if (null? tail)
-                      (error "cannot set cdr of empty list")
+                      (error 'linked-list "cannot set cdr of empty list")
                       (set-cdr! tail val)))))
         (lambda args
           (let ((op (car args)))
@@ -72,7 +72,7 @@
               ((eq? op 'set-cdr!) (apply %set-cdr! (cdr args)))
               ((eq? op 'to-list) head)
               ((eq? op 'traverse-from-head) (linked-list-elem:new head))
-              (else (error (cons "invalid operation" args))))))))))
+              (else (error 'linked-list (cons "invalid operation" args))))))))))
 
 (define x (linked-list:new))
 (x 'push-tail 1)
diff --git a/read.scm b/read.scm
index 9040772..772ada7 100644
--- a/read.scm
+++ b/read.scm
@@ -82,6 +82,8 @@
                     ;; OFFSET is sometimes set to #F to denote an unknown
                     ;; offset.
                     (offset (set! offset (+ 1 offset))))))
+               (location
+                (lambda () (list filename line-number offset)))
                (set-datum-label!
                 (lambda (label value)
                   (set! datum-labels
@@ -107,7 +109,7 @@
                 (lambda (op . args)
                   ;; TODO: turn into string map?
                   (cond
-                    ((eq? op 'pos) (list filename line-number offset))
+                    ((eq? op 'location) (location))
                     ((eq? op 'read)
                      (process
                       (if (null? pushback-buffer)
@@ -131,7 +133,7 @@
                     ((eq? op 'fold-case!) (set! fold-case? (car args)))
                     ((eq? op 'set-datum-label!) (apply set-datum-label! args))
                     ((eq? op 'get-datum-label) (apply get-datum-label args))
-                    (else (error "read->port: invalid" (cons op args)))))))
+                    (else (error 'read->port 'invalid (cons op args)))))))
         port))))
 
 ;;; ;;;;;;;;;;;;;;
@@ -283,11 +285,29 @@
 ;;; Identifier reader
 ;;; ;;;;;;;;;;;;;;;;;
 
+(define read:ident
+  (lambda (name location)
+    (lambda (op . args)
+      (cond
+        ((eq? op 'type) 'ident)
+        ((eq? op 'value) name)
+        (else (error 'read:ident "invalid operation" op args))))))
+
+(define read:ident-builder
+  (lambda (start-char location)
+    (let ((char-list (linked-list:new)))
+      (char-list 'push start-char)
+      (lambda (op . args)
+        (cond
+          ((eq? op 'finalize->ident)
+           (read:ident (list->string (char-list 'to-list)) location))
+          (else (apply char-list op args)))))))
+
 ;;; Push back CHAR and return ACC.
-(define readtable:return-acc-keep-char
+(define readtable:return-acc-as-ident
   (lambda (table char acc port)
     (port 'push char)
-    acc))
+    (acc 'finalize->ident)))
 
 ;;; Push CHAR to ACC and continue reading from TABLE.
 (define readtable:push-char
@@ -300,7 +320,7 @@
 (define readtable:exclude-from-identifiers
   (lambda (table excluded)
     (fold (lambda (char table)
-            (readtable:update table char readtable:return-acc-keep-char))
+            (readtable:update table char readtable:return-acc-as-ident))
           table
           excluded)))
 
@@ -325,12 +345,11 @@
 ;;; Read an identifier starting with CHAR.
 (define readtable:read-ident
   (lambda (table char acc port)
-    (let ((lst (linked-list:new)))
-      (lst 'push char)
-      (list->string
-       ((readtable:act readtable:identifier
-                     (port 'read) lst port)
-        'to-list)))))
+    (readtable:act readtable:identifier
+                   (port 'read)
+                   (read:ident-builder char
+                                       (port 'location))
+                   port)))
 
 ;;; ;;;;;;;;;;;;;;;;;;;;
 ;;; Comments and whitespace reader
@@ -357,6 +376,7 @@
            (readtable:act (readtable:update table
                                             %eol
                                             (readtable:error
+                                             'read-improper-cdr
                                              "proper list must have cdr"))
                           (port 'read)
                           #f
@@ -364,6 +384,7 @@
       (acc 'set-cdr! val)
       (let ((table (readtable:process
                     (readtable:empty/default (readtable:error
+                                              'read-improper-cdr
                                               "improper list has 1 cdr"))
                     (list readtable:update-list
                           readtable:ASCII-whitespace
@@ -419,7 +440,9 @@
   (lambda (table port)
     (readtable:read-list-loop (readtable:table-for-list
                                table
-                               (readtable:error "expected proper list"))
+                               (readtable:error
+                                'read-proper-list
+                                "expected proper list"))
                               port)))
 
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -499,7 +522,8 @@
 ;;; looks like "#[NUMBER]=" and a reference looks like "#[NUMBER]#".
 (define readtable:datum-label-next
   (readtable:process
-   (readtable:empty/default (readtable:error "invalid datum label/ref"))
+   (readtable:empty/default (readtable:error 'datum-label-next
+                                             "invalid datum label/ref"))
    (list readtable:update-list readtable:digits readtable:push-char)
    (list readtable:update #\=
          (lambda (_ __ acc port)
@@ -522,7 +546,7 @@
                  ;; the datum label.
                  (if (and (pair? next-value)
                           (equal? (car next-value) label))
-                     (error "datum label cannot be itself")
+                     (error 'datum-label-next "datum label cannot be itself")
                      (set-cdr! datum-label next-value))
                  next-value)))))
    (list readtable:update #\#
@@ -530,7 +554,8 @@
            (let ((label (list->string (acc 'to-list))))
              (let ((datum-label (port 'get-datum-label label)))
                (if (null? datum-label)
-                   (error "unknown reference to datum label" label)
+                   (error 'datum-label-next
+                          "unknown reference to datum label" label)
                    (map:val datum-label))))))))
 
 ;;; Reads the next toplevel datum, discards it, and then continues at the
@@ -546,7 +571,7 @@
 
 (define readtable:hash
   (readtable:process
-   (readtable:empty/default (readtable:error "unimplemented"))
+   (readtable:empty/default (readtable:error 'hash "unimplemented"))
    (list readtable:update #\| (readtable:jump/next readtable:block-comment))
    (list readtable:update #\; readtable:datum-comment)
    (list readtable:update-list readtable:digits ; Datum labels
@@ -571,7 +596,7 @@
            readtable:skip)
      (list readtable:update #f (readtable:return 'eof))
      (list readtable:update %bol readtable:read-list)
-     (list readtable:update %eol (readtable:error "unbalanced list"))
+     (list readtable:update %eol (readtable:error 'top "unbalanced list"))
      (list readtable:update #\# (readtable:next/old-as-acc
                                  readtable:hash))
      (list readtable:update #\;
@@ -605,6 +630,11 @@
                                  (if (not (null? (intset:in used-counters cur-cntr)))
                                      (list 'def cur-cntr '= returned)
                                      returned)))))))
+                    ((procedure? value)
+                     (let ((type (value 'type)))
+                       (cond
+                         ((eq? type 'ident) (value 'value))
+                         (else (vector 'unrepresentable type)))))
                     (else value)))))
         (uncycle value)))))