From a2fd28fb6d0b3d8d230a7c933db352f80891ac1c Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sat, 19 May 2012 15:28:41 +0300 Subject: [PATCH] factor debug-name cleaning into a separate function We will need it elsewhere too. --- src/code/debug.lisp | 41 ++++++++++++++++++++--------------------- 1 file changed, 20 insertions(+), 21 deletions(-) diff --git a/src/code/debug.lisp b/src/code/debug.lisp index 9a9db8b..2558ba3 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -361,29 +361,28 @@ thread, NIL otherwise." (make-unprintable-object "more unavailable arguments"))))) args))) +(defun clean-debug-fun-name (name &optional args) + ;; FIXME: do we need to deal with + ;; HAIRY-FUNCTION-ENTRY here? I can't make it or + ;; &AUX-BINDINGS appear in backtraces, so they are + ;; left alone for now. --NS 2005-02-28 + (if (consp name) + (case (first name) + ((sb!c::xep sb!c::tl-xep) + (clean-xep name args)) + ((sb!c::&more-processor) + (clean-&more-processor name args)) + ((sb!c::hairy-arg-processor + sb!c::varargs-entry sb!c::&optional-processor) + (clean-debug-fun-name (second name) args)) + (t + (values name args))) + (values name args))) + (defun frame-call (frame) (labels ((clean-name-and-args (name args) - (if (and (consp name) (not *show-entry-point-details*)) - ;; FIXME: do we need to deal with - ;; HAIRY-FUNCTION-ENTRY here? I can't make it or - ;; &AUX-BINDINGS appear in backtraces, so they are - ;; left alone for now. --NS 2005-02-28 - (case (first name) - ((eval) - ;; The name of an evaluator thunk contains - ;; the source context -- but that makes for a - ;; confusing frame name, since it can look like an - ;; EVAL call with a bogus argument. - (values '#:eval-thunk nil)) - ((sb!c::xep sb!c::tl-xep) - (clean-xep name args)) - ((sb!c::&more-processor) - (clean-&more-processor name args)) - ((sb!c::hairy-arg-processor - sb!c::varargs-entry sb!c::&optional-processor) - (clean-name-and-args (second name) args)) - (t - (values name args))) + (if (not *show-entry-point-details*) + (clean-debug-fun-name name args) (values name args)))) (let ((debug-fun (sb!di:frame-debug-fun frame))) (multiple-value-bind (name args) -- 1.7.10.4