external/lift.darcs/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 ;; Handle missing platforms gracefully?
  20 (defun total-bytes-allocated ()
  21   (if (fboundp '%total-bytes-allocated)
  22     (funcall '%total-bytes-allocated)
  23     0))
  24
  25 #+allegro
  26 (defun %total-bytes-allocated ()
  27   (sys::gsgc-totalloc-bytes t))
  28
  29 #+(or digitool openmcl)
  30 (defun %total-bytes-allocated ()
  31   (ccl::total-bytes-allocated))
  32
  33 #+sbcl
  34 (defun %total-bytes-allocated ()
  35   (cl-user::get-bytes-consed))
  36
  37 #+(or cmu scl)
  38 (defun %total-bytes-allocated ()
  39   (ext:get-bytes-consed))
  40
  41 #+lispworks
  42 ;; thanks to Frank Schorr, via e-mail
  43 (defun %total-bytes-allocated ()
  44   (hcl:total-allocation))
  45
  46 #+mcl
  47 (defun get-backtrace (error)
  48   (with-output-to-string (s)
  49     (let ((*debug-io* s))
  50       (format *terminal-io* "~@<An unhandled error condition has been signalled:~3I ~a~I~:@>~%~%"
  51               error)
  52       (ccl:print-call-history :detailed-p nil))))
  53
  54 #+allegro
  55 (defun get-backtrace (error)
  56   (with-output-to-string (s)
  57     (with-standard-io-syntax
  58       (let ((*print-readably* nil)
  59             (*print-miser-width* 40)
  60             (*print-pretty* t)
  61             (tpl:*zoom-print-circle* t)
  62             (tpl:*zoom-print-level* nil)
  63             (tpl:*zoom-print-length* nil))
  64         (cl:ignore-errors
  65           (format *terminal-io* "~&~@<An unhandled error condition has been signalled:~3I ~a~I~:@>~%~%"
  66                   error))
  67         (cl:ignore-errors
  68           (let ((*terminal-io* s)
  69                 (*standard-output* s))
  70             (tpl:do-command "zoom"
  71                             :from-read-eval-print-loop nil
  72                             :count t
  73                             :all t)))))))
  74
  75 #+(or)
  76 (defun zoom-to-stream (condition output)
  77   (with-standard-io-syntax
  78     (let ((*print-readably* nil)
  79           (*print-miser-width* 40)
  80           (*print-pretty* t)
  81           (tpl:*zoom-print-circle* t)
  82           (tpl:*zoom-print-level* nil)
  83           (tpl:*zoom-print-length* nil))
  84       (ignore-errors
  85         (format *terminal-io* "Creating backtrace for ~a to ~a"
  86                 condition output))
  87       (flet ((zoom (s)
  88                (ignore-errors
  89                  (let ((*terminal-io* s)
  90                        (*standard-output* s))
  91                    (tpl:do-command "zoom"
  92                      :from-read-eval-print-loop nil
  93                    :count t :all t)))))
  94         (cond ((streamp output)
  95                (zoom output))
  96               (t
  97                (ensure-directories-exist output)
  98                (with-open-file (s output :direction :output
  99                                   :if-exists :supersede
 100                                   :if-does-not-exist :create)
 101                  (zoom s))))))))
 102
 103 #+lispworks
 104 (defun get-backtrace (error)
 105   (declare (ignore error))
 106   (with-output-to-string (s)
 107     (let ((dbg::*debugger-stack* (dbg::grab-stack nil :how-many most-positive-fixnum))
 108           (*debug-io* s)
 109           (dbg:*debug-print-level* nil)
 110           (dbg:*debug-print-length* nil))
 111       (dbg:bug-backtrace nil))))
 112
 113 #+sbcl
 114 ;; determine how we're going to access the backtrace in the next
 115 ;; function
 116 (eval-when (:compile-toplevel :load-toplevel :execute)
 117   (when (find-symbol "*DEBUG-PRINT-VARIABLE-ALIST*" :sb-debug)
 118     (pushnew :hunchentoot-sbcl-debug-print-variable-alist *features*)))
 119
 120 #+sbcl
 121 (defun get-backtrace (error)
 122   (declare (ignore error))
 123   (with-output-to-string (s)
 124     #+:hunchentoot-sbcl-debug-print-variable-alist
 125     (let ((sb-debug:*debug-print-variable-alist*
 126             (list* '(*print-level* . nil)
 127                    '(*print-length* . nil)
 128                    sb-debug:*debug-print-variable-alist*)))
 129       (sb-debug:backtrace most-positive-fixnum s))
 130     #-:hunchentoot-sbcl-debug-print-variable-alist
 131     (let ((sb-debug:*debug-print-level* nil)
 132           (sb-debug:*debug-print-length* nil))
 133       (sb-debug:backtrace most-positive-fixnum s))))
 134
 135 #+clisp
 136 (defun get-backtrace (error)
 137   (declare (ignore error))
 138   (with-output-to-string (s)
 139     (system::print-backtrace :out s)))
 140
 141 #+(or cmucl scl)
 142 (defun get-backtrace (error)
 143   (declare (ignore error))
 144   (with-output-to-string (s)
 145     (let ((debug:*debug-print-level* nil)
 146           (debug:*debug-print-length* nil))
 147       (debug:backtrace most-positive-fixnum s))))
 148
 149