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

Diff of /slime/swank.lisp

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

revision 1.109.2.1 by lgorrie, Sun Jan 25 20:52:47 2004 UTC revision 1.109.2.2 by heller, Sat Jan 31 11:26:02 2004 UTC
# Line 16  Line 16 
16    
17  (in-package :swank)  (in-package :swank)
18    
19  (declaim (optimize (debug 3)))  (declaim (optimize (debug 2)))
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  (defconstant server-port 4005  (defconstant +server-port+ 4005
27    "Default port for the Swank TCP server.")    "Default port for the Swank TCP server.")
28    
29  (defvar *swank-debug-p* t  (defvar *swank-debug-p* t
# Line 32  Line 32 
32  (defvar *sldb-pprint-frames* nil  (defvar *sldb-pprint-frames* nil
33    "*pretty-print* is bound to this value when sldb prints a frame.")    "*pretty-print* is bound to this value when sldb prints a frame.")
34    
 (defvar *processing-rpc* nil  
   "True when Lisp is evaluating an RPC from Emacs.")  
   
 (defvar *multiprocessing-enabled* nil  
   "True when multiprocessing support is to be used.")  
   
 (defvar *debugger-hook-passback* nil  
   ;; Temporary hack!  
   "When set while processing a command, the value is copied into  
 *debugger-hook*.  
   
 This allows RPCs from Emacs to change the global value of  
 *debugger-hook*, which is shadowed in a dynamic binding while they  
 run.")  
   
 (defparameter *redirect-io* t  
   "When non-nil redirect Lisp standard I/O to Emacs.  
 Redirection is done while Lisp is processing a request for Emacs.")  
   
35  ;;; public interface.  slimefuns are the things that emacs is allowed  ;;; public interface.  slimefuns are the things that emacs is allowed
36  ;;; to call  ;;; to call
37    
# Line 107  Redirection is done while Lisp is proces Line 88  Redirection is done while Lisp is proces
88    
89  (defstruct (connection  (defstruct (connection
90               (:conc-name connection.)               (:conc-name connection.)
91               (:print-function %print-connection)               ;; (:print-function %print-connection)
92               (:constructor make-connection (owner-id socket-io dedicated-output               )
                                                      user-input user-output user-io)))  
   ;; Thread-id of the connection's owner.  
   (owner-id         nil)  
93    ;; Raw I/O stream of socket connection.    ;; Raw I/O stream of socket connection.
94    (socket-io        nil :type stream)    (socket-io        nil :type stream :read-only t)
95    ;; Optional dedicated output socket (backending `user-output' slot).    ;; Optional dedicated output socket (backending `user-output' slot).
96    ;; Has a slot so that it can be closed with the connection.    ;; Has a slot so that it can be closed with the connection.
97    (dedicated-output nil :type (or stream null))    (dedicated-output nil :type (or stream null))
# Line 121  Redirection is done while Lisp is proces Line 99  Redirection is done while Lisp is proces
99    ;; redirected to Emacs.    ;; redirected to Emacs.
100    (user-input       nil :type (or stream null))    (user-input       nil :type (or stream null))
101    (user-output      nil :type (or stream null))    (user-output      nil :type (or stream null))
102    (user-io          nil :type (or stream null)))    (user-io          nil :type (or stream null))
103      ;;
104      (control-thread   nil :read-only t)
105      (reader-thread    nil :read-only t)
106      read
107      send
108      serve-requests
109      cleanup
110      )
111    
112  (defvar *main-connection* nil  (defvar *emacs-connection* nil
113    "The main (first established) connection to Emacs.    "The connection to Emacs.
114  Any thread may send out-of-band messages to Emacs using this  Any thread may send out-of-band messages to Emacs using this
115  connection.")  connection.")
116    
117  (defvar *main-thread-id* nil  (defvar *swank-state-stack* '())
118    "ID of the thread that established *MAIN-CONNECTION*.  
119  Only this thread can read from or send in-band messages to the  (defslimefun state-stack ()
120  *MAIN-CONNECTION*.")    *swank-state-stack*)
   
 ;; This can't be initialized right away due to our compilation/loading  
 ;; order: it ends up calling the NO-APPLICABLE-METHOD version from  
 ;; swank-backend before the real one loads.  
 (defvar *write-lock*)  
 (setf (documentation '*write-lock* 'variable)  
       "Lock held while writing to sockets.")  
   
 (defvar *dispatching-connection* nil  
   "Connection currently being served.  
 Dynamically bound while dispatching a request that arrives from  
 Emacs.")  
121    
122    #+(or)
123  (defun %print-connection (connection stream depth)  (defun %print-connection (connection stream depth)
124    (declare (ignore depth))    (declare (ignore depth))
125    (print-unreadable-object (connection stream :type t :identity t)))    (print-unreadable-object (connection stream :type t :identity t)))
# Line 157  Emacs.") Line 132  Emacs.")
132    
133  ;;;; Helper macros  ;;;; Helper macros
134    
135  (defmacro with-I/O-lock ((&rest ignore) &body body)  (defmacro with-io-redirection ((&rest ignore) &body body)
   (declare (ignore ignore))  
   `(call-with-lock-held *write-lock* (lambda () ,@body)))  
   
 (defmacro with-io-redirection ((&optional (connection '(current-connection)))  
                                &body body)  
136    "Execute BODY with I/O redirection to CONNECTION.    "Execute BODY with I/O redirection to CONNECTION.
137  If *REDIRECT-IO* is true, all standard I/O streams are redirected."  If *REDIRECT-IO* is true, all standard I/O streams are redirected."
138      (declare (ignore ignore))
139    `(if *redirect-io*    `(if *redirect-io*
140         (call-with-redirected-io ,connection (lambda () ,@body))         (call-with-redirected-io *emacs-connection* (lambda () ,@body))
141         (progn ,@body)))         (progn ,@body)))
142    
143  (defmacro without-interrupts (&body body)  (defmacro without-interrupts (&body body)
144    `(call-without-interrupts (lambda () ,@body)))    `(call-without-interrupts (lambda () ,@body)))
145    
146    (defmacro destructure-case (value &rest patterns)
147      "Dispatch VALUE to one of PATTERNS.
148    A cross between `case' and `destructuring-bind'.
149    The pattern syntax is:
150      ((HEAD . ARGS) . BODY)
151    The list of patterns is searched for a HEAD `eq' to the car of
152    VALUE. If one is found, the BODY is executed with ARGS bound to the
153    corresponding values in the CDR of VALUE."
154      (let ((operator (gensym "op-"))
155            (operands (gensym "rand-"))
156            (tmp (gensym "tmp-")))
157        `(let* ((,tmp ,value)
158                (,operator (car ,tmp))
159                (,operands (cdr ,tmp)))
160          (case ,operator
161            ,@(mapcar (lambda (clause)
162                        (if (eq (car clause) t)
163                            `(t ,@(cdr clause))
164                            (destructuring-bind ((op &rest rands) &rest body)
165                                clause
166                              `(,op (destructuring-bind ,rands ,operands
167                                      . ,body)))))
168                      patterns)
169            ,@(if (eq (caar (last patterns)) t)
170                  '()
171                  `((t (error "destructure-case failed: ~S" ,tmp))))))))
172    
173  ;;;; TCP Server  ;;;; TCP Server
174    
175  (defvar *close-swank-socket-after-setup* nil)  (defparameter *redirect-io* t
176      "When non-nil redirect Lisp standard I/O to Emacs.
177    Redirection is done while Lisp is processing a request for Emacs.")
178    
179  (defvar *use-dedicated-output-stream* t)  (defvar *use-dedicated-output-stream* t)
180  (defvar *swank-in-background* nil)  (defvar *swank-in-background* nil)
181    (defvar *log-events* t)
182    
183  (defun start-server (port-file)  (defun start-server (port-file)
184    (setup-server 0 (lambda (port) (announce-server-port port-file port))    (setup-server 0 (lambda (port) (announce-server-port port-file port))
185                  *swank-in-background*))                  *swank-in-background*))
186    
187  (defun create-swank-server (&optional (port 4005)  (defun create-swank-server (&optional (port +server-port+)
188                              (background *swank-in-background*)                              (background *swank-in-background*)
189                              (announce-fn #'simple-announce-function))                              (announce-fn #'simple-announce-function))
190    (setup-server port announce-fn background))    (setup-server port announce-fn background))
191    
192  (defun setup-server (port announce-fn background)  (defun setup-server (port announce-fn style)
   (setq *write-lock* (make-lock :name "Swank write lock"))  
193    (let* ((socket (create-socket port))    (let* ((socket (create-socket port))
194           (port (local-port socket)))           (port (local-port socket)))
195      (funcall announce-fn port)      (funcall announce-fn port)
196      (if (eq *swank-in-background* :spawn)      (cond ((eq style :spawn)
197          (spawn (lambda () (serve-connection socket nil)) :name "Swank")             (spawn (lambda () (serve-connection socket :spawn)) :name "Swank"))
198          (serve-connection socket background))            (t (serve-connection socket style)))
199      port))      port))
200    
201  (defun serve-connection (socket background)  (defun serve-connection (socket style)
202    (let ((client (accept-connection socket)))    (let ((client (accept-connection socket)))
203      (close-socket socket)      (close-socket socket)
204      (let ((connection (create-connection client)))      (let ((connection (create-connection client style)))
205        (init-main-connection connection)        (init-emacs-connection connection)
206        (serve-requests client connection background))))        (serve-requests connection))))
207    
208  (defun serve-requests (client connection background)  (defun serve-requests (connection)
209    (ecase background    (funcall (connection.serve-requests connection) connection))
210      (:fd-handler (add-input-handler  
211                    client (lambda ()  (defun init-emacs-connection (connection)
212                             (loop (cond ((handle-request connection)    (setq *emacs-connection* connection)
                                         (remove-input-handlers client)  
                                         (return))  
                                        ((listen client))  
                                        (t (return)))))))  
     ((nil) (loop until (handle-request connection)))))  
   
 (defun init-main-connection (connection)  
   (setq *main-connection* connection)  
 ;;  (setq *dispatching-connection* *main-connection*) ;**  
   (setq *main-thread-id* (thread-id))  
213    (emacs-connected))    (emacs-connected))
214    
215  (defun announce-server-port (file port)  (defun announce-server-port (file port)
# Line 229  If *REDIRECT-IO* is true, all standard I Line 220  If *REDIRECT-IO* is true, all standard I
220      (format s "~S~%" port))      (format s "~S~%" port))
221    (simple-announce-function port))    (simple-announce-function port))
222    
223  (defun create-connection (socket-io)  (defun open-streams (socket-io)
224    (send-to-emacs `(:check-protocol-version ,(changelog-date)) socket-io)    (encode-message `(:check-protocol-version ,(changelog-date)) socket-io)
225    (multiple-value-bind (output-fn dedicated-output)    (multiple-value-bind (output-fn dedicated-output)
226        (make-output-function socket-io)        (make-output-function socket-io)
227      (let ((input-fn  (lambda () (read-user-input-from-emacs socket-io))))      (let ((input-fn  (lambda () (read-user-input-from-emacs))))
228        (multiple-value-bind (in out) (make-fn-streams input-fn output-fn)        (multiple-value-bind (in out) (make-fn-streams input-fn output-fn)
229          (let ((out (or dedicated-output out)))          (let ((out (or dedicated-output out)))
230            (let ((io (make-two-way-stream in out)))            (let ((io (make-two-way-stream in out)))
231              (make-connection (thread-id) socket-io dedicated-output              (values dedicated-output in out io)))))))
                              in out io)))))))  
232    
233  (defun make-output-function (socket-io)  (defun make-output-function (socket-io)
234    "Create function to send user output to Emacs.    "Create function to send user output to Emacs.
# Line 261  Return an output stream suitable for wri Line 251  Return an output stream suitable for wri
251  This is an optimized way for Lisp to deliver output to Emacs."  This is an optimized way for Lisp to deliver output to Emacs."
252    (let* ((socket (create-socket 0))    (let* ((socket (create-socket 0))
253           (port (local-port socket)))           (port (local-port socket)))
254      (send-to-emacs `(:open-dedicated-output-stream ,port) socket-io)      (encode-message `(:open-dedicated-output-stream ,port) socket-io)
255      (accept-connection socket)))      (accept-connection socket)))
256    
257  (defun handle-request (connection)  (defun handle-request ()
258    "Read and respond to one request from CONNECTION."    (assert (null *swank-state-stack*))
259    (catch 'slime-toplevel    (let ((*swank-state-stack* '(:handle-request)))
260      (with-simple-restart (abort "Return to SLIME toplevel.")      (catch 'slime-toplevel
261        (let ((*dispatching-connection* connection))        (with-simple-restart (abort "Return to SLIME toplevel.")
262          (with-io-redirection ()          (with-io-redirection ()
263            (handler-case (read-from-emacs)            (read-from-emacs))))))
             (slime-read-error (e)  
               (when *swank-debug-p*  
                 (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e))  
               (close-connection connection)  
               (return-from handle-request t)))))))  
   nil)  
264    
265  (defun simple-announce-function (port)  (defun simple-announce-function (port)
266    (when *swank-debug-p*    (when *swank-debug-p*
# Line 296  determined at compile time." Line 280  determined at compile time."
280                   `(quote ,date))))                   `(quote ,date))))
281      (date)))      (date)))
282    
283    (defun current-socket-io ()
284      (connection.socket-io *emacs-connection*))
285    
286    (defun close-connection (c &optional condition)
287      (when condition
288        (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" condition))
289      (when (connection.cleanup c)
290        (funcall (connection.cleanup c) c))
291      (close (connection.socket-io c))
292      (when (connection.dedicated-output c)
293        (close (connection.dedicated-output c))))
294    
295    (defmacro with-reader-error-handler ((connection) &body body)
296      `(handler-case (progn ,@body)
297        (slime-read-error (e) (close-connection ,connection e))))
298    
299    (defun read-loop (control-thread input-stream)
300      (with-reader-error-handler (*emacs-connection*)
301        (loop (send control-thread (decode-message input-stream)))))
302    
303    (defvar *active-threads* '())
304    (defvar *thread-counter* 0)
305    
306    (defun add-thread (thread)
307      (let ((id (mod (1+ *thread-counter*) most-positive-fixnum)))
308        (setq *active-threads* (acons id thread *active-threads*)
309              *thread-counter* id)
310        id))
311    
312    (defun drop&find (item list key test)
313      "Return LIST where item is removed together with the removed
314    element."
315      (do ((stack '() (cons (car l) stack))
316           (l list (cdr l)))
317          ((null l) (values (nreverse stack) nil))
318        (when (funcall test item (funcall key (car l)))
319          (return (values (nreconc stack (cdr l))
320                          (car l))))))
321    
322    (defun drop-thread (thread)
323      "Drop the first occurence of thread in *active-threads* and return its id."
324      (multiple-value-bind (list pair) (drop&find thread *active-threads*
325                                                  #'cdr #'eql)
326        (setq *active-threads* list)
327        (assert pair)
328        (car pair)))
329    
330    (defun lookup-thread (thread)
331      (let ((probe (rassoc thread *active-threads*)))
332        (cond (probe (car probe))
333              (t (add-thread thread)))))
334    
335    (defun lookup-thread-id (id &optional noerror)
336      (let ((probe (assoc id *active-threads*)))
337        (cond (probe (cdr probe))
338              (noerror nil)
339              (t (error "Thread id not found ~S" id)))))
340    
341    (defun dispatch-loop (socket-io)
342      (setq *active-threads* '())
343      (setq *thread-counter* 0)
344      (loop (with-simple-restart (abort "Retstart dispatch loop.")
345              (loop (dispatch-event (receive) socket-io)))))
346    
347    
348    (defun simple-break ()
349      (with-simple-restart  (continue "Continue from interrupt.")
350        (invoke-debugger (make-condition 'simple-error
351                                         :format-control "Interrupt from Emacs"))))
352    
353    (defun interrupt-worker-thread (thread)
354      (let ((thread (etypecase thread
355                      ((member t) (cdr (car *active-threads*)))
356                      (fixnum (lookup-thread-id thread))))
357            (hook #'swank-debugger-hook))
358        (interrupt-thread thread (lambda ()
359                                   (let ((*debugger-hook* hook))
360                                     (simple-break))))))
361    
362    (defun dispatch-event (event socket-io)
363      (log-event "DISPATCHING: ~S~%" event)
364      (destructure-case event
365        ((:emacs-rex string package thread id)
366         (let ((thread (etypecase thread
367                         ((member t) (spawn #'handle-request :name "worker"))
368                         (fixnum (lookup-thread-id thread)))))
369           (send thread `(eval-string ,string ,package ,id))
370           (add-thread thread)))
371        ((:emacs-interrupt thread)
372         (interrupt-worker-thread thread))
373        ((:debug thread &rest args)
374         (encode-message `(:debug ,(add-thread thread) . ,args) socket-io))
375        ((:debug-return thread level)
376         (encode-message `(:debug-return ,(drop-thread thread) ,level) socket-io))
377        ((:return thread &rest args)
378         (drop-thread thread)
379         (encode-message `(:return ,@args) socket-io))
380        ((:read-string thread &rest args)
381         (encode-message `(:read-string ,(add-thread thread) ,@args) socket-io))
382        ((:read-aborted thread &rest args)
383         (encode-message `(:read-aborted ,(drop-thread thread) ,@args) socket-io))
384        ((:emacs-return-string thread tag string)
385         (send (lookup-thread-id thread) `(take-input ,tag ,string)))
386        (((:read-output :new-package :new-features :ed :debug-condition)
387          &rest _)
388         (declare (ignore _))
389         (encode-message event socket-io))))
390    
391    (defun create-connection (socket-io style)
392      (multiple-value-bind (dedicated in out io) (open-streams socket-io)
393        (ecase style
394          (:spawn
395           (let* ((control-thread (spawn (lambda () (dispatch-loop socket-io))
396                                         :name "control-thread"))
397                  (reader-thread (spawn (lambda ()
398                                          (read-loop control-thread socket-io))
399                                        :name "reader-thread")))
400             (make-connection :socket-io socket-io :dedicated-output dedicated
401                              :user-input in :user-output out :user-io io
402                              :control-thread control-thread
403                              :reader-thread reader-thread
404                              :read 'read-from-control-thread
405                              :send 'send-to-control-thread
406                              :serve-requests (lambda (c) c))))
407          (:sigio
408           (make-connection :socket-io socket-io :dedicated-output dedicated
409                            :user-input in :user-output out :user-io io
410                            :read 'read-from-socket-io
411                            :send 'send-to-socket-io
412                            :serve-requests 'install-sigio-handler
413                            :cleanup 'remove-sigio-handler))
414          ((nil)
415           (make-connection :socket-io socket-io :dedicated-output dedicated
416                            :user-input in :user-output out :user-io io
417                            :read 'read-from-socket-io
418                            :send 'send-to-socket-io
419                            :serve-requests 'simple-serve-requests)))))
420    
421    (defun install-sigio-handler (connection)
422      (let ((client (connection.socket-io connection)))
423        (labels ((process-available-input (fn)
424                   (loop do (funcall fn)
425                         while (listen client)))
426                 (handler ()
427                   (cond ((null *swank-state-stack*)
428                          (with-reader-error-handler (connection)
429                            (process-available-input #'handle-request)))
430                         ((eq (car *swank-state-stack*) :read-next-form))
431                         (t (process-available-input #'read-from-emacs)))))
432          (handler)
433          (add-input-handler client #'handler))))
434    
435    (defun remove-sigio-handler (connection)
436      (remove-input-handlers (connection.socket-io connection)))
437    
438    (defun simple-serve-requests (connection)
439      (let ((socket-io (connection.socket-io connection)))
440        (encode-message '(:use-sigint-for-interrupt) socket-io)
441        (with-reader-error-handler (connection)
442          (loop (handle-request)))))
443    
444    (defun read-from-socket-io ()
445      (let ((event (decode-message (current-socket-io))))
446        (log-event "DISPATCHING: ~S~%" event)
447        (destructure-case event
448          ((:emacs-rex string package thread id)
449           `(eval-string ,string ,package ,id))
450          ((:emacs-interrupt thread)
451           '(simple-break))
452          ((:emacs-return-string thread tag string)
453           `(take-input ,tag ,string)))))
454    
455    (defun send-to-socket-io (event)
456      (log-event "DISPATCHING: ~S~%" event)
457      (flet ((send (o) (encode-message o (current-socket-io))))
458        (destructure-case event
459          (((:debug :debug-return :read-string :read-aborted) thread &rest args)
460           (declare (ignore thread))
461           (send `(,(car event) 0 ,@args)))
462          ((:return thread &rest args)
463           (declare (ignore thread))
464           (send `(:return ,@args)))
465          (((:read-output :new-package :new-features :ed :debug-condition)
466            &rest _)
467           (declare (ignore _))
468           (send event)))))
469    
470    
471  ;;;; IO to Emacs  ;;;; IO to Emacs
472  ;;;  ;;;
# Line 318  determined at compile time." Line 489  determined at compile time."
489           (*terminal-io* io))           (*terminal-io* io))
490      (funcall function)))      (funcall function)))
491    
 (defun current-connection ()  
   (cond ((and *dispatching-connection*  
               ;; In SBCL new threads inherit the dynamic bindings of  
               ;; their parent. That means the *dispatching-connection*  
               ;; when the thread is created (e.g. from SLIME REPL)  
               ;; will be visible to the new thread, even though it's  
               ;; not the owner and mustn't use it. Must ask Dan all  
               ;; about this. -luke (15/Jan/2004)  
               #+SBCL (equal (thread-id) (connection.owner-id *dispatching-connection*)))  
          *dispatching-connection*)  
         ((equal (thread-id) *main-thread-id*)  
          *main-connection*)  
         (t nil)))  
   
 (defun current-socket-io ()  
   (connection.socket-io (current-connection)))  
   
 (defmacro with-a-connection ((&rest ignore) &body body)  
   "Execute BODY with a connection.  
 If no connection is currently available then a new one is  
 temporarily created for the extent of the execution.  
   
 Thus the BODY forms can call READ-FROM-EMACS and SEND-TO-EMACS."  
   (declare (ignore ignore))  
   `(if (current-connection)  
        (progn ,@body)  
        (call-with-aux-connection (lambda () ,@body))))  
   
 (defun call-with-aux-connection (fn)  
   (let* ((c (open-aux-connection))  
          (*dispatching-connection* c))  
     (unwind-protect (funcall fn)  
       (close-connection c))))  
   
 (defun close-connection (c)  
   (close (connection.socket-io c))  
   (when (connection.dedicated-output c)  
     (close (connection.dedicated-output c))))  
   
 (defun open-aux-connection ()  
   (let* ((socket (create-socket 0))  
          (port (local-port socket)))  
     (send-to-emacs `(:open-aux-connection ,port)  
                    (connection.socket-io *main-connection*))  
     (create-connection (accept-connection socket))))  
   
 (defun announce-aux-server (port)  
   (send-to-emacs `(:open-aux-connection ,port)  
                  (connection.socket-io *main-connection*)))  
   
 (defvar *log-events* nil)  
   
492  (defun log-event (format-string &rest args)  (defun log-event (format-string &rest args)
493    "Write a message to *terminal-io* when *log-events* is non-nil.    "Write a message to *terminal-io* when *log-events* is non-nil.
494  Useful for low level debugging."  Useful for low level debugging."
495    (when *log-events*    (when *log-events*
496      (apply #'format *terminal-io* format-string args)))      (apply #'format *terminal-io* format-string args)))
497    
498  (defun read-from-emacs (&optional (stream (current-socket-io)))  (defun read-from-emacs ()
499    "Read and process a request from Emacs."    "Read and process a request from Emacs."
500    (let ((form (read-next-form stream)))    (apply #'funcall (funcall (connection.read *emacs-connection*))))
     (log-event "READ: ~S~%" form)  
     (apply #'funcall form)))  
501    
502  (defun read-next-form (stream)  (defun read-from-control-thread ()
503      (receive))
504    
505    (defun decode-message (stream)
506    "Read an S-expression from STREAM using the SLIME protocol.    "Read an S-expression from STREAM using the SLIME protocol.
507  If a protocol error occurs then a SLIME-READ-ERROR is signalled."  If a protocol error occurs then a SLIME-READ-ERROR is signalled."
508    (flet ((next-byte () (char-code (read-char stream))))    (let ((*swank-state-stack* (cons :read-next-form *swank-state-stack*)))
509      (handler-case      (flet ((next-byte () (char-code (read-char stream t))))
510          (let* ((length (logior (ash (next-byte) 16)        (handler-case
511                                 (ash (next-byte) 8)            (let* ((length (logior (ash (next-byte) 16)
512                                 (next-byte)))                                   (ash (next-byte) 8)
513                 (string (make-string length))                                   (next-byte)))
514                 (pos (read-sequence string stream)))                   (string (make-string length))
515            (assert (= pos length) ()                   (pos (read-sequence string stream)))
516                    "Short read: length=~D  pos=~D" length pos)              (assert (= pos length) ()
517            (read-form string))                      "Short read: length=~D  pos=~D" length pos)
518        (serious-condition (c)              (let ((form (read-form string)))
519          (error (make-condition 'slime-read-error :condition c))))))                (log-event "READ: ~A~%" string)
520                  form))
521            (serious-condition (c)
522              (error (make-condition 'slime-read-error :condition c)))))))
523    
524  (defun read-form (string)  (defun read-form (string)
525    (with-standard-io-syntax    (with-standard-io-syntax
# Line 412  If a protocol error occurs then a SLIME- Line 535  If a protocol error occurs then a SLIME-
535      (setq *slime-features* *features*)      (setq *slime-features* *features*)
536      (send-to-emacs (list :new-features (mapcar #'symbol-name *features*)))))      (send-to-emacs (list :new-features (mapcar #'symbol-name *features*)))))
537    
538  (defun send-to-emacs (object &optional (output (current-socket-io)))  (defun send-to-emacs (object)
539    "Send OBJECT to over CONNECTION to Emacs."    "Send OBJECT to Emacs."
540    (let* ((string (prin1-to-string-for-emacs object))    (funcall (connection.send *emacs-connection*) object))
          (length (1+ (length string))))  
     (log-event "SEND: ~A~%" string)  
     (with-I/O-lock ()  
       (without-interrupts  
        (loop for position from 16 downto 0 by 8  
              do (write-char (code-char (ldb (byte 8 position) length))  
                             output))  
        (write-string string output)  
        (terpri output)  
        (force-output output)))))  
541    
542  (defun send-oob-to-emacs (object)  (defun send-oob-to-emacs (object)
543    (send-to-emacs object (connection.socket-io *main-connection*)))    (send-to-emacs object))
544    
545    (defun send-to-control-thread (object)
546      (send (connection.control-thread *emacs-connection*) object))
547    
548    (defun encode-message (message stream)
549      (let* ((string (prin1-to-string-for-emacs message))
550             (length (1+ (length string))))
551        (log-event "WRITE: ~A~%" string)
552        (without-interrupts
553         (loop for position from 16 downto 0 by 8
554               do (write-char (code-char (ldb (byte 8 position) length))
555                              stream))
556         (write-string string stream)
557         (terpri stream)
558         (force-output stream))))
559    
560  (defun prin1-to-string-for-emacs (object)  (defun prin1-to-string-for-emacs (object)
561    (with-standard-io-syntax    (with-standard-io-syntax
# Line 437  If a protocol error occurs then a SLIME- Line 565  If a protocol error occurs then a SLIME-
565            (*package* *swank-io-package*))            (*package* *swank-io-package*))
566        (prin1-to-string object))))        (prin1-to-string object))))
567    
568  (defun force-user-output (&optional (connection *dispatching-connection*))  (defun force-user-output ()
569    (assert (connection-p connection))    (force-output (connection.user-io *emacs-connection*))
570    (force-output (connection.user-io connection))    (force-output (connection.user-output *emacs-connection*)))
571    (force-output (connection.user-output connection)))  
572    (defun clear-user-input  ()
573  (defun clear-user-input  (&optional (connection *dispatching-connection*))    (clear-input (connection.user-input *emacs-connection*)))
   (assert (connection-p connection))  
   (clear-input (connection.user-input connection)))  
574    
575  (defun send-output-to-emacs (string socket-io)  (defun send-output-to-emacs (string socket-io)
576    (send-to-emacs `(:read-output ,string) socket-io))    (encode-message `(:read-output ,string) socket-io))
577    
578  (defvar *read-input-catch-tag* 0)  (defvar *read-input-catch-tag* 0)
579    
580  (defun read-user-input-from-emacs (socket-io)  (defun read-user-input-from-emacs ()
581    (let ((*read-input-catch-tag* (1+ *read-input-catch-tag*)))    (let ((*read-input-catch-tag* (1+ *read-input-catch-tag*)))
582      (send-to-emacs `(:read-string ,*read-input-catch-tag*) socket-io)      (send-to-emacs `(:read-string ,(current-thread)
583                         ,*read-input-catch-tag*))
584      (let ((ok nil))      (let ((ok nil))
585        (unwind-protect        (unwind-protect
586             (prog1 (catch *read-input-catch-tag*             (prog1 (catch *read-input-catch-tag*
587                      (loop (read-from-emacs socket-io)))                      (loop (read-from-emacs)))
588               (setq ok t))               (setq ok t))
589          (unless ok          (unless ok
590            (send-to-emacs `(:read-aborted)))))))            (send-to-emacs `(:read-aborted ,(current-thread)
591                               *read-input-catch-tag*)))))))
592    
593  (defslimefun take-input (tag input)  (defslimefun take-input (tag input)
594    (throw tag input))    (throw tag input))
# Line 547  Call LAMBDA-LIST-FN with the symbol corr Line 675  Call LAMBDA-LIST-FN with the symbol corr
675  (defvar *sldb-initial-frames* 20  (defvar *sldb-initial-frames* 20
676    "The initial number of backtrace frames to send to Emacs.")    "The initial number of backtrace frames to send to Emacs.")
677    
   
678  (defun swank-debugger-hook (condition hook)  (defun swank-debugger-hook (condition hook)
679    "Debugger entry point, called from *DEBUGGER-HOOK*.    "Debugger entry point, called from *DEBUGGER-HOOK*.
680  Sends a message to Emacs declaring that the debugger has been entered,  Sends a message to Emacs declaring that the debugger has been entered,
681  then waits to handle further requests from Emacs. Eventually returns  then waits to handle further requests from Emacs. Eventually returns
682  after Emacs causes a restart to be invoked."  after Emacs causes a restart to be invoked."
683    (declare (ignore hook))    (declare (ignore hook))
 ;;  (unless (or *processing-rpc* (not *multiprocessing-enabled*))  
 ;;    (request-async-debug condition))  
684    (let ((*swank-debugger-condition* condition)    (let ((*swank-debugger-condition* condition)
685          (*package* (or (and (boundp '*buffer-package*)          (*package* (or (and (boundp '*buffer-package*)
686                              (symbol-value '*buffer-package*))                              (symbol-value '*buffer-package*))
687                         *package*)))                         *package*))
688      (let ((*sldb-level* (1+ *sldb-level*)))          (*sldb-level* (1+ *sldb-level*))
689            (*swank-state-stack* (cons :swank-debugger-hook *swank-state-stack*)))
690        (force-user-output)        (force-user-output)
691        (call-with-debugging-environment        (call-with-debugging-environment
692         (lambda () (sldb-loop *sldb-level*))))))         (lambda () (sldb-loop *sldb-level*)))))
   
 (defun slime-debugger-function ()  
   "Returns a function suitable for use as the value of *DEBUGGER-HOOK*  
 or SB-DEBUG::*INVOKE-DEBUGGER-HOOK*, to install the SLIME debugger  
 globally.  Must be run from the *slime-repl* buffer or somewhere else  
 that the slime streams are visible so that it can capture them."  
   (let ((package *buffer-package*))  
     (labels ((slime-debug (c &optional next)  
                (let ((*buffer-package* package))  
                  ;; check emacs is still there: don't want to end up  
                  ;; in recursive debugger loops if it's disconnected  
                  (when (open-stream-p (connection.socket-io *main-connection*))  
                    (with-a-connection ()  
                      (with-io-redirection ()  
                        (swank-debugger-hook c next)))))))  
       #'slime-debug)))  
   
 (defslimefun install-global-debugger-hook ()  
   (setq *debugger-hook-passback* (slime-debugger-function))  
   t)  
   
 (defun startup-multiprocessing-for-emacs ()  
   (setq *multiprocessing-enabled* t)  
   (startup-multiprocessing))  
693    
694  (defun sldb-loop (level)  (defun sldb-loop (level)
695    (unwind-protect    (unwind-protect
696         (loop (catch 'sldb-loop-catcher         (loop (catch 'sldb-loop-catcher
697                 (with-simple-restart                 (with-simple-restart (abort "Return to sldb level ~D." level)
698                     (abort "Return to sldb level ~D." level)                   (send-to-emacs
699                   (send-to-emacs (list* :debug *sldb-level*                    (list* :debug
700                                         (debugger-info-for-emacs 0                           (current-thread)
701                                                                  *sldb-initial-frames*)))                           *sldb-level*
702                             (debugger-info-for-emacs 0 *sldb-initial-frames*)))
703                   (handler-bind ((sldb-condition #'handle-sldb-condition))                   (handler-bind ((sldb-condition #'handle-sldb-condition))
704                     (read-from-emacs)))))                     (read-from-emacs)))))
705      (send-to-emacs `(:debug-return ,level))))      (send-to-emacs `(:debug-return ,(current-thread) ,level))))
706    
707  (defun handle-sldb-condition (condition)  (defun handle-sldb-condition (condition)
708    "Handle an internal debugger condition.    "Handle an internal debugger condition.
# Line 664  has changed, ignore the request." Line 767  has changed, ignore the request."
767  (defun eval-in-emacs (form)  (defun eval-in-emacs (form)
768    "Execute FROM in Emacs."    "Execute FROM in Emacs."
769    (destructuring-bind (fn &rest args) form    (destructuring-bind (fn &rest args) form
770      (swank::send-to-emacs      (send-to-emacs `(:%apply ,(string-downcase (string fn)) ,args))))
      `(:%apply ,(string-downcase (string fn)) ,args))))  
771    
772  (defslimefun eval-string (string buffer-package id)  (defslimefun eval-string (string buffer-package id)
773    (let ((*processing-rpc* t)    (let ((*debugger-hook* #'swank-debugger-hook))
         (*debugger-hook* #'swank-debugger-hook))  
774      (let (ok result)      (let (ok result)
775        (unwind-protect        (unwind-protect
776             (let ((*buffer-package* (guess-package-from-string buffer-package)))             (let ((*buffer-package* (guess-package-from-string buffer-package))
777                     (*swank-state-stack* (cons :eval-string *swank-state-stack*)))
778               (assert (packagep *buffer-package*))               (assert (packagep *buffer-package*))
779               (setq result (eval (read-form string)))               (setq result (eval (read-form string)))
780               (force-output)               (force-output)
781               (setq ok t))               (setq ok t))
782          (sync-state-to-emacs)          (sync-state-to-emacs)
783          (force-user-output)          (force-user-output)
784          (send-to-emacs `(:return ,(if ok `(:ok ,result) '(:abort)) ,id)))))          (send-to-emacs `(:return ,(current-thread)
785    (when *debugger-hook-passback*                           ,(if ok `(:ok ,result) '(:abort))
786      (setq *debugger-hook* *debugger-hook-passback*)                           ,id))))))
     (setq *debugger-hook-passback* nil)))  
787    
788  (defslimefun oneway-eval-string (string buffer-package)  (defslimefun oneway-eval-string (string buffer-package)
789    "Evaluate STRING in BUFFER-PACKAGE, without sending a reply.    "Evaluate STRING in BUFFER-PACKAGE, without sending a reply.

Legend:
Removed from v.1.109.2.1  
changed lines
  Added in v.1.109.2.2

  ViewVC Help
Powered by ViewVC 1.1.5