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

Diff of /slime/swank.lisp

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

revision 1.133 by heller, Wed Mar 3 08:51:24 2004 UTC revision 1.134 by heller, Wed Mar 3 20:52:40 2004 UTC
# Line 75  Line 75 
75    (user-output      nil :type (or stream null))    (user-output      nil :type (or stream null))
76    (user-io          nil :type (or stream null))    (user-io          nil :type (or stream null))
77    ;;    ;;
78    (control-thread   nil :read-only t)    control-thread
79    (reader-thread    nil :read-only t)    reader-thread
80    (read             (missing-arg) :type function)    (read             (missing-arg) :type function)
81    (send             (missing-arg) :type function)    (send             (missing-arg) :type function)
82    (serve-requests   (missing-arg) :type function)    (serve-requests   (missing-arg) :type function)
# Line 108  and to detect situations where interrupt Line 108  and to detect situations where interrupt
108    
109  ;;;; Helper macros  ;;;; Helper macros
110    
111  (defmacro with-io-redirection ((&rest ignore) &body body)  (defmacro with-io-redirection ((connection) &body body)
112    "Execute BODY with I/O redirection to CONNECTION.    "Execute BODY with I/O redirection to CONNECTION.
113  If *REDIRECT-IO* is true, all standard I/O streams are redirected."  If *REDIRECT-IO* is true, all standard I/O streams are redirected."
   (declare (ignore ignore))  
114    `(if *redirect-io*    `(if *redirect-io*
115         (call-with-redirected-io *emacs-connection* (lambda () ,@body))         (call-with-redirected-io ,connection (lambda () ,@body))
116         (progn ,@body)))         (progn ,@body)))
117    
118  (defmacro without-interrupts (&body body)  (defmacro without-interrupts (&body body)
# Line 195  Redirection is done while Lisp is proces Line 194  Redirection is done while Lisp is proces
194    (funcall (connection.serve-requests connection) connection))    (funcall (connection.serve-requests connection) connection))
195    
196  (defun init-emacs-connection (connection)  (defun init-emacs-connection (connection)
197    (setq *emacs-connection* connection)    (declare (ignore connection))
198    (emacs-connected))    (emacs-connected))
199    
200  (defun announce-server-port (file port)  (defun announce-server-port (file port)
# Line 245  This is an optimized way for Lisp to del Line 244  This is an optimized way for Lisp to del
244      (encode-message `(:open-dedicated-output-stream ,port) socket-io)      (encode-message `(:open-dedicated-output-stream ,port) socket-io)
245      (accept-connection socket)))      (accept-connection socket)))
246    
247  (defun handle-request ()  (defmacro with-connection ((connection) &body body)
248      "Execute BODY in the context of CONNECTION."
249      `(let ((*emacs-connection* ,connection))
250        (catch 'slime-toplevel
251          (with-simple-restart (abort "Return to SLIME toplevel.")
252            (with-io-redirection (connection)
253              (let ((*debugger-hook* #'swank-debugger-hook))
254                ,@body))))))
255    
256    (defun handle-request (connection)
257    "Read and process one request.  The processing is done in the extend    "Read and process one request.  The processing is done in the extend
258  of the toplevel restart."  of the toplevel restart."
259    (assert (null *swank-state-stack*))    (assert (null *swank-state-stack*))
260    (let ((*swank-state-stack* '(:handle-request)))    (let ((*swank-state-stack* '(:handle-request)))
261      (catch 'slime-toplevel      (with-connection (connection)
262        (with-simple-restart (abort "Return to SLIME toplevel.")        (read-from-emacs))))
         (with-io-redirection ()  
           (let ((*debugger-hook* #'swank-debugger-hook))  
             (read-from-emacs)))))))  
263    
264  (defun changelog-date ()  (defun changelog-date ()
265    "Return the datestring of the latest ChangeLog entry.  The date is    "Return the datestring of the latest ChangeLog entry.  The date is
# Line 287  determined at compile time." Line 292  determined at compile time."
292    `(handler-case (progn ,@body)    `(handler-case (progn ,@body)
293      (slime-read-error (e) (close-connection ,connection e))))      (slime-read-error (e) (close-connection ,connection e))))
294    
295  (defun read-loop (control-thread input-stream)  (defun read-loop (control-thread input-stream connection)
296    (with-reader-error-handler (*emacs-connection*)    (with-reader-error-handler (connection)
297      (loop (send control-thread (decode-message input-stream)))))      (loop (send control-thread (decode-message input-stream)))))
298    
299  (defvar *active-threads* '())  (defvar *active-threads* '())
# Line 330  element." Line 335  element."
335            (noerror nil)            (noerror nil)
336            (t (error "Thread id not found ~S" id)))))            (t (error "Thread id not found ~S" id)))))
337    
338  (defun dispatch-loop (socket-io)  (defun dispatch-loop (socket-io connection)
339    (setq *active-threads* '())    (let ((*emacs-connection* connection)
340    (setq *thread-counter* 0)          (*active-threads* '())
341    (loop (with-simple-restart (abort "Retstart dispatch loop.")          (*thread-counter* 0))
342            (loop (dispatch-event (receive) socket-io)))))      (loop (with-simple-restart (abort "Retstart dispatch loop.")
343                (loop (dispatch-event (receive) socket-io))))))
344    
345  (defun simple-break ()  (defun simple-break ()
346    (with-simple-restart  (continue "Continue from interrupt.")    (with-simple-restart  (continue "Continue from interrupt.")
# Line 354  element." Line 360  element."
360    (destructure-case event    (destructure-case event
361      ((:emacs-rex string package thread id)      ((:emacs-rex string package thread id)
362       (let ((thread (etypecase thread       (let ((thread (etypecase thread
363                       ((member t) (spawn #'handle-request :name "worker"))                       ((member t)
364                          (let ((c *emacs-connection*))
365                            (spawn (lambda () (handle-request c))
366                                   :name "worker")))
367                       (fixnum (lookup-thread-id thread)))))                       (fixnum (lookup-thread-id thread)))))
368         (send thread `(eval-string ,string ,package ,id))         (send thread `(eval-string ,string ,package ,id))
369         (add-thread thread)))         (add-thread thread)))
# Line 382  element." Line 391  element."
391    (multiple-value-bind (dedicated in out io) (open-streams socket-io)    (multiple-value-bind (dedicated in out io) (open-streams socket-io)
392      (ecase style      (ecase style
393        (:spawn        (:spawn
394         (let* ((control-thread (spawn (lambda () (dispatch-loop socket-io))         (let ((connection
395                                       :name "control-thread"))                (make-connection :socket-io socket-io :dedicated-output dedicated
396                (reader-thread (spawn (lambda ()                                 :user-input in :user-output out :user-io io
397                                        (read-loop control-thread socket-io))                                 :read #'read-from-control-thread
398                                      :name "reader-thread")))                                 :send #'send-to-control-thread
399           (make-connection :socket-io socket-io :dedicated-output dedicated                                 :serve-requests (lambda (c) c))))
400                            :user-input in :user-output out :user-io io           (let ((control-thread (spawn (lambda ()
401                            :control-thread control-thread                                          (dispatch-loop socket-io connection))
402                            :reader-thread reader-thread                                        :name "control-thread")))
403                            :read #'read-from-control-thread             (setf (connection.control-thread connection) control-thread)
404                            :send #'send-to-control-thread             (let ((reader-thread (spawn (lambda ()
405                            :serve-requests (lambda (c) c))))                                           (read-loop control-thread
406                                                        socket-io
407                                                        connection))
408                                           :name "reader-thread")))
409                 (setf (connection.reader-thread connection) reader-thread)
410                 connection))))
411        (:sigio        (:sigio
412         (make-connection :socket-io socket-io :dedicated-output dedicated         (make-connection :socket-io socket-io :dedicated-output dedicated
413                          :user-input in :user-output out :user-io io                          :user-input in :user-output out :user-io io
# Line 424  element." Line 438  element."
438    
439  (defun install-sigio-handler (connection)  (defun install-sigio-handler (connection)
440    (let ((client (connection.socket-io connection)))    (let ((client (connection.socket-io connection)))
441      (flet ((handler ()      (flet ((handler ()
442               (cond ((null *swank-state-stack*)               (cond ((null *swank-state-stack*)
443                      (with-reader-error-handler (connection)                      (with-reader-error-handler (connection)
444                        (process-available-input client #'handle-request)))                        (process-available-input
445                     ((eq (car *swank-state-stack*) :read-next-form))                         client (lambda () (handle-request connection)))))
446                     (t (process-available-input client #'read-from-emacs)))))                     ((eq (car *swank-state-stack*) :read-next-form))
447                       (t (process-available-input client #'read-from-emacs)))))
448        (add-sigio-handler client #'handler)        (add-sigio-handler client #'handler)
449        (handler))))        (handler))))
450    
# Line 441  element." Line 456  element."
456  (defun install-fd-handler (connection)  (defun install-fd-handler (connection)
457    (let ((client (connection.socket-io connection)))    (let ((client (connection.socket-io connection)))
458      (flet ((handler ()      (flet ((handler ()
459               (cond ((null *swank-state-stack*)               (cond ((null *swank-state-stack*)
460                      (with-reader-error-handler (connection)                      (with-reader-error-handler (connection)
461                        (process-available-input client #'handle-request)))                        (process-available-input
462                     ((eq (car *swank-state-stack*) :read-next-form))                         client (lambda () (handle-request connection)))))
463                     (t (process-available-input client #'read-from-emacs)))))                     ((eq (car *swank-state-stack*) :read-next-form))
464                       (t (process-available-input client #'read-from-emacs)))))
465        (encode-message '(:use-sigint-for-interrupt) client)        (encode-message '(:use-sigint-for-interrupt) client)
466        (setq *debugger-hook*        (setq *debugger-hook*
467              (lambda (c h)              (lambda (c h)
468                (with-reader-error-handler (connection)                (with-reader-error-handler (connection)
469                  (block debugger                  (block debugger
470                    (catch 'slime-toplevel                    (with-connection (connection)
471                      (swank-debugger-hook c h)                      (swank-debugger-hook c h)
472                      (return-from debugger))                      (return-from debugger))
473                    (abort)))))                    (abort)))))
# Line 467  element." Line 483  element."
483    (let ((socket-io (connection.socket-io connection)))    (let ((socket-io (connection.socket-io connection)))
484      (encode-message '(:use-sigint-for-interrupt) socket-io)      (encode-message '(:use-sigint-for-interrupt) socket-io)
485      (with-reader-error-handler (connection)      (with-reader-error-handler (connection)
486        (loop (handle-request)))))        (loop (handle-request connection)))))
487    
488  (defun read-from-socket-io ()  (defun read-from-socket-io ()
489    (let ((event (decode-message (current-socket-io))))    (let ((event (decode-message (current-socket-io))))
# Line 1526  a time.") Line 1542  a time.")
1542    (setq *thread-list* nil))    (setq *thread-list* nil))
1543    
1544  (defun lookup-thread-by-id (id)  (defun lookup-thread-by-id (id)
1545    (nth id (all-threads)))    (nth id *thread-list*))
1546    
1547  (defun debug-thread (thread-id)  (defun debug-thread (thread-id)
1548    (interrupt-thread (lookup-thread-by-id thread-id)    (let ((connection *emacs-connection*))
1549                      (let ((pack *package*))      (interrupt-thread (lookup-thread-by-id thread-id)
1550                        (lambda ()                        (lambda ()
1551                          (catch 'slime-toplevel                          (with-connection (connection)
1552                            (let ((*debugger-hook* (lambda (c h)                            (simple-break))))))
                                                    (declare (ignore h))  
                                                    ;; cut 'n paste from swank-debugger-hook  
                                                    (let ((*swank-debugger-condition* c)  
                                                          (*buffer-package* pack)  
                                                          (*package* pack)  
                                                          (*sldb-level* (1+ *sldb-level*))  
                                                          (*swank-state-stack* (cons :swank-debugger-hook *swank-state-stack*)))  
                                                      (force-user-output)  
                                                      (call-with-debugging-environment  
                                                       (lambda () (sldb-loop *sldb-level*)))))))  
                             (restart-case  
                                 (error (make-condition 'simple-error  
                                                        :format-control "Interrupt from Emacs"))  
                               (un-interrupt ()  
                                 :report "Abandon control of this thread."  
                                 nil))))))))  
1553    
1554  ;;; Local Variables:  ;;; Local Variables:
1555  ;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)"  (1 font-lock-keyword-face) (2 font-lock-function-name-face))))  ;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)"  (1 font-lock-keyword-face) (2 font-lock-function-name-face))))

Legend:
Removed from v.1.133  
changed lines
  Added in v.1.134

  ViewVC Help
Powered by ViewVC 1.1.5