Skip to content
Snippets Groups Projects
Commit 4b2ff8cd authored by wlott's avatar wlott
Browse files

Added rudiments of *current-code-location* support. Added ``DESCRIBE''

debugger command.
parent f4d1e1ff
No related branches found
No related tags found
No related merge requests found
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug.lisp,v 1.26 1992/02/14 23:44:34 wlott Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug.lisp,v 1.27 1992/03/10 15:21:11 wlott Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -52,6 +52,7 @@ ...@@ -52,6 +52,7 @@
(defvar *in-the-debugger* nil (defvar *in-the-debugger* nil
"If this is bound before the debugger is invoked, it is used as the stack "If this is bound before the debugger is invoked, it is used as the stack
top by the debugger.")
(defvar *stack-top* nil) (defvar *stack-top* nil)
;;;; Breakpoint state: ;;;; Breakpoint state:
...@@ -323,8 +324,9 @@ ...@@ -323,8 +324,9 @@
(setf max-name-len len)))))) (setf max-name-len len))))))
(unless (zerop max-name-len) (unless (zerop max-name-len)
(incf max-name-len 3)) (incf max-name-len 3))
(let ((*debug-command-level* (1+ *debug-command-level*)) (dolist (restart restarts)
(*current-frame* (di:top-frame))) (*current-frame* (di:top-frame))
(format s "~& ~2D: [~VA] ~A~%"
count (- max-name-len 3) name restart) count (- max-name-len 3) name restart)
(push name names-used)))) (push name names-used))))
(incf count))))) (incf count)))))
...@@ -632,35 +634,47 @@ ...@@ -632,35 +634,47 @@
;; Return the right value. ;; Return the right value.
(cond ((not res) nil) (cond ((not res) nil)
((= (length res) 1) ((= (length res) 1)
(if next (cdar res))
(print-frame-call (setf *current-frame* next)) (t ;Just return the names.
(format t "~&Top of stack.")))) (do ((cmds res (cdr cmds)))
((not cmds) res)
(setf (car cmds) (caar cmds))))))))
;;; ;;;
;;; Returns a list of debug commands (in the same format as *debug-commands*) ;;; Returns a list of debug commands (in the same format as *debug-commands*)
(if next ;;; that invoke each active restart.
(print-frame-call (setf *current-frame* next)) ;;;
(format t "~&Bottom of stack.")))) ;;; Two commands are made for each restart: one for the number, and one for
;;; the restart name (unless it's been shadowed by an earlier restart of the
;;; same name.
;;;
(defun make-restart-commands (&optional (restarts *debug-restarts*)) (defun make-restart-commands (&optional (restarts *debug-restarts*))
(let ((commands)
(num 0)) ; better be the same as show-restarts!
(dolist (restart restarts) (dolist (restart restarts)
(print-frame-call (let ((name (string (restart-name restart))))
(setf *current-frame* (unless (find name commands :key #'car :test #'string=)
(do ((prev *current-frame* lead) (let ((restart-fun
(lead (di:frame-up *current-frame*) (di:frame-up lead))) #'(lambda ()
((null lead) prev))))) (invoke-restart-interactively restart))))
(push (cons name restart-fun) commands)
(push (cons (format nil "~d" num) restart-fun) commands)))) (push (cons (format nil "~d" num) restart-fun) commands))))
(incf num)) (incf num))
(print-frame-call commands))
(setf *current-frame*
(do ((prev *current-frame* lead)
(lead (di:frame-down *current-frame*) (di:frame-down lead))) ;;;
((null lead) prev))))) ;;; Frame changing commands.
;;;
(def-debug-command "UP" ()
(let ((next (di:frame-up *current-frame*))) (let ((next (di:frame-up *current-frame*)))
(cond (next (cond (next
(setf *current-frame* next) (setf *current-frame* next)
(print-frame-call next)) (print-frame-call next))
(t (t
(format t "~&Top of stack.")))))
(def-debug-command "DOWN" () (def-debug-command "DOWN" ()
(let ((next (di:frame-down *current-frame*))) (let ((next (di:frame-down *current-frame*)))
...@@ -809,16 +823,22 @@ ...@@ -809,16 +823,22 @@
(def-debug-command-alias "PP" "VPRINT") (def-debug-command-alias "PP" "VPRINT")
(print-frame-source-form *current-frame* (read-if-available 0))) (def-debug-command "LIST-LOCALS" ()
(let ((d-fun (di:frame-debug-function *current-frame*)))
(if (di:debug-variable-info-available d-fun)
(let ((*print-level* (or *debug-print-level* *print-level*))
(*print-length* (or *debug-print-length* *print-level*)) (*print-length* (or *debug-print-length* *print-level*))
(*standard-output* *debug-io*) (*standard-output* *debug-io*)
(print-frame-source-form *current-frame* (read-if-available 0) t)) (location (di:frame-code-location *current-frame*))
(prefix (read-if-available nil))
(any-p nil)
(any-valid-p nil))
(dolist (v (di:ambiguous-debug-variables
d-fun d-fun
(if prefix (string prefix) "")))
;;; PRINT-FRAME-SOURCE-FORM -- Internal.
(setf any-p t) (setf any-p t)
(defun print-frame-source-form (frame context &optional verbose) (when (eq (di:debug-variable-validity v location) :valid)
(let* ((location (maybe-block-start-location (di:frame-code-location frame))) (setf any-valid-p t)
(format t "~A~:[#~D~;~*~] = ~S~%" (format t "~A~:[#~D~;~*~] = ~S~%"
(di:debug-variable-name v) (di:debug-variable-name v)
(zerop (di:debug-variable-id v)) (zerop (di:debug-variable-id v))
...@@ -907,6 +927,17 @@ ...@@ -907,6 +927,17 @@
(setf break (di:preprocess-for-eval break code-loc)) (setf break (di:preprocess-for-eval break code-loc))
(setf condition (di:preprocess-for-eval condition code-loc)) (setf condition (di:preprocess-for-eval condition code-loc))
(dolist (form print) (dolist (form print)
(push (cons (di:preprocess-for-eval form code-loc) form)
print-functions))))
(setup-function-end ()
(setf bp
(di:make-breakpoint #'main-hook-function place
:kind :function-end))
(setf break
(coerce `(lambda (dummy)
(declare (ignore dummy)) ,break)
'function))
(setf condition (coerce `(lambda (dummy)
(declare (ignore dummy)) ,condition) (declare (ignore dummy)) ,condition)
'function)) 'function))
(dolist (form print) (dolist (form print)
...@@ -917,7 +948,8 @@ ...@@ -917,7 +948,8 @@
print-functions))) print-functions)))
(setup-code-location () (setup-code-location ()
(setf place (nth index *possible-breakpoints*)) (setf place (nth index *possible-breakpoints*))
(di:frame-code-location *current-frame*))) (setf bp (di:make-breakpoint #'main-hook-function place
:kind :code-location))
(dolist (form print) (dolist (form print)
(push (cons (push (cons
(di:preprocess-for-eval form place) (di:preprocess-for-eval form place)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment