[slime-cvs] CVS slime
heller
heller at common-lisp.net
Mon Sep 15 10:41:04 UTC 2008
Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv30458
Modified Files:
ChangeLog slime.el swank-backend.lisp swank-clisp.lisp
swank-cmucl.lisp swank.lisp
Log Message:
* swank.lisp (sldb-loop): Send a :sldb-return event to ourselfes
to inform the debug session at the lower level.
(wait-for-event): Drop the report-interrupt argument. No longer
needed.
(event-match-p): Add an OR pattern operator. Used to wait for
different events simultaneously.
(read-packet): Use peek-char to detect EOF. read-sequence wouldn't
work.
* slime.el (slime-test-interrupt-in-debugger): Call sldb-quit and
sldb-continue in the right buffer.
* swank-backend.lisp (wait-for-input):
* swank-cmucl.lisp (wait-for-input):
* swank-clisp.lisp (wait-for-input): Use the idiom
"(when (check-slime-interrupts) (return :interrupt))".
--- /project/slime/cvsroot/slime/ChangeLog 2008/09/15 08:26:49 1.1506
+++ /project/slime/cvsroot/slime/ChangeLog 2008/09/15 10:41:02 1.1507
@@ -1,5 +1,25 @@
2008-09-15 Helmut Eller <heller at common-lisp.net>
+ * swank.lisp (sldb-loop): Send a :sldb-return event to ourselfes
+ when returning to inform the debug session at the lower level.
+ (wait-for-event): Drop the report-interrupt argument. No longer
+ needed.
+ (event-match-p): Add an OR pattern operator. Used to wait for
+ different events simultaneously.
+
+ (read-packet): Use peek-char to detect EOF. read-sequence wouldn't
+ work.
+
+ * slime.el (slime-test-interrupt-in-debugger): Call sldb-quit and
+ sldb-continue in the right buffer.
+
+ * swank-backend.lisp (wait-for-input):
+ * swank-cmucl.lisp (wait-for-input):
+ * swank-clisp.lisp (wait-for-input): Use the idiom
+ "(when (check-slime-interrupts) (return :interrupt))".
+
+2008-09-15 Helmut Eller <heller at common-lisp.net>
+
Interrupt related hacking.
* swank-backend.lisp (*pending-slime-interrupts*): Should be
--- /project/slime/cvsroot/slime/slime.el 2008/09/15 08:26:49 1.1015
+++ /project/slime/cvsroot/slime/slime.el 2008/09/15 10:41:02 1.1016
@@ -6818,7 +6818,6 @@
;; the debugger window. We also send a ping, just in case Lisp was
;; interrupted in swank:wait-for-input.
(defun sldb-maybe-kill-buffer (thread connection)
- (slime-eval-async `(swank:ping nil))
(run-with-idle-timer
0.3 nil
(lambda (thead connection)
@@ -7339,6 +7338,7 @@
(defun sldb-quit ()
"Quit to toplevel."
(interactive)
+ (assert sldb-restarts () "sldb-quit called outside of sldb buffer")
(slime-rex () ('(swank:throw-to-toplevel))
((:ok _) (error "sldb-quit returned"))
((:abort))))
@@ -7346,6 +7346,7 @@
(defun sldb-continue ()
"Invoke the \"continue\" restart."
(interactive)
+ (assert sldb-restarts () "sldb-continue called outside of sldb buffer")
(slime-rex ()
('(swank:sldb-continue))
((:ok _)
@@ -9419,16 +9420,17 @@
(dotimes (i interrupts)
(slime-interrupt)
(let ((level (1+ i)))
- (slime-wait-condition (format "Debug level %d reachend" lx1evel)
+ (slime-wait-condition (format "Debug level %d reachend" level)
(lambda () (equal (sldb-level) level))
2)))
(dotimes (i continues)
- (sldb-continue)
+ (with-current-buffer (sldb-get-default-buffer)
+ (sldb-continue))
(let ((level (- interrupts (1+ i))))
(slime-wait-condition (format "Return to debug level %d" level)
(lambda () (equal (sldb-level) level))
2)))
- (when (sldb-get-default-buffer)
+ (with-current-buffer (sldb-get-default-buffer)
(sldb-quit))
(slime-sync-to-top-level 1))
--- /project/slime/cvsroot/slime/swank-backend.lisp 2008/09/15 08:26:41 1.153
+++ /project/slime/cvsroot/slime/swank-backend.lisp 2008/09/15 10:41:03 1.154
@@ -1031,15 +1031,14 @@
;; This should only have thread-local bindings, so no init form.
(defvar *pending-slime-interrupts*)
-(defun check-slime-interrupts (&optional test-only)
+(defun check-slime-interrupts ()
"Execute pending interrupts if any.
This should be called periodically in operations which
can take a long time to complete.
-Return a boolean indicating whether any interrupts are queued."
+Return a boolean indicating whether any interrupts was processed."
(when (and (boundp '*pending-slime-interrupts*)
*pending-slime-interrupts*)
- (unless test-only
- (funcall (pop *pending-slime-interrupts*)))
+ (funcall (pop *pending-slime-interrupts*))
t))
(definterface wait-for-input (streams &optional timeout)
@@ -1055,7 +1054,7 @@
(let ((stream (car streams)))
(case timeout
((nil)
- (cond (*pending-slime-interrupts* :interrupt)
+ (cond ((check-slime-interrupts) :interrupt)
(t (peek-char nil stream nil nil)
streams)))
((t)
@@ -1066,7 +1065,7 @@
(t '()))))
(t
(loop
- (if *pending-slime-interrupts* (return :interrupt))
+ (if (check-slime-interrupts) (return :interrupt))
(when (wait-for-input streams t) (return streams))
(sleep 0.1)
(when (<= (decf timeout 0.1) 0) (return nil)))))))
--- /project/slime/cvsroot/slime/swank-clisp.lisp 2008/09/14 17:10:34 1.76
+++ /project/slime/cvsroot/slime/swank-clisp.lisp 2008/09/15 10:41:03 1.77
@@ -140,7 +140,7 @@
(assert (member timeout '(nil t)))
(let ((streams (mapcar (lambda (s) (list* s :input nil)) streams)))
(loop
- (cond (*pending-slime-interrupts* (return :interrupt))
+ (cond ((check-slime-interrupts) (return :interrupt))
(timeout
(socket:socket-status streams 0 0)
(return (loop for (s _ . x) in streams
--- /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/09/14 17:10:34 1.194
+++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/09/15 10:41:03 1.195
@@ -198,7 +198,7 @@
(let ((ready (remove-if-not #'listen streams)))
(when ready (return ready)))
(when timeout (return nil))
- (if *pending-slime-interrupts* (return :interrupt))
+ (when (check-slime-interrupts) (return :interrupt))
(let* ((f (constantly t))
(handlers (loop for s in streams
collect (add-one-shot-handler s f))))
--- /project/slime/cvsroot/slime/swank.lisp 2008/09/15 08:26:41 1.588
+++ /project/slime/cvsroot/slime/swank.lisp 2008/09/15 10:41:03 1.589
@@ -947,9 +947,8 @@
(defun process-requests (timeout just-one)
"Read and process requests from Emacs."
(loop
- (multiple-value-bind (event timeout? interrupt?)
- (wait-for-event `(:emacs-rex . _) timeout just-one)
- (when interrupt? (return nil))
+ (multiple-value-bind (event timeout?)
+ (wait-for-event `(:emacs-rex . _) timeout)
(when timeout? (return t))
(apply #'eval-for-emacs (cdr event))
(when just-one (return nil)))))
@@ -1119,21 +1118,18 @@
(cond ((use-threads-p) (interrupt-thread thread interrupt))
(t (funcall interrupt))))
-(defun wait-for-event (pattern &optional timeout report-interrupts)
+(defun wait-for-event (pattern &optional timeout)
(log-event "wait-for-event: ~s ~s~%" pattern timeout)
(without-slime-interrupts
(cond ((use-threads-p)
(receive-if (lambda (e) (event-match-p e pattern)) timeout))
(t
- (wait-for-event/event-loop pattern timeout report-interrupts)))))
+ (wait-for-event/event-loop pattern timeout)))))
-(defun wait-for-event/event-loop (pattern timeout report-interrupts)
+(defun wait-for-event/event-loop (pattern timeout)
(assert (or (not timeout) (eq timeout t)))
(loop
- (when *pending-slime-interrupts*
- (check-slime-interrupts)
- (when report-interrupts (return (values nil nil t)))
- (when timeout (return (values nil t))))
+ (check-slime-interrupts)
(let ((event (poll-for-event pattern)))
(when event (return (car event))))
(let ((events-enqueued *events-enqueued*)
@@ -1162,10 +1158,12 @@
(equal event pattern))
((symbolp pattern) t)
((consp pattern)
- (and (consp event)
- (and (event-match-p (car event) (car pattern))
- (event-match-p (cdr event) (cdr pattern)))))
- (t (error "Invalid pattern: ~S" pattern))))
+ (case (car pattern)
+ ((or) (some (lambda (p) (event-match-p event p)) (cdr pattern)))
+ (t (and (consp event)
+ (and (event-match-p (car event) (car pattern))
+ (event-match-p (cdr event) (cdr pattern)))))))
+ (t (error "Invalid pattern: ~S" pattern))))
(defun spawn-threads-for-connection (connection)
(setf (connection.control-thread connection)
@@ -1490,7 +1488,10 @@
(reader-error (c)
`(:reader-error ,packet ,c)))))))
+;; use peek-char to detect EOF, read-sequence may return 0 instead of
+;; signaling a condition.
(defun read-packet (stream)
+ (peek-char nil stream)
(let* ((header (read-chunk stream 6))
(length (parse-integer header :radix #x10))
(payload (read-chunk stream length)))
@@ -2207,13 +2208,22 @@
(send-to-emacs
(list* :debug (current-thread-id) level
(debugger-info-for-emacs 0 *sldb-initial-frames*)))
+ (send-to-emacs
+ (list :debug-activate (current-thread-id) level nil))
(loop
- (send-to-emacs (list :debug-activate (current-thread-id) level nil))
- (handler-case (process-requests nil t)
+ (handler-case
+ (destructure-case (wait-for-event
+ `(or (:emacs-rex . _)
+ (:sldb-return ,(1+ level))))
+ ((:emacs-rex &rest args) (apply #'eval-for-emacs args))
+ ((:sldb-return _) (declare (ignore _)) (return nil)))
(sldb-condition (c)
(handle-sldb-condition c))))))
(send-to-emacs `(:debug-return
- ,(current-thread-id) ,level ,*sldb-stepping-p*))))
+ ,(current-thread-id) ,level ,*sldb-stepping-p*))
+ (wait-for-event `(:sldb-return ,(1+ level)) t) ; clean event-queue
+ (when (> level 1)
+ (send-event (current-thread) `(:sldb-return ,level)))))
(defun handle-sldb-condition (condition)
"Handle an internal debugger condition.
More information about the slime-cvs
mailing list