/[slime]/slime/swank.lisp
ViewVC logotype

Diff of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.89 by heller, Fri Jan 9 18:51:18 2004 UTC revision 1.90 by lgorrie, Mon Jan 12 00:55:21 2004 UTC
# Line 16  Line 16 
16    
17  (in-package :swank)  (in-package :swank)
18    
19    (declaim (optimize (debug 3)))
20    
21  (defvar *swank-io-package*  (defvar *swank-io-package*
22    (let ((package (make-package "SWANK-IO-PACKAGE" :use '())))    (let ((package (make-package "SWANK-IO-PACKAGE" :use '())))
23      (import '(nil t quote) package)      (import '(nil t quote) package)
24      package))      package))
25    
26  (declaim (optimize (debug 3)))  (defvar *dispatching-connection* nil
27      "Connection currently being served.")
28    
29  (defconstant server-port 4005  (defconstant server-port 4005
30    "Default port for the Swank TCP server.")    "Default port for the Swank TCP server.")
# Line 63  run.") Line 66  run.")
66      (export ',fun :swank)))      (export ',fun :swank)))
67    
68    
69  ;;;; Setup and Hooks  ;;;; Helper macros
70    
71    (defmacro with-conversation-lock (&body body)
72      `(call-with-conversation-lock (lambda () ,@body)))
73    
74    (defmacro with-I/O-lock (&body body)
75      `(call-with-I/O-lock (lambda () ,@body)))
76    
77    (defmacro with-io-redirection ((&optional (connection '*dispatching-connection*))
78                                   &body body)
79      "Execute BODY with I/O redirection to CONNECTION.
80    If *REDIRECT-IO* is true, all standard I/O streams are redirected."
81      `(if *redirect-io*
82           (call-with-redirected-io ,connection (lambda () ,@body))
83           (progn ,@body)))
84    
85    ;;;
86    ;;;; Connection datatype
87    
88    (defstruct (connection
89                 (:conc-name connection.)
90                 (:print-function %print-connection)
91                 (:constructor make-connection (socket-io user-input user-output user-io)))
92      ;; Raw I/O stream of socket connection.
93      (socket-io   nil :type stream)
94      ;; Streams that can be used for user interaction, with requests
95      ;; redirected to Emacs. These streams must be initialized but,
96      ;; depending on configuration, may not be used.
97      (user-input  nil :type (or stream null))
98      (user-output nil :type (or stream null))
99      (user-io     nil :type (or stream null)))
100    
101    (defun %print-connection (connection stream depth)
102      (declare (ignore depth))
103      (print-unreadable-object (connection stream :type t :identity t)))
104    
105    ;; Condition for SLIME protocol errors.
106    (define-condition slime-read-error (error)
107      ((condition :initarg :condition :reader slime-read-error.condition))
108      (:report (lambda (condition stream)
109                 (format stream "~A" (slime-read-error.condition condition)))))
110    
111    
112    ;;;; TCP Server
113    
114  (defvar *start-swank-in-background* t)  (defvar *start-swank-in-background* t)
115  (defvar *close-swank-socket-after-setup* nil)  (defvar *close-swank-socket-after-setup* nil)
116  (defvar *use-dedicated-output-stream* t)  (defvar *use-dedicated-output-stream* t)
117    
118  (defun announce-server-port (file)  (defun start-server (port-file)
119      (create-socket-server #'init-connection
120                            :announce-fn (announce-server-port-fn port-file)
121                            :port 0
122                            :loop nil))
123    
124    (defun announce-server-port-fn (file)
125    (lambda (port)    (lambda (port)
126      (with-open-file (s file      (with-open-file (s file
127                         :direction :output                         :direction :output
# Line 78  run.") Line 130  run.")
130        (format s "~S~%" port))        (format s "~S~%" port))
131      (simple-announce-function port)))      (simple-announce-function port)))
132    
133    (defun init-connection (socket-io)
134      (emacs-connected)
135      (let ((connection (create-connection socket-io)))
136        (lambda ()
137          (handle-request connection))))
138    
139    (defun create-connection (socket-io)
140      (let ((output-fn (make-output-function socket-io))
141            (input-fn  (lambda () (read-user-input-from-emacs socket-io))))
142        (multiple-value-bind (user-in user-out) (make-fn-streams input-fn output-fn)
143          (let ((user-io (make-two-way-stream user-in user-out)))
144            (make-connection socket-io user-in user-out user-io)))))
145    
146    (defun make-output-function (socket-io)
147      (if *use-dedicated-output-stream*
148          (let ((stream (open-dedicated-output-stream socket-io)))
149            (lambda (string)
150              (princ string stream)
151              (force-output stream)))
152          (lambda (string)
153            (send-output-to-emacs string socket-io))))
154    
155    (defun open-dedicated-output-stream (socket-io)
156      "Open a dedicated output connection to the Emacs on SOCKET-IO.
157    Return an output stream suitable for writing program output.
158    
159    This is an optimized way for Lisp to deliver output to Emacs."
160      ;; We start a server process, ask Emacs to connect to it, and then
161      ;; return the socket's stream.
162      (let (stream)
163        (labels ((announce (port)
164                   (send-to-emacs `(:open-dedicated-output-stream ,port) socket-io))
165                 (init (client-stream)
166                   (setf stream client-stream)
167                   #'handle)
168                 (handle ()
169                   (error "Protocol error: received input on dedicated output socket.")))
170          (create-socket-server #'init
171                                :announce-fn #'announce
172                                :loop nil
173                                :accept-background nil
174                                :handle-background t)
175          (assert (streamp stream))
176          stream)))
177    
178    (defun handle-request (connection)
179      "Read and respond to one request from CONNECTION."
180      (catch 'slime-toplevel
181        (with-simple-restart (abort "Return to SLIME toplevel.")
182          (let ((*dispatching-connection* connection))
183            (with-io-redirection ()
184              (handler-case (read-from-emacs)
185                (slime-read-error (e)
186                  (when *swank-debug-p*
187                    (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e))
188                  (close (connection.socket-io connection))
189                  (return-from handle-request t)))))))
190      nil)
191    
192  (defun simple-announce-function (port)  (defun simple-announce-function (port)
193    (when *swank-debug-p*    (when *swank-debug-p*
194      (format *debug-io* "~&;; Swank started at port: ~D.~%" port)))      (format *debug-io* "~&;; Swank started at port: ~D.~%" port)))
195    
 (defun start-server (port-file-namestring)  
   "Create a SWANK server and write its port number to the file  
 PORT-FILE-NAMESTRING in ascii text."  
   (create-swank-server  
    0 :reuse-address t  
    :announce (announce-server-port port-file-namestring)))  
   
   
 ;;;; Helper macros  
   
 (defmacro with-conversation-lock (&body body)  
   `(call-with-conversation-lock (lambda () ,@body)))  
   
 (defmacro with-I/O-lock (&body body)  
   `(call-with-I/O-lock (lambda () ,@body)))  
   
