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

Diff of /slime/swank.lisp

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

revision 1.565 by heller, Mon Aug 11 07:39:29 2008 UTC revision 1.566 by heller, Mon Aug 11 17:41:55 2008 UTC
# Line 236  Backend code should treat the connection Line 236  Backend code should treat the connection
236    ;; The communication style used.    ;; The communication style used.
237    (communication-style nil :type (member nil :spawn :sigio :fd-handler))    (communication-style nil :type (member nil :spawn :sigio :fd-handler))
238    ;; The coding system for network streams.    ;; The coding system for network streams.
239    (coding-system ))    coding-system
240      ;; The SIGINT handler we should restore when the connection is
241      ;; closed.
242      saved-sigint-handler)
243    
244  (defun print-connection (conn stream depth)  (defun print-connection (conn stream depth)
245    (declare (ignore depth))    (declare (ignore depth))
# Line 317  Do not set this to T unless you want to Line 320  Do not set this to T unless you want to
320    
321  ;;;;; Helper macros  ;;;;; Helper macros
322    
323    (defvar *slime-interrupts-enabled*)
324    
325    (defmacro with-slime-interrupts (&body body)
326      `(progn
327         (check-slime-interrupts)
328         (let ((*slime-interrupts-enabled* t)
329               (*pending-slime-interrupts* '()))
330           (multiple-value-prog1 (progn ,@body)
331             (check-slime-interrupts)))))
332    
333    (defmacro without-slime-interrupts (&body body)
334      `(progn
335         (check-slime-interrupts)
336         (let ((*slime-interrupts-enabled* nil)
337               (*pending-slime-interrupts* '()))
338           (multiple-value-prog1 (progn ,@body)
339             (check-slime-interrupts)))))
340    
341    (defun invoke-or-queue-interrupt (function)
342      (cond ((not (boundp '*slime-interrupts-enabled*))
343             (without-slime-interrupts
344               (funcall function)))
345            (*slime-interrupts-enabled*
346             (funcall function))
347            ((cdr *pending-slime-interrupts*)
348             (simple-break "Two many queued interrupts"))
349            (t
350             (push function *pending-slime-interrupts*))))
351    
352    (defslimefun simple-break (&optional (datum "Interrupt from Emacs") &rest args)
353      (with-simple-restart (continue "Continue from break.")
354        (invoke-slime-debugger (coerce-to-condition datum args))))
355    
356    (defun coerce-to-condition (datum args)
357      (etypecase datum
358        (string (make-condition 'simple-error :format-control datum
359                                :format-arguments args))
360        (symbol (apply #'make-condition datum args))))
361    
362  (defmacro with-io-redirection ((connection) &body body)  (defmacro with-io-redirection ((connection) &body body)
363    "Execute BODY I/O redirection to CONNECTION.    "Execute BODY I/O redirection to CONNECTION.
364  If *REDIRECT-IO* is true then all standard I/O streams are redirected."  If *REDIRECT-IO* is true then all standard I/O streams are redirected."
# Line 333  If *REDIRECT-IO* is true then all standa Line 375  If *REDIRECT-IO* is true then all standa
375    
376  (defun call-with-connection (connection function)  (defun call-with-connection (connection function)
377    (let ((*emacs-connection* connection))    (let ((*emacs-connection* connection))
378      (with-swank-error-handler (*emacs-connection*)      (without-slime-interrupts
379        (with-io-redirection (*emacs-connection*)        (with-swank-error-handler (*emacs-connection*)
380          (call-with-debugger-hook #'swank-debugger-hook function)))))          (with-io-redirection (*emacs-connection*)
381              (call-with-debugger-hook #'swank-debugger-hook function))))))
382    
383  (defmacro without-interrupts (&body body)  (defmacro without-interrupts (&body body)
384    `(call-without-interrupts (lambda () ,@body)))    `(call-without-interrupts (lambda () ,@body)))
# Line 869  The processing is done in the extent of Line 912  The processing is done in the extent of
912    (connection.socket-io *emacs-connection*))    (connection.socket-io *emacs-connection*))
913    
914  (defun close-connection (c condition backtrace)  (defun close-connection (c condition backtrace)
915      (let ((*debugger-hook* nil))
916    (format *log-output* "~&;; swank:close-connection: ~A~%" condition)    (format *log-output* "~&;; swank:close-connection: ~A~%" condition)
917    (let ((cleanup (connection.cleanup c)))    (let ((cleanup (connection.cleanup c)))
918      (when cleanup      (when cleanup
# Line 894  The processing is done in the extent of Line 938  The processing is done in the extent of
938              (ignore-errors (stream-external-format (connection.socket-io c)))              (ignore-errors (stream-external-format (connection.socket-io c)))
939              (connection.communication-style c)              (connection.communication-style c)
940              *use-dedicated-output-stream*)              *use-dedicated-output-stream*)
941      (finish-output *log-output*)))      (finish-output *log-output*))))
   
 (defvar *slime-interrupts-enabled*)  
   
 (defmacro with-slime-interrupts (&body body)  
   `(progn  
      (check-slime-interrupts)  
      (let ((*slime-interrupts-enabled* t)  
            (*pending-slime-interrupts* '()))  
        (multiple-value-prog1 (progn ,@body)  
          (check-slime-interrupts)))))  
   
 (defmacro without-slime-interrupts (&body body)  
   `(progn  
      (check-slime-interrupts)  
      (let ((*slime-interrupts-enabled* nil)  
            (*pending-slime-interrupts* '()))  
        (multiple-value-prog1 (progn ,@body)  
          (check-slime-interrupts)))))  
   
 (defun invoke-or-queue-interrupt (function)  
   (cond ((not (boundp '*slime-interrupts-enabled*))  
          (without-slime-interrupts  
            (funcall function)))  
         (*slime-interrupts-enabled*  
          (funcall function))  
         ((cdr *pending-slime-interrupts*)  
          (simple-break "Two many queued interrupts"))  
         (t  
          (push function *pending-slime-interrupts*))))  
942    
 (defslimefun simple-break (&optional (fstring "Interrupt from Emacs")  
                                      &rest args)  
   (call-with-debugger-hook  
    #'swank-debugger-hook  
    (lambda ()  
      (cerror "Return from break." "~?" fstring args))))  
943    
944  ;;;;;; Thread based communication  ;;;;;; Thread based communication
945    
# Line 1033  The processing is done in the extent of Line 1042  The processing is done in the extent of
1042       (declare (ignore _))       (declare (ignore _))
1043       (encode-message event (current-socket-io)))       (encode-message event (current-socket-io)))
1044      (((:emacs-pong :emacs-return :emacs-return-string) thread-id &rest args)      (((:emacs-pong :emacs-return :emacs-return-string) thread-id &rest args)
1045       (send-event (find-thread thread-id) (cons (car event) args)))))       (send-event (find-thread thread-id) (cons (car event) args)))
1046        (((:end-of-stream))
1047         (close-connection *emacs-connection* nil (safe-backtrace)))))
1048    
1049  (defvar *event-queue* '())  (defvar *event-queue* '())
1050    
# Line 1048  The processing is done in the extent of Line 1059  The processing is done in the extent of
1059    
1060  (defun send-to-emacs (event)  (defun send-to-emacs (event)
1061    "Send EVENT to Emacs."    "Send EVENT to Emacs."
1062      ;;(log-event "send-to-emacs: ~a" event)
1063    (cond ((use-threads-p)    (cond ((use-threads-p)
1064           (send (connection.control-thread *emacs-connection*) event))           (send (connection.control-thread *emacs-connection*) event))
1065          (t (dispatch-event event))))          (t (dispatch-event event))))
# Line 1068  The processing is done in the extent of Line 1080  The processing is done in the extent of
1080  (defun wait-for-event/event-loop (pattern timeout)  (defun wait-for-event/event-loop (pattern timeout)
1081    (assert (or (not timeout) (eq timeout t)))    (assert (or (not timeout) (eq timeout t)))
1082    (loop    (loop
1083       (check-slime-interrupts)
1084     (let ((tail (member-if (lambda (e) (event-match-p e pattern))     (let ((tail (member-if (lambda (e) (event-match-p e pattern))
1085                            *event-queue*)))                            *event-queue*)))
1086       (when tail       (when tail
# Line 1119  The processing is done in the extent of Line 1132  The processing is done in the extent of
1132  ;;;;;; Signal driven IO  ;;;;;; Signal driven IO
1133    
1134  (defun install-sigio-handler (connection)  (defun install-sigio-handler (connection)
1135    (let ((client (connection.socket-io connection)))    (add-sigio-handler (connection.socket-io connection)
1136      (flet ((handler ()                       (lambda () (process-io-interrupt connection)))
1137               (cond ((null *swank-state-stack*)    (handle-or-process-requests connection))
1138                      (handle-requests connection t))  
1139                     ((eq (car *swank-state-stack*) :read-next-form))  (defun process-io-interrupt (connection)
1140                     (t (process-requests t nil)))))    (log-event "process-io-interrupt~%")
1141        (add-sigio-handler client #'handler)    (invoke-or-queue-interrupt
1142        (handler))))     (lambda () (handle-or-process-requests connection))))
1143    
1144    (defun handle-or-process-requests (connection)
1145      (log-event "handle-or-process-requests: ~a~%" *swank-state-stack*)
1146      (cond ((null *swank-state-stack*)
1147             (handle-requests connection t))
1148            ((eq (car *swank-state-stack*) :read-next-form))
1149            (t (process-requests t nil))))
1150    
1151  (defun deinstall-sigio-handler (connection)  (defun deinstall-sigio-handler (connection)
1152    (remove-sigio-handlers (connection.socket-io connection)))    (log-event "deinstall-sigio-handler...~%")
1153      (remove-sigio-handlers (connection.socket-io connection))
1154      (log-event "deinstall-sigio-handler...done~%"))
1155    
1156  ;;;;;; SERVE-EVENT based IO  ;;;;;; SERVE-EVENT based IO
1157    
1158  (defun install-fd-handler (connection)  (defun install-fd-handler (connection)
1159    (let ((client (connection.socket-io connection)))    (add-fd-handler (connection.socket-io connection)
1160      (flet ((handler ()                    (lambda () (handle-or-process-requests connection)))
1161               (cond ((null *swank-state-stack*)    (setf (connection.saved-sigint-handler connection)
1162                      (handle-requests connection t))          (install-sigint-handler (lambda () (process-io-interrupt connection))))
1163                     ((eq (car *swank-state-stack*) :read-next-form))    (handle-or-process-requests connection))
                    (t (process-requests t nil)))))  
       ;;;; handle sigint  
       ;;(install-debugger-globally  
       ;; (lambda (c h)  
       ;;   (with-reader-error-handler (connection)  
       ;;     (block debugger  
       ;;       (with-connection (connection)  
       ;;         (swank-debugger-hook c h)  
       ;;         (return-from debugger))  
       ;;       (abort)))))  
       (add-fd-handler client #'handler)  
       (handler))))  
1164    
1165  (defun deinstall-fd-handler (connection)  (defun deinstall-fd-handler (connection)
1166    (remove-fd-handlers (connection.socket-io connection)))    (remove-fd-handlers (connection.socket-io connection))
1167      (install-sigint-handler (connection.saved-sigint-handler connection)))
1168    
1169  ;;;;;; Simple sequential IO  ;;;;;; Simple sequential IO
1170    
1171  (defun simple-serve-requests (connection)  (defun simple-serve-requests (connection)
1172    (unwind-protect    (unwind-protect
1173         (with-simple-restart (close-connection "Close SLIME connection")         (call-with-user-break-handler
1174           (handle-requests connection))          (lambda () (process-io-interrupt connection))
1175            (lambda ()
1176              (with-simple-restart (close-connection "Close SLIME connection")
1177                (handle-requests connection))))
1178      (close-connection connection nil (safe-backtrace))))      (close-connection connection nil (safe-backtrace))))
1179    
1180  (defun initialize-streams-for-connection (connection)  (defun initialize-streams-for-connection (connection)
# Line 1390  NIL if streams are not globally redirect Line 1404  NIL if streams are not globally redirect
1404  (defun decode-message (stream &optional timeout)  (defun decode-message (stream &optional timeout)
1405    "Read an S-expression from STREAM using the SLIME protocol."    "Read an S-expression from STREAM using the SLIME protocol."
1406    (assert (or (not timeout) (eq timeout t)))    (assert (or (not timeout) (eq timeout t)))
1407    (when (and (eq timeout t) (not (input-available-p stream)))    ;;(log-event "decode-message~%")
     (return-from decode-message (values nil t)))  
1408    (let ((*swank-state-stack* (cons :read-next-form *swank-state-stack*)))    (let ((*swank-state-stack* (cons :read-next-form *swank-state-stack*)))
1409      (handler-bind ((error (lambda (c) (error (make-swank-error c)))))      (handler-bind ((error (lambda (c) (error (make-swank-error c)))))
1410        (let* ((length (decode-message-length stream))        (let ((c (read-char-no-hang stream nil)))
1411               (string (make-string length))          (cond ((and (not c) timeout) (values nil t))
1412               (pos (read-sequence string stream)))                (t
1413          (assert (= pos length) ()                 (and c (unread-char c stream))
1414                  "Short read: length=~D  pos=~D" length pos)                 (values (read-form (read-packet stream)) nil)))))))
1415          (log-event "READ: ~S~%" string)  
1416          (values (read-form string) nil)))))  (defun read-packet (stream)
1417      (peek-char nil stream) ; wait while queuing interrupts
1418  (defun decode-message-length (stream)    (check-slime-interrupts)
1419    (let ((buffer (make-string 6)))    (let* ((header (read-chunk stream 6))
1420      (dotimes (i 6)           (length (parse-integer header :radix #x10))
1421        (setf (aref buffer i) (read-char stream)))           (payload (read-chunk stream length)))
1422      (parse-integer buffer :radix #x10)))      (log-event "READ: ~S~%" payload)
1423        payload))
1424    
1425    (defun read-chunk (stream length)
1426      (let* ((buffer (make-string length))
1427             (count (read-sequence buffer stream)))
1428        (assert (= count length) () "Short read: length=~D  count=~D" length count)
1429        buffer))
1430    
1431  (defun read-form (string)  (defun read-form (string)
1432    (with-standard-io-syntax    (with-standard-io-syntax

Legend:
Removed from v.1.565  
changed lines
  Added in v.1.566

  ViewVC Help
Powered by ViewVC 1.1.5