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@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)