Debugging functions for SBCL

debugger-wannabe.lisp

(declaim (optimize (debug 2)))

;; Part one.

(defun line-number (fname code-loc)
  (let* ((all-offsets (sb-di::debug-source-start-positions code-loc))
         ;; Get last item from the array, I haven't found anything
         ;; like 'pop' to do it better.
         (offset (aref all-offsets (- (length all-offsets) 1))))
    (with-open-file (f fname)
                    (1+
                     ;; Since SBCL gives us only character offset, we
                     ;; have to manually walk through the file char
                     ;; by char and count newlines.
                     (loop repeat offset
                           count (eql (read-char f) #\Newline))))))

(defun meaningful-print-frame (frame print-locals?)
  (let* ((code-loc (sb-di::code-location-debug-source (sb-di::frame-code-location frame)))
         (filename (sb-di::debug-source-namestring code-loc)))
   (multiple-value-bind (fn-name args) (sb-debug::frame-call frame)
     (format *debug-io* "~&~a:~4t(~a~{ ~_~S~})~&~4tat ~a"
             (sb-di:frame-number frame)
             fn-name
             args
             (if filename
                 (format nil "~a:~d" filename (line-number filename code-loc))
               "<no file>:0"))
     (when print-locals?
       ;; Copypasted from SBCL's PRINT-LOCALS command, so I guess it
       ;; is good. Copypasted (not reused) because I wanted some
       ;; additional formatting, otherwise I'd just call
       ;; (sb-debug::list-locals-debug-command).
       (dolist (v (sb-di:ambiguous-debug-vars (sb-di:frame-debug-fun frame) ""))
         (format *debug-io* "~&~8t~S~:[#~W~;~*~]  =  ~S"
                      (sb-di:debug-var-symbol v)
                      (zerop (sb-di:debug-var-id v))
                      (sb-di:debug-var-id v)
                      (sb-di:debug-var-value v frame)))))))

(defun meaningful-backtrace (&key (count nil) (locals nil) (skip 0))
  ;; skip-ctr is used to suppress the output of our backtrace frames
  ;; when the backtrace is called not from the debugger. This solution
  ;; is dirty as hell but I don't want to rewrite
  ;; sb-debug::map-backtrace. Also it would be much better to
  ;; determine if the frame is somehow failed (it raised a condition)
  ;; and start printing from the first failed frame, but I don't know
  ;; how to do that and I'm already too late for lunch:).
  (let ((skip-ctr 0))
    (sb-debug::map-backtrace (lambda (frame)
                               (incf skip-ctr)
                               (if (> skip-ctr skip)
                                   (meaningful-print-frame frame locals)))
                             :count (if count
                                        (+ count skip)
                                      most-positive-fixnum))))

;; Part two.

(defmacro vigilantly (&rest body)
  `(handler-bind ((error
                   #'(lambda (_) (meaningful-backtrace :skip 2))))
                 ,@body))

;; Testcases. Primitive testcase. Run (foo) to test.
;; Call (meaningful-backtrace) from the debugger, or
;; (meaningful-backtrace :locals t) to see the locals as well.

(defun foo ()
  (bar "foo" 3))

(defun bar (a b)
  (+ a b))

#+nil
(foo) ; To enter the debugger

#+nil
(meaningful-backtrace)

#+nil
(meaningful-backtrace :locals t)

;; Testcases for part two.

(define-condition fubar (error)
  ((text :initarg :text)))

(defun tarfu ()
  (error 'fubar :text "TARFU"))

(defun snafu ()
  (vigilantly
   (tarfu)))

#+nil
(snafu) ; prints the backtrace and crashes into the debugger

#+nil
(handler-case (snafu)
              (fubar () (princ "FIDO")))

;; Prints the backtrace and lets higher-level handler process the
;; error.