gtk: Make call-within-main-loop-and-wait signal an error instead of just hanging...

diff --git a/gtk/gtk.high-level.lisp b/gtk/gtk.high-level.lisp
index 1e84c6f..977007f 100644 (file)
--- a/gtk/gtk.high-level.lisp
+++ b/gtk/gtk.high-level.lisp
@@ -1,16 +1,26 @@
 (in-package :gtk)
 
+(define-condition gtk-call-aborted (error)
+  ((condition :initarg :condition :reader gtk-call-aborted-condition))
+  (:report (lambda (c stream)
+             (format stream "Call within main loop aborted because of error:~%~A" (gtk-call-aborted-condition c)))))
+
 (defun call-within-main-loop-and-wait (fn)
   (let ((lock (bt:make-lock))
         (cv (bt:make-condition-variable))
+        error
         result)
     (bt:with-lock-held (lock)
       (within-main-loop
-        (setf result (multiple-value-list (funcall fn)))
+        (handler-case
+            (setf result (multiple-value-list (funcall fn)))
+          (error (e) (setf error e)))
         (bt:with-lock-held (lock)
           (bt:condition-notify cv)))
       (bt:condition-wait cv lock)
-      (values-list result))))
+      (if error
+          (error 'gtk-call-aborted :condition error)
+          (values-list result)))))
 
 (export 'call-within-main-loop-and-wait)
 

diff --git a/gtk/gtk.package.lisp b/gtk/gtk.package.lisp
index cd4ee40..800eeb9 100644 (file)
--- a/gtk/gtk.package.lisp
+++ b/gtk/gtk.package.lisp
@@ -21,7 +21,9 @@
            #:tree-node-remove-at
            #:tree-node-child-at
            #:tree-lisp-store-add-column
-           #:gtk-main-add-timeout))
+           #:gtk-main-add-timeout
+           #:gtk-call-aborted
+           #:gtk-call-aborted-condition))
 
 (defpackage :gtk-examples
   (:use :cl :gtk :gdk :gobject)