- (let ((debug-fun (sb!di:frame-debug-fun frame))
- (loc (sb!di:frame-code-location frame))
- (reversed-result nil))
- (handler-case
- (progn
- (dolist (ele (sb!di:debug-fun-lambda-list debug-fun))
- (lambda-list-element-dispatch ele
- :required ((push (frame-call-arg ele loc frame) reversed-result))
- :optional ((push (frame-call-arg (second ele) loc frame)
- reversed-result))
- :keyword ((push (second ele) reversed-result)
- (push (frame-call-arg (third ele) loc frame)
- reversed-result))
- :deleted ((push (frame-call-arg ele loc frame) reversed-result))
- :rest ((lambda-var-dispatch (second ele) loc
- nil
- (progn
- (setf reversed-result
- (append (reverse (sb!di:debug-var-value
- (second ele) frame))
- reversed-result))
- (return))
- (push (make-unprintable-object
- "unavailable &REST argument")
- reversed-result)))))
- ;; As long as we do an ordinary return (as opposed to SIGNALing
- ;; a CONDITION) from the DOLIST above:
- (nreverse reversed-result))
- (sb!di:lambda-list-unavailable
- ()
- (make-unprintable-object "unavailable lambda list")))))
-(legal-fun-name-p '(lambda ()))
-(defvar *show-entry-point-details* nil)
-
-(defun frame-call (frame)
- (labels ((clean-name-and-args (name args)
- (if (and (consp name) (not *show-entry-point-details*))
- (case (first name)
- ((sb!c::xep sb!c::tl-xep)
- (clean-name-and-args
- (second name)
- (let ((count (first args))
- (real-args (rest args)))
- (subseq real-args 0 (min count (length real-args))))))
- ((sb!c::&more-processor)
- (clean-name-and-args
- (second name)
- (let* ((more (last args 2))
- (context (first more))
- (count (second more)))
- (append (butlast args 2)
- (multiple-value-list
- (sb!c:%more-arg-values context 0 count))))))
- ;; 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
- ((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)))))))
+ (handler-case
+ (let ((location (sb!di:frame-code-location frame))
+ (reversed-result nil))
+ (block enumerating
+ (map-frame-args
+ (lambda (element)
+ (lambda-list-element-dispatch element
+ :required ((push (frame-call-arg element location frame) reversed-result))
+ :optional ((push (frame-call-arg (second element) location frame)
+ reversed-result))
+ :keyword ((push (second element) reversed-result)
+ (push (frame-call-arg (third element) location frame)
+ reversed-result))
+ :deleted ((push (frame-call-arg element location frame) reversed-result))
+ :rest ((lambda-var-dispatch (second element) location
+ nil
+ (let ((rest (sb!di:debug-var-value (second element) frame)))
+ (if (listp rest)
+ (setf reversed-result (append (reverse rest) reversed-result))
+ (push (make-unprintable-object "unavailable &REST argument")
+ reversed-result))
+ (return-from enumerating))
+ (push (make-unprintable-object
+ "unavailable &REST argument")
+ reversed-result)))
+ :more ((lambda-var-dispatch (second element) location
+ nil
+ (let ((context (sb!di:debug-var-value (second element) frame))
+ (count (sb!di:debug-var-value (third element) frame)))
+ (setf reversed-result
+ (append (reverse
+ (multiple-value-list
+ (sb!c::%more-arg-values context 0 count)))
+ reversed-result))
+ (return-from enumerating))
+ (push (make-unprintable-object "unavailable &MORE argument")
+ reversed-result)))))
+ frame))
+ (nreverse reversed-result))
+ (sb!di:lambda-list-unavailable ()
+ (make-unprintable-object "unavailable lambda list"))))
+
+(defun clean-xep (name args info)
+ (values (second name)
+ (if (consp args)
+ (let* ((count (first args))
+ (real-args (rest args)))
+ (if (fixnump count)
+ ;; So, this is a cheap trick -- but makes backtraces for
+ ;; too-many-arguments-errors much, much easier to to
+ ;; understand. FIXME: For :EXTERNAL frames at least we
+ ;; should be able to get the actual arguments, really.
+ (loop repeat count
+ for arg = (if real-args
+ (pop real-args)
+ (make-unprintable-object "unknown"))
+ collect arg)
+ real-args))
+ args)
+ (if (eq (car name) 'sb!c::tl-xep)
+ (cons :tl info)
+ info)))
+
+(defun clean-&more-processor (name args info)
+ (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)
+ (cons :more info)))
+
+(defun clean-fast-method (name args style info)
+ (multiple-value-bind (cname cargs)
+ (ecase style
+ (:minimal
+ (let ((gf-name (second name))
+ (real-args (cddr args)))
+ (if (and (fboundp gf-name)
+ (notany #'sb!impl::unprintable-object-p real-args)
+ (let ((methods (compute-applicable-methods
+ (fdefinition gf-name) real-args)))
+ (and methods (not (cdr methods)))))
+ (values gf-name real-args)
+ (values (cons :method (cdr name)) real-args))))
+ (:normal
+ (values (cons :method (cdr name)) (cddr args)))
+ (:full
+ (values name args)))
+ (values cname cargs (cons :fast-method info))))
+
+(defun clean-frame-call (name args method-frame-style info)
+ (if (consp name)
+ (case (first name)
+ ((sb!c::xep sb!c::tl-xep)
+ (clean-xep name args info))
+ ((sb!c::&more-processor)
+ (clean-&more-processor name args info))
+ ((sb!c::&optional-processor)
+ (clean-frame-call (second name) args method-frame-style
+ info))
+ ((sb!pcl::fast-method)
+ (clean-fast-method name args method-frame-style info))
+ (t
+ (values name args info)))
+ (values name args info)))
+
+(defun frame-call (frame &key (method-frame-style *method-frame-style*)
+ replace-dynamic-extent-objects)
+ "Returns as multiple values a descriptive name for the function responsible
+for FRAME, arguments that that function, and a list providing additional
+information about the frame.
+
+Unavailable arguments are represented using dummy-objects printing as
+#<unavailable argument>.
+
+METHOD-FRAME-STYLE (defaulting to *METHOD-FRAME-STYLE*), determines how frames
+corresponding to method functions are printed. Possible values
+are :MINIMAL, :NORMAL, and :FULL. See *METHOD-FRAME-STYLE* for more
+information.
+
+If REPLACE-DYNAMIC-EXTENT-OBJECTS is true, objects allocated on the stack of
+the current thread are replaced with dummy objects which can safely escape."
+ (let* ((debug-fun (sb!di:frame-debug-fun frame))
+ (kind (sb!di:debug-fun-kind debug-fun)))
+ (multiple-value-bind (name args info)
+ (clean-frame-call (sb!di:debug-fun-name debug-fun)
+ (frame-args-as-list frame)
+ method-frame-style
+ (when kind (list kind)))
+ (let ((args (if (and (consp args) replace-dynamic-extent-objects)
+ (mapcar #'replace-dynamic-extent-object args)
+ args)))
+ (values name args info)))))