~ chicken-r7rs (master) 265cd5806237ab14bf7f7e5e10342bd5ddceb0a9

commit 265cd5806237ab14bf7f7e5e10342bd5ddceb0a9
Author:     Peter Bex <peter@more-magic.net>
AuthorDate: Sat Jun 8 16:10:48 2013 +0000
Commit:     Evan Hanson <evhan@foldling.org>
CommitDate: Sat Jun 8 16:10:48 2013 +0000

    Simplify, add tests for input string ports, add {input,output}-port-open? predicates and export close-port

diff --git a/scheme.base-interface.scm b/scheme.base-interface.scm
index c395ea0..d6805da 100644
--- a/scheme.base-interface.scm
+++ b/scheme.base-interface.scm
@@ -25,7 +25,10 @@
   char->integer integer->char
   char<? char>? char<=? char>=?
   char?
-  close-input-port close-output-port close-port
+  close-input-port close-output-port
+  |#
+  close-port
+  #|
   complex?
   cond
   |#
@@ -77,7 +80,9 @@
   #|
   ;; import-for-syntax   XXX should we?
   include include-ci
+  |#
   input-port-open? output-port-open?
+  #|
   input-port? output-port?
   integer?
   lambda
diff --git a/scheme.base.scm b/scheme.base.scm
index 65d1ca6..d6166c6 100644
--- a/scheme.base.scm
+++ b/scheme.base.scm
@@ -174,6 +174,13 @@
         (else
          (error 'close-port "not a port" port))))
 
+(define (output-port-open? port)
+  (##sys#check-output-port port #f 'output-port-open?)
+  (not (port-closed? port)))
+(define (input-port-open? port)
+  (##sys#check-input-port port #f 'input-port-open?)
+  (not (port-closed? port)))
+
 (define (eof-object) #!eof)
 
 
diff --git a/tests/run.scm b/tests/run.scm
index 2c33573..a79a9c7 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -60,24 +60,53 @@
 
 ;; call-with-port is not supposed to close its port when leaving the
 ;; dynamic extent, only on normal return.
-(test-group "ports"
-  (let*-values (((jump-back? jump!) (call/cc (lambda (k) (values #f k))))
-                (_ (and jump-back? (jump! (void))))
-                ((string)
-                 (call-with-output-string
-                  (lambda (the-string-port)
-                    (test "call-with-port returns all values yielded by proc"
-                          '(1 2 3)
-                          (receive (call-with-port
-                                    the-string-port
-                                    (lambda (p)
-                                      (display "foo" p)
-                                      ;; Leave the dynamic extent momentarily;
-                                      ;; jump! will immediately return with #t.
-                                      (call/cc (lambda (k) (jump! #t k)))
-                                      (display "bar" p)
-                                      (values 1 2 3)))))
-                    (test-assert "call-with-port closes the port on normal return"
-                                 (port-closed? the-string-port))))))
-    (test "call-with-port passes the port correctly and allows temporary escapes"
-          "foobar" string)))
+;;
+;; XXX TODO: Rewrite in terms of SRFI-6 string port interface, so
+;; no call-with-*-string, but use get-output-string and such!
+;; Do this when it's clear how to re-export Chicken stuff.
+(test-group "string ports"
+  (receive (jump-back? jump!)
+      (call/cc (lambda (k) (values #f k)))
+    (when jump-back? (jump! (void)))
+    (let ((string (call-with-output-string
+                   (lambda (the-string-port)
+                     (receive (one two three)
+                         (call-with-port the-string-port
+                          (lambda (p)
+                            (display "foo" p)
+                            ;; Leave the dynamic extent momentarily;
+                            ;; jump! will immediately return with #t.
+                            (call/cc (lambda (k) (jump! #t k)))
+                            (test-assert "Port is still open after excursion"
+                                         (output-port-open? the-string-port))
+                            (display "bar" p)
+                            (values 1 2 3)))
+                       (test "call-with-port returns all values yielded by proc"
+                             '(1 2 3)
+                             (list one two three)))
+                     (test-assert "call-with-port closes the port on normal return"
+                                  (not (output-port-open? the-string-port)))
+                     (test-assert "It's ok to close output ports that are closed"
+                                  (close-port the-string-port))
+                     (test-error "input-port-open? fails on output ports"
+                                 (input-port-open? the-string-port))))))
+      (test "call-with-port passes the port correctly and allows temporary escapes"
+            "foobar" string)))
+
+  (call-with-input-string "foo"
+    (lambda (the-string-port)
+      (test-error "output-port-open? fails on input ports"
+                  (output-port-open? the-string-port))
+      (test-assert "Initially, string port is open"
+                   (input-port-open? the-string-port))
+      (test "Reading from string delivers the data"
+            'foo (read the-string-port))
+      (test "After reading all, we get the eof-object"
+            (eof-object) (read the-string-port))
+      (test-assert "Port is still open after all reads"
+                   (input-port-open? the-string-port))
+      (close-port the-string-port)
+      (test-assert "Port is no longer open after closing it"
+                   (not (input-port-open? the-string-port)))
+      (test-assert "It's ok to close input ports that are already closed"
+                   (close-port the-string-port)))))