[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Chicken-hackers] [PATCH 2/5] Add input-port-open? and output-port-open?
From: |
Evan Hanson |
Subject: |
[Chicken-hackers] [PATCH 2/5] Add input-port-open? and output-port-open? procedures |
Date: |
Thu, 30 Jun 2016 20:09:46 +1200 |
These test whether a port is open in a specific direction.
---
NEWS | 2 ++
chicken.h | 10 ++++++++--
chicken.import.scm | 2 ++
library.scm | 19 +++++++++++++------
manual/Unit library | 12 +++++++++++-
tests/port-tests.scm | 19 +++++++++++++------
types.db | 3 +++
7 files changed, 52 insertions(+), 15 deletions(-)
diff --git a/NEWS b/NEWS
index fa8188c..775ee57 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 dbb1e1b..29c0c2b 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 2b30f54..de0ce6b 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 1c24ff1..be9c61a 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 27f6696..ff93fe9 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 49b8e13..2fc19a0 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 dc070f7..259f191 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))
--
2.1.4
- [Chicken-hackers] [PATCH 0/5][5] Generalize port directionality and add basic refinement types, Evan Hanson, 2016/06/30
- [Chicken-hackers] [PATCH 2/5] Add input-port-open? and output-port-open? procedures,
Evan Hanson <=
- [Chicken-hackers] [PATCH 5/5] Add new `make-bidirectional-port` procedure to ports unit, Evan Hanson, 2016/06/30
- [Chicken-hackers] [PATCH 3/5] Add basic refinement types, Evan Hanson, 2016/06/30
- [Chicken-hackers] [PATCH 1/5] Generalize port directionality, Evan Hanson, 2016/06/30
- [Chicken-hackers] [PATCH 4/5] Add scrutinizer test suite, Evan Hanson, 2016/06/30
- Re: [Chicken-hackers] [PATCH 4/5] Add scrutinizer test suite, felix . winkelmann, 2016/06/30
- [Chicken-hackers] [PATCH] Nicer port direction error messages, Evan Hanson, 2016/06/30