[Chicken-hackers] [PATCH 1/5] Generalize port directionality

[Evan Hanson]

Convert the port direction and closed flags from booleans to bitmasks,
to allow for multidirectional ports.
---
 NEWS                 |  2 ++
 chicken.h            |  6 +++--
 library.scm          | 74 ++++++++++++++++++++++++++--------------------------
 ports.scm            | 14 +++++-----
 posix-common.scm     |  2 +-
 posixunix.scm        | 21 +++++++--------
 posixwin.scm         |  4 +--
 runtime.c            | 37 +++++---------------------
 tcp.scm              |  5 +---
 tests/port-tests.scm | 29 ++++++++++++++++++++
 types.db             | 10 +++----
 11 files changed, 103 insertions(+), 101 deletions(-)

diff --git a/NEWS b/NEWS
index 793c99a..fa8188c 100644
--- a/NEWS
+++ b/NEWS
@@ -6,6 +6,8 @@
     now return exact numbers where possible, so code relying on flonums
     being returned may need to be changed if rational numbers do not
     provide the desired performance.
+  - Port directionality has been generalized from a simple input/output
+    flag to a bitmap, to allow for multidirectional ports.
 
 - Compiler
   - Fixed an off by one allocation problem in generated C code for (list ...).
diff --git a/chicken.h b/chicken.h
index dc8cff0..dbb1e1b 100644
--- a/chicken.h
+++ b/chicken.h
@@ -673,8 +673,8 @@ static inline int isinf_ld (long double x)
 #define C_BAD_ARGUMENT_TYPE_NO_BOOLEAN_ERROR          37
 #define C_BAD_ARGUMENT_TYPE_NO_LOCATIVE_ERROR         38
 #define C_BAD_ARGUMENT_TYPE_NO_PORT_ERROR             39
-#define C_BAD_ARGUMENT_TYPE_NO_INPUT_PORT_ERROR       40
-#define C_BAD_ARGUMENT_TYPE_NO_OUTPUT_PORT_ERROR      41
+#define C_BAD_ARGUMENT_TYPE_PORT_DIRECTION_ERROR      40
+/* unused                                             41 */
 #define C_PORT_CLOSED_ERROR                           42
 #define C_ASCIIZ_REPRESENTATION_ERROR                 43
 #define C_MEMORY_VIOLATION_ERROR                      44
@@ -1180,6 +1180,8 @@ 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)
diff --git a/library.scm b/library.scm
index 20dd7bf..1c24ff1 100644
--- a/library.scm
+++ b/library.scm
@@ -2494,36 +2494,34 @@ EOF
 
 ;;; Ports:
 
