From 4384ee6b60b02392e3f10e84c437550982d48136 Mon Sep 17 00:00:00 2001 From: mainzelm Date: Tue, 15 Jul 2003 09:02:55 +0000 Subject: [PATCH] Kludge to terminate filtering threads --- scheme/xlib/sync-event.scm | 47 +++++++++++++++++++++++++++----------- 1 file changed, 34 insertions(+), 13 deletions(-) diff --git a/scheme/xlib/sync-event.scm b/scheme/xlib/sync-event.scm index 5f23269..1f48cef 100644 --- a/scheme/xlib/sync-event.scm +++ b/scheme/xlib/sync-event.scm @@ -41,7 +41,8 @@ (set! *most-recent-sync-x-event* (placeholder-value (really-next-sync-x-event *most-recent-sync-x-event*))))) - (lp)))))) + (lp)))) + 'init-sync-x-events)) (define (most-recent-sync-x-event) *most-recent-sync-x-event*) @@ -100,26 +101,46 @@ (define (call-with-event-channel display window event-mask fun) (let ((r (make-request display window event-mask)) - (channel (make-channel))) - (spawn-event-filter channel display window event-mask) + (x-event-channel (make-channel)) + (filter-control-channel (make-channel)) + (dead?-box (cons #f #f))) + (spawn-event-filter x-event-channel filter-control-channel + display window event-mask fun dead?-box) ;; we send the first sync-event to the thread to really have the ;; most recent one, without keeping it in an environment. - (send channel (most-recent-sync-x-event)) - (dynamic-wind - (lambda () (add-request! r)) - (lambda () (fun channel)) - (lambda () (remove-request! r))))) + (send filter-control-channel (most-recent-sync-x-event)) + (let ((first? #t)) + (dynamic-wind + (lambda () + (add-request! r) + (if first? + (set! first? #f) + (warn "throwing back into call-with-event-channel"))) + (lambda () (call-with-values + (lambda () (fun x-event-channel)) + (lambda args + (apply values args)))) + (lambda () + (set-car! dead?-box #t) + (remove-request! r)))))) -(define (spawn-event-filter out-channel display window event-mask) +(define (true x) #t) + +(define (spawn-event-filter out-channel control-channel display window event-mask fun dead?-box) (let ((pred (lambda (e) (and (eq? (any-event-display e) display) (matches-event-mask? window event-mask e))))) (spawn (lambda () ;; the first sync-event is send to us through the channel - (let loop ((se (receive out-channel))) - (let ((nse (next-sync-x-event se pred))) - (send out-channel (sync-x-event-event nse)) - (loop nse))))))) + (let loop ((se (receive control-channel))) + (if (not (car dead?-box)) + (let ((nse (next-sync-x-event se true))) + (if (not (car dead?-box)) + (if (pred (sync-x-event-event nse)) + (begin (send out-channel (sync-x-event-event nse)) + (loop nse)) + (loop nse))))))) + (cons 'spawn-event-filter fun)))) (define (matches-event-mask? window event-mask event) (let ((type (any-event-type event)))