Skip to content
Snippets Groups Projects
Commit f99de75d authored by chiles's avatar chiles
Browse files

Added CLEAR-TRACE-BREAKPOINT-RECORD to ext:*setf-fdefinition-hook*.

Fixed package system, so the old TRACE and new one didn't conflict with
variable names.

Added debug:*trace-frame* to support users who want to enter expressions for
evaluation in the frame.  This is described in the TRACE doc string.

Fixed TRACE interface to support any function name, not just symbols.
Underlying support allowed this, but TRACE complained when it inspected its
arguments.

Added full support for documented interface of TRACE since before it only
allowed users to see arguments and output without conditionalization, printing,
etc.
parent 53adbe16
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/ntrace.lisp,v 1.1 1991/10/13 14:29:30 chiles Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/ntrace.lisp,v 1.2 1991/11/03 17:21:16 chiles Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -20,30 +20,37 @@ ...@@ -20,30 +20,37 @@
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
(in-package "DEBUG") (in-package "LISP")
;;; BECAUSE SOMEONE SLOPPILY MADE THE "DEBUG" PACKAGE USE "EXT", I HAVE TO BEND (export '(trace untrace))
;;; OVER BACKWARDS NOW TO PREVENT STEPPING ON STUFF EXPORTED BY THE OLD TRACE
;;; CODE FROM "EXT". THAT'S WHY THERE ARE ALL THE FUNNY NAMES. NO, I DON'T
;;; FEEL LIKE CLEANING UP THE "DEBUG" PACKAGE ONCE AGAIN. (in-package "DEBUG")
;;;
(export '(*n-trace-print-level* *n-trace-print-length* *n-traced-function-list* (export '(*trace-print-level* *trace-print-length* *traced-function-list*
n-trace n-untrace)) *trace-frame* *max-trace-indentation*))
(defvar *n-traced-function-list* () (defvar *traced-function-list* nil
"A list of function names which are traced.") "A list of function names which are traced.")
(defvar *n-trace-print-length* () (defvar *trace-print-length* nil
"*Print-length* will be bound to this value when trace is printing.") "Tracing output occurs with *print-length* bound to this value.")
(defvar *trace-print-level* nil
"Tracing output occurs with *print-level* bound to this value.")
(defvar *n-trace-print-level* () (defvar *trace-frame* nil
"*Print-level* will be bound to this value when trace is printing.") "TRACE causes expressions for its switches to evaluate within a context
where this is bound to the appropriate control stack frame.")
(defvar *max-trace-indentation* nil
"This is currently unused.")
;;;; TRACE. ;;;; TRACE.
(eval-when (compile eval)
;;; WITH-KEYWORDS -- Internal. ;;; WITH-KEYWORDS -- Internal.
;;; ;;;
;;; This takes an options list of the following form: ;;; This takes an options list of the following form:
...@@ -62,11 +69,14 @@ ...@@ -62,11 +69,14 @@
key-list) key-list)
,@body)) ,@body))
;;; N-TRACE -- Public. ) ;EVAL-WHEN
;;; TRACE -- Public.
;;; ;;;
(defmacro n-trace (&rest specs) (defmacro trace (&rest specs)
"Establishes tracing for specified functions and pushes their names on "Establishes tracing for specified functions and pushes their names on
*n-traced-function-list*. Each specification is either the name of a function *traced-function-list*. Each specification is either the name of a function
or a list of the form: or a list of the form:
(function-name <trace-option> <value> <trace-option> <value> ...) (function-name <trace-option> <value> <trace-option> <value> ...)
If you supply no specifications, TRACE returns the list of traced functions. If you supply no specifications, TRACE returns the list of traced functions.
...@@ -87,9 +97,15 @@ ...@@ -87,9 +97,15 @@
:print-after :print-after
Like :print, but takes effect after the call. Like :print, but takes effect after the call.
:print-all :print-all
Like :print, but takes effect before and after the call." Like :print, but takes effect before and after the call.
While the provided expression evaluate, debug:*trace-frame* is bound to the
appropriate frame for accessing locals of the TRACE'd function. Therefore,
you can use DI:PREPROCESS-FOR-EVAL (and DI:DEBUG-FUNCTION-START-LOCATION if
necessary) and with its resulting function, provide an expression including
a FUNCALL of the function and debug:*trace-frame*."
(cond (cond
((not specs) '*n-traced-function-list*) ((not specs) '*traced-function-list*)
(t (t
(let ((name-list nil) (let ((name-list nil)
(trace-1-forms nil)) (trace-1-forms nil))
...@@ -104,11 +120,16 @@ ...@@ -104,11 +120,16 @@
(symbol (symbol
(values spec nil)) (values spec nil))
(list (list
(unless (symbolp (car spec)) (let ((fun (car spec)))
(error "Illegal function name: ~S." (car spec))) (cond ((eq fun 'quote)
(when (eq (car spec) 'quote) (error "Do NOT quote function names."))
(error "I bet you don't want to trace QUOTE.")) ((symbolp fun)
(values (car spec) (cdr spec))) (values fun (cdr spec)))
((not (and (consp fun) (= (length fun) 2)))
(error "Illegal function name: ~S." fun))
((eq (car fun) 'setf)
(values fun (cdr spec)))
(t (error "Illegal function name: ~S." fun)))))
(t (error "Illegal trace spec: ~S." spec))) (t (error "Illegal trace spec: ~S." spec)))
(push name name-list) (push name name-list)
(with-keywords options (with-keywords options
...@@ -130,7 +151,10 @@ ...@@ -130,7 +151,10 @@
(null nil) (null nil)
(symbol (list wherein)) (symbol (list wherein))
(list (dolist (fun wherein wherein) (list (dolist (fun wherein wherein)
(unless (symbolp fun) (unless (or (symbolp fun)
(and (consp fun)
(= (length fun) 2)
(eq (car fun) 'setf)))
(error "Illegal function name, ~S, in :wherein." (error "Illegal function name, ~S, in :wherein."
fun)))) fun))))
(t (error "Illegal :wherein option: ~S." wherein)))) (t (error "Illegal :wherein option: ~S." wherein))))
...@@ -139,7 +163,7 @@ ...@@ -139,7 +163,7 @@
(error "Illegal form list, ~S, for :print." print)) (error "Illegal form list, ~S, for :print." print))
(unless (listp print-after) (unless (listp print-after)
(error "Illegal form list, ~S, for :print-after." print-after)) (error "Illegal form list, ~S, for :print-after." print-after))
(push `(n-trace-1 ',name ',condition ',break ',break-after (push `(trace-1 ',name ',condition ',break ',break-after
',wherein ',print ',print-after) ',wherein ',print ',print-after)
trace-1-forms)))))))) trace-1-forms))))))))
...@@ -162,46 +186,101 @@ ...@@ -162,46 +186,101 @@
;;; can get rid of them in UNTRACE-1. ;;; can get rid of them in UNTRACE-1.
;;; ;;;
(defvar *trace-breakpoints* (make-hash-table :test #'eq)) (defvar *trace-breakpoints* (make-hash-table :test #'eq))
;;;
(defun clear-trace-breakpoint-record (fname new-value)
(declare (ignore new-value))
(let ((bpts (gethash fname *trace-breakpoints*)))
(when bpts
;; Free breakpoint bookkeeping data.
(di:delete-breakpoint (car bpts))
(di:delete-breakpoint (cdr bpts))
;; Free TRACE bookkeeping data.
(setf (gethash fname *trace-breakpoints*) nil))))
;;;
(push #'clear-trace-breakpoint-record ext:*setf-fdefinition-hook*)
;;; N-TRACE-1 -- Internal. ;;; TRACE-1 -- Internal.
;;; ;;;
;;; This establishes :function-start and :function-end breakpoints with ;;; This establishes :function-start and :function-end breakpoints with
;;; appropriate hook functions to TRACE function-name as described by the user. ;;; appropriate hook functions to TRACE function-name as described by the user.
;;; ;;;
(defun n-trace-1 (function-name condition break break-after wherein print (defun trace-1 (function-name condition break break-after where-in print
print-after) print-after)
(declare (ignore condition break break-after wherein print print-after))
(cond (cond
((member function-name *n-traced-function-list*) ((member function-name *traced-function-list*)
(warn "Function ~S already TRACE'd, ignoring this request." (warn "Function ~S already TRACE'd, ignoring this request."
function-name)) function-name))
(t (t
(when where-in
(dolist (f where-in)
(unless (fboundp f)
(error "Undefined :where-in name -- ~S." f))))
(let* ((debug-fun (di:function-debug-function (fdefinition function-name))) (let* ((debug-fun (di:function-debug-function (fdefinition function-name)))
(start (di:make-breakpoint #'print-trace-start ;; The start and end hooks use conditionp for communication.
debug-fun (conditionp nil)
:kind :function-start)) (start (di:make-breakpoint
(end (di:make-breakpoint #'print-trace-end #'(lambda (frame bpt)
debug-fun (let ((*trace-frame* frame))
:kind :function-end (cond ((and (or (not condition) ;Save a call to EVAL
:function-end-cookie (eval condition))
#'(lambda (x) (push x *traced-entries*))))) (or (not where-in)
(trace-where-in-p frame where-in)))
(setf conditionp t)
(print-trace-start frame bpt print))
(t (setf conditionp nil)))
(when (and break (eval break))
(break "Breaking before TRACE'd call to ~S."
(di:debug-function-name
(di:frame-debug-function frame))))))
debug-fun :kind :function-start))
(end (di:make-breakpoint
#'(lambda (frame bpt values cookie)
(let ((*trace-frame* frame))
(when conditionp
(print-trace-end frame bpt values cookie print-after))
(pop *traced-entries*)
(when (and break-after (eval break-after))
(break "Breaking after TRACE'd call to ~S."
(di:debug-function-name
(di:frame-debug-function frame))))))
debug-fun :kind :function-end
:function-end-cookie
#'(lambda (frame x)
(when (and *traced-entries*
(not (di:function-end-cookie-valid-p
frame (car *traced-entries*))))
(format t "~&WARNING: dynamic flow of control occurred ~
while TRACE'ing.~%")
(loop
(pop *traced-entries*)
(when (or (not *traced-entries*)
(di:function-end-cookie-valid-p
frame (car *traced-entries*)))
(return))))
(push x *traced-entries*)))))
(setf (gethash function-name *trace-breakpoints*) (cons start end)) (setf (gethash function-name *trace-breakpoints*) (cons start end))
;; This works TOTALLY SLIMY by the order of the next two calls. ;; The next two forms must be in the order in which they appear. They
;; rely on a documented property that later activated breakpoint hooks
;; run first, and the end breakpoint establishes a starting helper bpt.
(di:activate-breakpoint start) (di:activate-breakpoint start)
(di:activate-breakpoint end)) (di:activate-breakpoint end))
(push function-name *n-traced-function-list*)))) (push function-name *traced-function-list*))))
;;; PRINT-TRACE-START -- Internal. ;;; PRINT-TRACE-START -- Internal.
;;; ;;;
;;; This prints a representation of the call establishing frame. ;;; This prints a representation of the call establishing frame.
;;; ;;;
(defun print-trace-start (frame bpt) (defun print-trace-start (frame bpt &optional print)
(declare (ignore bpt)) (declare (ignore bpt))
(let ((*print-length* (or *n-trace-print-length* *print-length*)) (let ((*print-length* (or *trace-print-length* *print-length*))
(*print-level* (or *n-trace-print-level* *print-level*))) (*print-level* (or *trace-print-level* *print-level*)))
(fresh-line) (fresh-line)
(print-trace-indentation) (print-trace-indentation)
(print-frame-call-1 frame nil) (print-frame-call-1 frame nil)
(dolist (ele print)
(fresh-line)
(print-trace-indentation)
(prin1 (eval ele)))
(terpri))) (terpri)))
;;; PRINT-TRACE-END -- Internal. ;;; PRINT-TRACE-END -- Internal.
...@@ -211,18 +290,21 @@ ...@@ -211,18 +290,21 @@
;;; to see that cookie is at the top of *traced-entries*; if it is not, then we ;;; to see that cookie is at the top of *traced-entries*; if it is not, then we
;;; need to adjust this list to determine the correct indentation for output. ;;; need to adjust this list to determine the correct indentation for output.
;;; ;;;
(defun print-trace-end (frame bpt values cookie) (defun print-trace-end (frame bpt values cookie &optional print-after)
(declare (ignore frame bpt)) (declare (ignore frame bpt))
(unless (eq cookie (car *traced-entries*)) (unless (eq cookie (car *traced-entries*))
(setf *traced-entries* (member cookie *traced-entries*)) (setf *traced-entries* (member cookie *traced-entries*))
(fresh-line) (fresh-line)
(write-line "WARNING: dynamic flow of control occurred while TRACE'ing.")) (write-line "WARNING: dynamic flow of control occurred while TRACE'ing."))
(print-trace-indentation) (print-trace-indentation)
(pop *traced-entries*)
(write-string "returned ") (write-string "returned ")
(dolist (v values) (dolist (v values)
(prin1 v) (prin1 v)
(write-char #\space)) (write-char #\space))
(dolist (ele print-after)
(terpri)
(print-trace-indentation)
(prin1 (eval ele)))
(terpri)) (terpri))
(defun print-trace-indentation () (defun print-trace-indentation ()
...@@ -231,25 +313,36 @@ ...@@ -231,25 +313,36 @@
(prin1 len) (prin1 len)
(write-string ": "))) (write-string ": ")))
;;; TRACE-WHERE-IN-P -- Internal.
;;;
;;; The TRACE hooks use this for the :where-in arg.
;;;
(defun trace-where-in-p (frame names)
(do ((frame (di:frame-down frame) (di:frame-down frame)))
((not frame) nil)
(when (member (di:debug-function-name (di:frame-debug-function frame))
names :test #'equal)
(return t))))
;;;; N-UNTRACE. ;;;; N-UNTRACE.
(defmacro n-untrace (&rest names) (defmacro untrace (&rest names)
"Removes tracing from the functions named. With no args, untraces all "Removes tracing from the functions named. With no args, untraces all
functions." functions."
(let ((names (or names *n-traced-function-list*)) (let ((names (or names *traced-function-list*))
(untrace-1-forms nil)) (untrace-1-forms nil))
(dolist (name names `(progn ,@(nreverse untrace-1-forms) t)) (dolist (name names `(progn ,@(nreverse untrace-1-forms) t))
(if (symbolp name) (if (symbolp name)
(push `(n-untrace-1 ',name) untrace-1-forms) (push `(untrace-1 ',name) untrace-1-forms)
(error "Illegal function name -- ~S." name))))) (error "Illegal function name -- ~S." name)))))
(defun n-untrace-1 (name) (defun untrace-1 (name)
(cond ((member name *n-traced-function-list*) (cond ((member name *traced-function-list*)
(let ((breakpoints (gethash name *trace-breakpoints*))) (let ((breakpoints (gethash name *trace-breakpoints*)))
(di:delete-breakpoint (car breakpoints)) (di:delete-breakpoint (car breakpoints))
(di:delete-breakpoint (cdr breakpoints)) (di:delete-breakpoint (cdr breakpoints))
(setf (gethash name *trace-breakpoints*) nil)) (setf (gethash name *trace-breakpoints*) nil))
(setf *n-traced-function-list* (delete name *n-traced-function-list*))) (setf *traced-function-list* (delete name *traced-function-list*)))
(t (warn "Function is not TRACE'd -- ~S." name)))) (t (warn "Function is not TRACE'd -- ~S." name))))
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