dev/backtrace.lisp

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