-(define (port? x) (##core#inline "C_i_portp" x))
-
-(define-inline (%port? x)
+(define (port? x)
   (and (##core#inline "C_blockp" x)
-       (##core#inline "C_portp" x)) )
+       (##core#inline "C_portp" x)))
 
 (define (input-port? x)
-  (and (%port? x)
-       (##sys#slot x 1) ) )
+  (and (##core#inline "C_blockp" x)
+       (##core#inline "C_input_portp" x)))
 
 (define (output-port? x)
-  (and (%port? x)
-       (not (##sys#slot x 1)) ) )
+  (and (##core#inline "C_blockp" x)
+       (##core#inline "C_output_portp" x)))
 
 (define (port-closed? p)
   (##sys#check-port p 'port-closed?)
-  (##sys#slot p 8))
+  (fx= (##sys#slot p 8) 0))
 
 
 ;;; Port layout:
 ;
 ; 0:  FP (special)
-; 1:  input/output (bool)
+; 1:  direction (fixnum)
 ; 2:  class (vector of procedures)
 ; 3:  name (string)
 ; 4:  row (fixnum)
 ; 5:  col (fixnum)
 ; 6:  EOF (bool)
 ; 7:  type ('stream | 'custom | 'string | 'socket)
-; 8:  closed (bool)
+; 8:  closed (fixnum)
 ; 9:  data
 ; 10-15: reserved, port class specific
 ;
@@ -2548,6 +2546,7 @@ EOF
     (##sys#setislot port 4 1)
     (##sys#setislot port 5 0)
     (##sys#setslot port 7 type)
+    (##sys#setslot port 8 i/o)
     port) )
 
 ;;; Stream ports:
@@ -2585,7 +2584,7 @@ EOF
            (##core#inline "C_display_char" p c) )
          (lambda (p s)                 ; write-string
            (##core#inline "C_display_string" p s) )
-         (lambda (p)                   ; close
+         (lambda (p d)                 ; close
            (##core#inline "C_close_file" p)
            (##sys#update-errno) )
          (lambda (p)                   ; flush-output
@@ -2656,9 +2655,9 @@ EOF
 
 (define ##sys#open-file-port (##core#primitive "C_open_file_port"))
 
-(define ##sys#standard-input (##sys#make-port #t ##sys#stream-port-class 
"(stdin)" 'stream))
-(define ##sys#standard-output (##sys#make-port #f ##sys#stream-port-class 
"(stdout)" 'stream))
-(define ##sys#standard-error (##sys#make-port #f ##sys#stream-port-class 
"(stderr)" 'stream))
+(define ##sys#standard-input (##sys#make-port 1 ##sys#stream-port-class 
"(stdin)" 'stream))
+(define ##sys#standard-output (##sys#make-port 2 ##sys#stream-port-class 
"(stdout)" 'stream))
+(define ##sys#standard-error (##sys#make-port 2 ##sys#stream-port-class 
"(stderr)" 'stream))
 
 (##sys#open-file-port ##sys#standard-input 0 #f)
 (##sys#open-file-port ##sys#standard-output 1 #f)
@@ -2666,13 +2665,13 @@ EOF
 
 (define (##sys#check-input-port x open . loc)
   (if (pair? loc)
-      (##core#inline "C_i_check_port_2" x #t open (car loc))
-      (##core#inline "C_i_check_port" x #t open) ) )
+      (##core#inline "C_i_check_port_2" x 1 open (car loc))
+      (##core#inline "C_i_check_port" x 1 open)))
 
 (define (##sys#check-output-port x open . loc)
   (if (pair? loc)
-      (##core#inline "C_i_check_port_2" x #f open (car loc))
-      (##core#inline "C_i_check_port" x #f open) ) )
+      (##core#inline "C_i_check_port_2" x 2 open (car loc))
+      (##core#inline "C_i_check_port" x 2 open)))
 
 (define (##sys#check-port x . loc)
   (if (pair? loc)
@@ -2753,24 +2752,25 @@ EOF
                (##sys#error loc "cannot use append mode with input file")
                (set! fmode "a") ) ]
             [else (##sys#error loc "invalid file option" o)] ) ) )
-      (let ([port (##sys#make-port inp ##sys#stream-port-class name 'stream)])
+      (let ((port (##sys#make-port (if inp 1 2) ##sys#stream-port-class name 
'stream)))
         (unless (##sys#open-file-port port name (##sys#string-append fmode 
bmode))
           (##sys#update-errno)
           (##sys#signal-hook #:file-error loc (##sys#string-append "cannot 
open file - " strerror) name) )
         port) ) )
 
-  (define (close port loc)
+  (define (close port inp loc)
     (##sys#check-port port loc)
-    ;; repeated closing is ignored
-    (unless (##sys#slot port 8)                ; closed?
-      ((##sys#slot (##sys#slot port 2) 4) port) ; close
-      (##sys#setislot port 8 #t) )
-    (##core#undefined) )
+    ; 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)
+       ((##sys#slot (##sys#slot port 2) 4) port inp))))
 
   (set! open-input-file (lambda (name . mode) (open name #t mode 
'open-input-file)))
   (set! open-output-file (lambda (name . mode) (open name #f mode 
'open-output-file)))
-  (set! close-input-port (lambda (port) (close port 'close-input-port)))
-  (set! close-output-port (lambda (port) (close port 'close-output-port))) )
+  (set! close-input-port (lambda (port) (close port #t 'close-input-port)))
+  (set! close-output-port (lambda (port) (close port #f 'close-output-port))))
 
 (define call-with-input-file
   (let ([open-input-file open-input-file]
@@ -2857,12 +2857,12 @@ EOF
   (##sys#setslot port 3 name) )
 
 (define (##sys#port-line port)
-  (and (##sys#slot port 1) 
+  (and (fxodd? (##sys#slot port 1)) ; input port?
        (##sys#slot port 4) ) )
 
 (define (port-position #!optional (port ##sys#standard-input))
   (##sys#check-port port 'port-position)
-  (if (##sys#slot port 1) 
+  (if (fxodd? (##sys#slot port 1)) ; input port?
       (##sys#values (##sys#slot port 4) (##sys#slot port 5))
       (##sys#error 'port-position "cannot compute position of port" port) ) )
 
@@ -4071,9 +4071,10 @@ EOF
                 (outstr port (##sys#lambda-info->string x))
                 (outchr port #\>) )
                ((##core#inline "C_portp" x)
-                (if (##sys#slot x 1)
-                    (outstr port "#<input port \"")
-                    (outstr port "#<output port \"") )
+                (case (##sys#slot x 1)
+                  ((1)  (outstr port "#<input port \""))
+                  ((2)  (outstr port "#<output port \""))
+                  (else (outstr port "#<port \"")))
                 (outstr port (##sys#slot x 3))
                 (outstr port "\">") )
                ((##core#inline "C_vectorp" x)
@@ -4295,14 +4296,14 @@ EOF
 
 (define (open-input-string string)
   (##sys#check-string string 'open-input-string)
-  (let ([port (##sys#make-port #t ##sys#string-port-class "(string)" 'string)])
+  (let ((port (##sys#make-port 1 ##sys#string-port-class "(string)" 'string)))
     (##sys#setislot port 11 (##core#inline "C_block_size" string))
     (##sys#setislot port 10 0)
     (##sys#setslot port 12 string)
     port ) )
 
 (define (open-output-string)
-  (let ([port (##sys#make-port #f ##sys#string-port-class "(string)" 'string)])
+  (let ((port (##sys#make-port 2 ##sys#string-port-class "(string)" 'string)))
     (##sys#setislot port 10 0)
     (##sys#setislot port 11 output-string-initial-size)
     (##sys#setslot port 12 (##sys#make-string output-string-initial-size))
@@ -4905,8 +4906,7 @@ EOF
        ((37) (apply ##sys#signal-hook #:type-error loc "bad argument type - 
not a boolean" args))
        ((38) (apply ##sys#signal-hook #:type-error loc "bad argument type - 
not a locative" args))
        ((39) (apply ##sys#signal-hook #:type-error loc "bad argument type - 
not a port" args))
-       ((40) (apply ##sys#signal-hook #:type-error loc "bad argument type - 
not an input-port" args))
-       ((41) (apply ##sys#signal-hook #:type-error loc "bad argument type - 
not an output-port" args))
+       ((40) (apply ##sys#signal-hook #:type-error loc "bad argument type - 
not a port of the correct type" args))
        ((42) (apply ##sys#signal-hook #:file-error loc "port already closed" 
args))
        ((43) (apply ##sys#signal-hook #:type-error loc "cannot represent 
string with NUL bytes as C string" args))
        ((44) (apply ##sys#signal-hook #:memory-error loc "segmentation 
violation" args))
diff --git a/ports.scm b/ports.scm
index 1744c35..33390c4 100644
--- a/ports.scm
+++ b/ports.scm
@@ -254,9 +254,8 @@
                          last) ] ) ) )
             #f                         ; write-char
             #f                         ; write-string
-            (lambda (p)                ; close
-              (close)
-              (##sys#setislot p 8 #t) )
+            (lambda (p d)              ; close
+              (close))
             #f                         ; flush-output
             (lambda (p)                ; char-ready?
               (ready?) )
@@ -264,7 +263,7 @@
             read-line                  ; read-line
             read-buffered))
           (data (vector #f))
-          (port (##sys#make-port #t class "(custom)" 'custom)) )
+          (port (##sys#make-port 1 class "(custom)" 'custom)))
       (##sys#set-port-data! port data) 
       port) ) )
 
@@ -278,16 +277,15 @@
               (write (string c)) )
             (lambda (p s)              ; write-string
               (write s) )
-            (lambda (p)                ; close
-              (close)
-              (##sys#setislot p 8 #t) )
+            (lambda (p d)              ; close
+              (close))
             (lambda (p)                ; flush-output
               (when flush (flush)) )
             #f                         ; char-ready?
             #f                         ; read-string!
             #f) )                      ; read-line
           (data (vector #f))
-          (port (##sys#make-port #f class "(custom)" 'custom)) )
+          (port (##sys#make-port 2 class "(custom)" 'custom)))
       (##sys#set-port-data! port data) 
       port) ) )
 
diff --git a/posix-common.scm b/posix-common.scm
index 991ac7d..4bb21fb 100644
--- a/posix-common.scm
+++ b/posix-common.scm
@@ -380,7 +380,7 @@ EOF
   (define (check loc fd inp r)
     (if (##sys#null-pointer? r)
         (posix-error #:file-error loc "cannot open file" fd)
-        (let ([port (##sys#make-port inp ##sys#stream-port-class "(fdport)" 
'stream)])
+        (let ((port (##sys#make-port (if inp 1 2) ##sys#stream-port-class 
"(fdport)" 'stream)))
           (##core#inline "C_set_file_ptr" port r)
           port) ) )
   (set! open-input-file*
diff --git a/posixunix.scm b/posixunix.scm
index 3e25ff5..63cef98 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -662,7 +662,7 @@ EOF
   (define (check loc cmd inp r)
     (if (##sys#null-pointer? r)
        (posix-error #:file-error loc "cannot open pipe" cmd)
-       (let ([port (##sys#make-port inp ##sys#stream-port-class "(pipe)" 
'stream)])
+       (let ((port (##sys#make-port (if inp 1 2) ##sys#stream-port-class 
"(pipe)" 'stream)))
          (##core#inline "C_set_file_ptr" port r)
          port) ) )
   (set! open-input-pipe
@@ -1122,12 +1122,10 @@ EOF
                   (lambda ()           ; char-ready?
                     (or (fx< bufpos buflen)
                         (ready?)) )
-                  (lambda ()         ; close
-                                       ; Do nothing when closed already
-                    (unless (##sys#slot this-port 8)
-                      (when (fx< (##core#inline "C_close" fd) 0)
-                        (posix-error #:file-error loc "cannot close" fd nam) )
-                      (on-close) ) )
+                  (lambda ()           ; close
+                    (when (fx< (##core#inline "C_close" fd) 0)
+                      (posix-error #:file-error loc "cannot close" fd nam))
+                    (on-close))
                   (lambda ()           ; peek-char
                     (when (fx>= bufpos buflen)
                       (fetch))
@@ -1233,11 +1231,10 @@ EOF
                (make-output-port
                 (lambda (str)          ; write-string
                   (store str) )
-                (lambda ()           ; close - do nothing when closed already
-                  (unless (##sys#slot this-port 8)
-                    (when (fx< (##core#inline "C_close" fd) 0)
-                      (posix-error #:file-error loc "cannot close" fd nam) )
-                    (on-close) ) )
+                (lambda ()             ; close
+                  (when (fx< (##core#inline "C_close" fd) 0)
+                    (posix-error #:file-error loc "cannot close" fd nam))
+                  (on-close))
                 (lambda ()             ; flush
                   (store #f) ) )] )
        (set-port-name! this-port nam)
diff --git a/posixwin.scm b/posixwin.scm
index 59776b2..9ad9eff 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -882,7 +882,7 @@ EOF
     (##sys#update-errno)
     (if (##sys#null-pointer? r)
        (##sys#signal-hook #:file-error "cannot open pipe" cmd)
-       (let ([port (##sys#make-port inp ##sys#stream-port-class "(pipe)" 
'stream)])
+       (let ((port (##sys#make-port (if inp 1 2) ##sys#stream-port-class 
"(pipe)" 'stream)))
          (##core#inline "C_set_file_ptr" port r)
          port) ) )
   (set! open-input-pipe
@@ -1072,7 +1072,7 @@ EOF
     (##sys#update-errno)
     (if (##sys#null-pointer? r)
        (##sys#signal-hook #:file-error "cannot open file" fd)
-       (let ([port (##sys#make-port inp ##sys#stream-port-class "(fdport)" 
'stream)])
+       (let ((port (##sys#make-port (if inp 1 2) ##sys#stream-port-class 
"(fdport)" 'stream)))
          (##core#inline "C_set_file_ptr" port r)
          port) ) )
   (set! open-input-file*
diff --git a/runtime.c b/runtime.c
index a7282f8..c7a35cb 100644
--- a/runtime.c
+++ b/runtime.c
@@ -1882,13 +1882,8 @@ void barf(int code, char *loc, ...)
     c = 1;
     break;
 
-  case C_BAD_ARGUMENT_TYPE_NO_INPUT_PORT_ERROR:
-    msg = C_text("bad argument type - not an input-port");
-    c = 1;
-    break;
-
-  case C_BAD_ARGUMENT_TYPE_NO_OUTPUT_PORT_ERROR:
-    msg = C_text("bad argument type - not an output-port");
+  case C_BAD_ARGUMENT_TYPE_PORT_DIRECTION_ERROR:
+    msg = C_text("bad argument type - not a port of the correct type");
     c = 1;
     break;
 
@@ -7062,39 +7057,21 @@ C_regparm C_word C_fcall C_i_check_list_2(C_word x, 
C_word loc)
 }
 
 
-C_regparm C_word C_fcall C_i_check_port_2(C_word x, C_word input, C_word open, 
C_word loc)
+C_regparm C_word C_fcall C_i_check_port_2(C_word x, C_word dir, C_word open, 
C_word loc)
 {
-  int inp;
 
   if(C_immediatep(x) || C_header_bits(x) != C_PORT_TYPE) {
     error_location = loc;
     barf(C_BAD_ARGUMENT_TYPE_NO_PORT_ERROR, NULL, x);
   }
 
-  inp = C_block_item(x, 1) == C_SCHEME_TRUE;   /* slot #1: I/O flag */
-
-  switch(input) {
-  case C_SCHEME_TRUE:
-    if(!inp) {
-      error_location = loc;
-      barf(C_BAD_ARGUMENT_TYPE_NO_INPUT_PORT_ERROR, NULL, x);
-    }
-
-    break;
-
-  case C_SCHEME_FALSE:
-    if(inp) {
-      error_location = loc;
-      barf(C_BAD_ARGUMENT_TYPE_NO_OUTPUT_PORT_ERROR, NULL, x);
-    }
-
-    break;
-
-    /* any other value: omit direction check */
+  if((C_block_item(x, 1) & dir) != dir) {      /* slot #1: I/O direction mask 
*/
+    error_location = loc;
+    barf(C_BAD_ARGUMENT_TYPE_PORT_DIRECTION_ERROR, NULL, x);
   }
 
   if(open == C_SCHEME_TRUE) {
-    if(C_block_item(x, 8) != C_SCHEME_FALSE) { /* slot #8: closed flag */
+    if(C_block_item(x, 8) == C_FIXNUM_BIT) {   /* slot #8: closed mask */
       error_location = loc;
       barf(C_PORT_CLOSED_ERROR, NULL, x);
     }
diff --git a/tcp.scm b/tcp.scm
index 5f5e519..bdb90ca 100644
--- a/tcp.scm
+++ b/tcp.scm
@@ -657,10 +657,7 @@ EOF
 
 (define (tcp-abandon-port p)
   (##sys#check-open-port p 'tcp-abandon-port)
-  (##sys#setislot
-   (##sys#port-data p)
-   (if (##sys#slot p 1) 1 2)
-   #t) )
+  (##sys#setislot (##sys#port-data p) (##sys#slot p 1) #t))
 
 (define (tcp-listener-fileno l)
   (##sys#check-structure l 'tcp-listener 'tcp-listener-fileno)
diff --git a/tests/port-tests.scm b/tests/port-tests.scm
index 78565e3..49b8e13 100644
--- a/tests/port-tests.scm
+++ b/tests/port-tests.scm
@@ -95,6 +95,35 @@ EOF
      (lambda (in) (read-char in)))
     (get-output-string out))))
 
+;; direction-specific port closure
+
+(let* ((n 0)
+       (p (make-input-port (constantly #\a)
+                          (constantly #t)
+                          (lambda () (set! n (add1 n))))))
+  (close-output-port p)
+  (assert (not (port-closed? p)))
+  (assert (= n 0))
+  (close-input-port p)
+  (assert (port-closed? p))
+  (assert (= n 1))
+  (close-input-port p)
+  (assert (port-closed? 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 (= n 0))
+  (close-output-port p)
+  (assert (port-closed? p))
+  (assert (= n 1))
+  (close-output-port p)
+  (assert (port-closed? p))
+  (assert (= n 1)))
+
 ;; fill buffers
 (with-input-from-file "compiler.scm" read-string)
 
diff --git a/types.db b/types.db
index d2b2b0b..dc070f7 100644
--- a/types.db
+++ b/types.db
@@ -1251,7 +1251,7 @@
 (port? (#(procedure #:pure #:predicate (or input-port output-port)) port? (*) 
boolean))
 
 (port-closed? (#(procedure #:clean #:enforce) port-closed? (port) boolean)
-             ((port) (##sys#slot #(1) '8)))
+             ((port) (eq? (##sys#slot #(1) '8) '0)))
 
 (print (procedure print (#!rest *) undefined))
 (print-call-chain (#(procedure #:clean #:enforce) print-call-chain (#!optional 
output-port fixnum * string) undefined))
@@ -1403,13 +1403,13 @@
 
 (##sys#check-input-port
  (#(procedure #:clean #:enforce) ##sys#check-input-port (input-port * 
#!optional *) *)
- ((* *) (##core#inline "C_i_check_port" #(1) '#t #(2)))
- ((* * *) (##core#inline "C_i_check_port_2" #(1) '#t #(2) #(3))))
+ ((* *) (##core#inline "C_i_check_port" #(1) '1 #(2)))
+ ((* * *) (##core#inline "C_i_check_port_2" #(1) '1 #(2) #(3))))
 
 (##sys#check-output-port
  (#(procedure #:clean #:enforce) ##sys#check-output-port (output-port * 
#!optional *) *)
- ((* *) (##core#inline "C_i_check_port" #(1) '#f #(2)))
- ((* * *) (##core#inline "C_i_check_port_2" #(1) '#f #(2) #(3))))
+ ((* *) (##core#inline "C_i_check_port" #(1) '2 #(2)))
+ ((* * *) (##core#inline "C_i_check_port_2" #(1) '2 #(2) #(3))))
 
 (##sys#check-open-port
  (#(procedure #:clean #:enforce) ##sys#check-open-port ((or input-port 
output-port) #!optional *) *)
-- 
2.1.4