read: add datum labels and UNCYCLE to cope with circular definitions

read.scm

@@ -32,15 +32,9 @@
 ;;; structure to convert it to regular Scheme data will resolve the
 ;;; indirection.
 ;;; 
-;;; Printing circular structures and shared structures:
+;;; All tokens are procedure-encapsulated objects, since the reader should
-;;; 
+;;; never return a literal procedure. Each procedure has a TYPE message.
-;;; The only way to do so is to find a way to sort lists in a way that
+
-;;; respects EQ?. This is impossible in standard Scheme and also in
-;;; many implementations because of moving collectors.
-;;; 
-;;; A list could be maintained of all previous values, and each print
-;;; could check the list using EQ? to find a match, but for R7RS WRITE
-;;; and WRITE-SHARED this would be an O(N^2) operation.
 
 (load "chez-compat.scm")
 (load "util.scm")
@@ -78,13 +72,30 @@
     (let ((line-number 1)
           (offset 0)
           (pushback-buffer '())
+          (datum-labels '())
           (fold-case? #f))
       (letrec ((update-position!
                 (lambda (ch)
                   (cond
                     ((eqv? ch #\newline)
                      (set! line-number (+ 1 line-number)) (set! offset 0))
+                    ;; OFFSET is sometimes set to #F to denote an unknown
+                    ;; offset.
                     (offset (set! offset (+ 1 offset))))))
+               (set-datum-label!
+                (lambda (label value)
+                  (set! datum-labels
+                        (car (smap:insert datum-labels label value)))))
+               (get-datum-label
+                (lambda (label)
+                  (smap:search datum-labels label)))
+               (dump-mutable
+                (lambda ()
+                  (list datum-labels fold-case?)))
+               (restore-mutable!
+                (lambda (state)
+                  (set! datum-labels (car state))
+                  (set! fold-case? (cadr state))))
                (process
                 (lambda (ch)
                   (update-position! ch)
@@ -94,6 +105,7 @@
                     (else ch))))
                (port
                 (lambda (op . args)
+                  ;; TODO: turn into string map?
                   (cond
                     ((eq? op 'pos) (list filename line-number offset))
                     ((eq? op 'read)
@@ -117,6 +129,8 @@
                        (set! pushback-buffer (cons ch pushback-buffer))))
                     ((eq? op 'fold-case?) fold-case?)
                     ((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)))))))
         port))))
 
@@ -224,8 +238,8 @@
 ;;; Return an error.
 (define readtable:error
   (lambda emsg
-    (lambda tablemsg
+    (lambda (table char acc port)
-      (apply error tablemsg emsg))))
+      (error emsg char acc table port))))
 
 ;;; Discard the current character and continue reading the readtable.
 (define readtable:skip
@@ -412,6 +426,9 @@
 ;;; Reader for stuff that start with "#"
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+(define readtable:digits
+  (list #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
+
 (define readtable:vector
   (lambda (_ __ toplevel port)
     (list 'vector (readtable:read-proper-list toplevel port))))
@@ -468,6 +485,54 @@
                                      port))))))
     loop))
 
+;;; Encapsulate LINKED-LIST object with an additional value for the
+;;; toplevel table.
+(define linked-list/toplevel:new
+  (lambda (toplevel)
+    (let ((ll (linked-list:new)))
+      (lambda (op . args)
+        (cond
+          ((eq? op 'toplevel) toplevel)
+          (else (apply ll 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
+  (readtable:process
+   (readtable:empty/default (readtable:error "invalid datum label/ref"))
+   (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 cannot be itself")
+                     (set-cdr! datum-label next-value))
+                 next-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 "unknown reference to datum label" label)
+                   (map:val datum-label))))))))
+
 ;;; Reads the next toplevel datum, discards it, and then continues at the
 ;;; toplevel.
 ;;; 
@@ -484,6 +549,12 @@
    (readtable:empty/default (readtable:error "unimplemented"))
    (list readtable:update #\| (readtable:jump/next readtable:block-comment))
    (list readtable:update #\; readtable:datum-comment)
+   (list readtable:update-list readtable:digits ; Datum labels
+         (lambda (_ char toplevel port)
+           (readtable:act readtable:datum-label-next
+                          char
+                          (linked-list/toplevel:new toplevel)
+                          port)))
    (list readtable:update %bol readtable:vector)))
 
 ;;; ;;;;;;;;;;;;;;;;
@@ -506,6 +577,37 @@
      (list readtable:update #\;
            (readtable:jump-discard readtable:read-to-newline)))))
 
+(define intset:insert (set:insert (set:update integer<=>)))
+(define intset:in (set:in integer<=>))
+
+(define uncycle
+  (lambda (value)
+    (let ((cntr 0)
+          (used-counters '())
+          (pointers '()))
+      (letrec ((uncycle
+                (lambda (value)
+                  (cond
+                    ((pair? value)
+                     (let ((pair (assq value pointers)))
+                       (if (pair? pair)
+                           (begin
+                             (set! used-counters
+                                   (car (intset:insert used-counters (cdr pair))))
+                             (list 'ref (cdr pair)))
+                           (begin
+                             (set! pointers (cons (cons value cntr)
+                                                  pointers))
+                             (let ((cur-cntr cntr))
+                               (set! cntr (+ 1 cntr))
+                               (let ((returned (cons (uncycle (car value))
+                                                     (uncycle (cdr value)))))
+                                 (if (not (null? (intset:in used-counters cur-cntr)))
+                                     (list 'def cur-cntr '= returned)
+                                     returned)))))))
+                    (else value)))))
+        (uncycle value)))))
+
 ;;; ;;;;;;;;;;;
 ;;; Test reader
 ;;; ;;;;;;;;;;;
@@ -531,7 +633,7 @@
                                     (readtable:top) (reader 'read)
                                     #f
                                     reader)))
-                        (display (list "return" value))
+                        (display (list "return" (uncycle value)))
                         (newline)
                         (loop))))))
         (loop)))))
@@ -545,3 +647,4 @@
 (read-all "#( a b #| this is a #| nested block |# comment|# z w)")
 (read-all "#(a b #(c #|close#|comment|#|#y))")
 (read-all "(this has a #;(call with (current continuation)) datum comment)")
+(read-all "#0=(#0# not unix)")