Better stacktraces for SBCL without external dependencies

debugger.lisp

(in-package :some-debugger)

(defun vector->list (vec)
  (coerce vec 'list))

(defun frame-file (frame)
  (let* ((code-location (sb-di:frame-code-location frame))
         (dsource (sb-di:code-location-debug-source code-location)))
    (if dsource
      (let ((file (sb-c::debug-source-namestring dsource)))
        (if (probe-file file) file)))))

(defun frame-args (frame)
  (let* ((code-location (sb-di:frame-code-location frame))
         (vars (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame)))
         (filtered-vars (remove-if (lambda (var)
                                     (ecase (sb-di:debug-var-validity var code-location)
                                       (:valid nil)
                                       ((:invalid :unknown) t)))
                                   vars))
         (list-of-vars (vector->list filtered-vars)))
    (mapcar (lambda (var)
              (format nil "~a = ~s"
                (sb-di:debug-var-symbol var)
                (sb-di:debug-var-value var frame)))
            list-of-vars)))

(defun line-number (offset file)
  (if (and file (probe-file file) offset)
    (with-open-file (stream file)
      (1+ (loop repeat offset
                count (eql (read-char stream) #\Newline))))))

(defun frame-line-number (frame)
  (let* ((code-location (sb-di:frame-code-location frame))
         (dsource       (sb-di:code-location-debug-source code-location))
         (file          (frame-file frame))
         (positions     (if dsource (sb-c::debug-source-start-positions dsource)))
         (offset        (if positions (aref positions (1- (length positions)))))
         (line          (line-number offset file)))
    line))

(defun frame->info-list (frame add-locals)
  (let ((num         (sb-di:frame-number frame))
        (call        (sb-debug::frame-call frame))
        (file        (frame-file frame))
        (line-number (frame-line-number frame))
        (arguments   (if add-locals (frame-args frame))))
    (list num call file line-number arguments)))

(defun get-stack (add-locals)
  (loop for frame = (sb-di:top-frame)
        then (sb-di:frame-down frame)
        while frame
        collect (frame->info-list frame add-locals)))

(defun print-stack-to-out (out stack)
  (let ((fmt "~2@a: ~s~%~
                     ~:[~*~;~:[~2:*    File: ~a (unknown line)~*~%~;~
                               ~2:*    File: ~a:~a~%~]~]~
                     ~{          ~a~%~}"))
    (apply #'format out fmt stack)))

(defun print-stack (out print-locals)
  (dolist (stack (get-stack print-locals))
    (print-stack-to-out out stack)))

(defun print-locals (out))

(defmacro catch-them-all (out print-locals &body body)
  "Catch exception in body, print nice stacktrace, print locals if print-locals set to T"
  `(handler-bind ((error (lambda (e)
                           (print-stack ,out ,print-locals)
                           (error e))))
     ,@body))

(catch-them-all *standard-output* t
  (error "hello error"))

; Samlpe output:
;
;2: (FLET #:LAMBDA601 :IN "/home/gnzh/mydev/sbcl-nice-stacktraces.lisp")
    ;File: /home/gnzh/mydev/sbcl-nice-stacktraces.lisp:84
          ;ARG-0 = #<SIMPLE-ERROR "hello error" {1003ED9563}>