Skip to content
Snippets Groups Projects
Commit 97fa6b64 authored by ram's avatar ram
Browse files

Merged in stuff from Bill:

New functionality DEBUG:ARG and DEBUG:VAR, vsource command.
Fixes to frame printing and stuff.
 
parent 1aa9e339
No related branches found
No related tags found
No related merge requests found
......@@ -16,7 +16,9 @@
(in-package "DEBUG")
(export '(internal-debug *in-the-debugger* backtrace *flush-debug-errors*
*debug-print-level* *debug-print-length* *debug-prompt*))
*debug-print-level* *debug-print-length* *debug-prompt*
var arg))
(in-package "LISP")
......@@ -110,6 +112,30 @@ Functions/macros for your enjoyment:
(bp (di:make-breakpoint #'main-hook-function debug-function
(print-frame-call frame))))
(di:activate-breakpoint bp)
(push (create-breakpoint-info debug-function bp 0)
*step-breakpoints*))))))))
;;;; Backtrace:
;;; BACKTRACE -- Public.
;;;
(defun backtrace (&optional (count most-positive-fixnum)
(*standard-output* *debug-io*))
"Show a listing of the call stack going down from the current frame. In the
debugger, the current frame is indicated by the prompt. Count is how many
frames to show."
(let ((*print-length* (or *debug-print-length* *print-length*))
(*print-level* (or *debug-print-level* *print-level*)))
(fresh-line *standard-output*)
(do ((frame (if *in-the-debugger* *current-frame* (di:top-frame))
(di:frame-down frame))
(count count (1- count)))
((or (null frame) (zerop count))
;;; LAMBDA-LIST-ELEMENT-DISPATCH -- Internal.
;;;
;;; This is a convenient way to express what to do for each type of lambda-list
;;; element.
......@@ -132,18 +158,13 @@ Functions/macros for your enjoyment:
(prin1 (di:debug-function-name d-fun))
(dolist (ele args)
(write-char #\space)
(etypecase ele
(di:debug-variable
(print-frame-call-arg ele loc frame))
(cons
(ecase (car ele)
(:optional
(print-frame-call-arg (second ele) loc frame))
(:rest)
(:keyword
(prin1 (second ele))
(write-char #\space)
(print-frame-call-arg (third ele) loc frame))))))
(lambda-list-element-dispatch ele
:required ((print-frame-call-arg ele loc frame))
:optional ((print-frame-call-arg (second ele) loc frame))
:keyword ((prin1 (second ele))
(write-char #\space)
(print-frame-call-arg (third ele) loc frame))
:deleted ((print-frame-call-arg ele loc frame))))
(write-char #\))
(when (di:debug-function-kind d-fun)
(write-string " [")
......@@ -159,7 +180,7 @@ Functions/macros for your enjoyment:
(defun print-frame-call-arg (var location frame)
(cond ((eq var :deleted)
(write-string "<unused-arg>"))
((di:debug-variable-validity var location)
((eq (di:debug-variable-validity var location) :valid)
(prin1 (di:debug-variable-value var frame)))
(t (write-string "<unavailable-arg>"))))
......@@ -222,7 +243,7 @@ Functions/macros for your enjoyment:
(make-unprintable-object "unused-arg")
(di:debug-variable-value var frame)
(make-unprintable-object "unavailable-arg")))
;;;; DEBUG
;;;; INVOKE-DEBUGGER.
;;; PRINT-FRAME-CALL -- Interface
;;;
;;; This prints a representation of the function call causing frame to exist.
......@@ -282,6 +303,148 @@ Functions/macros for your enjoyment:
(names-used '(nil))
(max-name-len 0))
(dolist (restart restarts)
;;;; DEBUG-LOOP.
(when name
(incf max-name-len 3))
(let ((*debug-command-level* (1+ *debug-command-level*))
(*current-frame* (di:top-frame)))
count (- max-name-len 3) name restart)
(push name names-used))))
(incf count)))))
;;; INTERNAL-DEBUG -- Internal Interface.
;;;
;;; This calls DEBUG-LOOP, performing some simple initializations before doing
;;; so. INVOKE-DEBUGGER calls this to actually get into the debugger.
;;; CONDITIONS::ERROR-ERROR calls this in emergencies to get into a debug
;;; prompt as quickly as possible with as little risk as possible for stepping
;;; on whatever is causing recursive errors.
(throw 'debug-loop-catcher nil))
(invoke-debugger condition))))
(funcall *debug-prompt*)
(let* ((exp (read))
(cmd-fun (debug-command-p exp))
;; Must bind level for restart function created by
;; WITH-SIMPLE-RESTART.
(level *debug-command-level*))
(clear-input *debug-io*)
(if cmd-fun
(funcall cmd-fun)
(debug-eval-print exp))))))))))
(when *flush-debug-errors*
;; WITH-SIMPLE-RESTART.
(let ((level *debug-command-level*)
(let* ((values (multiple-value-list (eval -)))
(cond (input
(let ((cmd-fun (debug-command-p
(ext:stream-command-name input)
restart-commands)))
(cond
((not cmd-fun)
(error "Unknown stream-command -- ~S." input))
((consp cmd-fun)
(error "Ambiguous debugger command: ~S." cmd-fun))
(t
(apply cmd-fun (ext:stream-command-args input))))))
(t
(let* ((exp (read))
(cmd-fun (debug-command-p exp restart-commands)))
(cond ((not cmd-fun)
(debug-eval-print exp))
((consp cmd-fun)
(format t "~&Your command, ~S, is ambiguous:~%"
exp)
(dolist (ele cmd-fun)
(format t " ~A~%" ele)))
(t
;;; VARS -- Public.
(:set
`(setf (di:debug-variable-value (car vars) *current-frame*)
,value-var))))
;; If there weren't any exact matches, flame about ambiguity
;; unless all the variables have the same name.
((and (not exact)
(find-if-not
#'(lambda (v)
(string= (di:debug-variable-name v)
(di:debug-variable-name (car vars))))
(cdr vars)))
(error "Specification ambiguous:~%~{ ~A~%~}"
(mapcar #'di:debug-variable-name
(delete-duplicates
vars :test #'string=
:key #'di:debug-variable-name))))
information."
(let* ((vars (etypecase name
(symbol (di:debug-function-symbol-variables
(di:frame-debug-function *current-frame*)
name))
(simple-string (di:ambiguous-debug-variables
(di:frame-debug-function *current-frame*)
name))))
(location (di:frame-code-location *current-frame*)))
(declare (list vars))
(setf vars
(remove-if-not #'(lambda (v)
(eq (di:debug-variable-validity v location) :valid))
vars))
(cond ((null vars)
(error "No known valid variables match ~S." name))
((= (length vars) 1)
(di:debug-variable-value (car vars) *current-frame*))
((find-if-not #'(lambda (v)
(string= (di:debug-variable-name v)
(di:debug-variable-name (car vars))))
vars)
(error "Specification ambiguous:~%~{ ~A~%~}"
(mapcar #'di:debug-variable-name
(delete-duplicates vars
:test #'string=
:key #'di:debug-variable-name))))
(id-supplied
(let ((v (find id vars :key #'di:debug-variable-id)))
(unless v
(error "Invalid variable ID, ~D, should have been one of ~S."
id (mapcar #'di:debug-variable-id vars)))
(di:debug-variable-value v *current-frame*)))
(t
(error "Specify variable id to disambiguate ~S. Use one of ~S."
name (mapcar #'di:debug-variable-id vars))))))
id (mapcar #'di:debug-variable-id vars)))
'(di:debug-variable-value v *current-frame*))
(:set
`(setf (di:debug-variable-value v *current-frame*)
,value-var)))))
argument in a frame's default printed representation. Keyword/value pairs
count as one."
(let* ((lambda-list (handler-case (di:debug-function-lambda-list
(di:frame-debug-function *current-frame*))
(di:lambda-list-unavailable ()
(error "No argument values are available."))))
(rest-pos (position-if #'(lambda (x)
(and (consp x) (eq (car x) :rest)))
lambda-list))
(arg (car (nthcdr (if (and rest-pos (<= rest-pos n))
(1+ n)
n)
lambda-list))))
(flet ((variable-value-if-valid (var frame)
(cond ((eq var :deleted)
(error "Unused arguments have no values."))
((eq (di:debug-variable-validity
var (di:frame-code-location frame))
:valid)
(di:debug-variable-value var frame))
(t (error "Invalid argument value.")))))
(lambda-list-element-dispatch arg
:required ((variable-value-if-valid arg *current-frame*))
:optional ((variable-value-if-valid (second arg) *current-frame*))
:keyword ((variable-value-if-valid (third arg) *current-frame*))
:deleted ((variable-value-if-valid arg *current-frame*))))))
(di:debug-variable-value var *current-frame*)
var)))
;;; NTH-ARG -- Internal.
;;;
......@@ -394,6 +557,12 @@ Functions/macros for your enjoyment:
(unless any-p (write-line "No variable information available."))))
(def-debug-command-alias "PP" "VPRINT")
(def-debug-command "SOURCE"
(print-frame-source-form *current-frame* (read-if-available 0)))
(*print-length* (or *debug-print-length* *print-level*))
(def-debug-command "VSOURCE"
(print-frame-source-form *current-frame* (read-if-available 0) t))
d-fun
(defun print-frame-source-form (frame context &optional verbose)
(let* ((location (di:frame-code-location *current-frame*))
(format t "~A~:[#~D~;~*~] = ~S~%"
(di:debug-variable-name v)
......@@ -408,15 +577,14 @@ Functions/macros for your enjoyment:
location))
(char-offset (aref (di:debug-source-start-positions
d-source)
tlf-offset))
(context (read-if-available 0)))
tlf-offset)))
(with-open-file (f name)
(file-position f char-offset)
(let* ((tlf (read f))
(translations (di:form-number-translations
tlf tlf-offset))
(*print-level* *debug-print-level*)
(*print-length* *debug-print-length*))
(*print-level* (if verbose nil *debug-print-level*))
(*print-length* (if verbose nil *debug-print-length*)))
(print (di:source-path-context
tlf
(svref translations
......@@ -450,54 +618,6 @@ Functions/macros for your enjoyment:
(setf *breakpoints*
(sort *breakpoints* #'< :key #'breakpoint-info-breakpoint-number))
(dolist (info *breakpoints*)
;;;; DEBUG-LOOP.
(defun debug-loop ()
(let ((*debug-command-level* (1+ *debug-command-level*))
(*current-frame* (di:top-frame)))
(handler-bind ((di:debug-condition #'(lambda (condition)
(princ condition *debug-io*)
(throw 'debug-loop-catcher nil))))
(print-frame-call *current-frame*)
(loop
(catch 'debug-loop-catcher
(handler-bind ((error #'(lambda (condition)
(when *flush-debug-errors*
(clear-input *debug-io*)
(princ condition)
(format t "~&Error flushed ...")
(throw 'debug-loop-catcher nil))
(invoke-debugger condition))))
(funcall *debug-prompt*)
(let* ((exp (read))
(cmd-fun (debug-command-p exp))
;; Must bind level for restart function created by
;; WITH-SIMPLE-RESTART.
(level *debug-command-level*))
(with-simple-restart (abort "Return to debug level ~D." level)
(if cmd-fun
(funcall cmd-fun)
(debug-eval-print exp))))))))))
(defun debug-eval-print (exp)
(setq +++ ++ ++ + + - - exp)
(let* ((values (multiple-value-list (eval -)))
(*standard-output* *debug-io*))
(fresh-line)
(if values (prin1 (car values)))
(dolist (x (cdr values))
(fresh-line)
(prin1 x))
(setq /// // // / / values)
(setq *** ** ** * * (car values))
;; Make sure nobody passes back an unbound marker.
(unless (boundp '*)
(setq * nil)
(fresh-line)
(princ "Setting * to NIL -- was unbound marker."))))
(print-breakpoint-info info)))
(def-debug-command-alias "LB" "LIST-BREAKPOINTS")
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment