From: Matt Birkholz Date: Tue, 26 Jul 2016 22:02:26 +0000 (-0700) Subject: Restore interruptibility to Edwin commands when on an X display. X-Git-Tag: mit-scheme-pucked-9.2.12~261^2~20 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=2bfc70ce025ac0d22d53c2e726a88a2efce00e40;p=mit-scheme.git Restore interruptibility to Edwin commands when on an X display. Commit 52eea88 (Do NOT use permanently-register-io-thread-event in Edwin.) removed too much. Without an IO thread event registered to preview X events, Edwin cannot be interrupted by a ^G key press. Restore X event previewing using a custom, "permanently" registered IO thread event that always consumes some input before re-registering (i.e. withOUT the reading-event? variable that caused the spinning previously). Now X events are read only in the previewer (and wait-for-event). Keyboard operations only process queued events. And the queue is used only by the previewer or with thread events (the previewer) blocked. Remove deregister-all-events from cmdl/start so that the "non- permanent" IO thread event registered by the grab-editor wrapper is not undone when the editor command level is started. Reversing the order ("grab" the editor INSIDE the command level) makes the wrapper's special operations unavailable when the command level is made. If there is need for the aggressive decoupling of command levels as rendered by deregister-all-events (which nevertheless did NOT remove "permanent" IO event registrations), some mechanism will be needed to set up the previewer after the command level is entered. --- diff --git a/src/edwin/xterm.scm b/src/edwin/xterm.scm index ca7a04845..18cab574c 100644 --- a/src/edwin/xterm.scm +++ b/src/edwin/xterm.scm @@ -500,23 +500,23 @@ 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) @@ -544,54 +544,30 @@ 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? @@ -604,6 +580,36 @@ 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 () @@ -754,6 +760,7 @@ 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 @@ -763,6 +770,7 @@ 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 @@ -770,6 +778,7 @@ 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)) @@ -1335,13 +1344,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)) diff --git a/src/runtime/rep.scm b/src/runtime/rep.scm index 1a1862040..9d82d9547 100644 --- a/src/runtime/rep.scm +++ b/src/runtime/rep.scm @@ -137,7 +137,6 @@ USA. (loop (bind-abort-restart cmdl (lambda () - (deregister-all-events) (with-interrupt-mask interrupt-mask/all (lambda (interrupt-mask) interrupt-mask