~ chicken-core (chicken-5) c29ba2b8b26f9bbbafdb9483ae58704dda3eb538
commit c29ba2b8b26f9bbbafdb9483ae58704dda3eb538
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Thu Jun 30 20:09:45 2016 +1200
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Sat Jul 9 16:26:41 2016 +0200
Generalize port directionality
Convert the port direction and closed flags from booleans to bitmasks,
to allow for multidirectional ports.
Signed-off-by: Peter Bex <peter@more-magic.net>
diff --git a/NEWS b/NEWS
index 793c99a8..fa8188c8 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 dbaa92d9..509af5c4 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 20dd7bfa..1c24ff19 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 1744c356..33390c47 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 991ac7d2..4bb21fbd 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 3e25ff5c..63cef98c 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 59776b24..9ad9eff7 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 a7282f84..c7a35cb3 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 5f5e5196..bdb90cab 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 78565e35..49b8e138 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 d2b2b0ba..dc070f75 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 *) *)
Trap