From: Matt Birkholz Date: Wed, 27 Jul 2016 04:53:56 +0000 (-0700) Subject: x11-screen: Backport "permanent" IO thread event from x-screen. X-Git-Tag: mit-scheme-pucked-9.2.12~261^2~16 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=54a4c584792dda1537f5664f2ba854d3c8fa97c1;p=mit-scheme.git x11-screen: Backport "permanent" IO thread event from x-screen. --- diff --git a/src/x11-screen/x11-screen.scm b/src/x11-screen/x11-screen.scm index 35543143e..f5b244b60 100644 --- a/src/x11-screen/x11-screen.scm +++ b/src/x11-screen/x11-screen.scm @@ -5,21 +5,22 @@ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016 Massachusetts Institute of Technology -This file is part of an X11-screen plugin for MIT/GNU Scheme. +This file is part of MIT/GNU Scheme. -This plugin is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 2 of the License, or (at your -option) any later version. +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. -This plugin is distributed in the hope that it will be useful, but +MIT/GNU Scheme is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License -along with this plugin; if not, write to the Free Software Foundation, -Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. |# @@ -427,23 +428,23 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (guarantee-result))))))))))) (define (read-event queue display block?) - (preview-events display queue) - (let ((event - (if (queue-empty? queue) - (if (eq? 'IN-UPDATE block?) - #f - (read-event-1 display block?)) - (dequeue!/unsafe queue)))) - (if (and event trace-port) - (write-line event trace-port)) - event)) - -(define (preview-events display queue) (let loop () - (let ((event (x-display-process-events display 2))) - (if event - (begin (preview-event event queue) - (loop)))))) + (let* ((empty "empty") + (event* (with-thread-events-blocked + (lambda () + (if (queue-empty? queue) + empty + (dequeue!/unsafe queue))))) + (event (if (eq? event* empty) + (and (not (memq block? '(IN-UPDATE #f))) + (block-for-event display)) + event*))) + (if (and event trace-port) + (write-line event trace-port)) + (or event + (if (memq block? '(IN-UPDATE #f)) + #f + (loop)))))) (define trace-port #f) @@ -471,54 +472,30 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (vector-ref event 4) (vector-ref event 5)))) -(define (read-event-1 display block?) - ;; Now consider other (non-X) events. - (if (eq? '#T block?) - (let loop () - (let ((event (block-for-event display))) - (or event - (loop)))) - (cond (inferior-thread-changes? - event:inferior-thread-output) - ((process-output-available?) - event:process-output) - ((process-status-changes?) - event:process-status) - (else #f)))) - (define (block-for-event display) - (let ((x-events-available? #f) + display + (let ((queue x-display-events) (output-available? #f) (registrations)) (dynamic-wind (lambda () - (let ((thread (current-thread))) - (set! registrations - (cons - (register-io-thread-event - (x-display-descriptor display) 'READ - thread (lambda (mode) - mode - (set! x-events-available? #t))) - (register-process-output-events - thread (lambda (mode) - mode - (set! output-available? #t))))))) + (set! registrations + (register-process-output-events + (current-thread) + (lambda (mode) + mode + (set! output-available? #t))))) (lambda () (let loop () (with-thread-events-blocked (lambda () - (if (and (not x-events-available?) + (if (and (queue-empty? queue) (not output-available?) (not (process-status-changes?)) (not inferior-thread-changes?)) (suspend-current-thread)))) - (cond (x-events-available? - (let ((queue x-display-events)) - (preview-events display queue) - (if (queue-empty? queue) - #f - (dequeue!/unsafe queue)))) + (cond ((not (queue-empty? queue)) + (dequeue!/unsafe queue)) ((process-status-changes?) event:process-status) (output-available? @@ -531,6 +508,36 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (for-each deregister-io-thread-event registrations) (set! registrations))))) +(define (preview-event-stream) + (with-thread-events-blocked + (lambda () + + (define (register!) + (set! previewer-registration + (register-io-thread-event (x-display-descriptor x-display-data) + 'READ (current-thread) preview-events)) + unspecific) + + (define (preview-events mode) + mode + (if previewer-registration + (register!)) + (let loop () + (let ((event (x-display-process-events x-display-data 2))) + (if event + (begin (preview-event event x-display-events) + (loop)))))) + + (register!)))) + +(define (unpreview-event-stream) + (with-thread-events-blocked + (lambda () + (let ((registration previewer-registration)) + (set! previewer-registration #f) + (if registration + (deregister-io-thread-event registration)))))) + (define (wait-for-event interval predicate process-event) (let ((timeout (+ (real-time-clock) interval))) (let loop () @@ -681,6 +688,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (and (not (screen-deleted? screen)) (make-input-event 'DELETE-SCREEN delete-screen! screen)))) +;; Note that this handler is run in an interrupt (IO event). (define-event-handler event-type:map (lambda (screen event) event @@ -690,6 +698,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (screen-force-update screen) (make-input-event 'UPDATE update-screen! screen #f))))) +;; Note that this handler is run in an interrupt (IO event). (define-event-handler event-type:unmap (lambda (screen event) event @@ -697,6 +706,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (set-screen-mapped?! screen #f)) #f)) +;; Note that this handler is run in an interrupt (IO event). (define-event-handler event-type:visibility (lambda (screen event) (and (not (screen-deleted? screen)) @@ -1266,13 +1276,18 @@ Otherwise, it is copied from the primary selection." (define signal-interrupts?) (define last-focus-time) +(define previewer-registration) (define ignore-button-state) (define (with-editor-interrupts-from-x receiver) (fluid-let ((signal-interrupts? #t) (last-focus-time #f) + (previewer-registration) (ignore-button-state #f)) - (receiver (lambda (thunk) (thunk)) '()))) + (dynamic-wind + preview-event-stream + (lambda () (receiver (lambda (thunk) (thunk)) '())) + unpreview-event-stream))) (define (with-x-interrupts-enabled thunk) (with-signal-interrupts #t thunk))