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