[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[STUMP] backtrace patch
From: |
David Hansen |
Subject: |
[STUMP] backtrace patch |
Date: |
Wed, 25 Oct 2006 18:48:15 +0200 |
User-agent: |
Gnus/5.110006 (No Gnus v0.6) Emacs/22.0.50 (gnu/linux) |
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))
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- [STUMP] backtrace patch,
David Hansen <=