1 ;; Copyright (C) 2010 Free Software Foundation, Inc.
2 ;; Copyright (C) Ray Dillinger 2003. All Rights Reserved.
4 ;; Contains code based upon Alex Shinn's public-domain implementation of
5 ;; `read-with-shared-structure' found in Chicken's SRFI 38 egg.
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:
15 ;; The above copyright notice and this permission notice shall be
16 ;; included in all copies or substantial portions of the Software.
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
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))
35 (cond-expand-provide (current-module) '(srfi-38))
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.
41 ;; Code attributed to Al Petrofsky, modified by Ray Dillinger.
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.
47 (define* (write-with-shared-structure obj
49 (outport (current-output-port))
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).
58 (define (interesting? obj)
60 (and (vector? obj) (not (zero? (vector-length obj))))
61 (and (string? obj) (not (zero? (string-length obj))))
67 ;; (write-obj OBJ STATE):
69 ;; STATE is a hashtable which has an entry for each interesting part
70 ;; of OBJ. The associated value will be:
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
78 ;; Mutates STATE for any parts that had numbers assigned.
79 (define (write-obj obj state)
80 (define (write-interesting)
83 (write-obj (car obj) state)
84 (let write-cdr ((obj (cdr obj)))
85 (cond ((and (pair? obj) (not (hash-table-ref state obj)))
87 (write-obj (car obj) state)
88 (write-cdr (cdr obj)))
90 (display ")" outport))
92 (display " . " outport)
94 (display ")" outport)))))
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))
110 (begin (display "#" outport)
112 (display "#" outport)))
114 (let ((n (+ 1 (hash-table-ref state 'counter))))
115 (display "#" outport)
117 (display "=" outport)
118 (hash-table-set! state 'counter n)
119 (hash-table-set! state obj n)
120 (write-interesting))))))
122 (write obj outport))))
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,
127 (define (scan obj state)
128 (cond ((not (interesting? obj)))
129 ((hash-table-exists? state obj)
130 (hash-table-set! state obj #t))
132 (hash-table-set! state obj #f)
134 (scan (car obj) state)
135 (scan (cdr obj) state))
137 (let ((len (vector-length obj)))
140 (scan (vector-ref obj i) state))))))))
142 (let ((state (make-hash-table eq?)))
144 (hash-table-set! state 'counter 0)
145 (write-obj obj state)))
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.
152 (define* (read-with-shared-structure #:optional (port (current-input-port)))
153 (let ((parts-table (make-hash-table eqv?)))
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))))))
163 (define (read-hash c port)
164 (let* ((n (string->number (read-some-chars char-numeric? (list c))))
166 (thunk (hash-table-ref/default parts-table n #f)))
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)))
179 (error "Use of undeclared part " n)))
181 (error "Malformed shared part specifier")))))
183 (with-fluid* %read-hash-procedures (fluid-ref %read-hash-procedures)
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))
193 (define (hole? x) (procedure? x))
194 (define (fill-hole x) (if (hole? x) (fill-hole (x)) 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))))
202 (do ((i (- (vector-length x) 1) (- i 1)))
204 (let ((elt (vector-ref x i)))
206 (vector-set! x i (fill-hole elt))