Skip to content
Snippets Groups Projects
Commit 158b38fc authored by ram's avatar ram
Browse files

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.
parent ee750fd3
No related branches found
No related tags found
No related merge requests found
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman (FAHLMAN@CMUC). ;;; 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 ;;; CMU Common Lisp Debugger. This is a very basic command-line oriented
;;; debugger. ;;; debugger.
...@@ -32,10 +32,12 @@ ...@@ -32,10 +32,12 @@
;;; Used to communicate to debug-loop that we are at a step breakpoint. ;;; Used to communicate to debug-loop that we are at a step breakpoint.
;;; ;;;
(define-condition step-condition (simple-condition)) (define-condition step-condition (simple-condition))
"*Print-level* is bound to this value when debug prints a function call.")
;;;; Variables, parameters, and constants. ;;;; 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*") null, use *PRINT-LEVEL*")
(defparameter *debug-print-length* 5 (defparameter *debug-print-length* 5
...@@ -73,7 +75,6 @@ ...@@ -73,7 +75,6 @@
;;; A list of breakpoint-info structures of the made and active step ;;; A list of breakpoint-info structures of the made and active step
;;; breakpoints. ;;; breakpoints.
PUSH rebinds things in another command level. Good for hide/show.
ABORT returns to the previous abort restart case. ABORT returns to the previous abort restart case.
;;; ;;;
(defvar *step-breakpoints* nil) (defvar *step-breakpoints* nil)
...@@ -111,8 +112,8 @@ ...@@ -111,8 +112,8 @@
(dolist (code-location next-code-locations) (dolist (code-location next-code-locations)
(let ((bp-info (location-in-list code-location *breakpoints*))) (let ((bp-info (location-in-list code-location *breakpoints*)))
(di:deactivate-breakpoint (breakpoint-info-breakpoint bp-info)))) (di:deactivate-breakpoint (breakpoint-info-breakpoint bp-info))))
(let ((*print-length* *debug-print-length*) (let ((bp (di:make-breakpoint #'main-hook-function code-location
(*print-level* *debug-print-level*)) :kind :code-location)))
(di:activate-breakpoint bp) (di:activate-breakpoint bp)
(push (create-breakpoint-info code-location bp 0) (push (create-breakpoint-info code-location bp 0)
*step-breakpoints*)))) *step-breakpoints*))))
...@@ -167,8 +168,10 @@ ...@@ -167,8 +168,10 @@
keyword deleted) keyword deleted)
`(etypecase ,element `(etypecase ,element
(defun print-frame-call (frame &optional (defun print-frame-call (frame &optional
(*print-length* *debug-print-length*) (*print-length* (or *debug-print-length*
(*print-level* *debug-print-level*) *print-length*))
(*print-level* (or *debug-print-level*
*print-level*))
(verbosity 1)) (verbosity 1))
(ecase verbosity (ecase verbosity
(0 (print frame)) (0 (print frame))
...@@ -564,9 +567,6 @@ ...@@ -564,9 +567,6 @@
(setf *current-frame* (setf *current-frame*
(do ((prev *current-frame* lead) (do ((prev *current-frame* lead)
(def-debug-command "PUSH"
(invoke-debugger *debug-condition*))
(def-debug-command "ABORT" (def-debug-command "ABORT"
;; There's always at least one abort restart due to the top-level one. ;; There's always at least one abort restart due to the top-level one.
(invoke-restart *debug-abort*)) (invoke-restart *debug-abort*))
...@@ -623,27 +623,34 @@ ...@@ -623,27 +623,34 @@
(def-debug-command "L" (def-debug-command "L"
(setf end len) (setf end len)
(return)) (return))
(let ((*print-level* *debug-print-level*) ((or (zerop (decf count)) (= end len))
(*print-length* *debug-print-length*) (return))))
(write-string debug-help-string *standard-output* (write-string debug-help-string *standard-output*
:start start :end end)) :start start :end end))
(when (= end len) (return))
(format t "~%[RETURN FOR MORE, Q TO QUIT HELP TEXT]: ") (format t "~%[RETURN FOR MORE, Q TO QUIT HELP TEXT]: ")
(force-output) (force-output)
(di:do-debug-function-variables (v d-fun) (let ((res (read-line)))
(when (or (string= res "q") (string= res "Q"))
(cond ((eq (di:debug-variable-validity v location) :valid) (return))))))
(setf any-valid-p t)
(format t "~A~:[#~D~;~*~] = ~S~%" (def-debug-command-alias "?" "HELP")
(di:debug-variable-name v)
(zerop (di:debug-variable-id v)) (def-debug-command "ERROR" ()
(di:debug-variable-id v) (format t "~A~%" *debug-condition*)
(di:debug-variable-value v *current-frame*))) (show-restarts *debug-restarts*))
(t #|(format t "~A has an invalid value currently.~%"
(di:debug-variable-name v))|#))) (def-debug-command "BACKTRACE" ()
(cond ((not any-p) (backtrace (read-if-available most-positive-fixnum)))
(write-line "No local variables in function."))
((not any-valid-p) (def-debug-command "PRINT" ()
(write-line "All variables currently have invalid values.")))) (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-alias "PP" "VPRINT")
(def-debug-command "SOURCE" (def-debug-command "SOURCE"
...@@ -662,14 +669,14 @@ ...@@ -662,14 +669,14 @@
(zerop (di:debug-variable-id v)) (zerop (di:debug-variable-id v))
(di:debug-variable-id v) (di:debug-variable-id v)
(di:debug-variable-value v *current-frame*)))) (di:debug-variable-value v *current-frame*))))
(:lisp
(print-frame-source (cond
name ;the top-level form ((not any-p)
0 ;top-level form offset is always zero when we have it in hand. (format t "No local variables ~@[starting with ~A ~]~
location context verbose)) in function."
(:stream prefix))
(format t "~%Source extracted from some stream. Sorry.")))))
((not any-valid-p) ((not any-valid-p)
(format t "All variables ~@[starting with ~A ~]currently ~ (format t "All variables ~@[starting with ~A ~]currently ~
have invalid values." have invalid values."
prefix)))) prefix))))
...@@ -702,8 +709,9 @@ ...@@ -702,8 +709,9 @@
(pushnew #'(lambda () (pushnew #'(lambda ()
(let* ((tlf-offset (di:code-location-top-level-form-offset (let* ((tlf-offset (di:code-location-top-level-form-offset
location)) location))
(char-offset (aref (di:debug-source-start-positions (char-offset (aref (or (di:debug-source-start-positions
d-source) d-source)
;;; We also cache the last top-level form that we printed a source for so that
tlf-offset))) tlf-offset)))
;;; ;;;
(defvar *cached-top-level-form-offset* nil) (defvar *cached-top-level-form-offset* nil)
...@@ -725,8 +733,12 @@ ...@@ -725,8 +733,12 @@
(values *cached-form-number-translations* *cached-top-level-form*) (values *cached-form-number-translations* *cached-top-level-form*)
(let ((translations (di:form-number-translations (let ((translations (di:form-number-translations
tlf tlf-offset)) tlf tlf-offset))
(*print-level* (if verbose nil *debug-print-level*)) (*print-level* (if verbose
(*print-length* (if verbose nil *debug-print-length*))) (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) (setq *cached-top-level-form-offset* offset)
(values (setq *cached-form-number-translations* (values (setq *cached-form-number-translations*
(svref translations (svref translations
...@@ -738,8 +750,9 @@ ...@@ -738,8 +750,9 @@
(setup-function-start () (setup-function-start ()
(let ((code-loc (di:debug-function-start-location place))) (let ((code-loc (di:debug-function-start-location place)))
(def-debug-command "FLUSH" (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 (when old-bp-info
(di:deactivate-breakpoint (breakpoint-info-breakpoint old-bp-info)) (di:deactivate-breakpoint (breakpoint-info-breakpoint old-bp-info))
(setf *breakpoints* (remove old-bp-info *breakpoints*)) (setf *breakpoints* (remove old-bp-info *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