~ chicken-core (chicken-5) 3693970dc8b09eabc2c2ba6c04b268edef3ec8fa

commit 3693970dc8b09eabc2c2ba6c04b268edef3ec8fa
Author:     Evan Hanson <evhan@foldling.org>
AuthorDate: Thu Jun 30 20:09:46 2016 +1200
Commit:     Peter Bex <peter@more-magic.net>
CommitDate: Sat Jul 9 16:26:41 2016 +0200

    Add input-port-open? and output-port-open? procedures
    
    These test whether a port is open in a specific direction.
    
    Signed-off-by: Peter Bex <peter@more-magic.net>

diff --git a/NEWS b/NEWS
index fa8188c8..775ee576 100644
--- a/NEWS
+++ b/NEWS
@@ -33,6 +33,8 @@
   - `with-error-output-to-port' from the ports module has been renamed
     to the more common `with-error-to-port', and `with-error-to-string'
     has been added for completeness (thanks to Michael Silver).
+  - New `input-port-open?` and `output-port-open?` procedures have been
+    added for testing whether a port is open in a specific direction.
 
 - Module system
   - The compiler has been modularised, for improved namespacing.  This
diff --git a/chicken.h b/chicken.h
index 509af5c4..fe109ffe 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1180,8 +1180,6 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret;
 #define C_vectorp(x)              C_mk_bool(C_header_bits(x) == C_VECTOR_TYPE)
 #define C_bytevectorp(x)          C_mk_bool(C_header_bits(x) == C_BYTEVECTOR_TYPE)
 #define C_portp(x)                C_mk_bool(C_header_bits(x) == C_PORT_TYPE)
-#define C_input_portp(x)          C_mk_bool(C_header_bits(x) == C_PORT_TYPE && C_block_item(x, 1) & 0x2)
-#define C_output_portp(x)         C_mk_bool(C_header_bits(x) == C_PORT_TYPE && C_block_item(x, 1) & 0x4)
 #define C_structurep(x)           C_mk_bool(C_header_bits(x) == C_STRUCTURE_TYPE)
 #define C_locativep(x)            C_mk_bool(C_block_header(x) == C_LOCATIVE_TAG)
 #define C_charp(x)                C_mk_bool(((x) & C_IMMEDIATE_TYPE_BITS) == C_CHARACTER_BITS)
@@ -1202,6 +1200,14 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret;
 #define C_vemptyp(x)              C_mk_bool(C_header_size(x) == 0)
 #define C_notvemptyp(x)           C_mk_bool(C_header_size(x) > 0)
 
+#define C_port_typep(x, n)        C_mk_bool((C_block_item(x, 1) & n) == n)
+#define C_input_portp(x)          C_and(C_portp(x), C_port_typep(x, 0x2))
+#define C_output_portp(x)         C_and(C_portp(x), C_port_typep(x, 0x4))
+
+#define C_port_openp(port, n)     C_mk_bool((C_block_item(port, 8) & n) == n)
+#define C_input_port_openp(port)  C_port_openp(port, 0x2)
+#define C_output_port_openp(port) C_port_openp(port, 0x4)
+
 #define C_slot(x, i)              C_block_item(x, C_unfix(i))
 #define C_subbyte(x, i)           C_fix(((C_byte *)C_data_pointer(x))[ C_unfix(i) ] & 0xff)
 #define C_subchar(x, i)           C_make_character(((C_uchar *)C_data_pointer(x))[ C_unfix(i) ])
diff --git a/chicken.import.scm b/chicken.import.scm
index 2b30f54f..de0ce6bc 100644
--- a/chicken.import.scm
+++ b/chicken.import.scm
@@ -114,6 +114,7 @@
    getter-with-setter
    implicit-exit-handler
    infinite?
