From 158b38fc15ef4afa89b4625ec1d8f46e3c57336e Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Thu, 11 Oct 1990 18:05:21 +0000 Subject: [PATCH] Made *debug-print-XXX* go to *print-XXX* if they are NIL. Flushed "push" command. Made "l" command accept a prefix of the variables to print. Made source commands die more gracefully if there is no d-s-start-positions. Made source commands understand the new :STREAM debug-info format. Made "flush" print whether it turned flushing on or off. --- code/debug.lisp | 95 ++++++++++++++++++++++++++++--------------------- 1 file changed, 54 insertions(+), 41 deletions(-) diff --git a/code/debug.lisp b/code/debug.lisp index ea63062ff..f616e758c 100644 --- a/code/debug.lisp +++ b/code/debug.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug.lisp,v 1.11 1990/10/04 19:19:03 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug.lisp,v 1.12 1990/10/11 18:05:21 ram Exp $ ;;; ;;; CMU Common Lisp Debugger. This is a very basic command-line oriented ;;; debugger. @@ -32,10 +32,12 @@ ;;; Used to communicate to debug-loop that we are at a step breakpoint. ;;; (define-condition step-condition (simple-condition)) - "*Print-level* is bound to this value when debug prints a function call.") + + ;;;; Variables, parameters, and constants. - "*Print-length* is bound to this value when debug prints a function call.") +(defparameter *debug-print-level* 3 + "*PRINT-LEVEL* is bound to this value when debug prints a function call. If null, use *PRINT-LEVEL*") (defparameter *debug-print-length* 5 @@ -73,7 +75,6 @@ ;;; A list of breakpoint-info structures of the made and active step ;;; breakpoints. - PUSH rebinds things in another command level. Good for hide/show. ABORT returns to the previous abort restart case. ;;; (defvar *step-breakpoints* nil) @@ -111,8 +112,8 @@ (dolist (code-location next-code-locations) (let ((bp-info (location-in-list code-location *breakpoints*))) (di:deactivate-breakpoint (breakpoint-info-breakpoint bp-info)))) - (let ((*print-length* *debug-print-length*) - (*print-level* *debug-print-level*)) + (let ((bp (di:make-breakpoint #'main-hook-function code-location + :kind :code-location))) (di:activate-breakpoint bp) (push (create-breakpoint-info code-location bp 0) *step-breakpoints*)))) @@ -167,8 +168,10 @@ keyword deleted) `(etypecase ,element (defun print-frame-call (frame &optional - (*print-length* *debug-print-length*) - (*print-level* *debug-print-level*) + (*print-length* (or *debug-print-length* + *print-length*)) + (*print-level* (or *debug-print-level* + *print-level*)) (verbosity 1)) (ecase verbosity (0 (print frame)) @@ -564,9 +567,6 @@ (setf *current-frame* (do ((prev *current-frame* lead) -(def-debug-command "PUSH" - (invoke-debugger *debug-condition*)) - (def-debug-command "ABORT" ;; There's always at least one abort restart due to the top-level one. (invoke-restart *debug-abort*)) @@ -623,27 +623,34 @@ (def-debug-command "L" (setf end len) (return)) - (let ((*print-level* *debug-print-level*) - (*print-length* *debug-print-length*) + ((or (zerop (decf count)) (= end len)) + (return)))) (write-string debug-help-string *standard-output* :start start :end end)) + (when (= end len) (return)) (format t "~%[RETURN FOR MORE, Q TO QUIT HELP TEXT]: ") (force-output) - (di:do-debug-function-variables (v d-fun) - - (cond ((eq (di:debug-variable-validity v location) :valid) - (setf any-valid-p t) - (format t "~A~:[#~D~;~*~] = ~S~%" - (di:debug-variable-name v) - (zerop (di:debug-variable-id v)) - (di:debug-variable-id v) - (di:debug-variable-value v *current-frame*))) - (t #|(format t "~A has an invalid value currently.~%" - (di:debug-variable-name v))|#))) - (cond ((not any-p) - (write-line "No local variables in function.")) - ((not any-valid-p) - (write-line "All variables currently have invalid values.")))) + (let ((res (read-line))) + (when (or (string= res "q") (string= res "Q")) + (return)))))) + +(def-debug-command-alias "?" "HELP") + +(def-debug-command "ERROR" () + (format t "~A~%" *debug-condition*) + (show-restarts *debug-restarts*)) + +(def-debug-command "BACKTRACE" () + (backtrace (read-if-available most-positive-fixnum))) + +(def-debug-command "PRINT" () + (print-frame-call *current-frame*)) + +(def-debug-command-alias "P" "PRINT") + + (format t "All variables ~@[starting with ~A~ ]currently ~ + (print-frame-call *current-frame* :print-level nil :print-length nil + :verbosity (read-if-available 2))) (def-debug-command-alias "PP" "VPRINT") (def-debug-command "SOURCE" @@ -662,14 +669,14 @@ (zerop (di:debug-variable-id v)) (di:debug-variable-id v) (di:debug-variable-value v *current-frame*)))) - (:lisp - (print-frame-source - name ;the top-level form - 0 ;top-level form offset is always zero when we have it in hand. - location context verbose)) - (:stream - (format t "~%Source extracted from some stream. Sorry."))))) + + (cond + ((not any-p) + (format t "No local variables ~@[starting with ~A ~]~ + in function." + prefix)) ((not any-valid-p) + (format t "All variables ~@[starting with ~A ~]currently ~ have invalid values." prefix)))) @@ -702,8 +709,9 @@ (pushnew #'(lambda () (let* ((tlf-offset (di:code-location-top-level-form-offset location)) - (char-offset (aref (di:debug-source-start-positions - d-source) + (char-offset (aref (or (di:debug-source-start-positions + d-source) +;;; We also cache the last top-level form that we printed a source for so that tlf-offset))) ;;; (defvar *cached-top-level-form-offset* nil) @@ -725,8 +733,12 @@ (values *cached-form-number-translations* *cached-top-level-form*) (let ((translations (di:form-number-translations tlf tlf-offset)) - (*print-level* (if verbose nil *debug-print-level*)) - (*print-length* (if verbose nil *debug-print-length*))) + (*print-level* (if verbose + (res + (ecase (di:debug-source-from d-source) + (:file (get-file-top-level-form location)) + ((:lisp :stream) + (svref (di:debug-source-name d-source) offset))))) (setq *cached-top-level-form-offset* offset) (values (setq *cached-form-number-translations* (svref translations @@ -738,8 +750,9 @@ (setup-function-start () (let ((code-loc (di:debug-function-start-location place))) (def-debug-command "FLUSH" - (setf *flush-debug-errors* (not *flush-debug-errors*))) - + :kind :function-start)) + (setf break (di:preprocess-for-eval break code-loc)) + (write-line "Errors now not flushed."))) (when old-bp-info (di:deactivate-breakpoint (breakpoint-info-breakpoint old-bp-info)) (setf *breakpoints* (remove old-bp-info *breakpoints*)) -- GitLab