[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: [Chicken-hackers] [PATCH] cleanup port-checking routines
|
From: |
Felix |
|
Subject: |
Re: [Chicken-hackers] [PATCH] cleanup port-checking routines |
|
Date: |
Fri, 30 Sep 2011 02:37:20 -0400 (EDT) |
From: Alan Post <address@hidden>
Subject: Re: [Chicken-hackers] [PATCH] cleanup port-checking routines
Date: Thu, 29 Sep 2011 06:03:38 -0601
> On Thu, Sep 29, 2011 at 03:40:42AM -0400, Felix wrote:
>> The attached patch introduces a native port-check routine and
>> various wrappers for checking port-direction and closed-status.
>> All uses of ##sys#check-port where changed accordingly and
>> redundant call to ##sys#check-port-mode where removed.
>>
>>
>> cheers,
>> felix
>
>> diff --git a/optimizer.scm b/optimizer.scm
>> index e0f4214..4e66027 100644
>> --- a/optimizer.scm
>> +++ b/optimizer.scm
>> @@ -1,4 +1,4 @@
>> -;;;; optimizer.scm - The CHICKEN Scheme compiler (optimizations)
>> +char;;;; optimizer.scm - The CHICKEN Scheme compiler (optimizations)
>> ;
>> ; Copyright (c) 2008-2011, The Chicken Team
>> ; Copyright (c) 2000-2007, Felix L. Winkelmann
>
> I don't think this file should be patched, as the patch looks to me like
> a typo.
Attached a new version. Thanks again for spotting this.
cheers,
felix
commit 15a40a03dc77f0d87bfdabb6e0b89601317bfbdb
Author: felix <address@hidden>
Date: Fri Sep 30 08:19:10 2011 +0200
Squashed commit of the following:
commit ea3060ca9d458ce8c79c5cc121c2dcc024d9b62a
Author: felix <address@hidden>
Date: Fri Sep 30 08:18:15 2011 +0200
fixed junk in optimizer.scm (detected by Alan Post)
commit 62fdf24668971131d25af1d4f087d83d8b56c7c0
Author: felix <address@hidden>
Date: Thu Sep 29 14:04:08 2011 +0200
fixed incorrectly named parameter (thanks to Alan Post)
commit 1d6a1e66ec087d191beb7aa6da39d0903722d137
Author: felix <address@hidden>
Date: Thu Sep 29 08:14:31 2011 +0200
added more diverse selection of port-check routines
diff --git a/c-platform.scm b/c-platform.scm
index efeb48e..e8452d6 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -172,6 +172,8 @@
##sys#pointer? ##sys#generic-structure? ##sys#structure?
##sys#check-structure
##sys#check-exact ##sys#check-number ##sys#check-list ##sys#check-pair
##sys#check-string
##sys#check-symbol ##sys#check-boolean ##sys#check-locative
+ ##sys#check-port ##sys#check-input-port ##sys#check-output-port
+ ##sys#check-open-port
##sys#check-char ##sys#check-vector ##sys#check-byte-vector ##sys#list
##sys#cons
##sys#call-with-values ##sys#fits-in-int? ##sys#fits-in-unsigned-int?
##sys#flonum-in-fixnum-range?
##sys#fudge ##sys#immediate? ##sys#direct-return ##sys#context-switch
diff --git a/chicken.h b/chicken.h
index 8c6eff3..d52e925 100644
--- a/chicken.h
+++ b/chicken.h
@@ -572,6 +572,10 @@ static inline int isinf_ld (long double x)
#define C_CIRCULAR_DATA_ERROR 36
#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_PORT_CLOSED_ERROR 42
/* Platform information */
@@ -1278,6 +1282,7 @@ extern double trunc(double);
#define C_i_check_vector(x) C_i_check_vector_2(x, C_SCHEME_FALSE)
#define C_i_check_structure(x, st) C_i_check_structure_2(x, (st),
C_SCHEME_FALSE)
#define C_i_check_char(x) C_i_check_char_2(x, C_SCHEME_FALSE)
+#define C_i_check_port(x, in, op) C_i_check_port_2(x, in, op,
C_SCHEME_FALSE)
#define C_u_i_8vector_length(x) C_fix(C_header_size(C_block_item(x,
1)))
#define C_u_i_16vector_length(x) C_fix(C_header_size(C_block_item(x,
1)) >> 1)
@@ -1768,6 +1773,7 @@ C_fctexport C_word C_fcall C_i_check_locative_2(C_word x,
C_word loc) C_regparm;
C_fctexport C_word C_fcall C_i_check_vector_2(C_word x, C_word loc) C_regparm;
C_fctexport C_word C_fcall C_i_check_structure_2(C_word x, C_word st, C_word
loc) C_regparm;
C_fctexport C_word C_fcall C_i_check_char_2(C_word x, C_word loc) C_regparm;
+C_fctexport C_word C_fcall C_i_check_port_2(C_word x, C_word in, C_word op,
C_word loc) C_regparm;
C_fctexport C_word C_fcall C_2_times(C_word **ptr, C_word x, C_word y)
C_regparm;
C_fctexport C_word C_fcall C_2_plus(C_word **ptr, C_word x, C_word y)
C_regparm;
C_fctexport C_word C_fcall C_2_minus(C_word **ptr, C_word x, C_word y)
C_regparm;
diff --git a/extras.scm b/extras.scm
index 3be95cc..c5c9160 100644
--- a/extras.scm
+++ b/extras.scm
@@ -83,7 +83,7 @@
(let* ([parg (pair? args)]
[p (if parg (car args) ##sys#standard-input)]
[limit (and parg (pair? (cdr args)) (cadr args))])
- (##sys#check-port* p 'read-line)
+ (##sys#check-input-port p #t 'read-line)
(cond ((##sys#slot (##sys#slot p 2) 8) => (lambda (rl) (rl p limit)))
(else
(let* ((buffer-len (if limit limit 256))
@@ -129,7 +129,7 @@
(if (string? port)
(call-with-input-file port doread)
(begin
- (##sys#check-port port 'read-lines)
+ (##sys#check-input-port port #t 'read-lines)
(doread port) ) ) ) ) )
(define write-line
@@ -137,8 +137,7 @@
(let* ((p (if (##core#inline "C_eqp" port '())
##sys#standard-output
(##sys#slot port 0) ) ))
- (##sys#check-port* p 'write-line)
- (##sys#check-port-mode p #f 'write-line)
+ (##sys#check-output-port p #t 'write-line)
(##sys#check-string str 'write-line)
((##sys#slot (##sys#slot p 2) 3) p str) ; write-string method
(##sys#write-char-0 #\newline p))))
@@ -175,7 +174,7 @@
(else (fx+ n2 m))) )))))))
(define (read-string! n dest #!optional (port ##sys#standard-input) (start 0))
- (##sys#check-port* port 'read-string!)
+ (##sys#check-input-port port #t 'read-string!)
(##sys#check-string dest 'read-string!)
(when n
(##sys#check-exact n 'read-string!)
@@ -188,7 +187,7 @@
(define ##sys#read-string/port
(lambda (n p)
- (##sys#check-port* p 'read-string)
+ (##sys#check-input-port p #t 'read-string)
(cond (n (##sys#check-exact n 'read-string)
(let* ((str (##sys#make-string n))
(n2 (##sys#read-string! n str p 0)) )
@@ -218,7 +217,7 @@
;; string-, process- and tcp ports.
(define (read-buffered #!optional (port ##sys#standard-input))
- (##sys#check-port port 'read-buffered)
+ (##sys#check-input-port port #t 'read-buffered)
(let ((rb (##sys#slot (##sys#slot port 2) 9))) ; read-buffered method
(if rb
(rb port)
@@ -230,7 +229,7 @@
(define read-token
(lambda (pred . port)
(let ([port (optional port ##sys#standard-input)])
- (##sys#check-port* port 'read-token)
+ (##sys#check-input-port port #t 'read-token)
(let ([out (open-output-string)])
(let loop ()
(let ([c (##sys#peek-char-0 port)])
@@ -244,7 +243,7 @@
(lambda (s . more)
(##sys#check-string s 'write-string)
(let-optionals more ([n #f] [port ##sys#standard-output])
- (##sys#check-port port 'write-string)
+ (##sys#check-output-port port #t 'write-string)
(when n (##sys#check-exact n 'write-string))
(display
(if (and n (fx< n (##sys#size s)))
@@ -256,7 +255,7 @@
;;; Binary I/O
(define (read-byte #!optional (port ##sys#standard-input))
- (##sys#check-port* port 'read-byte)
+ (##sys#check-input-port port #t 'read-byte)
(let ((x (##sys#read-char-0 port)))
(if (eof-object? x)
x
@@ -264,7 +263,7 @@
(define (write-byte byte #!optional (port ##sys#standard-output))
(##sys#check-exact byte 'write-byte)
- (##sys#check-port* port 'write-byte)
+ (##sys#check-output-port port #t 'write-byte)
(##sys#write-char-0 (integer->char byte) port) )
@@ -579,7 +578,7 @@
(define fprintf0
(lambda (loc port msg args)
- (when port (##sys#check-port* port loc))
+ (when port (##sys#check-output-port port #t loc))
(let ((out (if (and port (##sys#tty-port? port))
port
(open-output-string))))
diff --git a/library.scm b/library.scm
index 4cf975c..7f0ae5f 100644
--- a/library.scm
+++ b/library.scm
@@ -1693,6 +1693,7 @@ EOF
(##sys#check-port p 'port-closed?)
(##sys#slot p 8))
+
;;; Port layout:
;
; 0: FP (special)
@@ -1799,18 +1800,33 @@ EOF
(##sys#open-file-port ##sys#standard-output 1 #f)
(##sys#open-file-port ##sys#standard-error 2 #f)
+(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) ) )
+
+(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) ) )
+
(define (##sys#check-port x . loc)
- (unless (%port? x)
- (##sys#signal-hook
- #:type-error (and (pair? loc) (car loc)) "argument is not a port" x) ) )
+ (if (pair? loc)
+ (##core#inline "C_i_check_port_2" x 0 #f (car loc))
+ (##core#inline "C_i_check_port" x 0 #f) ) )
+
+(define (##sys#check-open-port x . loc)
+ (if (pair? loc)
+ (##core#inline "C_i_check_port_2" x 0 #t (car loc))
+ (##core#inline "C_i_check_port" x 0 #t) ) )
-(define (##sys#check-port-mode port mode . loc)
+(define (##sys#check-port-mode port mode . loc) ; OBSOLETE
(unless (eq? mode (##sys#slot port 1))
(##sys#signal-hook
#:type-error (and (pair? loc) (car loc))
(if mode "port is not an input port" "port is not an output-port") port)
) )
-(define (##sys#check-port* p loc)
+(define (##sys#check-port* p loc) ; OBSOLETE
(##sys#check-port p)
(when (##sys#slot p 8)
(##sys#signal-hook #:file-error loc "port already closed" p) )
@@ -1916,6 +1932,7 @@ EOF
(define (close port 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) )
@@ -1997,8 +2014,7 @@ EOF
(##core#undefined) )
(define (flush-output #!optional (port ##sys#standard-output))
- (##sys#check-port* port 'flush-output)
- (##sys#check-port-mode port #f 'flush-output)
+ (##sys#check-output-port port #t 'flush-output)
(##sys#flush-output port) )
(define (port-name #!optional (port ##sys#standard-input))
@@ -2241,8 +2257,7 @@ EOF
(define (eof-object? x) (##core#inline "C_eofp" x))
(define (char-ready? #!optional (port ##sys#standard-input))
- (##sys#check-port* port 'char-ready?)
- (##sys#check-port-mode port #t 'char-ready?)
+ (##sys#check-input-port port #t 'char-ready?)
((##sys#slot (##sys#slot port 2) 6) port) ) ; char-ready?
(define (read-char #!optional (port ##sys#standard-input))
@@ -2262,8 +2277,7 @@ EOF
c) )
(define (##sys#read-char/port port)
- (##sys#check-port* port 'read-char)
- (##sys#check-port-mode port #t 'read-char)
+ (##sys#check-input-port port #t 'read-char)
(##sys#read-char-0 port) )
(define (##sys#peek-char-0 p)
@@ -2275,13 +2289,11 @@ EOF
c) ) )
(define (peek-char #!optional (port ##sys#standard-input))
- (##sys#check-port* port 'peek-char)
- (##sys#check-port-mode port #t 'peek-char)
+ (##sys#check-input-port port #t 'peek-char)
(##sys#peek-char-0 port) )
(define (read #!optional (port ##sys#standard-input))
- (##sys#check-port* port 'read)
- (##sys#check-port-mode port #t 'read)
+ (##sys#check-input-port port #t 'read)
(##sys#read port ##sys#default-read-info-hook) )
(define ##sys#default-read-info-hook #f)
@@ -3027,38 +3039,37 @@ EOF
(##sys#void))
(define (##sys#write-char/port c port)
- (##sys#check-port* port 'write-char)
+ (##sys#check-output-port port #t 'write-char)
(##sys#check-char c 'write-char)
(##sys#write-char-0 c port) )
(define (write-char c #!optional (port ##sys#standard-output))
(##sys#check-char c 'write-char)
- (##sys#check-port* port 'write-char)
- (##sys#check-port-mode port #f 'write-char)
+ (##sys#check-output-port port #t 'write-char)
(##sys#write-char-0 c port) )
(define (newline #!optional (port ##sys#standard-output))
(##sys#write-char/port #\newline port) )
(define (write x #!optional (port ##sys#standard-output))
- (##sys#check-port* port 'write)
+ (##sys#check-output-port port #t 'write)
(##sys#print x #t port) )
(define (display x #!optional (port ##sys#standard-output))
- (##sys#check-port* port 'display)
+ (##sys#check-output-port port #t 'display)
(##sys#print x #f port) )
(define-inline (*print-each lst)
(for-each (cut ##sys#print <> #f ##sys#standard-output) lst) )
(define (print . args)
- (##sys#check-port* ##sys#standard-output 'print)
+ (##sys#check-output-port ##sys#standard-output #t 'print)
(*print-each args)
(##sys#write-char-0 #\newline ##sys#standard-output)
(void) )
(define (print* . args)
- (##sys#check-port* ##sys#standard-output 'print)
+ (##sys#check-output-port ##sys#standard-output #t 'print)
(*print-each args)
(##sys#flush-output ##sys#standard-output)
(void) )
@@ -3072,7 +3083,7 @@ EOF
(case-sensitive case-sensitive)
(keyword-style keyword-style))
(lambda (x readable port)
- (##sys#check-port-mode port #f)
+ (##sys#check-output-port port #t #f)
(let ([csp (case-sensitive)]
[ksp (keyword-style)]
[length-limit (##sys#print-length-limit)]
@@ -3507,8 +3518,7 @@ EOF
port ) )
(define (get-output-string port)
- (##sys#check-port port 'get-output-string)
- (##sys#check-port-mode port #f 'get-output-string)
+ (##sys#check-output-port port #f 'get-output-string)
(if (not (eq? 'string (##sys#slot port 7)))
(##sys#signal-hook
#:type-error 'get-output-string "argument is not a string-output-port"
port)
@@ -3737,7 +3747,7 @@ EOF
(define (print-call-chain #!optional (port ##sys#standard-output) (start 0)
(thread ##sys#current-thread)
(header "\n\tCall history:\n") )
- (##sys#check-port* port 'print-call-chain)
+ (##sys#check-output-port port #t 'print-call-chain)
(##sys#check-exact start 'print-call-chain)
(##sys#check-string header 'print-call-chain)
(let ((ct (##sys#get-call-chain start thread)))
@@ -4084,6 +4094,10 @@ EOF
((36) (apply ##sys#signal-hook #:limit-error loc "recursion too deep or
circular data encountered" args))
((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))
+ ((42) (apply ##sys#signal-hook #:file-error loc "port already closed"
args))
(else (apply ##sys#signal-hook #:runtime-error loc "unknown internal
error" args)) ) ) ) )
@@ -4641,7 +4655,7 @@ EOF
(lambda (ex . args)
(let-optionals args ([port ##sys#standard-output]
[header "Error"] )
- (##sys#check-port port 'print-error-message)
+ (##sys#check-output-port port #t 'print-error-message)
(newline port)
(display header port)
(cond [(and (not (##sys#immediate? ex)) (eq? 'condition (##sys#slot ex
0)))
diff --git a/ports.scm b/ports.scm
index 6e5275a..651c048 100644
--- a/ports.scm
+++ b/ports.scm
@@ -163,17 +163,17 @@
;;; Redirect standard ports:
(define (with-input-from-port port thunk)
- (##sys#check-port port 'with-input-from-port)
+ (##sys#check-input-port port #t 'with-input-from-port)
(fluid-let ([##sys#standard-input port])
(thunk) ) )
(define (with-output-to-port port thunk)
- (##sys#check-port port 'with-output-from-port)
+ (##sys#check-output-port port #t 'with-output-from-port)
(fluid-let ([##sys#standard-output port])
(thunk) ) )
(define (with-error-output-to-port port thunk)
- (##sys#check-port port 'with-error-output-from-port)
+ (##sys#check-output-port port #t 'with-error-output-from-port)
(fluid-let ([##sys#standard-error port])
(thunk) ) )
diff --git a/posix-common.scm b/posix-common.scm
index ea85d3d..8c95354 100644
--- a/posix-common.scm
+++ b/posix-common.scm
@@ -274,7 +274,7 @@ EOF
(define port->fileno
(lambda (port)
- (##sys#check-port port 'port->fileno)
+ (##sys#check-open-port port 'port->fileno)
(cond [(eq? 'socket (##sys#slot port 7)) (##sys#tcp-port->fileno port)]
[(not (zero? (##sys#peek-unsigned-integer port 0)))
(let ([fd (##core#inline "C_C_fileno" port)])
diff --git a/posixunix.scm b/posixunix.scm
index a9e4565..ef0d680 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -805,11 +805,18 @@ EOF
(else (badmode m)) ) ) ) ) )
(set! close-input-pipe
(lambda (port)
- (##sys#check-port port 'close-input-pipe)
+ (##sys#check-input-port port #t 'close-input-pipe)
(let ((r (##core#inline "close_pipe" port)))
- (when (eq? -1 r) (posix-error #:file-error 'close-input/output-pipe
"error while closing pipe" port))
+ (when (eq? -1 r)
+ (posix-error #:file-error 'close-input-pipe "error while closing
pipe" port))
r) ) )
- (set! close-output-pipe close-input-pipe) )
+ (set! close-output-pipe
+ (lambda (port)
+ (##sys#check-output-port port #t 'close-output-pipe)
+ (let ((r (##core#inline "close_pipe" port)))
+ (when (eq? -1 r)
+ (posix-error #:file-error 'close-output-pipe "error while closing
pipe" port))
+ r) ) ))
(define call-with-input-pipe
(lambda (cmd proc . mode)
@@ -1687,9 +1694,9 @@ EOF
(##sys#check-port port 'set-buffering-mode!)
(let ([size (if (pair? size) (car size) _bufsiz)]
[mode (case mode
- [(###full) _iofbf]
- [(###line) _iolbf]
- [(###none) _ionbf]
+ [(#:full) _iofbf]
+ [(#:line) _iolbf]
+ [(#:none) _ionbf]
[else (##sys#error 'set-buffering-mode! "invalid
buffering-mode" mode port)] ) ] )
(##sys#check-exact size 'set-buffering-mode!)
(when (fx< (if (eq? 'stream (##sys#slot port 7))
@@ -1699,12 +1706,12 @@ EOF
(##sys#error 'set-buffering-mode! "cannot set buffering mode" port mode
size) ) ) ) )
(define (terminal-port? port)
- (##sys#check-port* port 'terminal-port?)
+ (##sys#check-open-port port 'terminal-port?)
(let ([fp (##sys#peek-unsigned-integer port 0)])
(and (not (eq? 0 fp)) (##core#inline "C_tty_portp" port) ) ) )
(define (##sys#terminal-check caller port)
- (##sys#check-port port caller)
+ (##sys#check-open-port port caller)
(unless (and (eq? 'stream (##sys#slot port 7))
(##core#inline "C_tty_portp" port))
(##sys#error caller "port is not connected to a terminal" port)))
diff --git a/posixwin.scm b/posixwin.scm
index 0430876..de0286d 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -1157,13 +1157,20 @@ EOF
(else (badmode m)) ) ) ) ) )
(set! close-input-pipe
(lambda (port)
- (##sys#check-port port 'close-input-pipe)
+ (##sys#check-input-port port #t 'close-input-pipe)
(let ((r (##core#inline "close_pipe" port)))
(##sys#update-errno)
(when (eq? -1 r)
(##sys#signal-hook #:file-error 'close-input-pipe "error while
closing pipe" port) )
r)))
- (set! close-output-pipe close-input-pipe) )
+ (set! close-output-pipe
+ (lambda (port)
+ (##sys#check-output-port port #t 'close-output-pipe)
+ (let ((r (##core#inline "close_pipe" port)))
+ (##sys#update-errno)
+ (when (eq? -1 r)
+ (##sys#signal-hook #:file-error 'close-output-pipe "error while
closing pipe" port) )
+ r))))
(define call-with-input-pipe
(lambda (cmd proc . mode)
@@ -1390,7 +1397,7 @@ EOF
(define port->fileno
(lambda (port)
- (##sys#check-port port 'port->fileno)
+ (##sys#check-open-port port 'port->fileno)
(if (not (zero? (##sys#peek-unsigned-integer port 0)))
(let ([fd (##core#inline "C_C_fileno" port)])
(when (fx< fd 0)
@@ -1456,7 +1463,7 @@ EOF
(ex0 (if (pair? code) (car code) 0)) ) ) )
(define (terminal-port? port)
- (##sys#check-port* port 'terminal-port?)
+ (##sys#check-open-port port 'terminal-port?)
(let ([fp (##sys#peek-unsigned-integer port 0)])
(and (not (eq? 0 fp)) (##core#inline "C_tty_portp" port) ) ) )
@@ -1472,7 +1479,7 @@ EOF
(define set-buffering-mode!
(lambda (port mode . size)
- (##sys#check-port port 'set-buffering-mode!)
+ (##sys#check-open-port port 'set-buffering-mode!)
(let ([size (if (pair? size) (car size) _bufsiz)]
[mode (case mode
[(###full) _iofbf]
diff --git a/runtime.c b/runtime.c
index c0c91bc..1f5a9c2 100644
--- a/runtime.c
+++ b/runtime.c
@@ -1616,6 +1616,26 @@ void barf(int code, char *loc, ...)
c = 0;
break;
+ case C_BAD_ARGUMENT_TYPE_NO_PORT_ERROR:
+ msg = C_text("bad argument type - not a port");
+ 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");
+ c = 1;
+ break;
+
+ case C_PORT_CLOSED_ERROR:
+ msg = C_text("port already closed");
+ c = 1;
+ break;
+
default: panic(C_text("illegal internal error code"));
}
@@ -5548,6 +5568,48 @@ 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)
+{
+ 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(open == C_SCHEME_TRUE) {
+ if(C_block_item(x, 8) != C_SCHEME_FALSE) { /* slot #8: closed flag */
+ error_location = loc;
+ barf(C_PORT_CLOSED_ERROR, NULL, x);
+ }
+ }
+
+ return C_SCHEME_UNDEFINED;
+}
+
+
/*XXX these are not correctly named */
C_regparm C_word C_fcall C_i_foreign_char_argumentp(C_word x)
{
diff --git a/srfi-4.scm b/srfi-4.scm
index 31461cd..cdbe388 100644
--- a/srfi-4.scm
+++ b/srfi-4.scm
@@ -642,7 +642,7 @@ EOF
(define (write-u8vector v #!optional (port ##sys#standard-output) (from 0)
(to (u8vector-length v)))
(##sys#check-structure v 'u8vector 'write-u8vector)
- (##sys#check-port* port 'write-u8vector)
+ (##sys#check-output-port port #t 'write-u8vector)
(do ((i from (fx+ i 1)))
((fx>= i to))
(##sys#write-char-0
@@ -650,7 +650,7 @@ EOF
port) ) )
(define (read-u8vector! n dest #!optional (port ##sys#standard-input) (start
0))
- (##sys#check-port* port 'read-u8vector!)
+ (##sys#check-input-port port #t 'read-u8vector!)
(##sys#check-exact start 'read-u8vector!)
(##sys#check-structure dest 'u8vector 'read-u8vector!)
(let ((dest (##sys#slot dest 1)))
@@ -670,7 +670,7 @@ EOF
(##core#inline "C_substring_copy" str str2 0 n 0)
str2) ) )
(lambda (#!optional n (p ##sys#standard-input))
- (##sys#check-port* p 'read-u8vector)
+ (##sys#check-input-port p #t 'read-u8vector)
(cond (n (##sys#check-exact n 'read-u8vector)
(let* ((str (##sys#allocate-vector n #t #f #t))
(n2 (##sys#read-string! n str p 0)) )
diff --git a/tcp.scm b/tcp.scm
index 1e09420..4dfe579 100644
--- a/tcp.scm
+++ b/tcp.scm
@@ -629,7 +629,7 @@ EOF
(error '##sys#tcp-port->fileno "argument does not appear to be a TCP
port" p))))
(define (tcp-addresses p)
- (##sys#check-port* p 'tcp-addresses)
+ (##sys#check-open-port p 'tcp-addresses)
(let ((fd (##sys#tcp-port->fileno p)))
(values
(or (##net#getsockname fd)
@@ -642,7 +642,7 @@ EOF
(##sys#string-append "cannot compute remote address - " strerror) p)
) ) ) )
(define (tcp-port-numbers p)
- (##sys#check-port* p 'tcp-port-numbers)
+ (##sys#check-open-port p 'tcp-port-numbers)
(let ((fd (##sys#tcp-port->fileno p)))
(let ((sp (##net#getsockport fd))
(pp (##net#getpeerport fd)))
@@ -667,7 +667,7 @@ EOF
port) )
(define (tcp-abandon-port p)
- (##sys#check-port* p 'tcp-abandon-port)
+ (##sys#check-open-port p 'tcp-abandon-port)
(##sys#setislot
(##sys#port-data p)
(if (##sys#slot p 1) 1 2)