From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 13 Aug 1999 18:40:43 +0000 (+0000)
Subject: Implement and export various host-name manipulating procedures.
X-Git-Tag: 20090517-FFI~4475
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d84965e69c90a7b3f59239d34d33ce3a10c03b23;p=mit-scheme.git

Implement and export various host-name manipulating procedures.
Change TCP-SERVER-CONNECTION-ACCEPT to accept the peer address as an
argument and to return only a single value.
---

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 255dfac42..d11e92fae 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.330 1999/08/09 18:10:41 cph Exp $
+$Id: runtime.pkg,v 14.331 1999/08/13 18:40:43 cph Exp $
 
 Copyright (c) 1988-1999 Massachusetts Institute of Technology
 
@@ -2268,7 +2268,12 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   (files "socket")
   (parent ())
   (export ()
+	  allocate-host-address
+	  canonical-host-name
 	  close-tcp-server-socket
+	  get-host-by-address
+	  get-host-by-name
+	  get-host-name
 	  open-tcp-server-socket
 	  open-tcp-stream-socket
 	  open-tcp-stream-socket-channel
diff --git a/v7/src/runtime/socket.scm b/v7/src/runtime/socket.scm
index 138f216df..2b69257f8 100644
--- a/v7/src/runtime/socket.scm
+++ b/v7/src/runtime/socket.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: socket.scm,v 1.14 1999/07/26 21:20:44 cph Exp $
+$Id: socket.scm,v 1.15 1999/08/13 18:40:30 cph Exp $
 
 Copyright (c) 1990-1999 Massachusetts Institute of Technology
 
@@ -52,15 +52,6 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	 (lambda ()
 	   ((ucode-primitive new-open-tcp-stream-socket 3) host port p)))))))
 
-(define (get-host-by-name host-name)
-  (with-thread-timer-stopped
-    (lambda ()
-      ((ucode-primitive get-host-by-name 1) host-name))))
-
-(define (os/hostname)
-  ((ucode-primitive canonical-host-name 1)
-   ((ucode-primitive get-host-name 0))))
-
 (define (open-unix-stream-socket-channel filename)
   (open-channel
    (lambda (p)
@@ -85,23 +76,41 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 (define (close-tcp-server-socket server-socket)
   (channel-close server-socket))
 
+(define (tcp-server-connection-accept server-socket block? peer-address)
+  (let ((channel
+	 (with-channel-blocking server-socket block?
+	   (lambda ()
+	     (open-channel
+	      (lambda (p)
+		(with-thread-timer-stopped
+		  (lambda ()
+		    ((ucode-primitive new-tcp-server-connection-accept 3)
+		     (channel-descriptor server-socket)
+		     peer-address
+		     p)))))))))
+    (and channel
+	 (make-generic-i/o-port channel channel 64 64))))
+
+(define (get-host-by-name host-name)
+  (with-thread-timer-stopped
+    (lambda ()
+      ((ucode-primitive get-host-by-name 1) host-name))))
+
+(define (get-host-by-address host-address)
+  (with-thread-timer-stopped
+    (lambda ()
+      ((ucode-primitive get-host-by-address 1) host-address))))
+
+(define (canonical-host-name host-name)
+  (with-thread-timer-stopped
+    (lambda ()
+      ((ucode-primitive canonical-host-name 1) host-name))))
+
+(define get-host-name
+  (ucode-primitive get-host-name 0))
+
+(define (os/hostname)
+  (canonical-host-name (get-host-name)))
+
 (define (allocate-host-address)
-  (string-allocate ((ucode-primitive host-address-length 0))))
-
-(define (tcp-server-connection-accept server-socket block?)
-  (let ((peer-address (allocate-host-address)))
-    (let ((channel
-	   (with-channel-blocking server-socket block?
-	     (lambda ()
-	       (open-channel
-		(lambda (p)
-		  (with-thread-timer-stopped
-		    (lambda ()
-		      ((ucode-primitive new-tcp-server-connection-accept 3)
-		       (channel-descriptor server-socket)
-		       peer-address
-		       p)))))))))
-      (if channel
-	  (let ((port (make-generic-i/o-port channel channel 64 64)))
-	    (values port peer-address))
-	  (values #f #f)))))
\ No newline at end of file
+  (string-allocate ((ucode-primitive host-address-length 0))))
\ No newline at end of file
diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg
index c3094c194..aae7ea1b3 100644
--- a/v8/src/runtime/runtime.pkg
+++ b/v8/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.335 1999/08/09 18:10:44 cph Exp $
+$Id: runtime.pkg,v 14.336 1999/08/13 18:40:39 cph Exp $
 
 Copyright (c) 1988-1999 Massachusetts Institute of Technology
 
@@ -2272,7 +2272,12 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   (files "socket")
   (parent ())
   (export ()
+	  allocate-host-address
+	  canonical-host-name
 	  close-tcp-server-socket
+	  get-host-by-address
+	  get-host-by-name
+	  get-host-name
 	  open-tcp-server-socket
 	  open-tcp-stream-socket
 	  open-tcp-stream-socket-channel