[slime-cvs] CVS slime
heller
heller at common-lisp.net
Mon Aug 11 07:37:26 UTC 2008
Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv17980
Modified Files:
ChangeLog swank.lisp
Log Message:
* swank.lisp (wait-for-event): Add timeout argument. This is used
for :fd-handler and :sigio style where we only process events as
long as we don't block.
(wait-for-event/event-loop, read-event)
(decode-message, receive-if): Ditto.
(process-requests): Renamed from read-from-emacs.
(handle-requests): Renamed from handle-request. Take timeout
argument. Update callers.
(process-available-input): Deleted.
(with-swank-error-handler): Renamed from
with-reader-error-handler.
(with-connection): Use it.
--- /project/slime/cvsroot/slime/ChangeLog 2008/08/11 07:37:01 1.1430
+++ /project/slime/cvsroot/slime/ChangeLog 2008/08/11 07:37:15 1.1431
@@ -2,13 +2,16 @@
* swank.lisp (wait-for-event): Add timeout argument. This is used
for :fd-handler and :sigio style where we only process events as
- long we don't block.
+ long as we don't block.
(wait-for-event/event-loop, read-event)
(decode-message, receive-if): Ditto.
- (process-events): Renamed from read-from-emacs.
+ (process-requests): Renamed from read-from-emacs.
(handle-requests): Renamed from handle-request. Take timeout
argument. Update callers.
(process-available-input): Deleted.
+ (with-swank-error-handler): Renamed from
+ with-reader-error-handler.
+ (with-connection): Use it.
2008-08-10 Helmut Eller <heller at common-lisp.net>
--- /project/slime/cvsroot/slime/swank.lisp 2008/08/11 07:37:07 1.562
+++ /project/slime/cvsroot/slime/swank.lisp 2008/08/11 07:37:16 1.563
@@ -281,6 +281,32 @@
(call-with-debugging-environment
(lambda () (backtrace 0 nil)))))
+(defvar *debug-on-swank-error* nil
+ "When non-nil invoke the system debugger on swank internal errors.
+Do not set this to T unless you want to debug swank internals.")
+
+(defmacro with-swank-error-handler ((connection) &body body)
+ (let ((var (gensym)))
+ `(let ((,var ,connection))
+ (handler-case
+ (handler-bind ((swank-error
+ (lambda (condition)
+ (when *debug-on-swank-error*
+ (invoke-default-debugger condition)))))
+ (progn , at body))
+ (swank-error (condition)
+ (close-connection ,var
+ (swank-error.condition condition)
+ (swank-error.backtrace condition)))))))
+
+(defmacro with-panic-handler ((connection) &body body)
+ (let ((var (gensym)))
+ `(let ((,var ,connection))
+ (handler-bind ((serious-condition
+ (lambda (condition)
+ (close-connection ,var condition (safe-backtrace)))))
+ . ,body))))
+
(add-hook *new-connection-hook* 'notify-backend-of-connection)
(defun notify-backend-of-connection (connection)
(declare (ignore connection))
@@ -305,10 +331,11 @@
"Execute BODY in the context of CONNECTION."
`(call-with-connection ,connection (lambda () , at body)))
-(defun call-with-connection (connection fun)
+(defun call-with-connection (connection function)
(let ((*emacs-connection* connection))
- (with-io-redirection (*emacs-connection*)
- (call-with-debugger-hook #'swank-debugger-hook fun))))
+ (with-swank-error-handler (*emacs-connection*)
+ (with-io-redirection (*emacs-connection*)
+ (call-with-debugger-hook #'swank-debugger-hook function)))))
(defmacro without-interrupts (&body body)
`(call-without-interrupts (lambda () , at body)))
@@ -822,13 +849,12 @@
(assert (null *swank-state-stack*))
(let ((*swank-state-stack* '(:handle-request)))
(with-connection (connection)
- (progn ; with-reader-error-handler (connection)
- (loop
- (with-simple-restart (abort "Return to SLIME's top level.")
- (let* ((*sldb-quit-restart* (find-restart 'abort))
- (timeout? (process-requests timeout just-one)))
- (when (or just-one timeout?)
- (return)))))))))
+ (loop
+ (with-simple-restart (abort "Return to SLIME's top level.")
+ (let* ((*sldb-quit-restart* (find-restart 'abort))
+ (timeout? (process-requests timeout just-one)))
+ (when (or just-one timeout?)
+ (return))))))))
(defun process-requests (timeout just-one)
"Read and process requests from Emacs."
@@ -870,27 +896,6 @@
*use-dedicated-output-stream*)
(finish-output *log-output*)))
-(defvar *debug-on-swank-error* nil
- "When non-nil internal swank errors will drop to a
- debugger (not an sldb buffer). Do not set this to T unless you
- want to debug swank internals.")
-
-(defmacro with-reader-error-handler ((connection) &body body)
- (let ((var (gensym)))
- `(let ((,var ,connection))
- (handler-case (progn , at body)
- (swank-error (condition)
- (close-connection ,var
- (swank-error.condition condition)
- (swank-error.backtrace condition)))))))
-
-(defmacro with-panic-handler (&body body)
- `(handler-bind ((serious-condition
- (lambda (condition)
- (close-connection *emacs-connection* condition
- (safe-backtrace)))))
- . ,body))
-
(defvar *slime-interrupts-enabled*)
(defmacro with-slime-interrupts (&body body)
@@ -934,12 +939,12 @@
(defun read-loop (connection)
(let ((input-stream (connection.socket-io connection))
(control-thread (connection.control-thread connection)))
- (with-reader-error-handler (connection)
+ (with-swank-error-handler (connection)
(loop (send control-thread (decode-message input-stream))))))
(defun dispatch-loop (connection)
(let ((*emacs-connection* connection))
- (with-panic-handler
+ (with-panic-handler (connection)
(loop (dispatch-event (read-event))))))
(defvar *auto-flush-interval* 0.2)
@@ -1038,7 +1043,6 @@
(t (setf *event-queue* (nconc *event-queue* (list event))))))
(defun read-event (&optional timeout)
- (log-event "read-event: ~a~%" (current-socket-io))
(cond ((use-threads-p) (receive timeout))
(t (decode-message (current-socket-io) timeout))))
@@ -1071,12 +1075,10 @@
(nconc (ldiff *event-queue* tail) (cdr tail)))
(return (car tail))))
(multiple-value-bind (event timeout?) (read-event timeout)
- (log-event "read-event-> ~a ~a~%" event timeout?)
(when timeout? (return (values nil t)))
(dispatch-event event))))
(defun event-match-p (event pattern)
- (log-event "event-match-p: ~s ~s~%" event pattern)
(cond ((or (keywordp pattern) (numberp pattern) (stringp pattern)
(member pattern '(nil t)))
(equal event pattern))
@@ -2009,9 +2011,12 @@
(restart-case (invoke-slime-debugger condition)
(default-debugger (&optional v)
:report "Use default debugger." (declare (ignore v))
- (let ((*debugger-hook* nil))
- (invoke-debugger condition)))))
+ (invoke-default-debugger))))
+(defun invoke-default-debugger (condition)
+ (let ((*debugger-hook* nil))
+ (invoke-debugger condition)))
+
(defvar *global-debugger* nil
"Non-nil means the Swank debugger hook will be installed globally.")
More information about the slime-cvs
mailing list