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) - ,@body) + ,@body) #+lispworks `(with-open-stream (,var (comm:open-tcp-stream ,host ,port)) - ,@body) + ,@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 :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 ,@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 ,@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)) - ,@body) + ,@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)