dev/backtrace.lisp

   1 (in-package #:trivial-backtrace)
   2
   3 (defun print-condition (condition stream)
   4   "Print `condition` to `stream` using the pretty printer."
   5   (format
   6    stream
   7    "~@<An unhandled error condition has been signalled:~3I ~a~I~:@>~%~%"
   8    condition))
   9
  10 (defun print-backtrace (error &key (output *debug-io*)
  11                         (if-exists :append)
  12                         (verbose nil))
  13   "Send a backtrace for the error `error` to `output`.
  14
  15 The keywords arguments are:
  16
  17  * :output - where to send the output. This can be:
  18
  19      * a string (which is assumed to designate a pathname)
  20      * an open stream
  21      * nil to indicate that the backtrace information should be
  22        returned as a string
  23
  24  * if-exists - what to do if output designates a pathname and
  25    the pathname already exists. Defaults to :append.
  26
  27  * verbose - if true, then a message about the backtrace is sent
  28    to \\*terminal-io\\*. Defaults to `nil`.
  29
  30 If the `output` is nil, the returns the backtrace output as a
  31 string. Otherwise, returns nil.
  32 "
  33   (when verbose
  34     (print-condition error *terminal-io*))
  35   (multiple-value-bind (stream close?)
  36       (typecase output
  37         (null (values (make-string-output-stream) nil))
  38         (string (values (open output :if-exists if-exists
  39                               :if-does-not-exist :create
  40                               :direction :output) t))
  41         (stream (values output nil)))
  42     (unwind-protect
  43          (progn
  44            (format stream "~&Date/time: ~a" (date-time-string))
  45            (print-condition error stream)
  46            (terpri stream)
  47            (print-backtrace-to-stream stream)
  48            (terpri stream)
  49            (when (typep stream 'string-stream)
  50              (get-output-stream-string stream)))
  51          ;; cleanup
  52          (when close?
  53            (close stream)))))
  54
  55 #+(or mcl ccl)
  56 (defun print-backtrace-to-stream (stream)
  57   (let ((*debug-io* stream))
  58     (ccl:print-call-history :detailed-p nil)))
  59
  60 #+allegro
  61 (defun print-backtrace-to-stream (stream)
  62   (with-standard-io-syntax
  63     (let ((*print-readably* nil)
  64           (*print-miser-width* 40)
  65           (*print-pretty* t)
  66           (tpl:*zoom-print-circle* t)
  67           (tpl:*zoom-print-level* nil)
  68           (tpl:*zoom-print-length* nil))
  69       (cl:ignore-errors
  70        (let ((*terminal-io* stream)
  71              (*standard-output* stream))
  72          (tpl:do-command "zoom"
  73            :from-read-eval-print-loop nil
  74            :count t
  75            :all t))))))
  76
  77 #+lispworks
  78 (defun print-backtrace-to-stream (stream)
  79   (let ((dbg::*debugger-stack*
  80          (dbg::grab-stack nil :how-many most-positive-fixnum))
  81         (*debug-io* stream)
  82         (dbg:*debug-print-level* nil)
  83         (dbg:*debug-print-length* nil))
  84     (dbg:bug-backtrace nil)))
  85
  86 #+sbcl
  87 ;; determine how we're going to access the backtrace in the next
  88 ;; function
  89 (eval-when (:compile-toplevel :load-toplevel :execute)
  90   (when (find-symbol "*DEBUG-PRINT-VARIABLE-ALIST*" :sb-debug)
  91     (pushnew :sbcl-debug-print-variable-alist *features*)))
  92
  93 #+sbcl
  94 (defun print-backtrace-to-stream (stream)
  95   (let (#+:sbcl-debug-print-variable-alist
  96         (sb-debug:*debug-print-variable-alist*
  97          (list* '(*print-level* . nil)
  98                 '(*print-length* . nil)
  99                 sb-debug:*debug-print-variable-alist*))
 100         #-:sbcl-debug-print-variable-alist
 101         (sb-debug:*debug-print-level* nil)
 102         #-:sbcl-debug-print-variable-alist
 103         (sb-debug:*debug-print-length* nil))
 104     (sb-debug:backtrace most-positive-fixnum stream)))
 105
 106 #+clisp
 107 (defun print-backtrace-to-stream (stream)
 108   (system::print-backtrace :out stream))
 109
 110 #+(or cmucl scl)
 111 (defun print-backtrace-to-stream (stream)
 112   (let ((debug:*debug-print-level* nil)
 113         (debug:*debug-print-length* nil))
 114     (debug:backtrace most-positive-fixnum stream)))
 115
 116
 117 ;; must be after the defun above or the docstring may be wiped out
 118 (setf (documentation 'print-backtrace-to-stream 'function)
 119   "Send a backtrace of the current error to stream.
 120
 121 Stream is assumed to be an open writable file stream or a
 122 string-output-stream. Note that `print-backtrace-to-stream`
 123 will print a backtrace for whatever the Lisp deems to be the
 124 *current* error.
 125 ")
 126
 127