Below are portable implementations of a read and write that use the
srfi-38 notation.
Some nitty gritty:
* The composition of characters into tokens and of tokens into data
should be explicitly described in BNF and in English. Points
to cover:
-- The #nn# and #nn= tokens are self-terminating
-- Leading zeros allowed? #007#
-- Multiple labels allowed? #1=#2=(#1# #2#)
-- Labeled references allowed? #1=(#2=#1# #2#)
-- Require that #1=#1# signal an error rather than cause an infinite loop.
* Mention explicitly that numbers do not survive across reads and
writes.
* May the numbers start at any number? Must they be used
sequentially? May they be reused? May they be used before they are
declared, (#1# #1=foo)? I think all these answers should be No.
The implementations below are not heavily tested.
Read-with-numbered-parts should be able to handle any correct r5rs
datum. It signals some errors but allows several non-standard things
as well, like (. x) and #(x . (y)).
-al
(define (read-with-numbered-parts . optional-port)
(define port
(if (null? optional-port) (current-input-port) (car optional-port)))
(define (read-char*) (read-char port))
(define (peek-char*) (peek-char port))
(define (looking-at? c)
(eqv? c (peek-char*)))
(define (delimiter? c)
(case c
((#\( #\) #\" #\;) #t)
(else (or (eof-object? c)
(char-whitespace? c)))))
(define (not-delimiter? c) (not (delimiter? c)))
(define (eat-intertoken-space)
(define c (peek-char*))
(cond ((eof-object? c))
((char-whitespace? c) (read-char*) (eat-intertoken-space))
((char=? c #\;)
(do ((c (read-char*) (read-char*)))
((or (eof-object? c) (char=? c #\newline))))
(eat-intertoken-space))))
(define (read-string)
(read-char*)
(let read-it ((chars '()))
(let ((c (read-char*)))
(case c
((#\") (list->string (reverse chars)))
((#\\) (read-it (cons (read-char*) chars)))
(else (read-it (cons c chars)))))))
;; reads chars that match PRED and returns them as a string.
(define (read-some-chars pred)
(let iter ((chars '()))
(let ((c (peek-char*)))
(if (or (eof-object? c) (not (pred c)))
(list->string (reverse chars))
(iter (cons (read-char*) chars))))))
;; reads a character after the #\ has been read.
(define (read-character)
(let ((c (peek-char*)))
(if (char-alphabetic? c)
(let ((name (read-some-chars char-alphabetic?)))
(cond ((= 1 (string-length name)) (string-ref name 0))
((string-ci=? name "space") #\space)
((string-ci=? name "newline") #\newline)
(else (error "Unknown named character: " name))))
(read-char*))))
(define (read-number first-char)
(let ((str (string-append (string first-char)
(read-some-chars not-delimiter?))))
(or (string->number str)
(error "Malformed number: " str))))
(define char-standard-case
(if (char=? #\a (string-ref (symbol->string 'a) 0))
char-downcase
char-upcase))
(define (string-standard-case str)
(let* ((len (string-length str))
(new (make-string len)))
(do ((i 0 (+ i 1)))
((= i len) new)
(string-set! new i (char-standard-case (string-ref str i))))))
(define (read-identifier)
(string->symbol (string-standard-case (read-some-chars not-delimiter?))))
(define (read-part-spec)
(let ((n (string->number (read-some-chars char-numeric?))))
(let ((c (read-char*)))
(case c
((#\=) (cons 'label n))
((#\#) (cons 'use n))
(else (error "Malformed shared part specifier"))))))
;; Tokens: strings, characters, numbers, booleans, and
;; identifiers/symbols are represented as themselves.
;; Single-character tokens are represented as (CHAR), the
;; two-character tokens #( and ,@ become (#\#) and (#\@).
;; #NN= and #NN# become (label NN) and (use NN).
(define (read-token)
(eat-intertoken-space)
(let ((c (peek-char*)))
(case c
((#\( #\) #\' #\`) (read-char*) (list c))
((#\,)
(read-char*)
(if (looking-at? #\@)
(begin (read-char*) '(#\@))
'(#\,)))
((#\") (read-string))
((#\.)
(read-char*)
(cond ((delimiter? (peek-char*)) '(#\.))
((not (looking-at? #\.)) (read-number #\.))
((begin (read-char*) (looking-at? #\.)) (read-char*) '...)
(else (error "Malformed token starting with \"..\""))))
((#\+) (read-char*) (if (delimiter? (peek-char*)) '+ (read-number c)))
((#\-) (read-char*) (if (delimiter? (peek-char*)) '- (read-number c)))
((#\#)
(read-char*)
(let ((c (peek-char*)))
(case c
((#\() (read-char*) '(#\#))
((#\\) (read-char*) (read-character))
((#\t #\T) (read-char*) #t)
((#\f #\F) (read-char*) #f)
(else (cond ((char-numeric? c) (read-part-spec))
(else (read-number #\#)))))))
(else (cond ((eof-object? c) c)
((char-numeric? c) (read-char*) (read-number c))
(else (read-identifier)))))))
;; Maps the number of each part to a thunk that returns the part.
(define parts-alist '())
(define (read-object)
(finish-reading-object (read-token)))
(define (finish-reading-object first-token)
(if (not (pair? first-token))
first-token
(case (car first-token)
((#\() (read-tail))
((#\#) (list->vector (read-tail)))
((#\. #\)) (error "Unexpected \"" token "\""))
((use) (let ((n (cdr first-token)))
(cond ((assv n parts-alist) => cdr)
(else (error "Use of undeclared part " n)))))
((label)
;; This is complicated in order to allow #1=#2=() and
;; #1=(#2=#1#) and not to loop forever when given #1=#1#.
(let ((n (cdr first-token)))
(if (assv n parts-alist)
(error "Double declaration of part " n)
(let read-labels ((labels (list n)))
(define (add-labels-to-alist! thunk)
(set! parts-alist
(append (map (lambda (n) (cons n thunk)) labels)
parts-alist)))
(let ((token (read-token)))
(cond ((and (pair? token) (eq? 'label (car token)))
;; An additional label in a chain of them.
(let ((n (cdr token)))
(if (or (assv n parts-alist) (memv n labels))
(error "Double declaration of part " n))
(read-labels (cons n labels))))
((and (pair? token) (eq? 'use (car token)))
;; The labeled object is a use of a previous label:
;; reuse its thunk for our thunk.
(let* ((n (cdr token)) (p (assv n parts-alist)))
(if (not p)
(error "Use of undeclared part " n)
(let ((thunk (cdr p)))
(add-labels-to-alist! thunk)
thunk))))
(else
;; Normal case. Make a thunk (which doesn't
;; need to be usable until the read is complete.)
(letrec
((obj (begin
(add-labels-to-alist! (lambda () obj))
(finish-reading-object token))))
obj))))))))
(else (list (caadr (assv (car first-token)
'((#\' 'x) (#\, ,x) (#\` `x) (#\@ ,@x))))
(read-object))))))
(define (read-tail)
(let ((token (read-token)))
(cond ((eof-object? token) (error "EOF inside a list or vector"))
((not (pair? token)) (cons token (read-tail)))
(else (case (car token)
((#\)) '())
((#\.) (let* ((obj (read-object))
(tok (read-token)))
(if (and (pair? tok) (char=? #\) (car tok)))
obj
(error "Extra junk after a dot"))))
(else (let ((obj (finish-reading-object token)))
(cons obj (read-tail)))))))))
(let ((obj (read-object)))
(let fill-in-parts ((obj obj))
(cond ((pair? obj)
(if (procedure? (car obj))
(set-car! obj ((car obj)))
(fill-in-parts (car obj)))
(if (procedure? (cdr obj))
(set-cdr! obj ((cdr obj)))
(fill-in-parts (cdr obj))))
((vector? obj)
(let ((len (vector-length obj)))
(do ((i 0 (+ i 1)))
((= i len))
(let ((elt (vector-ref obj i)))
(if (procedure? elt)
(vector-set! obj i (elt))
(fill-in-parts elt))))))))
obj))
(define (write-with-numbered-parts obj . optional-port)
(define port
(if (null? optional-port) (current-output-port) (car optional-port)))
(define (write* obj) (write obj port))
(define (display* obj) (display obj port))
(define (acons key val alist)
(cons (cons key val) alist))
;; We only track duplicates of pairs, vectors, and strings. We
;; ignore zero-length vectors and strings because r5rs doesn't
;; guarantee that eq? treats them sanely (and they aren't very
;; interesting anyway).
(define (interesting? obj)
(or (pair? obj)
(and (vector? obj) (not (zero? (vector-length obj))))
(and (string? obj) (not (zero? (string-length obj))))))
;; (write-obj OBJ ALIST):
;; ALIST has an entry for each interesting part of OBJ. The
;; associated value will be:
;; -- a number if the part has been given one,
;; -- #t if the part will need to be assigned a number but has not been yet,
;; -- #f if the part will not need a number.
;; The cdr of ALIST's first element should be the most recently
;; assigned number.
;; Returns an alist with new shadowing entries for any parts that
;; had numbers assigned.
(define (write-obj obj alist)
(define (write-interesting alist)
(cond ((pair? obj)
(let ((caro (car obj)) (cdro (cdr obj)))
(cond ((and (pair? cdro)
(null? (cdr cdro))
(let ((abbrev (assq caro '('"'" `"`" ,"," ,@",@"))))
(and abbrev
;; we can't abbreviate (quote . #1#)
(not (cdr (assq cdro alist)))
abbrev)))
=> (lambda (abbrev)
(display* (cadr abbrev))
(write-obj (car cdro) alist)))
(else (display* "(")
(let write-cdr ((obj cdro)
(alist (write-obj caro alist)))
(cond ((and (pair? obj)
(not (cdr (assq obj alist))))
(display* " ")
(write-cdr (cdr obj)
(write-obj (car obj) alist)))
((null? obj) (display* ")") alist)
(else (display* " . ")
(let ((alist (write-obj obj alist)))
(display* ")")
alist))))))))
((vector? obj)
(display* "#(")
(let ((len (vector-length obj)))
(do ((i 1 (+ i 1))
(alist (write-obj (vector-ref obj 0) alist)
(write-obj (vector-ref obj i) alist)))
((= i len) (display* ")") alist)
(display* " "))))
;; else it's a string
(else (write* obj) alist)))
(cond ((interesting? obj)
(let ((val (cdr (assq obj alist))))
(cond ((not val) (write-interesting alist))
((number? val)
(display* "#") (write* val) (display* "#") alist)
(else
(let ((n (+ 1 (cdar alist))))
(display* "#") (write* n) (display* "=")
(write-interesting (acons obj n alist)))))))
(else (write* obj) alist)))
;; Scan computes the initial value of the alist, which maps each
;; interesting part of the object to #t if it occurs multiple times,
;; #f if only once.
(define (scan obj alist)
(cond ((not (interesting? obj)) alist)
((assq obj alist) =>
(lambda (p) (if (cdr p) alist (acons obj #t alist))))
(else
(let ((alist (acons obj #f alist)))
(cond ((pair? obj) (scan (car obj) (scan (cdr obj) alist)))
((vector? obj)
(let ((len (vector-length obj)))
(do ((i 0 (+ 1 i))
(alist alist (scan (vector-ref obj i) alist)))
((= i len) alist))))
(else alist))))))
(write-obj obj (acons 'dummy 0 (scan obj '())))
;; Don't want to return the big alist that write-obj did, lest it hinder gc.
(if #f #f))
