[slime-cvs] CVS slime

[jsnellman]

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv16073

Modified Files:
	ChangeLog slime.el swank-backend.lisp swank-sbcl.lisp 
	swank.lisp 
Log Message:
sbcl single-stepper

--- /project/slime/cvsroot/slime/ChangeLog	2006/09/18 21:25:24	1.946
+++ /project/slime/cvsroot/slime/ChangeLog	2006/09/18 21:56:13	1.947
@@ -1,3 +1,33 @@
+2006-09-19  Juho Snellman  <jsnell at iki.fi>
+
+	Extend the stepper protocol to work nicely with the SBCL stepper.
+
+	If sldb is invoked on a condition that's sldb-stepper-condition-p,
+	the sldb functions sldb-step, sldb-next and sldb-out will invoke
+	the matching backend functions for stepping into the stepped form,
+	to the next form, or out of the current function. Otherwise the
+	functions will behave like sldb-step used to (call active-stepping and
+	select the continue restart).
+
+	* swank-backend.lisp (sldb-stepper-condition-p, sldb-step-into, 
+	sldb-step-next, sldb-step-out): New interface functions
+	
+	* swank-sbcl.lisp (activate-stepper, condition-extras,
+	sldb-stepper-condition-p, sldb-step-into, sldb-step-next,
+	sldb-step-out): Implemented (conditional on CVS SBCL)
+	(call-with-debugger-hook): bind sb-ext:*stepper-hook* to
+	a function that binds *stack-top-hint* and invokes the debugger
+	(conditional on CVS SBCL)
+	
+	* swank.lisp (define-stepper-function): new macro for defining 
+	stepper-related functions, since they all follow the same form
+	(sldb-step): redefine with define-stepper-function
+	(sldb-next, sldb-out): new functions
+	(*sldb-stepping-p*): typo in docstring
+	
+	* slime.el (sldb-next, sldb-out): New commands
+        (sldb-mode-map): bind sldb-next to "x" and sldb-out to "o"
+	
 2006-09-18  Dan Weinreb <dlw at itasoftware.com>
 
 	For those cases where SLIME can't complete a user request (like
--- /project/slime/cvsroot/slime/slime.el	2006/09/18 21:26:13	1.650
+++ /project/slime/cvsroot/slime/slime.el	2006/09/18 21:56:13	1.651
@@ -912,7 +912,10 @@
       ("Invoke Restart"
        [ "Continue" sldb-continue ,C ]
        [ "Abort"    sldb-abort ,C ]
-       [ "Step"     sldb-step ,C ])
+       [ "Step"      sldb-step ,C ]
+       [ "Step next" sldb-next ,C ]
+       [ "Step out"  sldb-out ,C ]
+       )
       "--"
       [ "Quit (throw)" sldb-quit ,C ]
       [ "Break With Default Debugger" sldb-break-with-default-debugger ,C ])))
