read: add datum labels and UNCYCLE to cope with circular definitions
This commit is contained in:
parent
37355f1037
commit
3f9ba7c6ff
127
read.scm
127
read.scm
|
|
@ -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)")
|
||||
|
|
|
|||
Loading…
Reference in New Issue