~ chicken-core (chicken-5) 5cd403c419f083ef41dc5bb9be21804ac24eefe0
commit 5cd403c419f083ef41dc5bb9be21804ac24eefe0
Author: Florian Zumbiehl <florz@florz.de>
AuthorDate: Tue Mar 5 18:48:58 2013 +0100
Commit: Moritz Heidkamp <moritz@twoticketsplease.de>
CommitDate: Sun Mar 10 12:57:31 2013 +0100
extras/pretty-print: escape control characters in strings
Make pretty-print encode control characters in strings as escape sequences
rather than as literal bytes, the same way write does it.
Signed-off-by: Peter Bex <peter.bex@xs4all.nl>
diff --git a/extras.scm b/extras.scm
index 0e8b144e..f6daf1c2 100644
--- a/extras.scm
+++ b/extras.scm
@@ -331,31 +331,43 @@
(##sys#print obj #t s)
(out (get-output-string s) col) ) )
((procedure? obj) (out (##sys#procedure->string obj) col))
- ((string? obj) (if display?
- (out obj col)
- (let loop ((i 0) (j 0) (col (out "\"" col)))
- (if (and col (fx< j (string-length obj)))
- (let ((c (string-ref obj j)))
- (if (or (char=? c #\\)
- (char=? c #\"))
- (loop j
- (+ j 1)
- (out "\\"
- (out (##sys#substring obj i j)
- col)))
- (cond ((assq c '((#\tab . "\\t")
- (#\newline . "\\n")
- (#\return . "\\r")))
- =>
- (lambda (a)
- (let ((col2
- (out (##sys#substring obj i j) col)))
- (loop (fx+ j 1)
- (fx+ j 1)
- (out (cdr a) col2)))))
- (else (loop i (fx+ j 1) col)))))
- (out "\""
- (out (##sys#substring obj i j) col))))))
+ ((string? obj)
+ (if display?
+ (out obj col)
+ (let loop ((i 0) (j 0) (col (out "\"" col)))
+ (if (and col (fx< j (string-length obj)))
+ (let ((c (string-ref obj j)))
+ (cond
+ ((or (char=? c #\\)
+ (char=? c #\"))
+ (loop j
+ (+ j 1)
+ (out "\\"
+ (out (##sys#substring obj i j)
+ col))))
+ ((or (char<? c #\x20)
+ (char=? c #\x7f))
+ (loop (fx+ j 1)
+ (fx+ j 1)
+ (let ((col2
+ (out (##sys#substring obj i j) col)))
+ (cond ((assq c '((#\tab . "\\t")
+ (#\newline . "\\n")
+ (#\return . "\\r")
+ (#\vtab . "\\v")
+ (#\page . "\\f")
+ (#\alarm . "\\a")
+ (#\backspace . "\\b")))
+ =>
+ (lambda (a)
+ (out (cdr a) col2)))
+ (else
+ (out (number->string (char->integer c) 16)
+ (out (if (char<? c #\x10) "0" "")
+ (out "\\x" col2))))))))
+ (else (loop i (fx+ j 1) col))))
+ (out "\""
+ (out (##sys#substring obj i j) col))))))
((char? obj) (if display?
(out (make-string 1 obj) col)
(let ([code (char->integer obj)])
diff --git a/tests/pp-test.scm b/tests/pp-test.scm
index 318c982e..0af80e43 100644
--- a/tests/pp-test.scm
+++ b/tests/pp-test.scm
@@ -13,4 +13,5 @@
(test "\"\\\\\\\"\"\n" (pp->string "\\\""))
(test "\"\\\\\\\\\\\\\\\"\"\n" (pp->string "\\\\\\\""))
(test "\"\\\"\\\"\\\"\"\n" (pp->string "\"\"\""))
-(test "\\" "\\")
+(test "\"\\n\\t\\r\\b\\a\\v\\f\"\n" (pp->string "\n\t\r\b\a\v\f"))
+(test "\\" "\\") ; XXX?
Trap