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(a)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))
,@body)
+ #+allegro
+ `(let ((,var (acl-socket:make-socket
+ :remote-host ,host
+ :remote-port ,port
+ :type :stream
+ :address-family :internet)))
+ (unwind-protect (progn ,@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)