diff --git a/read.scm b/read.scm index 099de01..c430240 100644 --- a/read.scm +++ b/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) - (readtable:next toplevel #f 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))))))