blob: aa3951e30f9f37fb016ea99c8b2b9b4671881cd0 (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
|
(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.
")
|
