diff --git a/read.scm b/read.scm index 772ada7..f6f50c7 100644 --- a/read.scm +++ b/read.scm @@ -294,9 +294,10 @@ (else (error 'read:ident "invalid operation" op args)))))) (define read:ident-builder - (lambda (start-char location) + (lambda (location . start-char) (let ((char-list (linked-list:new))) - (char-list 'push start-char) + (if (not (null? start-char)) + (char-list 'push (car start-char))) (lambda (op . args) (cond ((eq? op 'finalize->ident) @@ -347,8 +348,8 @@ (lambda (table char acc port) (readtable:act readtable:identifier (port 'read) - (read:ident-builder char - (port 'location)) + (read:ident-builder (port 'location) + char) port))) ;;; ;;;;;;;;;;;;;;;;;;;; @@ -518,6 +519,30 @@ ((eq? op 'toplevel) toplevel) (else (apply ll op args))))))) +(define read:datum-label + (lambda (location toplevel) + (let ((finalized? #f) + (value '()) + (name (read:ident-builder location))) + (lambda (op . args) + (cond + ((eq? op 'finalize-value) + (if finalized? + (error 'datum-label "cannot finalize twice")) + (set! finalized? #t) + (set! value (car args)) + (set! toplevel #f)) + ((eq? op 'finalize->ident) + (set! name (name 'finalize->ident))) + ((eq? op 'value) + (if (not finalized?) + (error 'datum-label "value called before finalize")) + value) + ((eq? op 'toplevel) toplevel) + ((eq? op 'type) 'datum-label) + ((eq? op 'as-string) (name 'value)) + (else (apply name 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 @@ -527,36 +552,24 @@ (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-next "datum label cannot be itself") - (set-cdr! datum-label next-value)) - next-value))))) + (acc 'finalize->ident) + (port 'set-datum-label! (acc 'as-string) acc) + (let ((next-value (readtable:next (acc 'toplevel) + #f + port))) + (if (eqv? acc next-value) + (error 'datum-label-next "datum label cannot be itself")) + (acc 'finalize-value next-value) + (acc '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 'datum-label-next - "unknown reference to datum label" label) - (map:val datum-label)))))))) + (acc 'finalize->ident) + (let ((datum-label-container (port 'get-datum-label + (acc 'as-string)))) + (if (null? datum-label-container) + (error 'datum-label-next + "unknown reference to datum label" label) + (map:val datum-label-container))))))) ;;; Reads the next toplevel datum, discards it, and then continues at the ;;; toplevel. @@ -578,7 +591,7 @@ (lambda (_ char toplevel port) (readtable:act readtable:datum-label-next char - (linked-list/toplevel:new toplevel) + (read:datum-label (port 'location) toplevel) port))) (list readtable:update %bol readtable:vector))) @@ -634,6 +647,7 @@ (let ((type (value 'type))) (cond ((eq? type 'ident) (value 'value)) + ((eq? type 'datum-label) (uncycle (value 'value))) (else (vector 'unrepresentable type))))) (else value))))) (uncycle value)))))