Use shutdown-socket primitive to close one side of a socket.

diff --git a/v7/src/runtime/genio.scm b/v7/src/runtime/genio.scm
index 3fd0afbbface15b45f20a86fd9d95e6076bc2f45..ea129cecca3f0e12a84e3a3af15ad99f2b1b6622 100644 (file)
--- a/v7/src/runtime/genio.scm
+++ b/v7/src/runtime/genio.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: genio.scm,v 1.46 2006/11/01 05:09:42 cph Exp $
+$Id: genio.scm,v 1.47 2006/11/22 18:51:09 cph Exp $
 
 Copyright 1991,1993,1995,1996,1999,2002 Massachusetts Institute of Technology
 Copyright 2003,2004,2005,2006 Massachusetts Institute of Technology
@@ -29,12 +29,14 @@ USA.
 
 (declare (usual-integrations))
 \f
-(define (make-generic-i/o-port source sink)
+(define (make-generic-i/o-port source sink #!optional type)
   (if (not (or source sink))
       (error "Missing arguments."))
   (let ((port
-        (make-port (generic-i/o-port-type (source-type source)
-                                          (sink-type sink))
+        (make-port (if (default-object? type)
+                       (generic-i/o-port-type (source-type source)
+                                              (sink-type sink))
+                       type)
                    (make-gstate source sink 'TEXT 'TEXT))))
     (let ((ib (port-input-buffer port)))
       (if ib
@@ -353,6 +355,10 @@ USA.
     (and ib
         (input-buffer-open? ib))))
 
+(define (generic-io/io-open? port)
+  (and (generic-io/input-open? port)
+       (generic-io/output-open? port)))
+
 (define (generic-io/write-self port output-port)
   (cond ((i/o-port? port)
         (write-string " for channels: " output-port)

diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm
index d226e822412e1d667f5ca4a0fc4b8a4673dd433e..0a17e1b5a55b89228ae199ce07e59cdd73140399 100644 (file)
--- a/v7/src/runtime/make.scm
+++ b/v7/src/runtime/make.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: make.scm,v 14.105 2006/09/16 11:19:09 gjr Exp $
+$Id: make.scm,v 14.106 2006/11/22 18:51:11 cph Exp $
 
 Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 Copyright 1994,1995,1996,1997,1998,2000 Massachusetts Institute of Technology
@@ -469,6 +469,7 @@ USA.
    (RUNTIME GENERIC-I/O-PORT)
    (RUNTIME FILE-I/O-PORT)
    (RUNTIME CONSOLE-I/O-PORT)
+   (RUNTIME SOCKET)
    (RUNTIME TRANSCRIPT)
    (RUNTIME STRING-INPUT)
    (RUNTIME STRING-OUTPUT)

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index c198d16368a4ed3082f075a92fe310f61be1014b..87158203e7db30f926ad693f53e1d5fc9bb9de1a 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.605 2006/11/09 20:04:57 cph Exp $
+$Id: runtime.pkg,v 14.606 2006/11/22 18:51:12 cph Exp $
 
 Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
@@ -1740,18 +1740,20 @@ USA.
   (files "genio")
   (parent (runtime))
   (export ()
-         make-generic-i/o-port)
-  (export (runtime console-i/o-port)
          generic-i/o-port-type
          generic-io/char-ready?
+         generic-io/close-input
+         generic-io/close-output
          generic-io/flush-output
+         generic-io/io-open?
          generic-io/read-char
+         make-generic-i/o-port)
+  (export (runtime console-i/o-port)
          input-buffer-contents
          make-gstate
          port-input-buffer
          set-input-buffer-contents!)
   (export (runtime file-i/o-port)
-         generic-i/o-port-type
          clear-input-buffer
          input-buffer-encoded-character-size
          input-buffer-free-bytes
@@ -1761,15 +1763,12 @@ USA.
          port-input-buffer
          port-output-buffer)
   (export (runtime string-input)
-         generic-i/o-port-type
          make-gstate
          make-non-channel-source)
   (export (runtime string-output)
-         generic-i/o-port-type
          make-gstate
          make-non-channel-sink)
   (export (runtime truncated-string-output)
-         generic-i/o-port-type
          make-gstate
          make-non-channel-sink)
   (initialization (initialize-package!)))
@@ -3329,7 +3328,8 @@ USA.
          open-unix-stream-socket
          open-unix-stream-socket-channel
          os/hostname
-         tcp-server-connection-accept))
+         tcp-server-connection-accept)
+  (initialization (initialize-package!)))
 
 (define-package (runtime subprocess)
   (file-case options

diff --git a/v7/src/runtime/socket.scm b/v7/src/runtime/socket.scm
index 241f591000f6eef27357b51db2f83a603daf0966..d65d48904f3aa9d89663a8901e5ccd6df3df2e38 100644 (file)
--- a/v7/src/runtime/socket.scm
+++ b/v7/src/runtime/socket.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: socket.scm,v 1.28 2006/06/11 03:04:17 cph Exp $
+$Id: socket.scm,v 1.29 2006/11/22 18:51:14 cph Exp $
 
 Copyright 1996,1997,1998,1999,2001,2002 Massachusetts Institute of Technology
 Copyright 2003,2004,2005,2006 Massachusetts Institute of Technology
@@ -94,15 +94,15 @@ USA.
                   (let loop () (do-test loop))
                   (do-test (lambda () #f))))))))
     (and channel
-        (make-generic-i/o-port channel channel))))
+        (make-socket-port channel))))
 \f
 (define (open-tcp-stream-socket host-name service)
   (let ((channel (open-tcp-stream-socket-channel host-name service)))
-    (make-generic-i/o-port channel channel)))
+    (make-socket-port channel)))
 
 (define (open-unix-stream-socket filename)
   (let ((channel (open-unix-stream-socket-channel filename)))
-    (make-generic-i/o-port channel channel)))
+    (make-socket-port channel)))
 
 (define (open-tcp-stream-socket-channel host-name service)
   (let ((host
@@ -125,6 +125,31 @@ USA.
        (lambda ()
         ((ucode-primitive new-open-unix-stream-socket 2) filename p))))))
 
+(define (make-socket-port channel)
+  (make-generic-i/o-port channel channel socket-port-type))
+
+(define socket-port-type)
+(define (initialize-package!)
+  (set! socket-port-type
+       (make-port-type `((CLOSE-INPUT ,socket/close-input)
+                         (CLOSE-OUTPUT ,socket/close-output))
+                       (generic-i/o-port-type 'CHANNEL 'CHANNEL)))
+  unspecific)
+
+(define (socket/close-input port)
+  (if (generic-io/io-open? port)
+      ((ucode-primitive shutdown-socket 2)
+       (channel-descriptor (port/input-channel port))
+       1))
+  (generic-io/close-input port))
+
+(define (socket/close-output port)
+  (if (generic-io/io-open? port)
+      ((ucode-primitive shutdown-socket 2)
+       (channel-descriptor (port/input-channel port))
+       2))
+  (generic-io/close-output port))
+\f
 (define (get-host-by-name host-name)
   (with-thread-timer-stopped
     (lambda ()