[slime-cvs] CVS slime

[CVS User trittweiler]

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv2759

Modified Files:
	swank.lisp ChangeLog 
Log Message:
	* swank.lisp (*sldb-quit-restart*): Export. For users to customize
	what `q' does in SLDB.
	(handle-requests): Test differently for recursive invocations
	as *sldb-quit-restart* may now be globally bound due to user
	customization.
	(coerce-restart): Coerces a restart-designator to a restart.
	(throw-to-toplevel): Use it.

	* slime.texi (swank:*sldb-quit-restart*): Document it.


--- /project/slime/cvsroot/slime/swank.lisp	2009/12/15 21:56:55	1.675
+++ /project/slime/cvsroot/slime/swank.lisp	2009/12/16 09:24:12	1.676
@@ -38,6 +38,7 @@
            #:*readtable-alist*
            #:*globally-redirect-io*
            #:*global-debugger*
+           #:*sldb-quit-restart*
            #:*backtrace-printer-bindings*
            #:*default-worker-thread-bindings*
            #:*macroexpand-printer-bindings*
@@ -521,6 +522,12 @@
 (defun current-thread-id ()
   (thread-id (current-thread)))
 
+(defmacro define-special (name doc)
+  "Define a special variable NAME with doc string DOC.
+This is like defvar, but NAME will not be initialized."
+  `(progn
+    (defvar ,name)
+    (setf (documentation ',name 'variable) ,doc)))
 
 
 ;;;;; Logging
@@ -978,16 +985,19 @@
       (when socket
         (close-socket socket)))))
 
-;; The restart that will be invoked when the user calls sldb-quit.
-;; This restart will be named "abort" because many people press "a"
-;; instead of "q" in the debugger.
-(defvar *sldb-quit-restart*)
+;; 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.")
 
 ;; Establish a top-level restart and execute BODY.
 ;; Execute K if the restart is invoked.
 (defmacro with-top-level-restart ((connection k) &body body)
   `(with-connection (,connection)
-     (restart-case 
+     (restart-case
+         ;; We explicitly rebind (and do not look at user's
+         ;; customization), so sldb-quit will always be our restart
+         ;; for rex requests.
          (let ((*sldb-quit-restart* (find-restart 'abort)))
            . ,body)
        (abort (&optional v)
@@ -999,9 +1009,10 @@
 (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*)
+  (cond ((eq *emacs-connection* connection)
+         (assert (boundp '*sldb-quit-restart*))
          (process-requests timeout))
-        (t 
+        (t
          (tagbody
             start
             (with-top-level-restart (connection (go start))
@@ -1910,13 +1921,6 @@
 
 ;;;; Reading and printing
 
-(defmacro define-special (name doc)
-  "Define a special variable NAME with doc string DOC.
-This is like defvar, but NAME will not be initialized."
-  `(progn
-    (defvar ,name)
-    (setf (documentation ',name 'variable) ,doc)))
-
 (define-special *buffer-package*     
     "Package corresponding to slime-buffer-package.  
 
@@ -2692,12 +2696,16 @@
 (defslimefun sldb-continue ()
   (continue))
 
+(defun coerce-restart (restart-designator)
+  (when (or (typep restart-designator 'restart)
+            (typep restart-designator '(and symbol (not null))))
+    (find-restart restart-designator)))
+
 (defslimefun throw-to-toplevel ()
   "Invoke the ABORT-REQUEST restart abort an RPC from Emacs.
 If we are not evaluating an RPC then ABORT instead."
   (let ((restart (and (boundp '*sldb-quit-restart*)
-                      (typep *sldb-quit-restart* 'restart)
-                      (find-restart *sldb-quit-restart*))))
+                      (coerce-restart *sldb-quit-restart*))))
     (cond (restart (invoke-restart restart))
           (t "No toplevel restart active"))))
 
--- /project/slime/cvsroot/slime/ChangeLog	2009/12/15 21:56:55	1.1937
+++ /project/slime/cvsroot/slime/ChangeLog	2009/12/16 09:24:12	1.1938
@@ -1,5 +1,17 @@
 2009-12-15  Tobias C. Rittweiler <tcr at freebits.de>
 
+	* swank.lisp (*sldb-quit-restart*): Export. For users to customize
+	what `q' does in SLDB.
+	(handle-requests): Test differently for recursive invocations
+	as *sldb-quit-restart* may now be globally bound due to user
+	customization.
+	(coerce-restart): Coerces a restart-designator to a restart.
+	(throw-to-toplevel): Use it.
+
+	* slime.texi (swank:*sldb-quit-restart*): Document it.
+
+2009-12-15  Tobias C. Rittweiler <tcr at freebits.de>
+
 	* swank.lisp (collect-notes): Establish new abort restart ("Abort
 	Compilation"); if an error is signaled in EVAL-WHEN, or during
 	macroexpansion -- assuming the backend DTRT --, invoking this