[slime-cvs] CVS update: slime/swank-allegro.lisp slime/swank-lispworks.lisp slime/swank-clisp.lisp slime/swank-cmucl.lisp slime/swank-openmcl.lisp slime/swank-sbcl.lisp
Helmut Eller
heller at common-lisp.net
Tue Jan 13 18:20:05 UTC 2004
Update of /project/slime/cvsroot/slime
In directory common-lisp.net:/tmp/cvs-serv20718
Modified Files:
swank-allegro.lisp swank-lispworks.lisp swank-clisp.lisp
swank-cmucl.lisp swank-openmcl.lisp swank-sbcl.lisp
Log Message:
(create-socket, local-port, close-socket, accept-connection)
(add-input-handler, spawn): Implement new socket interface.
Date: Tue Jan 13 13:20:04 2004
Author: heller
Index: slime/swank-allegro.lisp
diff -u slime/swank-allegro.lisp:1.5 slime/swank-allegro.lisp:1.6
--- slime/swank-allegro.lisp:1.5 Fri Jan 2 13:23:14 2004
+++ slime/swank-allegro.lisp Tue Jan 13 13:20:04 2004
@@ -7,7 +7,7 @@
;;; This code has been placed in the Public Domain. All warranties
;;; are disclaimed.
;;;
-;;; $Id: swank-allegro.lisp,v 1.5 2004/01/02 18:23:14 heller Exp $
+;;; $Id: swank-allegro.lisp,v 1.6 2004/01/13 18:20:04 heller Exp $
;;;
;;; This code was written for
;;; Allegro CL Trial Edition "5.0 [Linux/X86] (8/29/98 10:57)"
@@ -36,56 +36,22 @@
;;; TCP Server
-(setq *start-swank-in-background* nil)
+(defmethod create-socket (port)
+ (socket:make-socket :connect :passive :local-port port :reuse-address t))
-(defun create-swank-server (port &key (reuse-address t)
- (announce #'simple-announce-function)
- (background *start-swank-in-background*)
- (close *close-swank-socket-after-setup*))
- "Create a Swank TCP server on `port'."
- (let ((server-socket (socket:make-socket :connect :passive :local-port port
- :reuse-address reuse-address)))
- (funcall announce (socket:local-port server-socket))
- (cond (background
- (mp:process-run-function "Swank" #'accept-loop server-socket close))
- (t
- (accept-loop server-socket close)))))
-
-(defun accept-loop (server-socket close)
- (unwind-protect (cond (close (accept-one-client server-socket))
- (t (loop (accept-one-client server-socket))))
- (close server-socket)))
-
-(defun accept-one-client (server-socket)
- (request-loop (socket:accept-connection server-socket :wait t)))
-
-(defun request-loop (stream)
- (let* ((out (if *use-dedicated-output-stream*
- (open-stream-to-emacs stream)
- (make-instance 'slime-output-stream)))
- (in (make-instance 'slime-input-stream))
- (io (make-two-way-stream in out)))
- (do () ((serve-one-request stream out in io)))))
-
-(defun serve-one-request (*emacs-io* *slime-output* *slime-input* *slime-io*)
- (catch 'slime-toplevel
- (with-simple-restart (abort "Return to Slime toplevel.")
- (handler-case (read-from-emacs)
- (slime-read-error (e)
- (when *swank-debug-p*
- (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e))
- (close *emacs-io*)
- (return-from serve-one-request t)))))
- nil)
-
-(defun open-stream-to-emacs (*emacs-io*)
- (let* ((listener (socket:make-socket :connect :passive :local-port 0
- :reuse-address t))
- (port (socket:local-port listener)))
- (unwind-protect (progn
- (eval-in-emacs `(slime-open-stream-to-lisp ,port))
- (socket:accept-connection listener :wait t))
- (close listener))))
+(defmethod local-port (socket)
+ (socket:local-port socket))
+
+(defmethod close-socket (socket)
+ (close socket))
+
+(defmethod accept-connection (socket)
+ (socket:accept-connection socket :wait t))
+
+(defmethod spawn (fn &key name)
+ (mp:process-run-function name fn))
+
+;;;
(defmethod arglist-string (fname)
(declare (type string fname))
Index: slime/swank-lispworks.lisp
diff -u slime/swank-lispworks.lisp:1.12 slime/swank-lispworks.lisp:1.13
--- slime/swank-lispworks.lisp:1.12 Mon Jan 12 23:22:20 2004
+++ slime/swank-lispworks.lisp Tue Jan 13 13:20:04 2004
@@ -7,7 +7,7 @@
;;; This code has been placed in the Public Domain. All warranties
;;; are disclaimed.
;;;
-;;; $Id: swank-lispworks.lisp,v 1.12 2004/01/13 04:22:20 lgorrie Exp $
+;;; $Id: swank-lispworks.lisp,v 1.13 2004/01/13 18:20:04 heller Exp $
;;;
(in-package :swank)
@@ -32,35 +32,37 @@
(defconstant +sigint+ 2)
-(defmethod accept-socket/run (&key (port 0) announce-fn init-fn)
- (flet ((sentinel (socket condition)
- (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))
+;;; TCP server
-(defun local-tcp-port (socket)
- (nth-value 1 (comm:get-socket-address socket)))
+(defun socket-fd (socket)
+ (etypecase socket
+ (fixnum socket)
+ (comm:socket-stream (comm:socket-stream-socket socket))))
+
+(defmethod create-socket (port)
+ (multiple-value-bind (socket where errno)
+ (comm::create-tcp-socket-for-service port :address "localhost")
+ (cond (socket socket)
+ (t (error 'network-error "asdf ~A")
+ :format-control "~A failed: ~A (~D)"
+ :format-arguments (list where
+ (list #+unix (lw:get-unix-error errno))
+ errno)))))
+
+(defmethod local-port (socket)
+ (nth-value 1 (comm:get-socket-address (socket-fd socket))))
+
+(defmethod close-socket (socket)
+ (comm::close-socket (socket-fd socket)))
+
+(defmethod accept-connection (socket)
+ (let ((fd (comm::get-fd-from-socket socket)))
+ (assert (/= fd -1))
+ (make-instance 'comm:socket-stream :socket fd :direction :io
+ :element-type 'base-char)))
+
+(defmethod spawn (fn &key name)
+ (mp:process-run-function name () fn))
(defmethod emacs-connected ()
;; Set SIGINT handler on Swank request handler thread.
@@ -70,14 +72,7 @@
(declare (ignore args))
(invoke-debugger "SIGINT"))
-(defmethod make-fn-streams (input-fn output-fn)
- (let* ((output (make-instance 'slime-output-stream
- :output-fn output-fn))
- (input (make-instance 'slime-input-stream
- :input-fn input-fn
- :output-stream output)))
- (values input output)))
-
+;;;
(defslimefun getpid ()
"Return the process ID of this superior Lisp."
Index: slime/swank-clisp.lisp
diff -u slime/swank-clisp.lisp:1.7 slime/swank-clisp.lisp:1.8
--- slime/swank-clisp.lisp:1.7 Mon Jan 12 23:23:12 2004
+++ slime/swank-clisp.lisp Tue Jan 13 13:20:04 2004
@@ -43,70 +43,30 @@
(defun without-interrupts* (fun)
(without-interrupts (funcall fun)))
-#+linux (defslimefun getpid () (linux::getpid))
#+unix (defslimefun getpid () (system::program-id))
#+win32 (defslimefun getpid () (or (system::getenv "PID") -1))
;; the above is likely broken; we need windows NT users!
-;;; Gray streams
-
-;; From swank-gray.lisp.
-
-(defclass slime-input-stream (fundamental-character-input-stream)
- ((buffer :initform "") (index :initform 0)))
-
-;; We have to define an additional method for the sake of the C
-;; function listen_char (see src/stream.d), on which SYS::READ-FORM
-;; depends.
-
-;; We could make do with either of the two methods below.
-
-(defmethod stream-read-char-no-hang ((s slime-input-stream))
- (with-slots (buffer index) s
- (when (< index (length buffer))
- (prog1 (aref buffer index) (incf index)))))
-
-;; This CLISP extension is what listen_char actually calls. The
-;; default method would call STREAM-READ-CHAR-NO-HANG, so it is a bit
-;; more efficient to define it directly.
-
-(defmethod stream-read-char-will-hang-p ((s slime-input-stream))
- (with-slots (buffer index) s
- (= index (length buffer))))
-
-
;;; TCP Server
-(defmethod accept-socket/stream (&key (port 0) announce-fn)
- (get-socket-stream port announce-fn))
+(defmethod create-socket (port)
+ (socket:socket-server port))
-(defmethod accept-socket/run (&key (port 0) announce-fn init-fn)
- (let* ((slime-stream (get-socket-stream port announce-fn))
- (handler-fn (funcall init-fn slime-stream)))
- (loop while t do (funcall handler-fn))))
+(defmethod local-port (socket)
+ (socket:socket-server-port socket))
-(defun get-socket-stream (port announce)
- (let ((socket (socket:socket-server port)))
- (unwind-protect
- (progn
- (funcall announce (socket:socket-server-port socket))
- (socket:socket-wait socket 0)
- (socket:socket-accept socket
- :buffered nil
- :element-type 'character
- :external-format (ext:make-encoding
- :charset 'charset:iso-8859-1
- :line-terminator :unix)))
- (socket:socket-server-close socket))))
+(defmethod close-socket (socket)
+ (socket:socket-server-close socket))
-(defmethod make-fn-streams (input-fn output-fn)
- (let* ((output (make-instance 'slime-output-stream
- :output-fn output-fn))
- (input (make-instance 'slime-input-stream
- :input-fn input-fn
- :output-stream output)))
- (values input output)))
+(defmethod accept-connection (socket)
+ (socket:socket-wait socket)
+ (socket:socket-accept socket
+ :buffered nil ;; XXX should be t
+ :element-type 'character
+ :external-format (ext:make-encoding
+ :charset 'charset:iso-8859-1
+ :line-terminator :unix)))
;;; Swank functions
Index: slime/swank-cmucl.lisp
diff -u slime/swank-cmucl.lisp:1.46 slime/swank-cmucl.lisp:1.47
--- slime/swank-cmucl.lisp:1.46 Mon Jan 12 23:22:07 2004
+++ slime/swank-cmucl.lisp Tue Jan 13 13:20:04 2004
@@ -10,30 +10,25 @@
;;;; TCP server.
-(defvar *start-swank-in-background* t)
-
-(defmethod accept-socket/stream (&key (port 0) announce-fn (host "localhost"))
- (let ((fd (ext:create-inet-listener port :stream
- :reuse-address t
- :host (resolve-hostname host))))
- (funcall announce-fn (local-tcp-port fd))
- (let ((client-fd (ext:accept-tcp-connection fd)))
- (unix:unix-close fd)
- (make-socket-io-stream client-fd))))
-
-(defmethod accept-socket/run (&key (port 0) announce-fn init-fn (host "localhost"))
- "Run in the background if *START-SWANK-IN-BACKGROUND* is true."
- (let ((fd (ext:create-inet-listener port :stream
- :reuse-address t
- :host (resolve-hostname host))))
- (funcall announce-fn (local-tcp-port fd))
- (add-input-handler fd (lambda ()
- (setup-client (ext:accept-tcp-connection fd) init-fn)))))
-
-(defun setup-client (fd init-fn)
- (let* ((socket-io (make-socket-io-stream fd))
- (handler-fn (funcall init-fn socket-io)))
- (add-input-handler fd handler-fn)))
+(defmethod create-socket (port)
+ (ext:create-inet-listener port :stream
+ :reuse-address t
+ :host (resolve-hostname "localhost")))
+
+(defmethod local-port (socket)
+ (nth-value 1 (ext::get-socket-host-and-port (socket-fd socket))))
+
+(defmethod close-socket (socket)
+ (ext:close-socket (socket-fd socket)))
+
+(defmethod accept-connection (socket)
+ (make-socket-io-stream (ext:accept-tcp-connection socket)))
+
+(defmethod add-input-handler (socket fn)
+ (flet ((callback (fd)
+ (declare (ignore fd))
+ (funcall fn)))
+ (system:add-fd-handler (socket-fd socket) :input #'callback)))
(defmethod make-fn-streams (input-fn output-fn)
(let* ((output (make-slime-output-stream output-fn))
@@ -43,21 +38,17 @@
;;;
;;;;; Socket helpers.
-(defun local-tcp-port (fd)
- "Return the TCP port of the socket represented by FD."
- (nth-value 1 (ext::get-socket-host-and-port fd)))
+(defun socket-fd (socket)
+ "Return the filedescriptor for the socket represented by SOCKET."
+ (etypecase socket
+ (fixnum socket)
+ (sys:fd-stream (sys:fd-stream-fd socket))))
(defun resolve-hostname (hostname)
"Return the IP address of HOSTNAME as an integer."
(let* ((hostent (ext:lookup-host-entry hostname))
(address (car (ext:host-entry-addr-list hostent))))
(ext:htonl address)))
-
-(defun add-input-handler (fd fn)
- (let ((callback (lambda (fd)
- (declare (ignore fd))
- (funcall fn))))
- (system:add-fd-handler fd :input callback)))
(defun make-socket-io-stream (fd)
"Create a new input/output fd-stream for FD."
Index: slime/swank-openmcl.lisp
diff -u slime/swank-openmcl.lisp:1.43 slime/swank-openmcl.lisp:1.44
--- slime/swank-openmcl.lisp:1.43 Fri Jan 2 13:23:14 2004
+++ slime/swank-openmcl.lisp Tue Jan 13 13:20:04 2004
@@ -13,7 +13,7 @@
;;; The LLGPL is also available online at
;;; http://opensource.franz.com/preamble.html
;;;
-;;; $Id: swank-openmcl.lisp,v 1.43 2004/01/02 18:23:14 heller Exp $
+;;; $Id: swank-openmcl.lisp,v 1.44 2004/01/13 18:20:04 heller Exp $
;;;
;;;
@@ -75,26 +75,22 @@
;;; TCP Server
-;; In OpenMCL, the Swank backend runs in a separate thread and simply
-;; blocks on its TCP port while waiting for forms to evaluate.
+(defmethod create-socket (port)
+ (ccl:make-socket :connect :passive :local-port port :reuse-address t))
-(defun create-swank-server (port &key (reuse-address t)
- (announce #'simple-announce-function)
- (background *start-swank-in-background*)
- (close *close-swank-socket-after-setup*))
- "Create a Swank TCP server on `port'."
- (let ((server-socket (ccl:make-socket :connect :passive :local-port port
- :reuse-address reuse-address)))
- (funcall announce (ccl:local-port server-socket))
- (cond (background
- (let ((swank (ccl:process-run-function
- "Swank" #'accept-loop server-socket close)))
- ;; tell openmcl which process you want to be interrupted when
- ;; sigint is received
- (setq ccl::*interactive-abort-process* swank)
- swank))
- (t
- (accept-loop server-socket close)))))
+(defmethod local-port (socket)
+ (ccl:local-port socket))
+
+(defmethod close-socket (socket)
+ (close socket))
+
+(defmethod accept-connection (socket)
+ (ccl:accept-connection socket :wait t))
+
+(defmethod spawn (fn &key name)
+ (ccl:process-run-function name fn))
+
+;;;
(let ((ccl::*warn-if-redefine-kernel* nil))
(defun ccl::force-break-in-listener (p)
@@ -125,7 +121,6 @@
(eq ccl::*current-process* ccl::*interactive-abort-process*))
(apply 'break-in-sldb ccl::arglist)
(:do-it)) :when :around :name sldb-break))
-
(defun break-in-sldb (&optional string &rest args)
(let ((c (make-condition 'simple-condition
@@ -146,44 +141,6 @@
(restart-case (invoke-debugger c)
(continue () :report (lambda (stream) (write-string "Resume interrupted evaluation" stream)) t))
)))
-
-(defun accept-loop (server-socket close)
- (unwind-protect (cond (close (accept-one-client server-socket))
- (t (loop (accept-one-client server-socket))))
- (close server-socket)))
-
-(defun accept-one-client (server-socket)
- (request-loop (ccl:accept-connection server-socket :wait t)))
-
-(defun request-loop (stream)
- (let* ((out (if *use-dedicated-output-stream*
- (open-stream-to-emacs stream)
- (make-instance 'slime-output-stream)))
- (in (make-instance 'slime-input-stream))
- (io (make-two-way-stream in out)))
- (push out ccl::*auto-flush-streams*)
- (unwind-protect (do () ((serve-one-request stream out in io)))
- (setq ccl::*auto-flush-streams* (remove out ccl::*auto-flush-streams*)))))
-
-(defun serve-one-request (*emacs-io* *slime-output* *slime-input* *slime-io*)
- (catch 'slime-toplevel
- (with-simple-restart (abort "Return to Slime toplevel.")
- (handler-case (read-from-emacs)
- (slime-read-error (e)
- (when *swank-debug-p*
- (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e))
- (close *emacs-io*)
- (return-from serve-one-request t)))))
- nil)
-
-(defun open-stream-to-emacs (*emacs-io*)
- (let* ((listener (ccl:make-socket :connect :passive :local-port 0
- :reuse-address t))
- (port (ccl:local-port listener)))
- (unwind-protect (progn
- (eval-in-emacs `(slime-open-stream-to-lisp ,port))
- (ccl:accept-connection listener :wait t))
- (close listener))))
;;; Evaluation
Index: slime/swank-sbcl.lisp
diff -u slime/swank-sbcl.lisp:1.47 slime/swank-sbcl.lisp:1.48
--- slime/swank-sbcl.lisp:1.47 Mon Jan 12 23:21:41 2004
+++ slime/swank-sbcl.lisp Tue Jan 13 13:20:04 2004
@@ -61,64 +61,47 @@
;;; TCP Server
-(defmethod accept-socket/stream (&key (port 0) announce-fn (reuse-address t))
- (let ((socket (open-listener port reuse-address)))
- (funcall announce-fn (local-tcp-port socket))
- (let ((client-socket (accept socket)))
- (sb-bsd-sockets:socket-close socket)
- (make-socket-io-stream client-socket))))
-
-(defmethod accept-socket/run (&key (port 0) announce-fn init-fn (reuse-address t))
- (let ((socket (open-listener port reuse-address)))
- (funcall announce-fn (local-tcp-port socket))
- (add-input-handler socket (lambda ()
- (setup-client (accept socket) init-fn)))))
-
-(defun setup-client (socket init-fn)
- (let* ((socket-io (make-socket-io-stream socket))
- (handler-fn (funcall init-fn socket-io)))
- (add-input-handler socket handler-fn)))
-
-(defun add-input-handler (socket handler-fn)
- (sb-sys:add-fd-handler (sb-bsd-sockets:socket-file-descriptor socket)
- :input (lambda (fd)
- (declare (ignore fd))
- (funcall handler-fn))))
-
-(defun open-listener (port reuse-address)
+(defmethod create-socket (port)
(let ((socket (make-instance 'sb-bsd-sockets:inet-socket
:type :stream
:protocol :tcp)))
- (when reuse-address
- (setf (sb-bsd-sockets:sockopt-reuse-address socket) t))
- ;;(setf (sb-bsd-sockets:non-blocking-mode socket) t)
+ (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
(sb-bsd-sockets:socket-bind socket #(127 0 0 1) port)
(sb-bsd-sockets:socket-listen socket 5)
socket))
-(defun local-tcp-port (socket)
+(defmethod local-port (socket)
(nth-value 1 (sb-bsd-sockets:socket-name socket)))
+(defmethod close-socket (socket)
+ (sb-bsd-sockets:socket-close socket))
+
+(defmethod accept-connection (socket)
+ (make-socket-io-stream (accept socket)))
+
+(defmethod add-input-handler (socket fn)
+ (sb-sys:add-fd-handler (socket-fd socket)
+ :input (lambda (fd)
+ (declare (ignore fd))
+ (funcall fn))))
+
+(defun socket-fd (socket)
+ (etypecase socket
+ (fixnum socket)
+ (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
+ (file-stream (sb-sys:fd-stream-fd socket))))
+
(defun make-socket-io-stream (socket)
(sb-bsd-sockets:socket-make-stream socket
:output t
:input t
:element-type 'base-char))
-
(defun accept (socket)
"Like socket-accept, but retry on EAGAIN."
(loop (handler-case
(return (sb-bsd-sockets:socket-accept socket))
(sb-bsd-sockets:interrupted-error ()))))
-
-(defmethod make-fn-streams (input-fn output-fn)
- (let* ((output (make-instance 'slime-output-stream
- :output-fn output-fn))
- (input (make-instance 'slime-input-stream
- :input-fn input-fn
- :output-stream output)))
- (values input output)))
;;; Utilities
More information about the slime-cvs
mailing list