X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fntrace.lisp;h=d4e2158ff3341a741a8a9b63aa9d0d457d9ae032;hb=d40a76606c86722b0aef8179155f9f2840739b72;hp=1c8b58aceb2ec17bfd8321e0d454a2f02499ec12;hpb=11214915e9b3151ec66dc3e30e1aa7638c676428;p=sbcl.git diff --git a/src/code/ntrace.lisp b/src/code/ntrace.lisp index 1c8b58a..d4e2158 100644 --- a/src/code/ntrace.lisp +++ b/src/code/ntrace.lisp @@ -37,7 +37,7 @@ ;;; a hash table that maps each traced function to the TRACE-INFO. The ;;; entry for a closure is the shared function-entry object. -(defvar *traced-functions* (make-hash-table :test 'eq)) +(defvar *traced-funs* (make-hash-table :test 'eq)) ;;; A TRACE-INFO object represents all the information we need to ;;; trace a given function. @@ -139,7 +139,7 @@ (defun trace-redefined-update (fname new-value) (when (fboundp fname) (let* ((fun (trace-fdefinition fname)) - (info (gethash fun *traced-functions*))) + (info (gethash fun *traced-funs*))) (when (and info (trace-info-named info)) (untrace-1 fname) (trace-1 fname info new-value))))) @@ -155,9 +155,9 @@ (if (sb-di:code-location-p loc) (let ((fun (sb-di:preprocess-for-eval exp loc))) (cons exp - #'(lambda (frame) - (let ((*current-frame* frame)) - (funcall fun frame))))) + (lambda (frame) + (let ((*current-frame* frame)) + (funcall fun frame))))) (let* ((bod (ecase loc ((nil) exp) (:encapsulated @@ -168,13 +168,13 @@ ,exp)))) (fun (coerce `(lambda () ,bod) 'function))) (cons exp - #'(lambda (frame) - (declare (ignore frame)) - (let ((*current-frame* nil)) - (funcall fun))))))))) + (lambda (frame) + (declare (ignore frame)) + (let ((*current-frame* nil)) + (funcall fun))))))))) (defun coerce-form-list (forms loc) - (mapcar #'(lambda (x) (coerce-form x loc)) forms)) + (mapcar (lambda (x) (coerce-form x loc)) forms)) ;;; Print indentation according to the number of trace entries. ;;; Entries whose condition was false don't count. @@ -236,34 +236,34 @@ (let (conditionp) (values - #'(lambda (frame bpt) - (declare (ignore bpt)) - (discard-invalid-entries frame) - (let ((condition (trace-info-condition info)) - (wherein (trace-info-wherein info))) - (setq conditionp - (and (not *in-trace*) - (or (not condition) - (funcall (cdr condition) frame)) - (or (not wherein) - (trace-wherein-p frame wherein))))) - (when conditionp - (let ((sb-kernel:*current-level* 0) - (*standard-output* *trace-output*) - (*in-trace* t)) - (fresh-line) - (print-trace-indentation) - (if (trace-info-encapsulated info) - (locally (declare (special basic-definition argument-list)) - (prin1 `(,(trace-info-what info) ,@argument-list))) - (print-frame-call frame)) - (terpri) - (trace-print frame (trace-info-print info))) - (trace-maybe-break info (trace-info-break info) "before" frame))) - - #'(lambda (frame cookie) - (declare (ignore frame)) - (push (cons cookie conditionp) *traced-entries*))))) + (lambda (frame bpt) + (declare (ignore bpt)) + (discard-invalid-entries frame) + (let ((condition (trace-info-condition info)) + (wherein (trace-info-wherein info))) + (setq conditionp + (and (not *in-trace*) + (or (not condition) + (funcall (cdr condition) frame)) + (or (not wherein) + (trace-wherein-p frame wherein))))) + (when conditionp + (let ((sb-kernel:*current-level* 0) + (*standard-output* *trace-output*) + (*in-trace* t)) + (fresh-line) + (print-trace-indentation) + (if (trace-info-encapsulated info) + (locally (declare (special basic-definition argument-list)) + (prin1 `(,(trace-info-what info) ,@argument-list))) + (print-frame-call frame)) + (terpri) + (trace-print frame (trace-info-print info))) + (trace-maybe-break info (trace-info-break info) "before" frame))) + + (lambda (frame cookie) + (declare (ignore frame)) + (push (cons cookie conditionp) *traced-entries*))))) ;;; This prints a representation of the return values delivered. ;;; First, this checks to see that cookie is at the top of @@ -272,35 +272,35 @@ ;;; see whether the function is still traced and that the condition ;;; succeeded before printing anything. (defun trace-end-breakpoint-fun (info) - #'(lambda (frame bpt *trace-values* cookie) - (declare (ignore bpt)) - (unless (eq cookie (caar *traced-entries*)) - (setf *traced-entries* - (member cookie *traced-entries* :key #'car))) - - (let ((entry (pop *traced-entries*))) - (when (and (not (trace-info-untraced info)) - (or (cdr entry) - (let ((cond (trace-info-condition-after info))) - (and cond (funcall (cdr cond) frame))))) - (let ((sb-kernel:*current-level* 0) - (*standard-output* *trace-output*) - (*in-trace* t)) - (fresh-line) - (pprint-logical-block (*standard-output* nil) - (print-trace-indentation) - (pprint-indent :current 2) - (format t "~S returned" (trace-info-what info)) - (dolist (v *trace-values*) - (write-char #\space) - (pprint-newline :linear) - (prin1 v))) - (terpri) - (trace-print frame (trace-info-print-after info))) - (trace-maybe-break info - (trace-info-break-after info) - "after" - frame))))) + (lambda (frame bpt *trace-values* cookie) + (declare (ignore bpt)) + (unless (eq cookie (caar *traced-entries*)) + (setf *traced-entries* + (member cookie *traced-entries* :key #'car))) + + (let ((entry (pop *traced-entries*))) + (when (and (not (trace-info-untraced info)) + (or (cdr entry) + (let ((cond (trace-info-condition-after info))) + (and cond (funcall (cdr cond) frame))))) + (let ((sb-kernel:*current-level* 0) + (*standard-output* *trace-output*) + (*in-trace* t)) + (fresh-line) + (pprint-logical-block (*standard-output* nil) + (print-trace-indentation) + (pprint-indent :current 2) + (format t "~S returned" (trace-info-what info)) + (dolist (v *trace-values*) + (write-char #\space) + (pprint-newline :linear) + (prin1 v))) + (terpri) + (trace-print frame (trace-info-print-after info))) + (trace-maybe-break info + (trace-info-break-after info) + "after" + frame))))) ;;; This function is called by the trace encapsulation. It calls the ;;; breakpoint hook functions with NIL for the breakpoint and cookie, @@ -330,7 +330,7 @@ (values definition t (nth-value 2 (trace-fdefinition definition))) (trace-fdefinition function-or-name)) - (when (gethash fun *traced-functions*) + (when (gethash fun *traced-funs*) (warn "~S is already TRACE'd, untracing it." function-or-name) (untrace-1 fun)) @@ -397,7 +397,7 @@ (sb-di:activate-breakpoint start) (sb-di:activate-breakpoint end))))) - (setf (gethash fun *traced-functions*) info))) + (setf (gethash fun *traced-funs*) info))) function-or-name) @@ -477,8 +477,8 @@ `(let ,(binds) (list ,@(forms))) `(list ,@(forms))))) -(defun %list-traced-functions () - (loop for x being each hash-value in *traced-functions* +(defun %list-traced-funs () + (loop for x being each hash-value in *traced-funs* collect (trace-info-what x))) (defmacro trace (&rest specs) @@ -559,14 +559,14 @@ -AFTER and -ALL forms are evaluated in the null environment." (if specs (expand-trace specs) - '(%list-traced-functions))) + '(%list-traced-funs))) ;;;; untracing ;;; Untrace one function. (defun untrace-1 (function-or-name) (let* ((fun (trace-fdefinition function-or-name)) - (info (gethash fun *traced-functions*))) + (info (gethash fun *traced-funs*))) (cond ((not info) (warn "Function is not TRACEd: ~S" function-or-name)) @@ -578,11 +578,11 @@ (sb-di:delete-breakpoint (trace-info-start-breakpoint info)) (sb-di:delete-breakpoint (trace-info-end-breakpoint info)))) (setf (trace-info-untraced info) t) - (remhash fun *traced-functions*))))) + (remhash fun *traced-funs*))))) ;;; Untrace all traced functions. (defun untrace-all () - (dolist (fun (%list-traced-functions)) + (dolist (fun (%list-traced-funs)) (untrace-1 fun)) t)