diff --git a/read.scm b/read.scm index b3c9567..9040772 100644 --- a/read.scm +++ b/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)")