+ "Calls the designated FUNCTION with each frame on the call stack.
+Returns the last value returned by FUNCTION.
+
+COUNT is the number of frames to backtrace, defaulting to
+*BACKTRACE-FRAME-COUNT*.
+
+START is the number of the frame the backtrace should start from.
+
+FROM specifies the frame relative to which the frames are numbered. Possible
+values are an explicit SB-DI:FRAME object, and the
+keywords :CURRENT-FRAME, :INTERRUPTED-FRAME, and :DEBUGGER-FRAME. Default
+is :DEBUGGER-FRAME.
+
+ :CURRENT-FRAME
+ specifies the caller of MAP-BACKTRACE.
+
+ :INTERRUPTED-FRAME
+ specifies the first interrupted frame on the stack \(typically the frame
+ where the error occured, as opposed to error handling frames) if any,
+ otherwise behaving as :CURRENT-FRAME.
+
+ :DEBUGGER-FRAME
+ specifies the currently debugged frame when inside the debugger, and
+ behaves as :INTERRUPTED-FRAME outside the debugger.
+"
+ (loop with result = nil
+ for index upfrom 0
+ for frame = (backtrace-start-frame from)
+ then (sb!di:frame-down frame)
+ until (null frame)
+ when (<= start index) do
+ (if (minusp (decf count))
+ (return result)
+ (setf result (funcall function frame)))
+ finally (return result)))
+
+(defun print-backtrace (&key
+ (stream *debug-io*)
+ (start 0)
+ (from :debugger-frame)
+ (count *backtrace-frame-count*)
+ (print-thread t)
+ (print-frame-source nil)
+ (method-frame-style *method-frame-style*))
+ #!+sb-doc
+ "Print a listing of the call stack to STREAM, defaulting to *DEBUG-IO*.
+
+COUNT is the number of frames to backtrace, defaulting to
+*BACKTRACE-FRAME-COUNT*.
+
+START is the number of the frame the backtrace should start from.
+
+FROM specifies the frame relative to which the frames are numbered. Possible
+values are an explicit SB-DI:FRAME object, and the
+keywords :CURRENT-FRAME, :INTERRUPTED-FRAME, and :DEBUGGER-FRAME. Default
+is :DEBUGGER-FRAME.
+
+ :CURRENT-FRAME
+ specifies the caller of PRINT-BACKTRACE.
+
+ :INTERRUPTED-FRAME
+ specifies the first interrupted frame on the stack \(typically the frame
+ where the error occured, as opposed to error handling frames) if any,
+ otherwise behaving as :CURRENT-FRAME.
+
+ :DEBUGGER-FRAME
+ specifies the currently debugged frame when inside the debugger, and
+ behaves as :INTERRUPTED-FRAME outside the debugger.
+
+If PRINT-THREAD is true (default), backtrace is preceded by printing the
+thread object the backtrace is from.
+
+If PRINT-FRAME-SOURCE is true (default is false), each frame is followed by
+printing the currently executing source form in the function responsible for
+that frame, when available. Requires the function to have been compiled at
+DEBUG 2 or higher. If PRINT-FRAME-SOURCE is :ALWAYS, it also reports \"no
+source available\" for frames for which were compiled at lower debug settings.
+
+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."
+ (with-debug-io-syntax ()
+ (fresh-line stream)
+ (when print-thread
+ (format stream "Backtrace for: ~S~%" sb!thread:*current-thread*))
+ (let ((*suppress-print-errors* (if (subtypep 'serious-condition *suppress-print-errors*)
+ *suppress-print-errors*
+ 'serious-condition))
+ (*print-circle* t)
+ (n start))
+ (handler-bind ((print-not-readable #'print-unreadably))
+ (map-backtrace (lambda (frame)
+ (print-frame-call frame stream
+ :number n
+ :method-frame-style method-frame-style
+ :print-frame-source print-frame-source)
+ (incf n))
+ :from (backtrace-start-frame from)
+ :start start
+ :count count)))
+ (fresh-line stream)
+ (values)))
+
+(defun list-backtrace (&key
+ (count *backtrace-frame-count*)
+ (start 0)
+ (from :debugger-frame)
+ (method-frame-style *method-frame-style*))
+ #!+sb-doc
+ "Returns a list describing the call stack. Each frame is represented
+by a sublist:
+
+ \(<name> ...args...)
+
+where the name describes the function responsible for the frame. The name
+might not be bound to the actual function object. Unavailable arguments are
+represented by dummy objects that print as #<unavailable argument>. Objects
+with dynamic-extent allocation by the current thread are represented by
+substitutes to avoid references to them from leaking outside their legal
+extent.
+
+COUNT is the number of frames to backtrace, defaulting to
+*BACKTRACE-FRAME-COUNT*.
+
+START is the number of the frame the backtrace should start from.
+
+FROM specifies the frame relative to which the frames are numbered. Possible
+values are an explicit SB-DI:FRAME object, and the
+keywords :CURRENT-FRAME, :INTERRUPTED-FRAME, and :DEBUGGER-FRAME. Default
+is :DEBUGGER-FRAME.
+
+ :CURRENT-FRAME
+ specifies the caller of LIST-BACKTRACE.
+
+ :INTERRUPTED-FRAME
+ specifies the first interrupted frame on the stack \(typically the frame
+ where the error occured, as opposed to error handling frames) if any,
+ otherwise behaving as :CURRENT-FRAME.
+
+ :DEBUGGER-FRAME
+ specifies the currently debugged frame when inside the debugger, and
+ behaves as :INTERRUPTED-FRAME outside the debugger.
+
+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."
+ (let (rbacktrace)
+ (map-backtrace
+ (lambda (frame)
+ (push (frame-call-as-list frame :method-frame-style method-frame-style)
+ rbacktrace))
+ :count count
+ :start start
+ :from (backtrace-start-frame from))
+ (nreverse rbacktrace)))
+
+(defun frame-call-as-list (frame &key (method-frame-style *method-frame-style*))
+ (multiple-value-bind (name args info)
+ (frame-call frame :method-frame-style method-frame-style
+ :replace-dynamic-extent-objects t)
+ (values (cons name args) info)))
+
+(defun replace-dynamic-extent-object (obj)
+ (if (stack-allocated-p obj)
+ (make-unprintable-object
+ (handler-case
+ (format nil "dynamic-extent: ~S" obj)
+ (error ()
+ "error printing dynamic-extent object")))
+ obj))
+
+(defun stack-allocated-p (obj)
+ "Returns T if OBJ is allocated on the stack of the current
+thread, NIL otherwise."
+ (with-pinned-objects (obj)
+ (let ((sap (int-sap (get-lisp-obj-address obj))))
+ (when (sb!vm:control-stack-pointer-valid-p sap nil)
+ t))))