Squashed 'third_party/lisp/trivial-backtrace/' content from commit 43ef7d9

git-subtree-dir: third_party/lisp/trivial-backtrace
git-subtree-split: 43ef7d947f4b4de767d0f91f28b50d9c03ad29d6

1 files changed, 127 insertions, 0 deletions

diff --git a/dev/backtrace.lisp b/dev/backtrace.lisp
new file mode 100644
index 000000000000..aa3951e30f9f
--- /dev/null
+++ b/dev/backtrace.lisp
@@ -0,0 +1,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.
+")
+
+