~ chicken-r7rs (master) d2663609c4a959abf24062f21bf6d6932a05c846
commit d2663609c4a959abf24062f21bf6d6932a05c846
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Tue May 20 10:31:02 2014 +0000
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Tue May 20 10:31:02 2014 +0000
read/write for shared data
diff --git a/r7rs.setup b/r7rs.setup
index b6f72f1..cb489c5 100644
--- a/r7rs.setup
+++ b/r7rs.setup
@@ -4,7 +4,7 @@
(use make srfi-1)
(define scheme-modules
- '("case-lambda" "char" "complex" "cxr" "eval" "file" "inexact" "lazy" "load" "process-context" "r5rs" "read" "repl" "time" "write")) ;XXX
+ '("case-lambda" "char" "complex" "cxr" "eval" "file" "inexact" "lazy" "load" "process-context" "r5rs" "read" "repl" "time" "write"))
(make (("r7rs-compile-time.so" ("r7rs-compile-time.scm" "r7rs-compile-time-module.scm")
(compile -s -O3 -d1 r7rs-compile-time-module.scm -J -o r7rs-compile-time.so)
diff --git a/scheme.char.scm b/scheme.char.scm
index 5421d61..e9e9e70 100644
--- a/scheme.char.scm
+++ b/scheme.char.scm
@@ -47,13 +47,13 @@
(define-extended-arity-comparator string-ci<=? %string-ci<=? ##sys#check-string)
(define-extended-arity-comparator string-ci>=? %string-ci>=? ##sys#check-string)
-(: char-foldcase (char --> char))
+(: char-foldcase (char -> char))
(define (char-foldcase c) (char-downcase c))
-(: string-foldcase (string --> string))
+(: string-foldcase (string -> string))
(define (string-foldcase s) (string-map char-foldcase s))
-(: digit-value (char --> (or fixnum boolean)))
+(: digit-value (char -> (or fixnum boolean)))
(define (digit-value c)
(let ((i (char->integer c)))
(and (fx>= i 48) (fx<= i 57) (fx- i 48)))))
diff --git a/scheme.read.scm b/scheme.read.scm
index 6cea019..1ca8fba 100644
--- a/scheme.read.scm
+++ b/scheme.read.scm
@@ -1,2 +1,79 @@
(module scheme.read (read)
- (import scheme))
+ (import (except scheme read)
+ (only chicken current-read-table fx+ fx= optional unless when))
+
+ (define (data? o)
+ (not (procedure? o)))
+
+ (define (unthunk o fail)
+ (let ((v (o)))
+ (cond ((data? v) v)
+ ((eq? v o)
+ (fail "self-referential datum"))
+ (else
+ (unthunk v fail)))))
+
+ ;; Fills holes in `o` destructively.
+ (define (unthunkify! o fail)
+ (let loop! ((o o))
+ (cond ((pair? o)
+ (if (data? (car o))
+ (loop! (car o))
+ (set-car! o (unthunk (car o) fail)))
+ (if (data? (cdr o))
+ (loop! (cdr o))
+ (set-cdr! o (unthunk (cdr o) fail))))
+ ((vector? o)
+ (let ((len (vector-length o)))
+ (do ((i 0 (fx+ i 1)))
+ ((fx= i len))
+ (let ((v (vector-ref o i)))
+ (if (data? v)
+ (loop! v)
+ (vector-set! o i (unthunk v fail))))))))))
+
+ (define (read-with-shared-structure port)
+
+ (define read-table (current-read-table))
+ (unless (##sys#slot read-table 3)
+ (##sys#setslot read-table 3 (##sys#make-vector 256 #f)))
+
+ (define read-hash/orig (##sys#slot (##sys#slot read-table 3) 35))
+ (define read-equal/orig (##sys#slot (##sys#slot read-table 3) 61))
+
+ (define shared '())
+ (define (register-shared! n thunk)
+ (set! shared (cons (cons n thunk) shared)))
+
+ (define (read-hash/shared _ p n)
+ (##sys#read-char-0 p)
+ (cond ((assv n shared) => cdr)
+ (else (##sys#read-error p "undefined datum" n))))
+
+ (define (read-equal/shared _ p n)
+ (##sys#read-char-0 p)
+ (letrec ((o (begin
+ (register-shared! n (lambda () o))
+ (##sys#read p ##sys#default-read-info-hook))))
+ o))
+
+ (define (read/shared p)
+ (let ((o (##sys#read port ##sys#default-read-info-hook)))
+ (when (pair? shared)
+ (unthunkify! o (lambda a (apply ##sys#read-error p a))))
+ o))
+
+ (dynamic-wind
+ (lambda ()
+ (##sys#setslot (##sys#slot read-table 3) 35 read-hash/shared)
+ (##sys#setslot (##sys#slot read-table 3) 61 read-equal/shared))
+ (lambda ()
+ (read/shared port))
+ (lambda ()
+ (##sys#setslot (##sys#slot read-table 3) 35 read-hash/orig)
+ (##sys#setslot (##sys#slot read-table 3) 61 read-equal/orig))))
+
+ (: read (#!optional input-port -> *))
+ (define (read . port)
+ (read-with-shared-structure
+ (optional port (current-input-port)))))
diff --git a/scheme.write.scm b/scheme.write.scm
index 63cd99a..279a1d1 100644
--- a/scheme.write.scm
+++ b/scheme.write.scm
@@ -1,6 +1,142 @@
(module scheme.write (display
write
- ; write-shared
+ write-shared
write-simple)
- (import scheme)
- (define write-simple write))
+ (import (rename scheme (display display-simple) (write write-simple))
+ (only chicken foldl fx+ fx= fx<= optional when))
+
+ (define (interesting? o)
+ (or (pair? o)
+ (and (vector? o)
+ (fx<= 1 (vector-length o)))))
+
+ (define (uninteresting? o)
+ (not (interesting? o)))
+
+ (define (display-char c p)
+ ((##sys#slot (##sys#slot p 2) 2) p c))
+
+ (define (display-string s p)
+ ((##sys#slot (##sys#slot p 2) 3) p s))
+
+ ;; Build an alist mapping `interesting?` objects to boolean values
+ ;; indicating whether those objects occur shared in `o`.
+ (define (find-shared o cycles-only?)
+
+ (define seen '())
+ (define (seen? x) (assq x seen))
+ (define (seen! x) (set! seen (cons (cons x 1) seen)))
+
+ ;; Walk the form, tallying the number of times each object is
+ ;; encountered. This has the effect of filling `seen` with
+ ;; occurence counts for all objects satisfying `interesting?`.
+ (let walk! ((o o))
+ (when (interesting? o)
+ (cond ((seen? o) =>
+ (lambda (p)
+ (set-cdr! p (fx+ (cdr p) 1))))
+ ((pair? o)
+ (seen! o)
+ (walk! (car o))
+ (walk! (cdr o)))
+ ((vector? o)
+ (seen! o)
+ (let ((len (vector-length o)))
+ (do ((i 0 (fx+ i 1)))
+ ((fx= i len))
+ (walk! (vector-ref o i))))))
+ ;; If we're only interested in cycles and this object isn't
+ ;; self-referential, discount it (resulting in `write` rather
+ ;; than `write-shared` behavior).
+ (when cycles-only?
+ (let ((p (seen? o)))
+ (when (fx<= (cdr p) 1)
+ (set-cdr! p 0))))))
+
+ ;; Mark shared objects #t, unshared objects #f.
+ (foldl (lambda (a p)
+ (if (fx<= (cdr p) 1)
+ (cons (cons (car p) #f) a)
+ (cons (cons (car p) #t) a)))
+ '()
+ seen))
+
+ (define (write-with-shared-structure writer obj cycles-only? port)
+
+ (define label 0)
+ (define (assign-label! pair)
+ (set-cdr! pair label)
+ (set! label (fx+ label 1)))
+
+ (define shared
+ (find-shared obj cycles-only?))
+
+ (define (write-interesting/shared o)
+ (cond ((pair? o)
+ (display-char #\( port)
+ (write/shared (car o))
+ (let loop ((o (cdr o)))
+ (cond ((null? o)
+ (display-char #\) port))
+ ((and (pair? o)
+ (not (cdr (assq o shared))))
+ (display-char #\space port)
+ (write/shared (car o))
+ (loop (cdr o)))
+ (else
+ (display-string " . " port)
+ (write/shared o)
+ (display-char #\) port)))))
+ ((vector? o)
+ (display-string "#(" port)
+ (write/shared (vector-ref o 0))
+ (let ((len (vector-length o)))
+ (do ((i 1 (fx+ i 1)))
+ ((fx= i len)
+ (display-char #\) port))
+ (display-char #\space port)
+ (write/shared (vector-ref o i)))))))
+
+ (define (write/shared o)
+ (if (uninteresting? o)
+ (writer o port)
+ (let* ((p (assq o shared))
+ (d (cdr p)))
+ (cond ((not d)
+ (write-interesting/shared o))
+ ((number? d)
+ (display-char #\# port)
+ (writer d port)
+ (display-char #\# port))
+ (else
+ (display-char #\# port)
+ (writer label port)
+ (display-char #\= port)
+ (assign-label! p)
+ (write-interesting/shared o))))))
+
+ (write/shared obj))
+
+ (: display (* #!optional output-port -> undefined))
+ (define (display o . p)
+ (write-with-shared-structure
+ display-simple
+ o
+ #t
+ (optional p (current-output-port))))
+
+ (: write (* #!optional output-port -> undefined))
+ (define (write o . p)
+ (write-with-shared-structure
+ write-simple
+ o
+ #t
+ (optional p (current-output-port))))
+
+ (: write-shared (* #!optional output-port -> undefined))
+ (define (write-shared o . p)
+ (write-with-shared-structure
+ write-simple
+ o
+ #f
+ (optional p (current-output-port)))))
Trap