scsh-conservatory
/
scx
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Kludge to terminate filtering threads

This commit is contained in:
mainzelm 2003-07-15 09:02:55 +00:00
parent 716c2ede20
commit 4384ee6b60
1 changed files with 34 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
scheme/xlib/sync-event.scm
View File

@ -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)))