[slime-cvs] CVS slime
heller
heller at common-lisp.net
Sat Aug 9 19:57:00 UTC 2008
Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv20543
Modified Files:
ChangeLog slime.el swank-lispworks.lisp swank-sbcl.lisp
swank.lisp
Log Message:
Display the "Use default debugger" restart more prominently.
* swank.lisp (swank-debugger-hook): Bind a user visible restart
to invoke the native debugger.
(*global-debugger*): Make this nil by default.
(sldb-loop): Minor cleanups.
(sldb-break-with-default-debugger): Invoke the native debugger
on top of the slime debugger.
* slime.el (sldb-setup): Always pop to the debugger buffer.
(sldb-activate): Optionally select the window.
* swank-sbcl.lisp (sb-thread::get-foreground): Override this
as the default implementation is unusable for Slime.
* swank-lispworks.lisp (environment-display-notifier): Just
return t.
--- /project/slime/cvsroot/slime/ChangeLog 2008/08/09 19:56:52 1.1421
+++ /project/slime/cvsroot/slime/ChangeLog 2008/08/09 19:56:59 1.1422
@@ -18,6 +18,26 @@
2008-08-09 Helmut Eller <heller at common-lisp.net>
+ Display the "Use default debugger" restart more prominently.
+
+ * swank.lisp (swank-debugger-hook): Bind a user visible restart
+ to invoke the native debugger.
+ (*global-debugger*): Make this nil by default.
+ (sldb-loop): Minor cleanups.
+ (sldb-break-with-default-debugger): Invoke the native debugger
+ on top of the slime debugger.
+
+ * slime.el (sldb-setup): Always pop to the debugger buffer.
+ (sldb-activate): Optionally select the window.
+
+ * swank-sbcl.lisp (sb-thread::get-foreground): Override this
+ as the default implementation is unusable for Slime.
+
+ * swank-lispworks.lisp (environment-display-notifier): Just
+ return t.
+
+2008-08-09 Helmut Eller <heller at common-lisp.net>
+
* swank-lispworks.lisp (disassemble-frame): Implemented.
2008-08-08 Helmut Eller <heller at common-lisp.net>
--- /project/slime/cvsroot/slime/slime.el 2008/08/09 10:49:48 1.978
+++ /project/slime/cvsroot/slime/slime.el 2008/08/09 19:57:00 1.979
@@ -2331,9 +2331,9 @@
(funcall (cdr rec) value))
(t
(error "Unexpected reply: %S %S" id value)))))
- ((:debug-activate thread level)
+ ((:debug-activate thread level select)
(assert thread)
- (sldb-activate thread level))
+ (sldb-activate thread level select))
((:debug thread level condition restarts frames conts)
(assert thread)
(sldb-setup thread level condition restarts frames conts))
@@ -6727,26 +6727,33 @@
(setq sldb-backtrace-start-marker (point-marker))
(save-excursion
(sldb-insert-frames (sldb-prune-initial-frames frames) t))
- (run-hooks 'sldb-hook)
- (pop-to-buffer (current-buffer))
- (sldb-recenter-region (point-min) (point))
- (setq buffer-read-only t)
- (when (and slime-stack-eval-tags
- ;; (y-or-n-p "Enter recursive edit? ")
- )
- (message "Entering recursive edit..")
- (recursive-edit)))))
+ (run-hooks 'sldb-hook))
+ (pop-to-buffer (current-buffer))
+ (sldb-recenter-region (point-min) (point))
+ (setq buffer-read-only t)
+ (when (and slime-stack-eval-tags
+ ;; (y-or-n-p "Enter recursive edit? ")
+ )
+ (message "Entering recursive edit..")
+ (recursive-edit))))
-(defun sldb-activate (thread level)
+(defun sldb-activate (thread level select)
"Display the debugger buffer for THREAD.
If LEVEL isn't the same as in the buffer, reinitialize the buffer."
- (unless (let ((b (sldb-find-buffer thread)))
- (and b (with-current-buffer b (equal sldb-level level))))
- (slime-rex (thread level)
- ('(swank:debugger-info-for-emacs 0 10)
- nil thread)
- ((:ok result)
- (apply #'sldb-setup thread level result)))))
+ (or (let ((buffer (sldb-find-buffer thread)))
+ (when buffer
+ (with-current-buffer buffer
+ (when (equal sldb-level level)
+ (when select (pop-to-buffer (current-buffer)))
+ t))))
+ (sldb-reinitialize thread level)))
+
+(defun sldb-reinitialize (thread level)
+ (slime-rex (thread level)
+ ('(swank:debugger-info-for-emacs 0 10)
+ nil thread)
+ ((:ok result)
+ (apply #'sldb-setup thread level result))))
(defun sldb-exit (thread level &optional stepping)
"Exit from the debug level LEVEL."
--- /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/08/09 19:56:52 1.109
+++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/08/09 19:57:00 1.110
@@ -220,15 +220,28 @@
(defmethod env-internals:environment-display-debugger ((env slime-env))
*debug-io*)
-;;(defimplementation call-with-debugger-hook (hook fun)
-;; (let ((*debugger-hook* hook))
-;; (env:with-environment ((slime-env hook '()))
-;; (funcall fun))))
+(defimplementation call-with-debugger-hook (hook fun)
+ (let ((*debugger-hook* hook))
+ (env:with-environment ((slime-env hook '()))
+ (funcall fun))))
(defimplementation install-debugger-globally (function)
(setq *debugger-hook* function)
(setf (env:environment) (slime-env function '())))
+(defmethod env-internals:environment-display-notifier
+ ((env slime-env) &key restarts condition)
+ (declare (ignore restarts))
+ ;;(funcall (swank-sym :swank-debugger-hook) condition *debugger-hook*)
+ (values t nil)
+ )
+
+(defmethod env-internals:environment-display-debugger ((env slime-env))
+ *debug-io*)
+
+(defmethod env-internals:confirm-p ((e slime-env) &optional msg &rest args)
+ (apply (swank-sym :y-or-n-p-in-emacs) msg args))
+
(defvar *sldb-top-frame*)
(defun interesting-frame-p (frame)
@@ -783,19 +796,7 @@
(defimplementation emacs-connected ()
(when (eq (eval (swank-sym :*communication-style*))
nil)
- (set-sigint-handler))
- ;; pop up the slime debugger by default
- (let ((lw:*handle-warn-on-redefinition* :warn))
- (defmethod env-internals:environment-display-notifier
- (env &key restarts condition)
- (declare (ignore restarts))
- (funcall (swank-sym :swank-debugger-hook) condition *debugger-hook*))
- (defmethod env-internals:environment-display-debugger (env)
- *debug-io*)))
-
-
-(defmethod env-internals:confirm-p ((e slime-env) &optional msg &rest args)
- (apply (swank-sym :y-or-n-p-in-emacs) msg args))
+ (set-sigint-handler)))
;;;; Weak hashtables
--- /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/08/08 13:43:33 1.210
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/08/09 19:57:00 1.211
@@ -1319,6 +1319,19 @@
mutex))
(sb-ext:timeout ()))))))
+ #-non-broken-terminal-sessions
+ (progn
+ (defvar *native-wait-for-terminal* #'sb-thread::get-foreground)
+ (sb-ext:with-unlocked-packages (sb-thread)
+ (defun sb-thread::get-foreground ()
+ (ignore-errors
+ (format *debug-io* ";; SWANK: sb-thread::get-foreground ...~%")
+ (finish-output *debug-io*))
+ (or (and (typep *debug-io* 'two-way-stream)
+ (typep (two-way-stream-input-stream *debug-io*)
+ 'slime-input-stream))
+ (funcall *native-wait-for-terminal*)))))
+
)
(defimplementation quit-lisp ()
--- /project/slime/cvsroot/slime/swank.lisp 2008/08/08 21:34:17 1.557
+++ /project/slime/cvsroot/slime/swank.lisp 2008/08/09 19:57:00 1.558
@@ -1983,13 +1983,18 @@
after Emacs causes a restart to be invoked."
(declare (ignore hook))
(without-slime-interrupts
- (cond (*emacs-connection*
- (debug-in-emacs condition))
- ((default-connection)
- (with-connection ((default-connection))
- (debug-in-emacs condition))))))
+ (restart-case
+ (cond (*emacs-connection*
+ (debug-in-emacs condition))
+ ((default-connection)
+ (with-connection ((default-connection))
+ (debug-in-emacs condition))))
+ (default-debugger (&optional v)
+ :report "Use default debugger." (declare (ignore v))
+ (let ((*debugger-hook* nil))
+ (invoke-debugger condition))))))
-(defvar *global-debugger* t
+(defvar *global-debugger* nil
"Non-nil means the Swank debugger hook will be installed globally.")
(add-hook *new-connection-hook* 'install-debugger)
@@ -2034,18 +2039,18 @@
(defun sldb-loop (level)
(unwind-protect
- (catch 'sldb-enter-default-debugger
- (send-to-emacs
- (list* :debug (current-thread-id) level
- (debugger-info-for-emacs 0 *sldb-initial-frames*)))
- (loop (catch 'sldb-loop-catcher
- (with-simple-restart (abort "Return to sldb level ~D." level)
- (send-to-emacs (list :debug-activate (current-thread-id)
- level))
- (handler-bind ((sldb-condition #'handle-sldb-condition))
- (read-from-emacs))))))
- (send-to-emacs `(:debug-return
- ,(current-thread-id) ,level ,*sldb-stepping-p*))))
+ (loop
+ (with-simple-restart (abort "Return to sldb level ~D." level)
+ (send-to-emacs
+ (list* :debug (current-thread-id) level
+ (debugger-info-for-emacs 0 *sldb-initial-frames*)))
+ (loop
+ (send-to-emacs (list :debug-activate (current-thread-id) level nil))
+ (handler-case (read-from-emacs)
+ (sldb-condition (c)
+ (handle-sldb-condition c))))))
+ (send-to-emacs `(:debug-return
+ ,(current-thread-id) ,level ,*sldb-stepping-p*))))
(defun handle-sldb-condition (condition)
"Handle an internal debugger condition.
@@ -2053,8 +2058,7 @@
conditions are simply reported."
(let ((real-condition (original-condition condition)))
(send-to-emacs `(:debug-condition ,(current-thread-id)
- ,(princ-to-string real-condition))))
- (throw 'sldb-loop-catcher nil))
+ ,(princ-to-string real-condition)))))
(defvar *sldb-condition-printer* #'format-sldb-condition
"Function called to print a condition to an SLDB buffer.")
@@ -2089,8 +2093,11 @@
;;;;; SLDB entry points
(defslimefun sldb-break-with-default-debugger ()
- "Invoke the default debugger by returning from our debugger-loop."
- (throw 'sldb-enter-default-debugger nil))
+ "Invoke the default debugger."
+ (call-with-debugger-hook
+ nil (lambda () (invoke-debugger *swank-debugger-condition*)))
+ (send-to-emacs
+ (list :debug-activate (current-thread-id) *sldb-level* t)))
(defslimefun backtrace (start end)
"Return a list ((I FRAME) ...) of frames from START to END.
More information about the slime-cvs
mailing list