[STUMP] backtrace patch

[David Hansen]

In case the first try is lost in spiced ham.  This one is also
against recent cvs HEAD.  There was one tiny conflict to
resolve.

David

cvs diff: Diffing .
Index: primitives.lisp
===================================================================
RCS file: /cvsroot/stumpwm/stumpwm/primitives.lisp,v
retrieving revision 1.39
diff -u -r1.39 primitives.lisp
--- primitives.lisp     23 Oct 2006 06:02:40 -0000      1.39
+++ primitives.lisp     25 Oct 2006 16:42:47 -0000
@@ -434,3 +434,22 @@
 (defun font-height (font)
   (+ (xlib:font-descent font)
      (xlib:font-ascent font)))
+
+
+;;; Debugging
+
+(defun print-backtrace (&optional (stream *error-output*))
+  #+sbcl (sb-debug:backtrace most-positive-fixnum stream)
+  #-sbcl (write-line "backtrace printing not supported" stream))
+
+(defmacro with-backtrace ((&optional enter-debugger) &body body)
+  `(catch 'error-message
+     (handler-bind
+         ((error #'(lambda (err)
+                     (let ((message (format nil "~A" err)))
+                       (write-line message *error-output*)
+                       (if ,enter-debugger
+                           (invoke-debugger err)
+                           (print-backtrace))
+                       (throw 'error-message message)))))
+       ,@body)))
Index: stumpwm.lisp
===================================================================
RCS file: /cvsroot/stumpwm/stumpwm/stumpwm.lisp,v
retrieving revision 1.43
diff -u -r1.43 stumpwm.lisp
--- stumpwm.lisp        23 Oct 2006 06:02:40 -0000      1.43
+++ stumpwm.lisp        25 Oct 2006 16:42:48 -0000
@@ -80,33 +80,37 @@
       (catch :quit
        (loop
           (run-hook *internal-loop-hook*)
-          (handler-case 
-              (progn
-                (if (> *timeout* 0)
-                    (progn
-                      (let* ((time-before (get-universal-time))
-                             (nevents (xlib:event-listen *display* *timeout*))
-                             (time-left  (- *timeout* (- (get-universal-time) 
time-before))))
-                        (if (<= time-left 0)
-                            (progn
-                              (unmap-all-frame-indicators)
-                              (unmap-all-message-windows)
-                              (setf *timeout* 0))
-                            (setf *timeout* time-left))
-                        (when nevents
-                          (xlib:process-event *display* :handler 
#'handle-event))))
-                    ;; Otherwise, simply wait for an event
-                    (xlib:process-event *display* :handler #'handle-event 
:timeout nil))
-                ;; flush any pending output. You'd think process-event would, 
but
-                ;; it seems not.
-                (xlib:display-finish-output *display*))
-            (error (c)
-              (ecase *top-level-error-action*
-                (:message
-                 (let ((s (format nil "~&Caught ~a at the top level. Please 
report this." c)))
-                   (write-line s)
-                   (echo-string (current-screen) s)))
-                (:break (invoke-debugger c))))))))))
+           (let ((error-message
+                  (with-backtrace ((eq :break *top-level-error-action*))
+                    (if (> *timeout* 0)
+                        (let* ((time-before (get-universal-time))
+                               (nevents (xlib:event-listen *display*
+                                                           *timeout*))
+                               (time-left (- *timeout*
+                                             (- (get-universal-time)
+                                                time-before))))
+                          (if (<= time-left 0)
+                              (progn
+                                (unmap-all-frame-indicators)
+                                (unmap-all-message-windows)
+                                (setf *timeout* 0))
+                              (setf *timeout* time-left))
+                          (when nevents
+                            (xlib:process-event *display*
+                                                :handler #'handle-event)))
+                        ;; Otherwise, simply wait for an event
+                        (xlib:process-event *display*
+                                            :handler #'handle-event
+                                            :timeout nil))
+                    ;; flush any pending output. You'd think process-event
+                    ;; would, but it seems not.
+                    (xlib:display-finish-output *display*))))
+             (and (stringp error-message)
+                  (eq :message *top-level-error-action*)
+                  (echo-string (current-screen)
+                               (concatenate 'string
+                                            "Please report this: "
+                                            error-message)))))))))
 
 (defun parse-display-string (display)
   "Parse an X11 DISPLAY string and return the host and display from it."
Index: user.lisp
===================================================================
RCS file: /cvsroot/stumpwm/stumpwm/user.lisp,v
retrieving revision 1.51
diff -u -r1.51 user.lisp
--- user.lisp   23 Oct 2006 06:02:40 -0000      1.51
+++ user.lisp   25 Oct 2006 16:42:55 -0000
@@ -384,9 +384,8 @@
 
 (defun eval-line (screen cmd)
   (echo-string screen
-              (handler-case (prin1-to-string (eval (read-from-string cmd)))
-                (error (c)
-                  (format nil "~A" c)))))
+               (with-backtrace ()
+                 (prin1-to-string (eval (read-from-string cmd))))))
 
 (define-stumpwm-command "eval" (screen (cmd :rest "Eval: "))
   (eval-line screen cmd))
@@ -482,9 +481,7 @@
 
 (defun interactive-command (cmd screen)
   "exec cmd and echo the result."
-  (let ((result (handler-case (parse-and-run-command cmd screen)
-                             (error (c)
-                                    (format nil "~A" c)))))
+  (let ((result (with-backtrace () (parse-and-run-command cmd screen))))
     ;; interactive commands update the modeline
     (when (screen-mode-line screen)
       (redraw-mode-line-for (screen-mode-line screen) screen))