From 3e4f39aed54688e361ada3e73be676ca1fb5dfb7 Mon Sep 17 00:00:00 2001 Message-Id: <3e4f39aed54688e361ada3e73be676ca1fb5dfb7.1715165474.git.mdw@distorted.org.uk> From: Mark Wooding Date: Tue, 4 Mar 2008 16:03:38 +0000 Subject: [PATCH 1/1] Added *REENTRANT-MAIN-ITERATION* to control if MAIN-ITERATE-ALL can be invoked recursively. Organization: Straylight/Edgeware From: espen --- gtk/defpackage.lisp | 3 ++- gtk/gtkobject.lisp | 13 +++++++++---- 2 files changed, 11 insertions(+), 5 deletions(-) diff --git a/gtk/defpackage.lisp b/gtk/defpackage.lisp index 58367a8..87836f4 100644 --- a/gtk/defpackage.lisp +++ b/gtk/defpackage.lisp @@ -20,7 +20,8 @@ (defpackage "GTK" #+clisp (:import-from "SOCKET" "SOCKET-STATUS") (:export "EVENTS-PENDING-P" "GET-CURRENT-EVENT" "MAIN-DO-EVENT" "MAIN" - "MAIN-LEVEL" "MAIN-QUIT" "MAIN-ITERATION-DO" "MAIN-ITERATE-ALL") + "MAIN-LEVEL" "MAIN-QUIT" "MAIN-ITERATION-DO" "MAIN-ITERATE-ALL" + "*REENTRANT-MAIN-ITERATION*" "*RUNNING-MAIN-ITERATION*") (:export "CONTAINER-CHILD-CLASS" "CONTAINER-CHILD" "CONTAINER-CHILD-CLASS") ;; Signal names that need to be explicit exported (:export "TOGGLED") diff --git a/gtk/gtkobject.lisp b/gtk/gtkobject.lisp index 6171c5b..7d57bfd 100644 --- a/gtk/gtkobject.lisp +++ b/gtk/gtkobject.lisp @@ -20,7 +20,7 @@ ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: gtkobject.lisp,v 1.45 2008-02-28 18:33:12 espen Exp $ +;; $Id: gtkobject.lisp,v 1.46 2008-03-04 16:03:38 espen Exp $ (in-package "GTK") @@ -56,6 +56,9 @@ (defbinding %object-sink () nil ;;;; Main loop and event handling +(defparameter *reentrant-main-iteration* t) +(defvar *running-main-iteration* nil) + (defbinding events-pending-p () boolean) (defbinding get-current-event () gdk:event) @@ -74,9 +77,11 @@ (defbinding main-iteration-do (&optional (blocking t)) boolean (defun main-iterate-all (&rest args) (declare (ignore args)) - (loop - while (events-pending-p) - do (main-iteration-do nil)) + (unless (and (not *reentrant-main-iteration*) *running-main-iteration*) + (let ((*running-main-iteration* t)) + (loop + while (events-pending-p) + do (main-iteration-do nil)))) #+clisp 0) -- [mdw]