external/lift/dev/port.lisp

   1 (in-package #:lift)
   2
   3 (setf (documentation 'get-backtrace 'function)
   4   "This is the function that is used internally by Hunchentoot to
   5 show or log backtraces.  It accepts a condition object ERROR and
   6 returns a string with the corresponding backtrace.")
   7
   8 (defun ensure-directory (pathname)
   9   (merge-pathnames (make-pathname :name :unspecific
  10                                   :type :unspecific)
  11                    pathname))
  12
  13 (defun writable-directory-p (directory)
  14   (let ((directory (ensure-directory directory)))
  15     (and (probe-file directory)
  16          #+allegro
  17          (excl.osi:access directory excl.osi:*w-ok*))))
  18
  19 #+allegro
  20 (defun total-bytes-allocated ()
  21   (sys::gsgc-totalloc-bytes t))
  22
  23 #+(or digitool openmcl)
  24 (defun total-bytes-allocated ()
  25   (ccl::total-bytes-allocated))
  26
  27 #+sbcl
  28 (defun total-bytes-allocated ()
  29   (cl-user::get-bytes-consed))
  30
  31 #+mcl
  32 (defun get-backtrace (error)
  33   (with-output-to-string (s)
  34     (let ((*debug-io* s))
  35       (format *terminal-io* "~@<An unhandled error condition has been signalled:~3I ~a~I~:@>~%~%"
  36               error)
  37       (ccl:print-call-history :detailed-p nil))))
  38
  39 #+allegro
  40 (defun get-backtrace (error)
  41   (with-output-to-string (s)
  42     (with-standard-io-syntax
  43       (let ((*print-readably* nil)
  44             (*print-miser-width* 40)
  45             (*print-pretty* t)
  46             (tpl:*zoom-print-circle* t)
  47             (tpl:*zoom-print-level* nil)
  48             (tpl:*zoom-print-length* nil))
  49         (cl:ignore-errors
  50           (format *terminal-io* "~&~@<An unhandled error condition has been signalled:~3I ~a~I~:@>~%~%"
  51                   error))
  52         (cl:ignore-errors
  53           (let ((*terminal-io* s)
  54                 (*standard-output* s))
  55             (tpl:do-command "zoom"
  56                             :from-read-eval-print-loop nil
  57                             :count t
  58                             :all t)))))))
  59
  60 #+(or)
  61 (defun zoom-to-stream (condition output)
  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       (ignore-errors
  70         (format *terminal-io* "Creating backtrace for ~a to ~a"
  71                 condition output))
  72       (flet ((zoom (s)
  73                (ignore-errors
  74                  (let ((*terminal-io* s)
  75                        (*standard-output* s))
  76                    (tpl:do-command "zoom"
  77                      :from-read-eval-print-loop nil
  78                    :count t :all t)))))
  79         (cond ((streamp output)
  80                (zoom output))
  81               (t
  82                (ensure-directories-exist output)
  83                (with-open-file (s output :direction :output
  84                                   :if-exists :supersede
  85                                   :if-does-not-exist :create)
  86                  (zoom s))))))))
  87
  88 #+lispworks
  89 (defun get-backtrace (error)
  90   (declare (ignore error))
  91   (with-output-to-string (s)
  92     (let ((dbg::*debugger-stack* (dbg::grab-stack nil :how-many most-positive-fixnum))
  93           (*debug-io* s)
  94           (dbg:*debug-print-level* nil)
  95           (dbg:*debug-print-length* nil))
  96       (dbg:bug-backtrace nil))))
  97
  98 #+sbcl
  99 ;; determine how we're going to access the backtrace in the next
 100 ;; function
 101 (eval-when (:compile-toplevel :load-toplevel :execute)
 102   (when (find-symbol "*DEBUG-PRINT-VARIABLE-ALIST*" :sb-debug)
 103     (pushnew :hunchentoot-sbcl-debug-print-variable-alist *features*)))
 104
 105 #+sbcl
 106 (defun get-backtrace (error)
 107   (declare (ignore error))
 108   (with-output-to-string (s)
 109     #+:hunchentoot-sbcl-debug-print-variable-alist
 110     (let ((sb-debug:*debug-print-variable-alist*
 111             (list* '(*print-level* . nil)
 112                    '(*print-length* . nil)
 113                    sb-debug:*debug-print-variable-alist*)))
 114       (sb-debug:backtrace most-positive-fixnum s))
 115     #-:hunchentoot-sbcl-debug-print-variable-alist
 116     (let ((sb-debug:*debug-print-level* nil)
 117           (sb-debug:*debug-print-length* nil))
 118       (sb-debug:backtrace most-positive-fixnum s))))
 119
 120 #+cmucl
 121 (defun get-backtrace (error)
 122   (declare (ignore error))
 123   (with-output-to-string (s)
 124     (let ((debug:*debug-print-level* nil)
 125           (debug:*debug-print-length* nil))
 126       (debug:backtrace most-positive-fixnum s))))
 127
 128