source: project/release/4/r7rs/trunk/scheme.write.scm @ 30898

Last change on this file since 30898 was 30898, checked in by evhan, 6 years ago

r7rs: read/write for shared data

File size: 3.7 KB
Line 
1(module scheme.write (display
2                      write
3                      write-shared
4                      write-simple)
5  (import (rename scheme (display display-simple) (write write-simple))
6          (only chicken foldl fx+ fx= fx<= optional when))
7
8  (define (interesting? o)
9    (or (pair? o)
10        (and (vector? o)
11             (fx<= 1 (vector-length o)))))
12
13  (define (uninteresting? o)
14    (not (interesting? o)))
15
16  (define (display-char c p)
17    ((##sys#slot (##sys#slot p 2) 2) p c))
18
19  (define (display-string s p)
20    ((##sys#slot (##sys#slot p 2) 3) p s))
21
22  ;; Build an alist mapping `interesting?` objects to boolean values
23  ;; indicating whether those objects occur shared in `o`.
24  (define (find-shared o cycles-only?)
25
26    (define seen '())
27    (define (seen? x) (assq x seen))
28    (define (seen! x) (set! seen (cons (cons x 1) seen)))
29
30    ;; Walk the form, tallying the number of times each object is
31    ;; encountered. This has the effect of filling `seen` with
32    ;; occurence counts for all objects satisfying `interesting?`.
33    (let walk! ((o o))
34      (when (interesting? o)
35        (cond ((seen? o) =>
36               (lambda (p)
37                 (set-cdr! p (fx+ (cdr p) 1))))
38              ((pair? o)
39               (seen! o)
40               (walk! (car o))
41               (walk! (cdr o)))
42              ((vector? o)
43               (seen! o)
44               (let ((len (vector-length o)))
45                 (do ((i 0 (fx+ i 1)))
46                     ((fx= i len))
47                   (walk! (vector-ref o i))))))
48        ;; If we're only interested in cycles and this object isn't
49        ;; self-referential, discount it (resulting in `write` rather
50        ;; than `write-shared` behavior).
51        (when cycles-only?
52          (let ((p (seen? o)))
53            (when (fx<= (cdr p) 1)
54              (set-cdr! p 0))))))
55
56    ;; Mark shared objects #t, unshared objects #f.
57    (foldl (lambda (a p)
58             (if (fx<= (cdr p) 1)
59                 (cons (cons (car p) #f) a)
60                 (cons (cons (car p) #t) a)))
61           '()
62           seen))
63
64  (define (write-with-shared-structure writer obj cycles-only? port)
65
66    (define label 0)
67    (define (assign-label! pair)
68      (set-cdr! pair label)
69      (set! label (fx+ label 1)))
70
71    (define shared
72      (find-shared obj cycles-only?))
73
74    (define (write-interesting/shared o)
75      (cond ((pair? o)
76             (display-char #\( port)
77             (write/shared (car o))
78             (let loop ((o (cdr o)))
79               (cond ((null? o)
80                      (display-char #\) port))
81                     ((and (pair? o)
82                           (not (cdr (assq o shared))))
83                      (display-char #\space port)
84                      (write/shared (car o))
85                      (loop (cdr o)))
86                     (else
87                      (display-string " . " port)
88                      (write/shared o)
89                      (display-char #\) port)))))
90            ((vector? o)
91             (display-string "#(" port)
92             (write/shared (vector-ref o 0))
93             (let ((len (vector-length o)))
94               (do ((i 1 (fx+ i 1)))
95                   ((fx= i len)
96                    (display-char #\) port))
97                 (display-char #\space port)
98                 (write/shared (vector-ref o i)))))))
99
100    (define (write/shared o)
101      (if (uninteresting? o)
102          (writer o port)
103          (let* ((p (assq o shared))
104                 (d (cdr p)))
105            (cond ((not d)
106                   (write-interesting/shared o))
107                  ((number? d)
108                   (display-char #\# port)
109                   (writer d port)
110                   (display-char #\# port))
111                  (else
112                   (display-char #\# port)
113                   (writer label port)
114                   (display-char #\= port)
115                   (assign-label! p)
116                   (write-interesting/shared o))))))
117
118    (write/shared obj))
119
120  (: display (* #!optional output-port -> undefined))
121  (define (display o . p)
122    (write-with-shared-structure
123     display-simple
124     o
125     #t
126     (optional p (current-output-port))))
127
128  (: write (* #!optional output-port -> undefined))
129  (define (write o . p)
130    (write-with-shared-structure
131     write-simple
132     o
133     #t
134     (optional p (current-output-port))))
135
136  (: write-shared (* #!optional output-port -> undefined))
137  (define (write-shared o . p)
138    (write-with-shared-structure
139     write-simple
140     o
141     #f
142     (optional p (current-output-port)))))
Note: See TracBrowser for help on using the repository browser.