read: change datum label to object, that returns an encapsulated datum label

1 files changed, 47 insertions, 33 deletions

diff --git a/read.scm b/read.scm
index 772ada7..f6f50c7 100644
--- a/read.scm
+++ b/read.scm
@@ -294,9 +294,10 @@
         (else (error 'read:ident "invalid operation" op args))))))
 
 (define read:ident-builder
-  (lambda (start-char location)
+  (lambda (location . start-char)
     (let ((char-list (linked-list:new)))
-      (char-list 'push start-char)
+      (if (not (null? start-char))
+          (char-list 'push (car start-char)))
       (lambda (op . args)
         (cond
           ((eq? op 'finalize->ident)
@@ -347,8 +348,8 @@
   (lambda (table char acc port)
     (readtable:act readtable:identifier
                    (port 'read)
-                   (read:ident-builder char
-                                       (port 'location))
+                   (read:ident-builder (port 'location)
+                                       char)
                    port)))
 
 ;;; ;;;;;;;;;;;;;;;;;;;;
@@ -518,6 +519,30 @@
           ((eq? op 'toplevel) toplevel)
           (else (apply ll op args)))))))
 
+(define read:datum-label
+  (lambda (location toplevel)
+    (let ((finalized? #f)
+          (value '())
+          (name (read:ident-builder location)))
+      (lambda (op . args)
+        (cond
+          ((eq? op 'finalize-value)
+           (if finalized?
+               (error 'datum-label "cannot finalize twice"))
+           (set! finalized? #t)
+           (set! value (car args))
+           (set! toplevel #f))
+          ((eq? op 'finalize->ident)
+           (set! name (name 'finalize->ident)))
+          ((eq? op 'value)
+           (if (not finalized?)
+               (error 'datum-label "value called before finalize"))
+           value)
+          ((eq? op 'toplevel) toplevel)
+          ((eq? op 'type) 'datum-label)
+          ((eq? op 'as-string) (name 'value))
+          (else (apply name op args)))))))
+
 ;;; Readtable for the number part of a datum label / reference. A label
 ;;; looks like "#[NUMBER]=" and a reference looks like "#[NUMBER]#".
 (define readtable:datum-label-next
@@ -527,36 +552,24 @@
    (list readtable:update-list readtable:digits readtable:push-char)
    (list readtable:update #\=
          (lambda (_ __ acc port)
-           ;; All datum labels are saved as strings.
-           (let ((label (list->string (acc 'to-list))))
-             ;; Datum labels are pairs, one with the label and the other
-             ;; with the data that is to be used. The label is there to
-             ;; detect when a datum label refers to iself: i.e.
-             ;; #0=#0# .
-             ;; 
-             ;; The CAR is the label and the CDR is the thing it refers
-             ;; to.
-             (let ((datum-label (cons label '())))
-               (port 'set-datum-label! label datum-label)
-               (let ((next-value (readtable:next (acc 'toplevel)
-                                                 #f
-                                                 port)))
-                 ;; After reading the part after the datum label, check
-                 ;; that the labeled datum is not self a reference to
-                 ;; the datum label.
-                 (if (and (pair? next-value)
-                          (equal? (car next-value) label))
-                     (error 'datum-label-next "datum label cannot be itself")
-                     (set-cdr! datum-label next-value))
-                 next-value)))))
+           (acc 'finalize->ident)
+           (port 'set-datum-label! (acc 'as-string) acc)
+           (let ((next-value (readtable:next (acc 'toplevel)
+                                             #f
+                                             port)))
+             (if (eqv? acc next-value)
+                 (error 'datum-label-next "datum label cannot be itself"))
+             (acc 'finalize-value next-value)
+             (acc 'value))))
    (list readtable:update #\#
          (lambda (_ __ acc port)
-           (let ((label (list->string (acc 'to-list))))
-             (let ((datum-label (port 'get-datum-label label)))
-               (if (null? datum-label)
-                   (error 'datum-label-next
-                          "unknown reference to datum label" label)
-                   (map:val datum-label))))))))
+           (acc 'finalize->ident)
+           (let ((datum-label-container (port 'get-datum-label
+                                              (acc 'as-string))))
+             (if (null? datum-label-container)
+                 (error 'datum-label-next
+                        "unknown reference to datum label" label)
+                 (map:val datum-label-container)))))))
 
 ;;; Reads the next toplevel datum, discards it, and then continues at the
 ;;; toplevel.
@@ -578,7 +591,7 @@
          (lambda (_ char toplevel port)
            (readtable:act readtable:datum-label-next
                           char
-                          (linked-list/toplevel:new toplevel)
+                          (read:datum-label (port 'location) toplevel)
                           port)))
    (list readtable:update %bol readtable:vector)))
 
@@ -634,6 +647,7 @@
                      (let ((type (value 'type)))
                        (cond
                          ((eq? type 'ident) (value 'value))
+                         ((eq? type 'datum-label) (uncycle (value 'value)))
                          (else (vector 'unrepresentable type)))))
                     (else value)))))
         (uncycle value)))))