chicken-hackers
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Chicken-hackers] [PATCH] cleanup port-checking routines


From: Felix
Subject: [Chicken-hackers] [PATCH] cleanup port-checking routines
Date: Thu, 29 Sep 2011 03:40:42 -0400 (EDT)

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
commit c219f8eeb94eb7c0ec58b0c3995d5db4b9b43072
Author: felix <address@hidden>
Date:   Thu Sep 29 08:15:58 2011 +0200

    Squashed commit of the following:
    
    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..e53a15f 100644
--- a/library.scm
+++ b/library.scm
@@ -1690,9 +1690,10 @@ EOF
        (not (##sys#slot x 1)) ) )
 
 (define (port-closed? p)
-  (##sys#check-port p 'port-closed?)
+  (##sys#check-port port '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/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
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)

reply via email to

[Prev in Thread] Current Thread [Next in Thread]