[slime-cvs] CVS slime
CVS User heller
heller at common-lisp.net
Fri Jun 4 07:30:05 UTC 2010
Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv8122
Modified Files:
ChangeLog swank.lisp
Log Message:
Some *sldb-quit-restart* related fixes.
* swank.lisp (*sldb-quit-restart*): Set to nil by default.
(throw-to-toplevel, debug-in-emacs): Get rid of boundp tests.
(format-restarts-for-emacs): Add a mark for *sldb-quit-restart*.
(handle-requests): Always bind *emacs-connection*.
(with-connection): Get rid of call-with-connection so that
compilers can remove the call frame more easily.
(repl-input-stream-read): Factored out from
make-repl-input-stream. Bind a *sldb-quit-restart* here too; no
need to restart the repl and a extra prompt for errors in Emacs
requests.
--- /project/slime/cvsroot/slime/ChangeLog 2010/05/28 13:55:30 1.2105
+++ /project/slime/cvsroot/slime/ChangeLog 2010/06/04 07:30:05 1.2106
@@ -1,3 +1,18 @@
+2010-06-04 Helmut Eller <heller at common-lisp.net>
+
+ Some *sldb-quit-restart* related fixes.
+
+ * swank.lisp (*sldb-quit-restart*): Set to nil by default.
+ (throw-to-toplevel, debug-in-emacs): Get rid of boundp tests.
+ (format-restarts-for-emacs): Add a mark for *sldb-quit-restart*.
+ (handle-requests): Always bind *emacs-connection*.
+ (with-connection): Get rid of call-with-connection so that
+ compilers can remove the call frame more easily.
+ (repl-input-stream-read): Factored out from
+ make-repl-input-stream. Bind a *sldb-quit-restart* here too; no
+ need to restart the repl and a extra prompt for errors in Emacs
+ requests.
+
2010-05-28 Helmut Eller <heller at common-lisp.net>
Fix last change.
--- /project/slime/cvsroot/slime/swank.lisp 2010/05/27 14:48:12 1.717
+++ /project/slime/cvsroot/slime/swank.lisp 2010/06/04 07:30:05 1.718
@@ -569,17 +569,16 @@
(defmacro with-connection ((connection) &body body)
"Execute BODY in the context of CONNECTION."
- `(call-with-connection ,connection (lambda () , at body)))
-
-(defun call-with-connection (connection function)
- (if (eq *emacs-connection* connection)
- (funcall function)
- (let ((*emacs-connection* connection)
- (*pending-slime-interrupts* '()))
- (without-slime-interrupts
- (with-swank-error-handler (*emacs-connection*)
- (with-io-redirection (*emacs-connection*)
- (call-with-debugger-hook #'swank-debugger-hook function)))))))
+ `(let ((connection ,connection)
+ (function (lambda () . ,body)))
+ (if (eq *emacs-connection* connection)
+ (funcall function)
+ (let ((*emacs-connection* connection)
+ (*pending-slime-interrupts* '()))
+ (without-slime-interrupts
+ (with-swank-error-handler (connection)
+ (with-io-redirection (connection)
+ (call-with-debugger-hook #'swank-debugger-hook function))))))))
(defun call-with-retry-restart (msg thunk)
(loop (with-simple-restart (retry "~a" msg)
@@ -1022,10 +1021,8 @@
;;;;; Event Processing
-;; By default, this restart will be named "abort" because many people
-;; press "a" instead of "q" in the debugger.
-(define-special *sldb-quit-restart*
- "The restart that will be invoked when the user calls sldb-quit.")
+(defvar *sldb-quit-restart* nil
+ "The restart that will be invoked when the user calls sldb-quit.")
;; Establish a top-level restart and execute BODY.
;; Execute K if the restart is invoked.
@@ -1043,14 +1040,14 @@
(defun handle-requests (connection &optional timeout)
"Read and process :emacs-rex requests.
The processing is done in the extent of the toplevel restart."
- (cond ((boundp '*sldb-quit-restart*)
- (assert *emacs-connection*)
- (process-requests timeout))
- (t
- (tagbody
- start
- (with-top-level-restart (connection (go start))
- (process-requests timeout))))))
+ (with-connection (connection)
+ (cond (*sldb-quit-restart*
+ (process-requests timeout))
+ (t
+ (tagbody
+ start
+ (with-top-level-restart (connection (go start))
+ (process-requests timeout)))))))
(defun process-requests (timeout)
"Read and process requests from Emacs."
@@ -1402,29 +1399,27 @@
(defun make-repl-input-stream (connection stdin)
(make-input-stream
- (lambda ()
- (log-event "pull-input: ~a ~a ~a~%"
- (connection.socket-io connection)
- (if (open-stream-p (connection.socket-io connection))
- :socket-open :socket-closed)
- (if (open-stream-p stdin)
- :stdin-open :stdin-closed))
- (loop
- (let* ((socket (connection.socket-io connection))
- (inputs (list socket stdin))
- (ready (wait-for-input inputs)))
- (cond ((eq ready :interrupt)
- (check-slime-interrupts))
- ((member socket ready)
- ;; A Slime request from Emacs is pending; make sure to
- ;; redirect IO to the REPL buffer.
- (with-io-redirection (connection)
- (handle-requests connection t)))
- ((member stdin ready)
- ;; User typed something into the *inferior-lisp* buffer,
- ;; so do not redirect.
- (return (read-non-blocking stdin)))
- (t (assert (null ready)))))))))
+ (lambda () (repl-input-stream-read connection stdin))))
+
+(defun repl-input-stream-read (connection stdin)
+ (loop
+ (let* ((socket (connection.socket-io connection))
+ (inputs (list socket stdin))
+ (ready (wait-for-input inputs)))
+ (cond ((eq ready :interrupt)
+ (check-slime-interrupts))
+ ((member socket ready)
+ ;; A Slime request from Emacs is pending; make sure to
+ ;; redirect IO to the REPL buffer.
+ (with-simple-restart (process-input "Continue reading input.")
+ (let ((*sldb-quit-restart* (find-restart 'process-input)))
+ (with-io-redirection (connection)
+ (handle-requests connection t)))))
+ ((member stdin ready)
+ ;; User typed something into the *inferior-lisp* buffer,
+ ;; so do not redirect.
+ (return (read-non-blocking stdin)))
+ (t (assert (null ready)))))))
(defun read-non-blocking (stream)
(with-output-to-string (str)
@@ -2505,9 +2500,8 @@
(defun debug-in-emacs (condition)
(let ((*swank-debugger-condition* condition)
(*sldb-restarts* (compute-restarts condition))
- (*sldb-quit-restart* (if (boundp '*sldb-quit-restart*)
- *sldb-quit-restart*
- (find-restart 'abort)))
+ (*sldb-quit-restart* (and *sldb-quit-restart*
+ (find-restart *sldb-quit-restart*)))
(*package* (or (and (boundp '*buffer-package*)
(symbol-value '*buffer-package*))
*package*))
@@ -2578,10 +2572,11 @@
"Return a list of restarts for *swank-debugger-condition* in a
format suitable for Emacs."
(let ((*print-right-margin* most-positive-fixnum))
- (loop for restart in *sldb-restarts*
- collect (list (princ-to-string (restart-name restart))
- (princ-to-string restart)))))
-
+ (loop for restart in *sldb-restarts* collect
+ (list (format nil "~:[~;*~]~a"
+ (eq restart *sldb-quit-restart*)
+ (restart-name restart) )
+ (princ-to-string restart)))))
;;;;; SLDB entry points
@@ -2677,8 +2672,7 @@
(defslimefun throw-to-toplevel ()
"Invoke the ABORT-REQUEST restart abort an RPC from Emacs.
If we are not evaluating an RPC then ABORT instead."
- (assert (boundp '*sldb-quit-restart*)) ; bound by debug-in-emacs
- (let ((restart (find-restart *sldb-quit-restart*)))
+ (let ((restart (and *sldb-quit-restart* (find-restart *sldb-quit-restart*))))
(cond (restart (invoke-restart restart))
(t (format nil "Restart not active [~s]" *sldb-quit-restart*)))))
More information about the slime-cvs
mailing list