From: Chris Hanson Date: Wed, 22 Nov 2006 18:51:14 +0000 (+0000) Subject: Use shutdown-socket primitive to close one side of a socket. X-Git-Tag: 20090517-FFI~836 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=4a237c56e9d6fc2d7aaaaf848230f216f8853f27;p=mit-scheme.git 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 3fd0afbbf..ea129cecc 100644 --- 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)) -(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 d226e8224..0a17e1b5a 100644 --- 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 c198d1636..87158203e 100644 --- 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 241f59100..d65d48904 100644 --- 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)))) (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)) + (define (get-host-by-name host-name) (with-thread-timer-stopped (lambda ()