@@ -7742,6 +7745,8 @@
   ("R"    'sldb-return-from-frame)
   ("c"    'sldb-continue)
   ("s"    'sldb-step)
+  ("x"    'sldb-next)
+  ("o"    'sldb-out)
   ("b"    'sldb-break-on-return)
   ("a"    'sldb-abort)
   ("q"    'sldb-quit)
@@ -8385,6 +8390,18 @@
   (let ((frame (sldb-frame-number-at-point)))
     (slime-eval-async `(swank:sldb-step ,frame))))
 
+(defun sldb-next ()
+  "Select the \"continue\" restart and set a new break point."
+  (interactive)
+  (let ((frame (sldb-frame-number-at-point)))
+    (slime-eval-async `(swank:sldb-next ,frame))))
+
+(defun sldb-out ()
+  "Select the \"continue\" restart and set a new break point."
+  (interactive)
+  (let ((frame (sldb-frame-number-at-point)))
+    (slime-eval-async `(swank:sldb-out ,frame))))
+
 (defun sldb-break-on-return ()
   "Set a breakpoint at the current frame. 
 The debugger is entered when the frame exits."
--- /project/slime/cvsroot/slime/swank-backend.lisp	2006/09/18 21:27:04	1.102
+++ /project/slime/cvsroot/slime/swank-backend.lisp	2006/09/18 21:56:13	1.103
@@ -636,6 +636,21 @@
 (definterface sldb-break-at-start (symbol)
   "Set a breakpoint on the beginning of the function for SYMBOL.")
   
+(definterface sldb-stepper-condition-p (condition)
+  "Return true if SLDB was invoked due to a single-stepping condition,
+false otherwise. "
+  (declare (ignore condition))
+  nil)
+
+(definterface sldb-step-into ()
+  "Step into the current single-stepper form.")
+
+(definterface sldb-step-next ()
+  "Step to the next form in the current function.")
+
+(definterface sldb-step-out ()
+  "Stop single-stepping temporarily, but resume it once the current function
+returns.")
 
 
 ;;;; Definition finding
--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2006/09/11 08:01:59	1.161
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2006/09/18 21:56:13	1.162
@@ -583,11 +583,24 @@
 
 ;;; Debugging
 
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  ;; Generate a form suitable for testing for stepper support (0.9.17)
+  ;; with #+.
+  (defun sbcl-with-new-stepper-p ()
+    (if (find-symbol "ENABLE-STEPPING" "SB-IMPL")
+        '(and)
+        '(or))))
+
 (defvar *sldb-stack-top*)
 
 (defimplementation install-debugger-globally (function)
   (setq sb-ext:*invoke-debugger-hook* function))
 
+#+#.(swank-backend::sbcl-with-new-stepper-p)
+(defimplementation condition-extras (condition)
+  (when (typep condition 'sb-impl::step-form-condition)
+    `((:short-frame-source 0))))
+
 (defimplementation call-with-debugging-environment (debugger-loop-fn)
   (declare (type function debugger-loop-fn))
   (let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame)))
@@ -599,8 +612,28 @@
                                :original-condition condition)))))
       (funcall debugger-loop-fn))))
 
+#+#.(swank-backend::sbcl-with-new-stepper-p)
+(progn
+  (defimplementation activate-stepping (frame)
+    (declare (ignore frame))
+    (sb-impl::enable-stepping))
+  (defimplementation sldb-stepper-condition-p (condition)
+    (typep condition 'sb-ext:step-form-condition))
+  (defimplementation sldb-step-into ()
+    (invoke-restart 'sb-ext:step-into))
+  (defimplementation sldb-step-next ()
+    (invoke-restart 'sb-ext:step-next))
+  (defimplementation sldb-step-out ()
+    (invoke-restart 'sb-ext:step-out)))
+
 (defimplementation call-with-debugger-hook (hook fun)
-  (let ((sb-ext:*invoke-debugger-hook* hook))
+  (let ((sb-ext:*invoke-debugger-hook* hook)
+        #+#.(swank-backend::sbcl-with-new-stepper-p)
+        (sb-ext:*stepper-hook*
+         (lambda (condition)
+           (when (typep condition 'sb-ext:step-form-condition)
+             (let ((sb-debug:*stack-top-hint* (sb-di::find-stepped-frame)))
+               (sb-impl::invoke-debugger condition))))))
     (funcall fun)))
 
 (defun nth-frame (index)
--- /project/slime/cvsroot/slime/swank.lisp	2006/09/18 21:27:49	1.399
+++ /project/slime/cvsroot/slime/swank.lisp	2006/09/18 21:56:13	1.400
@@ -2697,7 +2697,7 @@
   "The list of currenlty active restarts.")
 
 (defvar *sldb-stepping-p* nil
-  "True when during execution of a stepp command.")
+  "True during execution of a step command.")
 
 (defvar *sldb-quit-restart* 'abort-request
   "What restart should swank attempt to invoke when the user sldb-quits.")
@@ -2887,13 +2887,21 @@
   (with-buffer-syntax ()
     (sldb-break-at-start (read-from-string name))))
 
-(defslimefun sldb-step (frame)
-  (cond ((find-restart 'continue)
+(defmacro define-stepper-function (name backend-function-name)
+  `(defslimefun ,name (frame)
+     (cond ((sldb-stepper-condition-p *swank-debugger-condition*)
+            (setq *sldb-stepping-p* t)
+            (,backend-function-name))
+           ((find-restart 'continue)
          (activate-stepping frame)
          (setq *sldb-stepping-p* t)
          (continue))
         (t
-         (error "No continue restart."))))
+            (error "Not currently single-stepping, and no continue restart available.")))))
+
+(define-stepper-function sldb-step sldb-step-into)
+(define-stepper-function sldb-next sldb-step-next)
+(define-stepper-function sldb-out  sldb-step-out)
 
 
 ;;;; Compilation Commands.