summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMikael Djurfeldt <djurfeldt@nada.kth.se>2000-04-04 11:40:39 +0000
committerMikael Djurfeldt <djurfeldt@nada.kth.se>2000-04-04 11:40:39 +0000
commit186cf946542649468d16032c49b8be1f6e95a84a (patch)
treea412d396799c996ffbf72c252cb20bd60bd19778
parentf60d011a0599c339cdd640988f24f0a5d873a5f1 (diff)
downloadguile-186cf946542649468d16032c49b8be1f6e95a84a.tar.gz
* format.scm (format:obj->str): Handle circular references. Also,
print improper lists with (x y . z) syntax rather than as individual pairs. (This code should probably be integrated into C level facilities. It is currently terribly slow.)
-rw-r--r--ice-9/format.scm134
1 files changed, 80 insertions, 54 deletions
diff --git a/ice-9/format.scm b/ice-9/format.scm
index 8ef9a75b6..e4c5c6f63 100644
--- a/ice-9/format.scm
+++ b/ice-9/format.scm
@@ -775,68 +775,94 @@
;; quoted strings so that the output can always be processed by (read)
(define (format:obj->str obj slashify)
- (cond
- ((string? obj)
- (if slashify
- (let ((obj-len (string-length obj)))
- (string-append
- "\""
- (let loop ((i 0) (j 0)) ; taken from Marc Feeley's pp.scm
- (if (= j obj-len)
- (string-append (substring obj i j) "\"")
- (let ((c (string-ref obj j)))
- (if (or (char=? c #\\)
- (char=? c #\"))
- (string-append (substring obj i j) "\\"
- (loop j (+ j 1)))
- (loop i (+ j 1))))))))
- obj))
+ (define (obj->str obj slashify visited)
+ (if (memq obj (cdr visited))
+ (let ((n (- (list-index (cdr visited) (cdr obj)))))
+ (string-append "#" (number->string n) "#"))
+ (cond
+ ((string? obj)
+ (if slashify
+ (let ((obj-len (string-length obj)))
+ (string-append
+ "\""
+ (let loop ((i 0) (j 0)) ; taken from Marc Feeley's pp.scm
+ (if (= j obj-len)
+ (string-append (substring obj i j) "\"")
+ (let ((c (string-ref obj j)))
+ (if (or (char=? c #\\)
+ (char=? c #\"))
+ (string-append (substring obj i j) "\\"
+ (loop j (+ j 1)))
+ (loop i (+ j 1))))))))
+ obj))
- ((boolean? obj) (if obj "#t" "#f"))
+ ((boolean? obj) (if obj "#t" "#f"))
- ((number? obj) (number->string obj))
+ ((number? obj) (number->string obj))
- ((symbol? obj)
- (if format:symbol-case-conv
- (format:symbol-case-conv (symbol->string obj))
- (symbol->string obj)))
+ ((symbol? obj)
+ (if format:symbol-case-conv
+ (format:symbol-case-conv (symbol->string obj))
+ (symbol->string obj)))
- ((char? obj)
- (if slashify
- (format:char->str obj)
- (string obj)))
+ ((char? obj)
+ (if slashify
+ (format:char->str obj)
+ (string obj)))
- ((null? obj) "()")
+ ((null? obj) "()")
- ((input-port? obj)
- (format:iobj->str obj))
+ ((input-port? obj)
+ (format:iobj->str obj))
- ((output-port? obj)
- (format:iobj->str obj))
+ ((output-port? obj)
+ (format:iobj->str obj))
- ((list? obj)
- (string-append "("
- (let loop ((obj-list obj))
- (if (null? (cdr obj-list))
- (format:obj->str (car obj-list) #t)
- (string-append
- (format:obj->str (car obj-list) #t)
- " "
- (loop (cdr obj-list)))))
- ")"))
-
- ((pair? obj)
- (string-append "("
- (format:obj->str (car obj) #t)
- " . "
- (format:obj->str (cdr obj) #t)
- ")"))
-
- ((vector? obj)
- (string-append "#" (format:obj->str (vector->list obj) #t)))
-
- (else ; only objects with an #<...>
- (format:iobj->str obj)))) ; representation should fall in here
+ ((pair? obj)
+ (string-append "("
+ (let loop ((obj-list obj)
+ (visited visited)
+ (offset 0))
+ (cond ((null? (cdr obj-list))
+ (obj->str (car obj-list)
+ #t
+ (cons (car obj-list) visited)))
+ ((memq (cdr obj-list) visited)
+ (string-append
+ (obj->str (car obj-list)
+ #t
+ (cons (car obj-list) visited))
+ " . #"
+ (number->string
+ (- offset
+ (list-index visited (cdr obj-list))))
+ "#"))
+ ((pair? (cdr obj-list))
+ (string-append
+ (obj->str (car obj-list)
+ #t
+ (cons (car obj-list) visited))
+ " "
+ (loop (cdr obj-list)
+ (cons (cdr obj-list) visited)
+ (+ 1 offset))))
+ (else
+ (string-append
+ (obj->str (car obj-list)
+ #t
+ (cons (car obj-list) visited))
+ " . "
+ (obj->str (cdr obj-list)
+ #t
+ (cons (cdr obj-list) visited))))))
+ ")"))
+
+ ((vector? obj)
+ (string-append "#" (obj->str (vector->list obj) #t visited)))
+
+ (else ; only objects with an #<...>
+ (format:iobj->str obj))))) ; representation should fall in here
+ (obj->str obj slashify (list obj)))
;; format:iobj->str reveals the implementation dependent representation of
;; #<...> objects with the use of display and call-with-output-string.