From 97fa6b64e1c9adc136ae922dfd7fb39946331c3b Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Mon, 23 Apr 1990 16:24:12 +0000 Subject: [PATCH] Merged in stuff from Bill: New functionality DEBUG:ARG and DEBUG:VAR, vsource command. Fixes to frame printing and stuff. --- code/debug.lisp | 254 +++++++++++++++++++++++++++++++++++------------- 1 file changed, 187 insertions(+), 67 deletions(-) diff --git a/code/debug.lisp b/code/debug.lisp index 6ee94d950..02309b252 100644 --- a/code/debug.lisp +++ b/code/debug.lisp @@ -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") -- GitLab