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

[Rudi Schlatte]

Update of /project/s-xml-rpc/cvsroot/s-xml-rpc/src
In directory common-lisp.net:/tmp/cvs-serv11958/src

Modified Files:
	sysdeps.lisp 
Log Message:
Belatedly restore allegro support.

Date: Tue Oct 26 15:04:43 2004
Author: rschlatte

Index: s-xml-rpc/src/sysdeps.lisp
diff -u s-xml-rpc/src/sysdeps.lisp:1.3 s-xml-rpc/src/sysdeps.lisp:1.4
--- s-xml-rpc/src/sysdeps.lisp:1.3	Tue Oct 26 13:23:34 2004
+++ s-xml-rpc/src/sysdeps.lisp	Tue Oct 26 15:04:43 2004
@@ -1,6 +1,6 @@
 ;;;; -*- mode: lisp -*-
 ;;;;
-;;;; $Id: sysdeps.lisp,v 1.3 2004/10/26 11:23:34 rschlatte Exp $
+;;;; $Id: sysdeps.lisp,v 1.4 2004/10/26 13:04:43 rschlatte Exp $
 ;;;;
 ;;;; These are the system dependent part of S-XML-RPC.
 ;;;; Ports to OpenMCL, LispWorks and SBCL are provided.
@@ -20,31 +20,38 @@
   (or
    #+openmcl
    `(ccl:with-open-socket (,var :remote-host ,host :remote-port ,port)
-     , at body)
+      , at body)
    #+lispworks
    `(with-open-stream (,var (comm:open-tcp-stream ,host ,port))
-     , at body)
+      , 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
                                            :type :stream
                                            :protocol :tcp)))
-       (sb-bsd-sockets:socket-connect ,socket-object
-        (car (sb-bsd-sockets:host-ent-addresses
-              (sb-bsd-sockets:get-host-by-name ,host))) ,port)
-       (let ((,var (sb-bsd-sockets:socket-make-stream ,socket-object
-                                                      :element-type 'character
-                                                      :input t
-                                                      :output t
-                                                      :buffering :none)))
-         (unwind-protect
-              (progn , at body)
-           (close ,var)))))
+        (sb-bsd-sockets:socket-connect ,socket-object
+                                       (car (sb-bsd-sockets:host-ent-addresses
+                                             (sb-bsd-sockets:get-host-by-name ,host))) ,port)
+        (let ((,var (sb-bsd-sockets:socket-make-stream ,socket-object
+                                                       :element-type 'character
+                                                       :input t
+                                                       :output t
+                                                       :buffering :none)))
+          (unwind-protect
+               (progn , at body)
+            (close ,var)))))
    #+cmu
    `(with-open-stream (,var (sys:make-fd-stream
                              (ext:connect-to-inet-socket ,host ,port)
                              :input t :output t :buffering :none))
-     , at body)
+      , at body)
    (error "Unsupported Lisp system.")))
 
 (defun run-process (name function &rest arguments)
@@ -52,6 +59,7 @@
   (declare (ignorable name))
   #+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)
   #+cmu (apply function arguments)      ; could use threading on x86
   )
@@ -83,6 +91,16 @@
                         (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))
@@ -129,6 +147,11 @@
                               :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)