1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
|
;; Copyright (C) 2010 Free Software Foundation, Inc.
;; Copyright (C) Ray Dillinger 2003. All Rights Reserved.
;;
;; Contains code based upon Alex Shinn's public-domain implementation of
;; `read-with-shared-structure' found in Chicken's SRFI 38 egg.
;; Permission is hereby granted, free of charge, to any person obtaining
;; a copy of this software and associated documentation files (the
;; "Software"), to deal in the Software without restriction, including
;; without limitation the rights to use, copy, modify, merge, publish,
;; distribute, sublicense, and/or sell copies of the Software, and to
;; permit persons to whom the Software is furnished to do so, subject to
;; the following conditions:
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.
(define-module (srfi srfi-38)
#:export (write-with-shared-structure
read-with-shared-structure)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-8)
#:use-module (srfi srfi-69)
#:use-module (system vm trap-state))
(cond-expand-provide (current-module) '(srfi-38))
;; A printer that shows all sharing of substructures. Uses the Common
;; Lisp print-circle notation: #n# refers to a previous substructure
;; labeled with #n=. Takes O(n^2) time.
;; Code attributed to Al Petrofsky, modified by Ray Dillinger.
;; Modified in 2010 by Andreas Rottmann to use SRFI 69 hashtables,
;; making the time O(n), and adding some of Guile's data types to the
;; `interesting' objects.
(define* (write-with-shared-structure obj
#:optional
(outport (current-output-port))
(optarg #f))
;; We only track duplicates of pairs, vectors, strings, bytevectors,
;; structs (which subsume R6RS and SRFI-9 records), ports and (native)
;; hash-tables. 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))))
(bytevector? obj)
(struct? obj)
(port? obj)
(hash-table? obj)))
;; (write-obj OBJ STATE):
;;
;; STATE is a hashtable which 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 entry `counter' in STATE should be the most recently
;; assigned number.
;;
;; Mutates STATE for any parts that had numbers assigned.
(define (write-obj obj state)
(define (write-interesting)
(cond ((pair? obj)
(display "(" outport)
(write-obj (car obj) state)
(let write-cdr ((obj (cdr obj)))
(cond ((and (pair? obj) (not (hash-table-ref state obj)))
(display " " outport)
(write-obj (car obj) state)
(write-cdr (cdr obj)))
((null? obj)
(display ")" outport))
(else
(display " . " outport)
(write-obj obj state)
(display ")" outport)))))
((vector? obj)
(display "#(" outport)
(let ((len (vector-length obj)))
(write-obj (vector-ref obj 0) state)
(let write-vec ((i 1))
(cond ((= i len) (display ")" outport))
(else (display " " outport)
(write-obj (vector-ref obj i) state)
(write-vec (+ i 1)))))))
;; else it's a string
(else (write obj outport))))
(cond ((interesting? obj)
(let ((val (hash-table-ref state obj)))
(cond ((not val) (write-interesting))
((number? val)
(begin (display "#" outport)
(write val outport)
(display "#" outport)))
(else
(let ((n (+ 1 (hash-table-ref state 'counter))))
(display "#" outport)
(write n outport)
(display "=" outport)
(hash-table-set! state 'counter n)
(hash-table-set! state obj n)
(write-interesting))))))
(else
(write obj outport))))
;; Scan computes the initial value of the hash table, which maps each
;; interesting part of the object to #t if it occurs multiple times,
;; #f if only once.
(define (scan obj state)
(cond ((not (interesting? obj)))
((hash-table-exists? state obj)
(hash-table-set! state obj #t))
(else
(hash-table-set! state obj #f)
(cond ((pair? obj)
(scan (car obj) state)
(scan (cdr obj) state))
((vector? obj)
(let ((len (vector-length obj)))
(do ((i 0 (+ 1 i)))
((= i len))
(scan (vector-ref obj i) state))))))))
(let ((state (make-hash-table eq?)))
(scan obj state)
(hash-table-set! state 'counter 0)
(write-obj obj state)))
;; A reader that understands the output of the above writer. This has
;; been written by Andreas Rottmann to re-use Guile's built-in reader,
;; with inspiration from Alex Shinn's public-domain implementation of
;; `read-with-shared-structure' found in Chicken's SRFI 38 egg.
(define* (read-with-shared-structure #:optional (port (current-input-port)))
(let ((parts-table (make-hash-table eqv?)))
;; reads chars that match PRED and returns them as a string.
(define (read-some-chars pred initial)
(let iter ((chars initial))
(let ((c (peek-char port)))
(if (or (eof-object? c) (not (pred c)))
(list->string (reverse chars))
(iter (cons (read-char port) chars))))))
(define (read-hash c port)
(let* ((n (string->number (read-some-chars char-numeric? (list c))))
(c (read-char port))
(thunk (hash-table-ref/default parts-table n #f)))
(case c
((#\=)
(if thunk
(error "Double declaration of part " n))
(let* ((cell (list #f))
(thunk (lambda () (car cell))))
(hash-table-set! parts-table n thunk)
(let ((obj (read port)))
(set-car! cell obj)
obj)))
((#\#)
(or thunk
(error "Use of undeclared part " n)))
(else
(error "Malformed shared part specifier")))))
(with-fluid* %read-hash-procedures (fluid-ref %read-hash-procedures)
(lambda ()
(for-each (lambda (digit)
(read-hash-extend digit read-hash))
'(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
(let ((result (read port)))
(if (< 0 (hash-table-size parts-table))
(patch! result))
result)))))
(define (hole? x) (procedure? x))
(define (fill-hole x) (if (hole? x) (fill-hole (x)) x))
(define (patch! x)
(cond
((pair? x)
(if (hole? (car x)) (set-car! x (fill-hole (car x))) (patch! (car x)))
(if (hole? (cdr x)) (set-cdr! x (fill-hole (cdr x))) (patch! (cdr x))))
((vector? x)
(do ((i (- (vector-length x) 1) (- i 1)))
((< i 0))
(let ((elt (vector-ref x i)))
(if (hole? elt)
(vector-set! x i (fill-hole elt))
(patch! elt)))))))
|
