read: properly restore state when reading datum comments

read.scm

@@ -91,6 +91,9 @@
                (get-datum-label
                 (lambda (label)
                   (smap:search datum-labels label)))
+               (clear-datum-labels!
+                (lambda ()
+                  (set! datum-labels '())))
                (dump-mutable
                 (lambda ()
                   (list datum-labels fold-case?)))
@@ -133,6 +136,9 @@
                     ((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))
+                    ((eq? op 'clear-datum-labels!) (apply clear-datum-labels! args))
+                    ((eq? op 'dump-mutable) (apply dump-mutable args))
+                    ((eq? op 'restore-mutable!) (apply restore-mutable! args))
                     (else (error 'read->port 'invalid (cons op args)))))))
         port))))
 
@@ -582,12 +588,13 @@
 ;;; Reads the next toplevel datum, discards it, and then continues at the
 ;;; toplevel.
 ;;; 
-;;; TODO: The R7RS reader can cause side-effects due to #!FOLD-CASE. This
-;;; must be supressed in datum comments. A method could be added to PORT
-;;; that saves and restores mutable state (besides stream position).
+;;; The R7RS reader can cause side-effects due to #!FOLD-CASE and datum
+;;; labels. This must be supressed in datum comments.
 (define readtable:datum-comment
   (lambda (_ __ toplevel port)
+    (let ((mutable (port 'dump-mutable)))
       (readtable:next toplevel #f port)
+      (port 'restore-mutable! mutable))
     (readtable:next toplevel #f port)))
 
 (define readtable:hash
@@ -623,6 +630,14 @@
      (list readtable:update #\;
            (readtable:jump-discard readtable:read-to-newline)))))
 
+(define read/toplevel
+  (lambda (port)
+    ;; Does each invocation of READ keep datum labels from previous reads?
+    ;; (port 'clear-datum-labels!)
+    (readtable:next (readtable:top)
+                    #f
+                    port)))
+
 (define intset:insert (set:insert (set:update integer<=>)))
 (define intset:in (set:in integer<=>))
 
@@ -681,10 +696,7 @@
                 (lambda ()
                   (if (not (reader 'peek))
                       #t
-                      (let ((value (readtable:act
-                                    (readtable:top) (reader 'read)
-                                    #f
-                                    reader)))
+                      (let ((value (read/toplevel reader)))
                         (display (list "return" (uncycle value)))
                         (newline)
                         (loop))))))