[slime-cvs] CVS update: slime/swank-lispworks.lisp

[Luke Gorrie]

Update of /project/slime/cvsroot/slime
In directory common-lisp.net:/tmp/cvs-serv9665

Modified Files:
	swank-lispworks.lisp 
Log Message:
Updated for new network interface.

(accept-socket/stream): This function is currently broken, so
LispWorks can't use the dedicated output channel at the moment.

Date: Mon Jan 12 23:22:20 2004
Author: lgorrie

Index: slime/swank-lispworks.lisp
diff -u slime/swank-lispworks.lisp:1.11 slime/swank-lispworks.lisp:1.12
--- slime/swank-lispworks.lisp:1.11	Sun Jan 11 23:30:27 2004
+++ slime/swank-lispworks.lisp	Mon Jan 12 23:22:20 2004
@@ -7,7 +7,7 @@
 ;;; This code has been placed in the Public Domain.  All warranties
 ;;; are disclaimed.
 ;;;
-;;;   $Id: swank-lispworks.lisp,v 1.11 2004/01/12 04:30:27 lgorrie Exp $
+;;;   $Id: swank-lispworks.lisp,v 1.12 2004/01/13 04:22:20 lgorrie Exp $
 ;;;
 
 (in-package :swank)
@@ -32,43 +32,39 @@
 
 (defconstant +sigint+ 2)
 
-(defmethod create-socket-server (init-fn &key announce-fn (port 0)
-                                 (accept-background t)
-                                 (handle-background t)
-                                 (loop t))
+(defmethod accept-socket/run (&key (port 0) announce-fn init-fn)
   (flet ((sentinel (socket condition)
-           (cond (socket
-                  (let ((port (nth-value 1 (comm:get-socket-address socket))))
-                    (funcall announce-fn port)))
-                 (t
-                  (format *terminal-io* ";; Swank condition: ~A~%" 
-                          condition))))
-         (accept (fd)
-           (accept-connection fd init-fn handle-background)
-           (unless loop (mp:process-kill mp:*current-process*))))
-    (let ((server-process
-           (comm:start-up-server :announce #'sentinel :service port
-                                 :process-name "Swank server"
-                                 :function #'accept)))
-      (unless accept-background
-        (wait-process-death server-process)))))
-
-(defun accept-connection (fd init-fn background)
-  (let ((socket-io (make-instance 'comm:socket-stream
-                                  :socket fd
-                                  :direction :io
-                                  :element-type 'base-char)))
-    (sys:set-signal-handler +sigint+ #'sigint-handler)
-    (let* ((handler-fn (funcall init-fn socket-io))
-           (loop-fn (lambda () (loop (funcall handler-fn)))))
-      (if background
-          (mp:process-run-function "Swank request handler" () loop-fn)
-          (funcall loop-fn)))))
-
-(defun wait-process-death (process)
-  (mp:process-wait "Letting Emacs connect"
-                   (lambda () (not (mp:process-alive-p process)))))
-
+           (when socket
+             (funcall announce-fn (local-tcp-port socket))))
+         (accept (socket)
+           (let ((handler-fn (funcall init-fn (make-socket-stream socket))))
+             (loop while t do (funcall handler-fn)))))
+    (comm:start-up-server :announce #'sentinel
+                          :service port
+                          :process-name "Swank server"
+                          :function #'accept)))
+
+;;; FIXME: Broken. Why?
+(defmethod accept-socket/stream (&key (port 0) announce-fn)
+  (let ((mbox (mp:make-mailbox)))
+    (flet ((init (stream)
+             (mp:mailbox-send mbox stream)
+             (mp:process-kill mp:*current-process*)))
+    (accept-socket/run :port port :announce-fn announce-fn :init-fn #'init)
+    (mp:mailbox-read mbox "Waiting for socket stream"))))
+
+(defun make-socket-stream (socket)
+  (make-instance 'comm:socket-stream
+                 :socket socket
+                 :direction :io
+                 :element-type 'base-char))
+
+(defun local-tcp-port (socket)
+  (nth-value 1 (comm:get-socket-address socket)))
+
+(defmethod emacs-connected ()
+  ;; Set SIGINT handler on Swank request handler thread.
+  (sys:set-signal-handler +sigint+ #'sigint-handler))
 
 (defun sigint-handler (&rest args)
   (declare (ignore args))