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)
- ,@body)
- #+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
- :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))))))
+ (or
+ #+openmcl
+ `(ccl:with-open-socket (,var :remote-host ,host :remote-port ,port)
+ ,@body)
+ #+lispworks
+ `(with-open-stream (,var (comm:open-tcp-stream ,host ,port))
+ ,@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)))))
+ #+cmu
+ `(with-open-stream (,var (sys:make-fd-stream
+ (ext:connect-to-inet-socket ,host ,port)
+ :input t :output t :buffering :none))
+ ,@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
