[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-serv4782/src

Modified Files:
	sysdeps.lisp 
Log Message:
(with-open-socket-stream, run-process)
(start-standard-server, stop-server): Port to cmucl.

Date: Tue Oct 26 13:23:35 2004
Author: rschlatte

Index: s-xml-rpc/src/sysdeps.lisp
diff -u s-xml-rpc/src/sysdeps.lisp:1.2 s-xml-rpc/src/sysdeps.lisp:1.3
--- s-xml-rpc/src/sysdeps.lisp:1.2	Tue Jul 13 15:26:42 2004
+++ s-xml-rpc/src/sysdeps.lisp	Tue Oct 26 13:23:34 2004
@@ -1,6 +1,6 @@
 ;;;; -*- mode: lisp -*-
 ;;;;
-;;;; $Id: sysdeps.lisp,v 1.2 2004/07/13 13:26:42 bmastenbrook Exp $
+;;;; $Id: sysdeps.lisp,v 1.3 2004/10/26 11:23:34 rschlatte Exp $
 ;;;;
 ;;;; These are the system dependent part of S-XML-RPC.
 ;;;; Ports to OpenMCL, LispWorks and SBCL are provided.
@@ -17,42 +17,44 @@
 
 (defmacro with-open-socket-stream ((var host port) &body body)
   "Execute body with a bidirectional socket stream opened to host:port"
-  #+openmcl
-  `(ccl:with-open-socket (,var :remote-host ,host :remote-port ,port)
-    , at body)
-  #+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
-                                          :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))))))
+  (or
+   #+openmcl
+   `(ccl:with-open-socket (,var :remote-host ,host :remote-port ,port)
+     , at body)
+   #+lispworks
+   `(with-open-stream (,var (comm:open-tcp-stream ,host ,port))
+     , 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)))))
+   #+cmu
+   `(with-open-stream (,var (sys:make-fd-stream
+                             (ext:connect-to-inet-socket ,host ,port)
+                             :input t :output t :buffering :none))
+     , at body)
+   (error "Unsupported Lisp system.")))
 
 (defun run-process (name function &rest arguments)
   "Create and run a new process with name, executing function on arguments"
+  (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))
+  #+sbcl (apply function arguments)
+  #+cmu (apply function arguments)      ; could use threading on x86
+  )
 
 (defvar *server-processes* nil)
 
@@ -81,14 +83,6 @@
                         (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))
@@ -109,6 +103,19 @@
                        (sb-sys:add-fd-handler 
                         (sb-bsd-sockets:socket-file-descriptor socket)
                         :input handler-fn)) *server-processes*))
+  #+cmu (let* ((socket (ext:create-inet-listener port :stream :reuse-address t
+                                                 :backlog 15))
+               (handler-fn (lambda (fd)
+                             (declare (ignore fd))
+                             (let ((stream (sys:make-fd-stream
+                                            (ext:accept-tcp-connection socket)
+                                            :input t :output t
+                                            :element-type 'character
+                                            :buffering :none)))
+                               (funcall connection-handler stream)))))
+          (push (list name socket
+                      (sys:add-fd-handler socket :input handler-fn))
+                *server-processes*))
   name)
 
 (defun stop-server (name)
@@ -122,10 +129,6 @@
                               :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)
@@ -134,6 +137,15 @@
       (sb-bsd-sockets:socket-close socket))
     (setf *server-processes* (delete name *server-processes*
                                      :key #'car :test #'string=)))
+  #+cmu
+  (progn
+    (destructuring-bind (name socket handler)
+        (assoc name *server-processes* :test #'string=)
+      (declare (ignore name))
+      (sys:remove-fd-handler handler)
+      (unix:unix-close socket))
+    (setf *server-processes* (delete name *server-processes*
+                                     :key #'car :test #'string=)))  
   name)
 
 ;;;; eof