+   input-port-open?
    (ir-macro-transformer . chicken.expand#ir-macro-transformer)
    keyword-style
    (load-library . chicken.eval#load-library)
@@ -135,6 +136,7 @@
    on-exit
    open-input-string
    open-output-string
+   output-port-open?
    parentheses-synonyms
    port-closed?
    port-name
diff --git a/library.scm b/library.scm
index 1c24ff19..be9c61ae 100644
--- a/library.scm
+++ b/library.scm
@@ -2506,6 +2506,14 @@ EOF
   (and (##core#inline "C_blockp" x)
        (##core#inline "C_output_portp" x)))
 
+(define (input-port-open? p)
+  (##sys#check-input-port p 'input-port-open?)
+  (##core#inline "C_input_port_openp" p))
+
+(define (output-port-open? p)
+  (##sys#check-output-port p 'output-port-open?)
+  (##core#inline "C_output_port_openp" p))
+
 (define (port-closed? p)
   (##sys#check-port p 'port-closed?)
   (fx= (##sys#slot p 8) 0))
@@ -2761,10 +2769,9 @@ EOF
   (define (close port inp loc)
     (##sys#check-port port loc)
     ; repeated closing is ignored
-    (let* ((old-closed (##sys#slot port 8))
-	   (new-closed (fxand old-closed (fxnot (if inp 1 2)))))
-      (unless (fx= new-closed old-closed) ; already closed?
-	(##sys#setislot port 8 new-closed)
+    (let ((direction (if inp 1 2)))
+      (when (##core#inline "C_port_openp" port direction)
+	(##sys#setislot port 8 (fxand (##sys#slot port 8) (fxnot direction)))
 	((##sys#slot (##sys#slot port 2) 4) port inp))))
 
   (set! open-input-file (lambda (name . mode) (open name #t mode 'open-input-file)))
@@ -2857,12 +2864,12 @@ EOF
   (##sys#setslot port 3 name) )
 
 (define (##sys#port-line port)
-  (and (fxodd? (##sys#slot port 1)) ; input port?
+  (and (##core#inline "C_input_portp" port)
        (##sys#slot port 4) ) )
 
 (define (port-position #!optional (port ##sys#standard-input))
   (##sys#check-port port 'port-position)
-  (if (fxodd? (##sys#slot port 1)) ; input port?
+  (if (##core#inline "C_input_portp" port)
       (##sys#values (##sys#slot port 4) (##sys#slot port 5))
       (##sys#error 'port-position "cannot compute position of port" port) ) )
 
diff --git a/manual/Unit library b/manual/Unit library
index 27f66960..ff93fe9a 100644
--- a/manual/Unit library	
+++ b/manual/Unit library	
@@ -341,11 +341,21 @@ different behavior.
 Write buffered output to the given output-port. {{PORT}} defaults
 to the value of {{(current-output-port)}}.
 
+==== input-port-open?
+
+<procedure>(input-port-open? PORT)</procedure>
+
+Is the given {{PORT}} open for input?
+
+<procedure>(output-port-open? PORT)</procedure>
+
+Is the given {{PORT}} open for output?
+
 ==== port-closed?
 
 <procedure>(port-closed? PORT)</procedure>
 
-Is the given {{PORT}} closed?
+Is the given {{PORT}} closed (in all directions)?
 
 ==== port-name
 
diff --git a/tests/port-tests.scm b/tests/port-tests.scm
index 49b8e138..2fc19a08 100644
--- a/tests/port-tests.scm
+++ b/tests/port-tests.scm
@@ -95,6 +95,13 @@ EOF
      (lambda (in) (read-char in)))
     (get-output-string out))))
 
+;; {input,output}-port-open?
+
+(assert (input-port-open? (open-input-string "abc")))
+(assert (output-port-open? (open-output-string)))
+(assert-error (input-port-open? (open-output-string)))
+(assert-error (output-port-open? (open-input-string "abc")))
+
 ;; direction-specific port closure
 
 (let* ((n 0)
@@ -102,26 +109,26 @@ EOF
 			   (constantly #t)
 			   (lambda () (set! n (add1 n))))))
   (close-output-port p)
-  (assert (not (port-closed? p)))
+  (assert (input-port-open? p))
   (assert (= n 0))
   (close-input-port p)
-  (assert (port-closed? p))
+  (assert (not (input-port-open? p)))
   (assert (= n 1))
   (close-input-port p)
-  (assert (port-closed? p))
+  (assert (not (input-port-open? p)))
   (assert (= n 1)))
 
 (let* ((n 0)
        (p (make-output-port (lambda () (display #\a))
 			    (lambda () (set! n (add1 n))))))
   (close-input-port p)
-  (assert (not (port-closed? p)))
+  (assert (output-port-open? p))
   (assert (= n 0))
   (close-output-port p)
-  (assert (port-closed? p))
+  (assert (not (output-port-open? p)))
   (assert (= n 1))
   (close-output-port p)
-  (assert (port-closed? p))
+  (assert (not (output-port-open? p)))
   (assert (= n 1)))
 
 ;; fill buffers
diff --git a/types.db b/types.db
index dc070f75..259f191e 100644
--- a/types.db
+++ b/types.db
@@ -756,6 +756,9 @@
 (open-output-file (#(procedure #:clean #:enforce) open-output-file (string #!rest symbol) output-port))
 (close-input-port (#(procedure #:enforce) close-input-port (input-port) undefined))
 (close-output-port (#(procedure #:enforce) close-output-port (output-port) undefined))
+(input-port-open? (#(procedure #:enforce) input-port-open? (input-port) boolean))
+(output-port-open? (#(procedure #:enforce) output-port-open? (output-port) boolean))
+
 (read (#(procedure #:enforce) read (#!optional input-port) *))
 
 (eof-object? (#(procedure #:pure #:predicate eof) eof-object? (*) boolean))