Attached to this post is a patch to the debugger in
Apps/Debugger/clim-debugger.lisp. It adds keyboard support and a
simple-minded (and almost useless) `eval-in-frame' command.
/etc/host.conf: line 24: bad command `mdns off'
Index: Apps/Debugger/clim-debugger.lisp
===================================================================
RCS file: /project/mcclim/cvsroot/mcclim/Apps/Debugger/clim-debugger.lisp,v
retrieving revision 1.1
diff -u -r1.1 clim-debugger.lisp
--- Apps/Debugger/clim-debugger.lisp 26 Apr 2005 03:19:34 -0000 1.1
+++ Apps/Debugger/clim-debugger.lisp 28 Apr 2006 14:41:33 -0000
@@ -132,14 +132,14 @@
(defun compute-backtrace (start end)
(loop for frame in (swank-backend::compute-backtrace start end)
- for frame-no from 0
- collect (make-instance
- 'stack-frame
- :frame-string (let ((*print-pretty* nil))
- (with-output-to-string (stream)
- (swank-backend::print-frame frame stream)))
- :frame-no frame-no
- :frame-variables (swank-backend::frame-locals frame-no))))
+ for frame-no from 0
+ collect (make-instance
+ 'stack-frame
+ :frame-string (let ((*print-pretty* nil))
+ (with-output-to-string (stream)
+ (swank-backend::print-frame frame stream)))
+ :frame-no frame-no
+ :frame-variables (swank-backend::frame-locals frame-no))))
(defmethod expand-backtrace ((info debugger-info) (value integer))
(with-slots (backtrace) info
@@ -151,7 +151,19 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass debugger-pane (application-pane)
- ((condition-info :reader condition-info :initarg :condition-info)))
+ ((condition-info
+ :reader condition-info
+ :initarg :condition-info)
+ (selected-stack-frame-index
+ :accessor selected-stack-frame-index
+ :initarg :selected-strackframe-index
+ :type 'integer
+ :initform 0)
+ (presentation-hashmap
+ :accessor presentation-hash-table
+ :initarg :presentation-hash-tablen
+ :type 'hash-table
+ :initform (make-hash-table))))
;; FIXME - These two variables should be removed!
;; Used to return the chosen reatart in the debugger.
@@ -173,9 +185,15 @@
(define-application-frame clim-debugger ()
()
(:panes
- (debugger-pane (make-debugger-pane)))
+ (debugger-pane (make-debugger-pane))
+ (interactor :interactor
+ :max-height 100)
+ (pointer-doc :pointer-documentation))
(:layouts
- (default (vertically () (scrolling () debugger-pane))))
+ (default (vertically ()
+ (scrolling () debugger-pane)
+ interactor
+ pointer-doc)))
(:geometry :height 600 :width 800))
(defun run-debugger-frame ()
@@ -192,26 +210,119 @@
(define-presentation-type more-type ())
(define-presentation-type inspect ())
+(defun highlight-selected-stack-frame (debugger-pane)
+ "Highlight the presentation associated with the currently
+ selected stack frame."
+ (funcall-presentation-generic-function
+ highlight-presentation
+ 'stack-frame
+ (gethash (elt (backtrace
+ (condition-info debugger-pane))
+ (selected-stack-frame-index
+ debugger-pane))
+ (presentation-hash-table debugger-pane))
+ debugger-pane
+ :highlight))
+
+(defun unhighlight-selected-stack-frame (debugger-pane)
+ "Unhighlight the presentation associated with the currently
+ selected stack frame."
+ (funcall-presentation-generic-function
+ highlight-presentation
+ 'stack-frame
+ (gethash (elt (backtrace
+ (condition-info debugger-pane))
+ (selected-stack-frame-index
+ debugger-pane))
+ (presentation-hash-table debugger-pane))
+ debugger-pane
+ :unhighlight))
+
+(define-presentation-method highlight-presentation ((type stack-frame) record (stream debugger-pane) (state (eql :highlight)))
+ (declare (ignore state stream))
+ (unhighlight-selected-stack-frame stream)
+ ;; List this presentation as the currently selected.
+ (setf (selected-stack-frame-index stream)
+ (position (presentation-object record)
+ (backtrace (condition-info stream))))
+ ;; Unhighlight all other presentations.
+
+ (call-next-method))
+
+(define-presentation-method present (object (type stack-frame) stream
+ (view minimized-stack-frame-view)
+ &key acceptably for-context-type)
+ (declare (ignore acceptably for-context-type))
+ (format t "~A " (frame-string object)))
+
+(define-presentation-method present (object (type stack-frame) stream
+ (view maximized-stack-frame-view)
+ &key acceptably for-context-type)
+ (declare (ignore acceptably for-context-type))
+ (progn
+ (princ (frame-string object) stream)
+ (fresh-line)
+ (with-text-family (stream :sans-serif)
+ (bold (stream) (format t " Locals:")))
+ (fresh-line)
+ (format t " ")
+ (formatting-table
+ (stream)
+ (loop for (name n identifier id value val) in (frame-variables object)
+ do (formatting-row
+ (stream)
+ (formatting-cell (stream) (format t "~A" n))
+ (formatting-cell (stream) (format t "="))
+ (formatting-cell (stream) (present val 'inspect)))))
+ (terpri stream)))
+
+(define-presentation-method present (object (type restart) stream
+ (view textual-view)
+ &key acceptably for-context-type)
+ (declare (ignore acceptably for-context-type))
+ (bold (stream) (format t "~A" (restart-name object))))
+
+(define-presentation-method present (object (type more-type) stream
+ (view textual-view)
+ &key acceptably for-context-type)
+ (declare (ignore acceptably for-context-type))
+ (bold (stream) (format t "--- MORE ---")))
+
+(define-presentation-method present (object (type inspect) stream
+ (view textual-view)
+ &key acceptably for-context-type)
+ (declare (ignore acceptably for-context-type))
+ (format t "~A" object))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Commands ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(define-clim-debugger-command (com-more :name "More backtraces")
+(define-clim-debugger-command (com-more
+ :name "More backtraces")
((pane 'more-type))
(expand-backtrace (condition-info pane) 10))
-(define-clim-debugger-command (com-invoke-inspector :name "Invoke inspector")
+(define-clim-debugger-command (com-invoke-inspector
+ :name "Invoke inspector")
((obj 'inspect))
- (clouseau:inspector obj))
+ (clouseau:inspector obj :new-process t))
-(define-clim-debugger-command (com-refresh :name "Refresh" :menu t) ()
+(define-clim-debugger-command (com-refresh
+ :name "Refresh"
+ :menu t)
+ ()
(change-space-requirements (frame-panes *application-frame*)))
-(define-clim-debugger-command (com-quit :name "Quit" :menu t) ()
+(define-clim-debugger-command (com-quit
+ :name "Quit"
+ :menu t)
+ ()
(frame-exit *application-frame*))
-(define-clim-debugger-command (com-invoke-restart :name "Invoke restart")
+(define-clim-debugger-command (com-invoke-restart
+ :name "Invoke restart")
((restart 'restart))
(setf *returned-restart* restart)
(frame-exit *application-frame*))
@@ -225,6 +336,148 @@
(setf (view stack-frame) +minimized-stack-frame-view+))
(change-space-requirements (frame-panes *application-frame*))))
+(define-clim-debugger-command (com-eval-in-frame
+ :name "Eval in frame")
+ ((stack-frame 'stack-frame)
+ &key
+ (code 'expression
+ :prompt "code"
+ :default (accept 'expression)))
+ (setf swank::*buffer-package*
+ *package*
+ swank::*buffer-readtable*
+ *readtable*)
+ (print (swank:eval-string-in-frame
+ (write-to-string code)
+ (frame-no stack-frame))))
+
+;;; We want to be able to invoke restarts with the 1-9 letters on the
+;;; keyboard.
+
+(define-clim-debugger-command
+ (com-invoke-restart-by-number
+ :name "Invoke numbered restart")
+ ((number 'integer))
+ ;; `number' is the number of the restart to invoke. This
+ ;; is simply used as an index into a list.
+ (let* ((debugger-pane
+ (get-frame-pane *application-frame* 'debugger-pane))
+ (restarts
+ (restarts
+ (condition-info debugger-pane)))
+ (selected-restart (nth number restarts)))
+ ;; If the restart is not valid, we just ignore the command.
+ (when selected-restart
+ (setf *returned-restart* selected-restart)
+ (frame-exit *application-frame*))))
+
+;;; We associate keystrokes in the interval 0-9 to calls to
+;;; `clim-invoke-restart' with the keystroke as argument. Is this a
+;;; kludge? I couln't find a better way to do it.
+
+;; Define a macro for convenience.
+
+(defmacro keybind-restart-commands (n)
+ "Associate the numeric keys in the interval 0-N with a call to
+`clim-invoke-restart' with the relevant number as argument."
+ `(progn
+ ,@(loop for r from 0 upto n
+ collecting
+ `(add-command-to-command-table
+ '(com-invoke-restart-by-number ,r)
+ 'clim-debugger
+ :keystroke '(,(code-char (+ (char-code #\0) r)))))))
+
+(keybind-restart-commands 9)
+
+;; We also define an abort-command to permit quick exit.
+
+(define-clim-debugger-command
+ (com-invoke-abort-restart
+ :name "Invoke abort restart"
+ :keystroke (#\q))
+ ()
+ (setf *returned-restart* nil)
+ (frame-exit *application-frame*))
+
+;; We want to be able to navigate the list of stack frames
+;; with the keyboard.
+
+(define-clim-debugger-command
+ (com-next-stack-frame
+ :name "Next stack-frame"
+ :keystroke (#\n :control))
+ ()
+ (let ((debugger-pane (get-frame-pane *application-frame* 'debugger-pane)))
+ (when (< (selected-stack-frame-index debugger-pane)
+ (1- (length (backtrace (condition-info debugger-pane)))))
+ (incf (selected-stack-frame-index debugger-pane)))))
+
+(add-command-to-command-table
+ 'com-next-stack-frame
+ 'clim-debugger
+ :errorp nil
+ :keystroke '(#\n))
+
+(define-clim-debugger-command
+ (com-prev-stack-frame
+ :name "Previous stack-frame"
+ :keystroke (#\p :control))
+ ()
+ (let ((debugger-pane (get-frame-pane *application-frame* 'debugger-pane)))
+ (when (> (selected-stack-frame-index debugger-pane) 0)
+ (decf (selected-stack-frame-index debugger-pane)))))
+
+(add-command-to-command-table
+ 'com-prev-stack-frame
+ 'clim-debugger
+ :errorp nil
+ :keystroke '(#\p))
+
+(define-clim-debugger-command
+ (com-toggle-selected-stack-frame-index-view
+ :name "Toggle view of selected stack-frame"
+ :keystroke (#\e))
+ ()
+ (let* ((debugger-pane (get-frame-pane *application-frame* 'debugger-pane))
+ (stack-frame (nth (selected-stack-frame-index debugger-pane)
+ (backtrace (condition-info debugger-pane)))))
+ (execute-frame-command *application-frame*
+ `(com-toggle-stack-frame-view ,stack-frame))))
+
+(define-clim-debugger-command
+ (com-browse-next-stack-frame
+ :name "Browse next stack-frame"
+ :keystroke (#\N))
+ ()
+ ;; Minize current stack-frame, select and expand next stack-frame.
+ (let* ((debugger-pane (get-frame-pane *application-frame* 'debugger-pane))
+ (current-stack-frame (nth (selected-stack-frame-index debugger-pane)
+ (backtrace (condition-info debugger-pane)))))
+ (setf (view current-stack-frame) +minimized-stack-frame-view+)
+ (com-next-stack-frame)
+ ;; We have a new current stack-frame (this shadowing may be a bit
+ ;; ugly)..
+ (let ((current-stack-frame (nth (selected-stack-frame-index debugger-pane)
+ (backtrace (condition-info debugger-pane)))))
+ (setf (view current-stack-frame) +maximized-stack-frame-view+))))
+
+(define-clim-debugger-command
+ (com-browse-prev-stack-frame
+ :name "Browse previous stack-frame"
+ :keystroke (#\P))
+ ()
+ ;; Minize current stack-frame, select and expand previous stack-frame.
+ (let* ((debugger-pane (get-frame-pane *application-frame* 'debugger-pane))
+ (current-stack-frame (nth (selected-stack-frame-index debugger-pane)
+ (backtrace (condition-info debugger-pane)))))
+ (setf (view current-stack-frame) +minimized-stack-frame-view+)
+ (com-prev-stack-frame)
+ ;; We have a new current stack-frame.
+ (let ((current-stack-frame (nth (selected-stack-frame-index debugger-pane)
+ (backtrace (condition-info debugger-pane)))))
+ (setf (view current-stack-frame) +maximized-stack-frame-view+))))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Command translators ;;;;;;;;;;;;;;;;;;;;;
@@ -241,7 +494,16 @@
(list object))
(define-presentation-to-command-translator toggle-stack-frame-view
- (stack-frame com-toggle-stack-frame-view clim-debugger :gesture :select)
+ (stack-frame com-toggle-stack-frame-view clim-debugger
+ :gesture :select
+ :documentation "Toggle stack frame view")
+ (object)
+ (list object))
+
+(define-presentation-to-command-translator eval-in-frame
+ (stack-frame com-eval-in-frame clim-debugger
+ :gesture :edit
+ :documentation "Eval in frame")
(object)
(list object))
@@ -262,15 +524,15 @@
(formatting-cell (pane) (bold (pane) (format t "~A" first))))
(formatting-cell (pane)
(with-text-family (pane family)
- (format t "~A" second)))))
+ (format t "~A" second)))))
(defun display-debugger (frame pane)
(let ((*standard-output* pane))
(formatting-table (pane)
(std-form pane "Condition type:" (type-of-condition (condition-info
- pane)))
+ pane)))
(std-form pane "Description:" (condition-message (condition-info
- pane)))
+ pane)))
(when (condition-extra (condition-info pane))
(std-form pane "Extra:" (condition-extra (condition-info pane))
:family :fix))
@@ -287,9 +549,12 @@
(formatting-table
(pane)
(loop for r in (restarts (condition-info pane))
- do (formatting-row (pane)
+ for rcount from 0
+ do (formatting-row (pane)
(with-output-as-presentation (pane r 'restart)
(formatting-cell (pane)
+ (format pane "~A." rcount))
+ (formatting-cell (pane)
(format pane "~A" (restart-name r)))
(formatting-cell (pane)
@@ -298,8 +563,9 @@
(fresh-line)
(display-backtrace frame pane)
(change-space-requirements pane
- :width (bounding-rectangle-width (stream-output-history pane))
- :height (bounding-rectangle-height (stream-output-history pane)))))
+ :width (bounding-rectangle-width (stream-output-history pane))
+ :height (bounding-rectangle-height (stream-output-history pane))))
+ (highlight-selected-stack-frame pane))
(defun display-backtrace (frame pane)
@@ -311,13 +577,16 @@
(formatting-table
(pane)
(loop for stack-frame in (backtrace (condition-info pane))
- for i from 0
- do (formatting-row (pane)
- (with-output-as-presentation (pane stack-frame 'stack-frame)
- (bold (pane) (formatting-cell (pane) (format t "~A: " i)))
- (formatting-cell (pane)
- (present stack-frame 'stack-frame
- :view (view stack-frame))))))
+ for i from 0
+ do (formatting-row (pane)
+ (with-output-as-presentation (pane stack-frame 'stack-frame)
+ (bold (pane)
+ (formatting-cell (pane) (format t "~A: " i)))
+ (formatting-cell (pane)
+ (setf (gethash stack-frame (presentation-hash-table pane))
+ (present stack-frame 'stack-frame
+ :view (view stack-frame)
+ :single-box t))))))
(when (>= (length (backtrace (condition-info pane))) 20)
(formatting-row (pane)
(formatting-cell (pane))
@@ -325,53 +594,6 @@
(bold (pane)
(present pane 'more-type)))))))
-
-(define-presentation-method present (object (type stack-frame) stream
- (view minimized-stack-frame-view)
- &key acceptably for-context-type)
- (declare (ignore acceptably for-context-type))
- (format t "~A " (frame-string object)))
-
-(define-presentation-method present (object (type stack-frame) stream
- (view maximized-stack-frame-view)
- &key acceptably for-context-type)
- (declare (ignore acceptably for-context-type))
- (progn
- (princ (frame-string object) stream)
- (fresh-line)
- (with-text-family (stream :sans-serif)
- (bold (stream) (format t " Locals:")))
- (fresh-line)
- (format t " ")
- (formatting-table
- (stream)
- (loop for (name n identifier id value val) in (frame-variables object)
- do (formatting-row
- (stream)
- (formatting-cell (stream) (format t "~A" n))
- (formatting-cell (stream) (format t "="))
- (formatting-cell (stream) (present val 'inspect)))))
- (fresh-line)))
-
-(define-presentation-method present (object (type restart) stream
- (view textual-view)
- &key acceptably for-context-type)
- (declare (ignore acceptably for-context-type))
- (bold (stream) (format t "~A" (restart-name object))))
-
-(define-presentation-method present (object (type more-type) stream
- (view textual-view)
- &key acceptably for-context-type)
- (declare (ignore acceptably for-context-type))
- (bold (stream) (format t "--- MORE ---")))
-
-(define-presentation-method present (object (type inspect) stream
- (view textual-view)
- &key acceptably for-context-type)
- (declare (ignore acceptably for-context-type))
- (format t "~A" object))
-
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Starting the debugger ;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -412,4 +634,3 @@
(invoke-debugger
(make-condition 'simple-error
:format-control "Debugger test")))))
-
--
\ Troels "Athas" Henriksen
/\ - Insert witty signature
