From 94ccfc68c6f28678bbe66f74b1bf615a48165790 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 29 Apr 2008 13:02:12 +0000
Subject: [PATCH] r6rs tests and bug fixes (including PR 9324)

svn: r9534
---
 collects/rnrs/io/ports-6.ss     | 48 ++++++++++++++++++++++++++-
 collects/tests/r6rs/io/ports.ss | 57 +++++++++++++++++++++++++++++----
 2 files changed, 98 insertions(+), 7 deletions(-)

diff --git a/collects/rnrs/io/ports-6.ss b/collects/rnrs/io/ports-6.ss
index 09ce7285a4..bc15255eac 100644
--- a/collects/rnrs/io/ports-6.ss
+++ b/collects/rnrs/io/ports-6.ss
@@ -944,6 +944,24 @@
                               [(eq? c #\newline) 2]
                               [(eq? c #\return) 2]
                               [else 9])))]
+                     [(char? v)
+                      (case v
+                        [(#\x7) 7] ; #\alarm
+                        [(#\x1B) 5] ; #\esc
+                        [(#\x7F) 8] ; #\delete
+                        [else (and (not (char-graphic? v))
+                                   (+ 3
+                                      (if ((char->integer v) . < . #x10000)
+                                          4
+                                          6)))])]
+                     [(bytes? v) (+ 5
+                                    (sub1 (bytes-length v))
+                                    (for/fold ([len 0])
+                                        ([b (in-bytes v)])
+                                      (+ len (cond
+                                              [(b . < . 10) 1]
+                                              [(b . < . 100) 2]
+                                              [else 3]))))]
                      [else #f]))]
                  [pretty-print-print-hook
                   (lambda (v write? p)
@@ -963,7 +981,35 @@
                           (let ([s (format "00000~x" (char->integer c))])
                             (display (substring s (- (string-length s) 6)) p)
                             (write-char #\; p))]))
-                      (write-char #\" p)]))])
+                      (write-char #\" p)]
+                     [(char? v)
+                      (case v
+                        [(#\x7) (display "#\\alarm" p)]
+                        [(#\x1B) (display "#\\esc" p)]
+                        [(#\x7F) (display "#\\delete" p)]
+                        [else 
+                         (display "#\\x" p)
+                         (let ([n (number->string (char->integer v) 16)])
+                           (display (make-string
+                                     (- (if ((string-length n) . <= . 4)
+                                            4
+                                            6)
+                                        (string-length n))
+                                     #\0)
+                                    p)
+                           (display n p))])]
+                     [(bytes? v)
+                      (display "#vu8(" p)
+                      (if (zero? (bytes-length v))
+                          (display ")" p)
+                          (begin
+                            (display (bytes-ref v 0) p)
+                            (for ([b (in-bytes v)]
+                                  [i (in-naturals)])
+                              (unless (zero? i)
+                                (display " " p)
+                                (display b p)))
+                            (display ")" p)))]))])
     (pretty-print v port)))
 
 ;; ----------------------------------------
diff --git a/collects/tests/r6rs/io/ports.ss b/collects/tests/r6rs/io/ports.ss
index 028f2d7315..4fb508e6a1 100644
--- a/collects/tests/r6rs/io/ports.ss
+++ b/collects/tests/r6rs/io/ports.ss
@@ -98,6 +98,20 @@
            (test (port-has-set-port-position!? p) #f)
            (test/unspec (close-port p))))]))
 
+  (define-syntax test-rw
+    (syntax-rules ()
+      [(_ v)
+       (test (let ([p (open-string-input-port
+                       (call-with-string-output-port
+                        (lambda (p) (put-datum p v))))])
+               (dynamic-wind
+                   (lambda () 'ok)
+                   (lambda () (get-datum p))
+                   (lambda () (close-port p))))
+             v)]))
+
+  ;; ----------------------------------------
+
   (define (run-io-ports-tests)
 
     (test (enum-set->list (file-options)) '())
@@ -699,12 +713,43 @@
     (test (binary-port? (current-output-port)) #f)
     (test (textual-port? (current-output-port)) #t)
 
+    ;; ----------------------------------------
+
+    (test-rw 10)
+    (test-rw 10.0)
+    (test-rw 1/2)
+    (test-rw 1+2i)
+    (test-rw 1+2.0i)
+    (test-rw #t)
+    (test-rw #f)
+    (test-rw "apple")
+    (test-rw "app\x3BB;e")
+    (test-rw "app\x1678;e")
+    (test-rw #\a)
+    (test-rw #\x3BB)
+    (test-rw #\nul)
+    (test-rw #\alarm)
+    (test-rw #\backspace)
+    (test-rw #\tab)
+    (test-rw #\linefeed)
+    (test-rw #\newline)
+    (test-rw #\vtab)
+    (test-rw #\page)
+    (test-rw #\return)
+    (test-rw #\esc)
+    (test-rw #\space)
+    (test-rw #\delete)
+    (test-rw #\xFF)
+    (test-rw #\x00006587)
+    (test-rw #\x10FFFF)
+    (test-rw #\x1678)
+    (test-rw #vu8())
+    (test-rw #vu8(1 2 3))
+    (test-rw '#(a))
+    (test-rw '#())
+    (test-rw '#(a 1/2 "str" #vu8(1 2 7)))
+
     ;; ----------------------------------------
     
     ;;
-    )
-
-  (run-io-ports-tests)
-  (report-test-results)
-  )
-
+    ))