[s-xml-rpc-cvs] CVS update: s-xml-rpc/src/sysdeps.lisp

[Brian Mastenbrook]

Update of /project/s-xml-rpc/cvsroot/s-xml-rpc/src
In directory common-lisp.net:/home/bmastenbrook/s-xml-rpc/src

Modified Files:
	sysdeps.lisp 
Log Message:
ACL port from Ian Eslick <eslick at csail.mit.edu>

Date: Tue Jul 13 06:26:43 2004
Author: bmastenbrook

Index: s-xml-rpc/src/sysdeps.lisp
diff -u s-xml-rpc/src/sysdeps.lisp:1.1.1.1 s-xml-rpc/src/sysdeps.lisp:1.2
--- s-xml-rpc/src/sysdeps.lisp:1.1.1.1	Wed Jun  9 02:02:39 2004
+++ s-xml-rpc/src/sysdeps.lisp	Tue Jul 13 06:26:42 2004
@@ -1,6 +1,6 @@
 ;;;; -*- mode: lisp -*-
 ;;;;
-;;;; $Id: sysdeps.lisp,v 1.1.1.1 2004/06/09 09:02:39 scaekenberghe Exp $
+;;;; $Id: sysdeps.lisp,v 1.2 2004/07/13 13:26:42 bmastenbrook Exp $
 ;;;;
 ;;;; These are the system dependent part of S-XML-RPC.
 ;;;; Ports to OpenMCL, LispWorks and SBCL are provided.
@@ -23,6 +23,13 @@
   #+lispworks
   `(with-open-stream (,var (comm:open-tcp-stream ,host ,port))
     , at body)
+  #+allegro 
+  `(let ((,var (acl-socket:make-socket 
+		:remote-host ,host
+		:remote-port ,port
+		:type :stream 
+		:address-family :internet)))
+     (unwind-protect (progn , at body)))
   #+sbcl
   (let ((socket-object (gensym)))
     `(let ((,socket-object (make-instance 'sb-bsd-sockets:inet-socket
@@ -44,6 +51,7 @@
   "Create and run a new process with name, executing function on arguments"
   #+lispworks (apply #'mp:process-run-function name '(:priority 3) function arguments)
   #+openmcl (apply #'ccl:process-run-function name function arguments)
+  #+allegro (apply #'mp:process-run-function name function arguments)
   #+sbcl (apply function arguments))
 
 (defvar *server-processes* nil)
@@ -73,6 +81,14 @@
                         (let ((client-stream (ccl:accept-connection server-socket)))
                           (funcall connection-handler client-stream))) 
                      (close server-socket)))))
+  #+allegro (mp:process-run-function
+	     name
+	     #'(lambda ()
+		 (let ((server-socket (acl-socket:make-socket :connect :passive :local-port port)))
+		   (unwind-protect
+		       (loop
+			 (let ((client-stream (acl-socket:accept-connection server-socket)))
+			   (funcall connection-handler client-stream)))))))
   #+sbcl (let* ((socket
                  (make-instance 'sb-bsd-sockets:inet-socket :type :stream
                                 :protocol :tcp))
@@ -106,6 +122,10 @@
                               :key #'ccl:process-name :test #'string-equal)))
     (when server-process
       (ccl:process-kill server-process)))
+  #+allegro
+  (let ((server-process (find name sys:*all-processes* :test #'string-equal :key #'mp:process-name)))
+    (when server-process
+      (mp:process-kill server-process)))
   #+sbcl
   (progn
     (destructuring-bind (name socket handler)