tvl-depot/third_party/lisp/trivial-backtrace/dev/backtrace.lisp

(in-package #:trivial-backtrace)

(defun print-condition (condition stream)
  "Print `condition` to `stream` using the pretty printer."
  (format
   stream
   "~@<An unhandled error condition has been signalled:~3I ~a~I~:@>~%~%"
   condition))
  
(defun print-backtrace (error &key (output *debug-io*)
			(if-exists :append)
			(verbose nil))
  "Send a backtrace for the error `error` to `output`. 

The keywords arguments are:

 * :output - where to send the output. This can be:

     * a string (which is assumed to designate a pathname)
     * an open stream
     * nil to indicate that the backtrace information should be 
       returned as a string

 * if-exists - what to do if output designates a pathname and 
   the pathname already exists. Defaults to :append.

 * verbose - if true, then a message about the backtrace is sent
   to \\*terminal-io\\*. Defaults to `nil`.

If the `output` is nil, the returns the backtrace output as a
string. Otherwise, returns nil.
"
  (when verbose
    (print-condition error *terminal-io*))
  (multiple-value-bind (stream close?)
      (typecase output
	(null (values (make-string-output-stream) nil))
	(string (values (open output :if-exists if-exists
			      :if-does-not-exist :create
			      :direction :output) t))
	(stream (values output nil)))
    (unwind-protect
	 (progn
	   (format stream "~&Date/time: ~a" (date-time-string))
	   (print-condition error stream)
	   (terpri stream)
	   (print-backtrace-to-stream stream)
	   (terpri stream)
	   (when (typep stream 'string-stream)
	     (get-output-stream-string stream)))
	 ;; cleanup
	 (when close?
	   (close stream)))))

#+(or mcl ccl)
(defun print-backtrace-to-stream (stream)
  (let ((*debug-io* stream))
    (ccl:print-call-history :detailed-p nil)))

#+allegro
(defun print-backtrace-to-stream (stream)
  (with-standard-io-syntax
    (let ((*print-readably* nil)
	  (*print-miser-width* 40)
	  (*print-pretty* t)
	  (tpl:*zoom-print-circle* t)
	  (tpl:*zoom-print-level* nil)
	  (tpl:*zoom-print-length* nil))
      (cl:ignore-errors
       (let ((*terminal-io* stream)
	     (*standard-output* stream))
	 (tpl:do-command "zoom"
	   :from-read-eval-print-loop nil
	   :count t
	   :all t))))))

#+lispworks
(defun print-backtrace-to-stream (stream)
  (let ((dbg::*debugger-stack*
	 (dbg::grab-stack nil :how-many most-positive-fixnum))
	(*debug-io* stream)
	(dbg:*debug-print-level* nil)
	(dbg:*debug-print-length* nil))
    (dbg:bug-backtrace nil)))

#+sbcl
;; determine how we're going to access the backtrace in the next
;; function
(eval-when (:compile-toplevel :load-toplevel :execute)
  (when (find-symbol "*DEBUG-PRINT-VARIABLE-ALIST*" :sb-debug)
    (pushnew :sbcl-debug-print-variable-alist *features*)))

#+sbcl
(defun print-backtrace-to-stream (stream)
  (let (#+:sbcl-debug-print-variable-alist
	(sb-debug:*debug-print-variable-alist*
	 (list* '(*print-level* . nil)
		'(*print-length* . nil)
		sb-debug:*debug-print-variable-alist*))
	#-:sbcl-debug-print-variable-alist
	(sb-debug:*debug-print-level* nil)
	#-:sbcl-debug-print-variable-alist
	(sb-debug:*debug-print-length* nil))
    (sb-debug:backtrace most-positive-fixnum stream)))

#+clisp
(defun print-backtrace-to-stream (stream)
  (system::print-backtrace :out stream))

#+(or cmucl scl)
(defun print-backtrace-to-stream (stream)
  (let ((debug:*debug-print-level* nil)
	(debug:*debug-print-length* nil))
    (debug:backtrace most-positive-fixnum stream)))


;; must be after the defun above or the docstring may be wiped out
(setf (documentation 'print-backtrace-to-stream 'function)
  "Send a backtrace of the current error to stream. 

Stream is assumed to be an open writable file stream or a
string-output-stream. Note that `print-backtrace-to-stream`
will print a backtrace for whatever the Lisp deems to be the 
*current* error.
")