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

Diff of /slime/swank.lisp

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

revision 1.587 by heller, Sun Sep 14 17:10:34 2008 UTC revision 1.588 by heller, Mon Sep 15 08:26:41 2008 UTC
# Line 340  Do not set this to T unless you want to Line 340  Do not set this to T unless you want to
340    
341  ;;;;; Helper macros  ;;;;; Helper macros
342    
343    ;; If true execute interrupts, otherwise queue them.
344    ;; Note: `with-connection' binds *pending-slime-interrupts*.
345  (defvar *slime-interrupts-enabled*)  (defvar *slime-interrupts-enabled*)
346    
347  (defmacro with-slime-interrupts (&body body)  (defmacro with-interrupts-enabled% (flag body)
348    `(progn    `(progn
349       (check-slime-interrupts)       (check-slime-interrupts)
350       (multiple-value-prog1       (multiple-value-prog1
351           (let ((*slime-interrupts-enabled* t))           (let ((*slime-interrupts-enabled* ,flag))
352             ,@body)             ,@body)
353         (check-slime-interrupts))))         (check-slime-interrupts))))
354    
355    (defmacro with-slime-interrupts (&body body)
356      `(with-interrupts-enabled% t ,body))
357    
358  (defmacro without-slime-interrupts (&body body)  (defmacro without-slime-interrupts (&body body)
359    `(progn    `(with-interrupts-enabled% nil ,body))
      (check-slime-interrupts)  
      (multiple-value-prog1  
          (let ((*slime-interrupts-enabled* t))  
            ,@body)  
        (check-slime-interrupts))))  
360    
361  (defun invoke-or-queue-interrupt (function)  (defun invoke-or-queue-interrupt (function)
362    (log-event "invoke-or-queue-interrupt: ~a" function)    (log-event "invoke-or-queue-interrupt: ~a" function)
# Line 401  If *REDIRECT-IO* is true then all standa Line 401  If *REDIRECT-IO* is true then all standa
401  (defun call-with-connection (connection function)  (defun call-with-connection (connection function)
402    (if (eq *emacs-connection* connection)    (if (eq *emacs-connection* connection)
403        (funcall function)        (funcall function)
404        (let ((*emacs-connection* connection))        (let ((*emacs-connection* connection)
405                (*pending-slime-interrupts* '()))
406          (without-slime-interrupts          (without-slime-interrupts
407            (with-swank-error-handler (*emacs-connection*)            (with-swank-error-handler (*emacs-connection*)
408              (with-io-redirection (*emacs-connection*)              (with-io-redirection (*emacs-connection*)
# Line 946  The processing is done in the extent of Line 947  The processing is done in the extent of
947  (defun process-requests (timeout just-one)  (defun process-requests (timeout just-one)
948    "Read and process requests from Emacs."    "Read and process requests from Emacs."
949    (loop    (loop
950     (multiple-value-bind (event timeout?)     (multiple-value-bind (event timeout? interrupt?)
951         (wait-for-event `(:emacs-rex . _) timeout)         (wait-for-event `(:emacs-rex . _) timeout just-one)
952         (when interrupt? (return nil))
953       (when timeout? (return t))       (when timeout? (return t))
954       (apply #'eval-for-emacs (cdr event))       (apply #'eval-for-emacs (cdr event))
955       (when just-one (return nil)))))       (when just-one (return nil)))))
# Line 1117  The processing is done in the extent of Line 1119  The processing is done in the extent of
1119    (cond ((use-threads-p) (interrupt-thread thread interrupt))    (cond ((use-threads-p) (interrupt-thread thread interrupt))
1120          (t (funcall interrupt))))          (t (funcall interrupt))))
1121    
1122  (defun wait-for-event (pattern &optional timeout)  (defun wait-for-event (pattern &optional timeout report-interrupts)
1123    (log-event "wait-for-event: ~s ~s~%" pattern timeout)    (log-event "wait-for-event: ~s ~s~%" pattern timeout)
1124    (without-slime-interrupts    (without-slime-interrupts
1125      (cond ((use-threads-p)      (cond ((use-threads-p)
1126             (receive-if (lambda (e) (event-match-p e pattern)) timeout))             (receive-if (lambda (e) (event-match-p e pattern)) timeout))
1127            (t            (t
1128             (wait-for-event/event-loop pattern timeout)))))             (wait-for-event/event-loop pattern timeout report-interrupts)))))
1129    
1130  (defun wait-for-event/event-loop (pattern timeout)  (defun wait-for-event/event-loop (pattern timeout report-interrupts)
1131    (assert (or (not timeout) (eq timeout t)))    (assert (or (not timeout) (eq timeout t)))
1132    (loop    (loop
1133     (check-slime-interrupts)     (when *pending-slime-interrupts*
1134         (check-slime-interrupts)
1135         (when report-interrupts (return (values nil nil t)))
1136         (when timeout (return (values nil t))))
1137     (let ((event (poll-for-event pattern)))     (let ((event (poll-for-event pattern)))
1138       (when event (return (car event))))       (when event (return (car event))))
1139     (let ((events-enqueued *events-enqueued*)     (let ((events-enqueued *events-enqueued*)

Legend:
Removed from v.1.587  
changed lines
  Added in v.1.588

  ViewVC Help
Powered by ViewVC 1.1.5