diff options
author | Marius Vollmer <mvo@zagadka.de> | 2004-10-18 15:26:41 +0000 |
---|---|---|
committer | Marius Vollmer <mvo@zagadka.de> | 2004-10-18 15:26:41 +0000 |
commit | a6b3219e8586d0859f8314e88a30dd52d5e1a2d3 (patch) | |
tree | 53b69349648d4e8d850a9ad5470185a7cccc7a06 | |
parent | fbccd84e22a3374f6eb5ebd739b6cf5382158e2d (diff) | |
download | guile-a6b3219e8586d0859f8314e88a30dd52d5e1a2d3.tar.gz |
(format:obj->str): Simplified considerably by using
object->string or display instead of implementing our own printer.
Handle format:read-proof here. Unreadable objects are recognized
by their "#<" prefix instead of by being unknown to the custom
printer (which would treat keywords as unprintable, for example).
(format:iobj->str): Removed.
-rw-r--r-- | ice-9/format.scm | 141 |
1 files changed, 16 insertions, 125 deletions
diff --git a/ice-9/format.scm b/ice-9/format.scm index a8bad4ec9..2a92cbfa8 100644 --- a/ice-9/format.scm +++ b/ice-9/format.scm @@ -332,8 +332,8 @@ (next-arg) #f params) (anychar-dispatch)) ((#\S) ; Slashified -- for parsers - (set! format:read-proof (memq modifier - '(colon colon-at))) + (set! format:read-proof + (memq modifier '(colon colon-at))) (format:out-obj-padded (memq modifier '(at colon-at)) (next-arg) #t params) (anychar-dispatch)) @@ -807,132 +807,23 @@ (set! format:pos recursive-pos-save) arg-pos))) ; return the position in the arg. list - ;; format:obj->str returns a R4RS representation as a string of an arbitrary - ;; scheme object. - ;; First parameter is the object, second parameter is a boolean if the - ;; representation should be slashified as `write' does. - ;; It uses format:char->str which converts a character into - ;; a slashified string as `write' does and which is implementation dependent. - ;; It uses format:iobj->str to print out internal objects as - ;; quoted strings so that the output can always be processed by (read) - - (format:obj->str - (lambda (obj slashify) - (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")) - - ((number? obj) (number->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))) - - ((null? obj) "()") - - ((input-port? obj) - (format:iobj->str obj)) - - ((output-port? obj) - (format:iobj->str obj)) - - ((pair? obj) - (string-append "(" - (let loop ((obj-list obj) - (visited visited) - (offset 0) - (prefix "")) - (cond ((null? (cdr obj-list)) - (string-append - prefix - (obj->str (car obj-list) - #t - (cons (car obj-list) visited)))) - ((memq (cdr obj-list) visited) - (string-append - prefix - (obj->str (car obj-list) - #t - (cons (car obj-list) visited)) - " . #" - (number->string - (- offset - (list-index visited (cdr obj-list)))) - "#")) - ((pair? (cdr obj-list)) - (loop (cdr obj-list) - (cons (cdr obj-list) visited) - (+ 1 offset) - (string-append - prefix - (obj->str (car obj-list) - #t - (cons (car obj-list) visited)) - " "))) - (else - (string-append - prefix - (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. - ;; If format:read-proof is set to #t the resulting string is additionally - ;; set into string quotes. - + ;; when format:read-proof is true, format:obj->str will wrap + ;; result strings starting with "#<" in an extra pair of double + ;; quotes. + (format:read-proof #f) - (format:iobj->str - (lambda (iobj) - (if (or format:read-proof - format:iobj-case-conv) - (string-append - (if format:read-proof "\"" "") - (if format:iobj-case-conv - (format:iobj-case-conv - (call-with-output-string (lambda (p) (display iobj p)))) - (call-with-output-string (lambda (p) (display iobj p)))) - (if format:read-proof "\"" "")) - (call-with-output-string (lambda (p) (display iobj p)))))) + ;; format:obj->str returns a R4RS representation as a string of + ;; an arbitrary scheme object. + (format:obj->str + (lambda (obj slashify) + (let ((res (if slashify + (object->string obj) + (with-output-to-string (lambda () (display obj)))))) + (if (and format:read-proof (string-prefix? "#<" res)) + (object->string res) + res)))) ;; format:char->str converts a character into a slashified string as ;; done by `write'. The procedure is dependent on the integer |