196    
197  ;;;; IO to Emacs  ;;;; IO to Emacs
198  ;;;  ;;;
# Line 114  PORT-FILE-NAMESTRING in ascii text." Line 209  PORT-FILE-NAMESTRING in ascii text."
209  ;;; These stream variables are all dynamically-bound during request  ;;; These stream variables are all dynamically-bound during request
210  ;;; processing.  ;;; processing.
211    
212  (defvar *emacs-io* nil  (defparameter *redirect-io* t
   "The raw TCP stream connected to Emacs.")  
   
 (defvar *slime-output* nil  
   "Output stream for writing Lisp output text to Emacs.")  
   
 (defvar *slime-input* nil  
   "Input stream to read user input from Emacs.")  
   
 (defvar *slime-io* nil  
   "Two-way-stream built from *slime-input* and *slime-output*.")  
   
 (defparameter *redirect-output* t  
213    "When non-nil redirect Lisp standard I/O to Emacs.    "When non-nil redirect Lisp standard I/O to Emacs.
214  Redirection is done while Lisp is processing a request for Emacs.")  Redirection is done while Lisp is processing a request for Emacs.")
215    
216  (defun call-with-slime-streams (in out io fn args)  (defun call-with-redirected-io (connection function)
217    (if *redirect-output*    "Call FUNCTION with I/O streams redirected via CONNECTION."
218        (let ((*standard-output* out)    (let* ((io  (connection.user-io connection))
219              (*slime-input* in)           (in  (connection.user-input connection))
220              (*slime-output* out)           (out (connection.user-output connection))
221              (*slime-io* io)           (*standard-output* out)
222              (*error-output* out)           (*error-output* out)
223              (*trace-output* out)           (*trace-output* out)
224              (*debug-io* io)           (*debug-io* io)
225              (*query-io* io)           (*query-io* io)
226              (*standard-input* in)           (*standard-input* in)
227              (*terminal-io* io))           (*terminal-io* io))
228          (apply fn args))      (funcall function)))
229        (apply fn args)))  
230    (defun current-socket-io ()
231      (connection.socket-io *dispatching-connection*))
232    
233  (defvar *log-events* nil)  (defvar *log-events* nil)
234    
# Line 153  Useful for low level debugging." Line 238  Useful for low level debugging."
238    (when *log-events*    (when *log-events*
239      (apply #'format *terminal-io* format-string args)))      (apply #'format *terminal-io* format-string args)))
240    
241  (defun read-from-emacs ()  (defun read-from-emacs (&optional (stream (current-socket-io)))
242    "Read and process a request from Emacs."    "Read and process a request from Emacs."
243    (let ((form (read-next-form)))    (let ((form (read-next-form stream)))
244      (log-event "READ: ~S~%" form)      (log-event "READ: ~S~%" form)
245      (call-with-slime-streams      (apply #'funcall form)))
      *slime-input* *slime-output* *slime-io*  
      #'funcall form)))  
   
 (define-condition slime-read-error (error)  
   ((condition :initarg :condition :reader slime-read-error.condition))  
   (:report (lambda (condition stream)  
              (format stream "~A" (slime-read-error.condition condition)))))  
246    
247  (defun read-next-form ()  (defun read-next-form (stream)
248    "Read the next Slime request from *EMACS-IO* and return an    "Read an S-expression from STREAM using the SLIME protocol.
249  S-expression to be evaluated to handle the request.  If an error  If a protocol error occurs then a SLIME-READ-ERROR is signalled."
250  occurs during parsing, it will be noted and control will be tranferred    (flet ((next-byte () (char-code (read-char stream))))
 back to the main request handling loop."  
   (flet ((next-byte () (char-code (read-char *emacs-io*))))  
251      (handler-case      (handler-case
252          (with-I/O-lock          (with-I/O-lock
253            (let* ((length (logior (ash (next-byte) 16)            (let* ((length (logior (ash (next-byte) 16)
254                                   (ash (next-byte) 8)                                   (ash (next-byte) 8)
255                                   (next-byte)))                                   (next-byte)))
256                   (string (make-string length))                   (string (make-string length))
257                   (pos (read-sequence string *emacs-io*)))                   (pos (read-sequence string stream)))
258              (assert (= pos length) nil              (assert (= pos length) ()
259                      "Short read: length=~D  pos=~D" length pos)                      "Short read: length=~D  pos=~D" length pos)
260              (read-form string)))              (read-form string)))
261        (serious-condition (c)        (serious-condition (c)
262          (error (make-condition 'slime-read-error :condition c))))))          (error (make-condition 'slime-read-error :condition c))))))
263    
264  (defun read-form (string)  (defun read-form (string)
# Line 199  back to the main request handling loop." Line 275  back to the main request handling loop."
275      (setq *slime-features* *features*)      (setq *slime-features* *features*)
276      (send-to-emacs (list :new-features (mapcar #'symbol-name *features*)))))      (send-to-emacs (list :new-features (mapcar #'symbol-name *features*)))))
277    
278  (defun send-to-emacs (object)  (defun send-to-emacs (object &optional (output (current-socket-io)))
279    "Send `object' to Emacs."    "Send OBJECT to over CONNECTION to Emacs."
280    (let* ((string (prin1-to-string-for-emacs object))    (let* ((string (prin1-to-string-for-emacs object))
281           (length (1+ (length string))))           (length (1+ (length string))))
282      (log-event "SEND: ~A~%" string)      (log-event "SEND: ~A~%" string)
# Line 209  back to the main request handling loop." Line 285  back to the main request handling loop."
285         (lambda ()         (lambda ()
286           (loop for position from 16 downto 0 by 8           (loop for position from 16 downto 0 by 8
287              do (write-char (code-char (ldb (byte 8 position) length))              do (write-char (code-char (ldb (byte 8 position) length))
288                             *emacs-io*))                             output))
289           (write-string string *emacs-io*)           (write-string string output)
290           (terpri *emacs-io*)           (terpri output)
291           (force-output *emacs-io*))))))           (force-output output))))))
292    
293  (defun prin1-to-string-for-emacs (object)  (defun prin1-to-string-for-emacs (object)
294    (with-standard-io-syntax    (with-standard-io-syntax
# Line 222  back to the main request handling loop." Line 298  back to the main request handling loop."
298            (*package* *swank-io-package*))            (*package* *swank-io-package*))
299        (prin1-to-string object))))        (prin1-to-string object))))
300    
301    (defun force-user-output (&optional (connection *dispatching-connection*))
302  ;;;;; Input from Emacs    (assert (connection-p connection))
303      (force-output (connection.user-io connection))
304      (force-output (connection.user-output connection)))
305    
306    (defun clear-user-input  (&optional (connection *dispatching-connection*))
307      (assert (connection-p connection))
308      (clear-input (connection.user-input connection)))
309    
310  (defvar *read-input-catch-tag* 0)  (defun send-output-to-emacs (string socket-io)
311      (send-to-emacs `(:read-output ,string) socket-io))
312    
313  (defun slime-read-string ()  (defun read-user-input-from-emacs (socket-io)
   (force-output)  
   (force-output *slime-io*)  
314    (let ((*read-input-catch-tag* (1+ *read-input-catch-tag*)))    (let ((*read-input-catch-tag* (1+ *read-input-catch-tag*)))
315      (send-to-emacs `(:read-string ,*read-input-catch-tag*))      (send-to-emacs `(:read-string ,*read-input-catch-tag*) socket-io)
316      (let (ok)      (let ((ok nil))
317        (unwind-protect        (unwind-protect
318             (prog1 (catch *read-input-catch-tag*             (prog1 (catch *read-input-catch-tag*
319                      (loop (read-from-emacs)))                      (loop (read-from-emacs socket-io)))
320               (setq ok t))               (setq ok t))
321          (unless ok          (unless ok
322            (send-to-emacs `(:read-aborted)))))))            (send-to-emacs `(:read-aborted)))))))
323    
324    
325    ;;;;; Input from Emacs
326    
327    (defvar *read-input-catch-tag* 0)
328    
329  (defslimefun take-input (tag input)  (defslimefun take-input (tag input)
330    (throw tag input))    (throw tag input))
331    
# Line 325  or SB-DEBUG::*INVOKE-DEBUGGER-HOOK*, to Line 411  or SB-DEBUG::*INVOKE-DEBUGGER-HOOK*, to
411  globally.  Must be run from the *slime-repl* buffer or somewhere else  globally.  Must be run from the *slime-repl* buffer or somewhere else
412  that the slime streams are visible so that it can capture them."  that the slime streams are visible so that it can capture them."
413    (let ((package *buffer-package*)    (let ((package *buffer-package*)
414          (in *slime-input*)          (connection *dispatching-connection*))
         (out *slime-output*)  
         (io *slime-io*)  
         (eio *emacs-io*))  
415      (labels ((slime-debug (c &optional next)      (labels ((slime-debug (c &optional next)
416                 (let ((*buffer-package* package)                 (let ((*buffer-package* package)
417                       (*emacs-io* eio))                       (*dispatching-connection* connection))
418                   ;; check emacs is still there: don't want to end up                   ;; check emacs is still there: don't want to end up
419                   ;; in recursive debugger loops if it's disconnected                   ;; in recursive debugger loops if it's disconnected
420                   (when (open-stream-p *emacs-io*)                   (when (open-stream-p (connection.socket-io connection))
421                     (call-with-slime-streams                     (with-io-redirection ()
422                      in out io                       (swank-debugger-hook c next))))))
                     #'swank-debugger-hook (list c next))))))  
423        #'slime-debug)))        #'slime-debug)))
424    
425  (defslimefun install-global-debugger-hook ()  (defslimefun install-global-debugger-hook ()
# Line 446  has changed, ignore the request." Line 528  has changed, ignore the request."
528               (force-output)               (force-output)
529               (setq ok t))               (setq ok t))
530          (sync-state-to-emacs)          (sync-state-to-emacs)
531          (force-output *slime-io*)          (force-user-output)
532          (send-to-emacs `(:return ,(if ok `(:ok ,result) '(:abort)) ,id)))))          (send-to-emacs `(:return ,(if ok `(:ok ,result) '(:abort)) ,id)))))
533    (when *debugger-hook-passback*    (when *debugger-hook-passback*
534      (setq *debugger-hook* *debugger-hook-passback*)      (setq *debugger-hook* *debugger-hook-passback*)
# Line 486  change, then send Emacs an update." Line 568  change, then send Emacs an update."
568               (read-from-string string nil nil :start pos)))               (read-from-string string nil nil :start pos)))
569        (when (and package-update-p (not (eq *package* *buffer-package*)))        (when (and package-update-p (not (eq *package* *buffer-package*)))
570          (send-to-emacs (list :new-package          (send-to-emacs (list :new-package
571                               (shortest-package-nickname *package*)))))))                               (shortest-package-nickname *package*)))))))
572    
573  (defun shortest-package-nickname (package)  (defun shortest-package-nickname (package)
574    "Return the shortest nickname (or canonical name) of PACKAGE."    "Return the shortest nickname (or canonical name) of PACKAGE."
# Line 531  change, then send Emacs an update." Line 613  change, then send Emacs an update."
613    (package-name *package*))    (package-name *package*))
614    
615  (defslimefun listener-eval (string)  (defslimefun listener-eval (string)
616    (clear-input *slime-input*)    (clear-user-input)
617    (multiple-value-bind (values last-form) (eval-region string t)    (multiple-value-bind (values last-form) (eval-region string t)
618      (setq +++ ++  ++ +  + last-form      (setq +++ ++  ++ +  + last-form
619            *** **  ** *  * (car values)            *** **  ** *  * (car values)
# Line 837  that symbols accessible in the current p Line 919  that symbols accessible in the current p
919    (multiple-value-bind (symbol foundp)    (multiple-value-bind (symbol foundp)
920        (find-symbol-designator symbol-name)        (find-symbol-designator symbol-name)
921      (cond (foundp (print-description-to-string symbol))      (cond (foundp (print-description-to-string symbol))
922            (t (format nil "Unkown symbol: ~S [in ~A]"            (t (format nil "Unknown symbol: ~S [in ~A]"
923                       symbol-name *buffer-package*)))))                       symbol-name *buffer-package*)))))
924    
925  (defslimefun describe-function (symbol-name)  (defslimefun describe-function (symbol-name)

Legend:
Removed from v.1.89  
changed lines
  Added in v.1.90

  ViewVC Help
Powered by ViewVC 1.1.5