-
-;;; Print FRAME with verbosity level 1. If we hit a &REST arg, then
-;;; print as many of the values as possible, punting the loop over
-;;; lambda-list variables since any other arguments will be in the
-;;; &REST arg's list of values.
-(defun print-frame-call-1 (frame)
- (let ((debug-fun (sb!di:frame-debug-fun frame)))
-
- (pprint-logical-block (*standard-output* nil :prefix "(" :suffix ")")
- (let ((args (ensure-printable-object (frame-args-as-list frame))))
- ;; Since we go to some trouble to make nice informative function
- ;; names like (PRINT-OBJECT :AROUND (CLOWN T)), let's make sure
- ;; that they aren't truncated by *PRINT-LENGTH* and *PRINT-LEVEL*.
- (let ((*print-length* nil)
- (*print-level* nil))
- (prin1 (ensure-printable-object (sb!di:debug-fun-name debug-fun))))
- ;; For the function arguments, we can just print normally.
- (if (listp args)
- (format t "~{ ~_~S~}" args)
- (format t " ~S" args))))
-
- (when (sb!di:debug-fun-kind debug-fun)
- (write-char #\[)
- (prin1 (sb!di:debug-fun-kind debug-fun))
- (write-char #\]))))
+(legal-fun-name-p '(lambda ()))
+(defvar *show-entry-point-details* nil)
+
+(defun clean-xep (name args)
+ (values (second name)
+ (if (consp args)
+ (let ((count (first args))
+ (real-args (rest args)))
+ (if (fixnump count)
+ (subseq real-args 0
+ (min count (length real-args)))
+ real-args))
+ args)))
+
+(defun clean-&more-processor (name args)
+ (values (second name)
+ (if (consp args)
+ (let* ((more (last args 2))
+ (context (first more))
+ (count (second more)))
+ (append
+ (butlast args 2)
+ (if (fixnump count)
+ (multiple-value-list
+ (sb!c:%more-arg-values context 0 count))
+ (list
+ (make-unprintable-object "more unavailable arguments")))))
+ 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)
+ ((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)))
+ (values name args))))
+ (let ((debug-fun (sb!di:frame-debug-fun frame)))
+ (multiple-value-bind (name args)
+ (clean-name-and-args (sb!di:debug-fun-name debug-fun)
+ (frame-args-as-list frame))
+ (values name args
+ (when *show-entry-point-details*
+ (sb!di:debug-fun-kind debug-fun)))))))