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

This commit is contained in:
Peter McGoron 2024-09-22 11:48:26 -04:00
parent 37355f1037
commit 3f9ba7c6ff
1 changed files with 115 additions and 12 deletions

127
read.scm
View File

@ -32,15 +32,9 @@
;;; structure to convert it to regular Scheme data will resolve the
;;; indirection.
;;;
;;; Printing circular structures and shared structures:
;;;
;;; 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.
;;; All tokens are procedure-encapsulated objects, since the reader should
;;; never return a literal procedure. Each procedure has a TYPE message.
(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
(apply error tablemsg emsg))))
(lambda (table char acc port)
(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)")