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