From: Chris Hanson Date: Tue, 27 Apr 1993 09:22:32 +0000 (+0000) Subject: These changes require microcode 11.131 and runtime 14.161. The X-Git-Tag: 20090517-FFI~8378 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=cee9a6a0b6625af99dda6905d66aca5d253f4f3d;p=mit-scheme.git These changes require microcode 11.131 and runtime 14.161. The changes are a redesign of the keyboard input, subprocess, and inferior thread communication mechanisms to use the new `select' interface support. The changes should not be visible to users or customizers. --- diff --git a/v7/src/edwin/editor.scm b/v7/src/edwin/editor.scm index db1a2206b..210cbb8d9 100644 --- a/v7/src/edwin/editor.scm +++ b/v7/src/edwin/editor.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: editor.scm,v 1.226 1993/02/25 08:52:48 gjr Exp $ +;;; $Id: editor.scm,v 1.227 1993/04/27 09:22:26 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-1993 Massachusetts Institute of Technology ;;; @@ -428,12 +428,12 @@ This does not affect editor errors or evaluation errors." (lambda () (set-car! flags true) (set! inferior-thread-changes? true) - unspecific))) + (signal-thread-event editor-thread #f)))) (define (inferior-thread-output!/unsafe flags) (set-car! flags true) (set! inferior-thread-changes? true) - unspecific) + (signal-thread-event editor-thread #f)) (define (accept-thread-output) (without-interrupts diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg index 17836d466..5b48a4b5c 100644 --- a/v7/src/edwin/edwin.pkg +++ b/v7/src/edwin/edwin.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: edwin.pkg,v 1.117 1993/02/25 03:26:20 gjr Exp $ +$Id: edwin.pkg,v 1.118 1993/04/27 09:22:28 cph Exp $ Copyright (c) 1989-1993 Massachusetts Institute of Technology @@ -247,6 +247,7 @@ MIT in each case. |# screen-discard! screen-enter! screen-exit! + screen-force-update screen-get-output-line screen-in-update? screen-line-draw-cost @@ -874,6 +875,7 @@ MIT in each case. |# process-list ; always present process-mark process-name + process-output-available? process-runnable? process-send-char process-send-eof @@ -881,6 +883,7 @@ MIT in each case. |# process-send-substring process-sentinel process-status + process-status-changes? process-status-message quit-process set-process-buffer! diff --git a/v7/src/edwin/intmod.scm b/v7/src/edwin/intmod.scm index 599d153e5..019e86d98 100644 --- a/v7/src/edwin/intmod.scm +++ b/v7/src/edwin/intmod.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: intmod.scm,v 1.55 1993/01/20 04:50:16 cph Exp $ +;;; $Id: intmod.scm,v 1.56 1993/04/27 09:22:29 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology ;;; @@ -208,9 +208,11 @@ REPL uses current evaluation environment." (let ((port (buffer-interface-port buffer))) (if port (begin - (signal-thread-event (port/thread port) - (lambda () - (exit-current-thread unspecific))) + (let ((thread (port/thread port))) + (if (not (thread-dead? thread)) + (signal-thread-event thread + (lambda () + (exit-current-thread unspecific))))) (buffer-remove! buffer 'INTERFACE-PORT) (let ((run-light (ref-variable-object run-light))) (if (and (ref-variable evaluate-in-inferior-repl buffer) diff --git a/v7/src/edwin/make.scm b/v7/src/edwin/make.scm index bfd11b6f0..58f646c64 100644 --- a/v7/src/edwin/make.scm +++ b/v7/src/edwin/make.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: make.scm,v 3.77 1993/01/09 01:16:16 cph Exp $ +$Id: make.scm,v 3.78 1993/04/27 09:22:30 cph Exp $ -Copyright (c) 1989-1992 Massachusetts Institute of Technology +Copyright (c) 1989-93 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -40,4 +40,4 @@ MIT in each case. |# "edwin" `((os-type . ,(intern (microcode-identification-item 'OS-NAME-STRING)))) 'QUERY) -(add-system! (make-system "Edwin" 3 77 '())) \ No newline at end of file +(add-system! (make-system "Edwin" 3 78 '())) \ No newline at end of file diff --git a/v7/src/edwin/process.scm b/v7/src/edwin/process.scm index e7dec6425..176c8dc98 100644 --- a/v7/src/edwin/process.scm +++ b/v7/src/edwin/process.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: process.scm,v 1.28 1993/02/10 16:24:39 cph Exp $ +;;; $Id: process.scm,v 1.29 1993/04/27 09:22:31 cph Exp $ ;;; ;;; Copyright (c) 1991-93 Massachusetts Institute of Technology ;;; @@ -51,6 +51,7 @@ (define (initialize-processes!) (set! edwin-processes '()) + (set! process-input-queue (cons '() '())) (set-variable! exec-path (parse-path-string (let ((path (get-environment-variable "PATH"))) @@ -101,7 +102,8 @@ Initialized from the SHELL environment variable." (filter false) (sentinel false) (kill-without-query false) - (notification-tick (cons false false))) + (notification-tick (cons false false)) + (input-registration #f)) (define-integrable (process-arguments process) (subprocess-arguments (process-subprocess process))) @@ -166,11 +168,6 @@ Initialized from the SHELL environment variable." (without-interrupts (lambda () (let ((subprocess (make-subprocess))) - (let ((channel (subprocess-input-channel subprocess))) - (if channel - (begin - (channel-nonblocking channel) - (channel-register channel)))) (let ((process (%make-process subprocess @@ -180,6 +177,11 @@ Initialized from the SHELL environment variable." "<" (number->string n) ">"))) ((not (get-process-by-name name*)) name*)) buffer))) + (let ((channel (subprocess-input-channel subprocess))) + (if channel + (begin + (channel-nonblocking channel) + (register-process-input process channel)))) (update-process-mark! process) (subprocess-put! subprocess 'EDWIN-PROCESS process) (set! edwin-processes (cons process edwin-processes)) @@ -200,11 +202,16 @@ Initialized from the SHELL environment variable." (begin (subprocess-kill subprocess) (%perform-status-notification process 'SIGNALLED false))) - (let ((channel (subprocess-input-channel subprocess))) - (if (and channel (channel-open? channel)) - (channel-unregister channel))) + (deregister-process-input process) (subprocess-delete subprocess))))) +(define (deregister-process-input process) + (let ((registration (process-input-registration process))) + (if registration + (begin + (set-process-input-registration! process #f) + (deregister-input-thread-event registration))))) + (define (get-process-by-name name) (let loop ((processes edwin-processes)) (cond ((null? processes) false) @@ -228,6 +235,55 @@ Initialized from the SHELL environment variable." ;;;; Input and Output +(define process-input-queue) + +(define (register-process-input process channel) + (set-process-input-registration! + process + (permanently-register-input-thread-event + (channel-descriptor-for-select channel) + (current-thread) + (lambda () + (let ((queue process-input-queue) + (tail (list process))) + (if (null? (cdr queue)) + (set-car! queue tail) + (set-cdr! (cdr queue) tail)) + (set-cdr! queue tail)))))) + +(define (process-output-available?) + (not (null? (car process-input-queue)))) + +(define (accept-process-output) + (let ((queue process-input-queue)) + (let loop ((output? #f)) + (if (null? (car queue)) + output? + (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok))) + (let ((process (caar queue))) + (set-car! queue (cdar queue)) + (if (null? (car queue)) + (set-cdr! queue '())) + (let ((output? + (if (poll-process-for-output process) #t output?))) + (set-interrupt-enables! interrupt-mask) + (loop output?)))))))) + +(define (poll-process-for-output process) + (let ((channel (process-input-channel process)) + (buffer (make-string 512))) + (and (channel-open? channel) + (let ((n (channel-read channel buffer 0 512))) + (cond ((not n) + #f) + ((> n 0) + (output-substring process buffer n)) + (else + (deregister-process-input process) + (channel-close channel) + (%update-global-notification-tick) + (poll-process-for-status-change process))))))) + (define (process-send-eof process) (process-send-char process #\EOT)) @@ -240,45 +296,29 @@ Initialized from the SHELL environment variable." (define (process-send-char process char) (channel-write-char-block (process-output-channel process) char)) -(define (accept-process-output) +(define (process-status-changes?) (without-interrupts (lambda () - (let loop ((processes edwin-processes) (output? false)) - (if (null? processes) - output? - (loop (cdr processes) - (if (poll-process-for-output (car processes)) - true - output?))))))) - -(define (poll-process-for-output process) - (let ((channel (process-input-channel process)) - (buffer (make-string 512))) - (and (channel-open? channel) - (let loop ((output? false)) - (let ((n (channel-read channel buffer 0 512))) - (cond ((not n) - output?) - ((> n 0) - (loop (or (output-substring process buffer n) output?))) - (else - (channel-close channel) - output?))))))) + (not (eq? (subprocess-global-status-tick) global-notification-tick))))) (define (handle-process-status-changes) (without-interrupts (lambda () - (let ((tick (subprocess-global-status-tick))) - (and (not (eq? tick global-notification-tick)) - (begin - (set! global-notification-tick tick) - (let loop ((processes edwin-processes) (output? false)) - (if (null? processes) - output? - (loop (cdr processes) - (if (poll-process-for-status-change (car processes)) - true - output?)))))))))) + (and (%update-global-notification-tick) + (let loop ((processes edwin-processes) (output? false)) + (if (null? processes) + output? + (loop (cdr processes) + (if (poll-process-for-status-change (car processes)) + true + output?)))))))) + +(define (%update-global-notification-tick) + (let ((tick (subprocess-global-status-tick))) + (and (not (eq? tick global-notification-tick)) + (begin + (set! global-notification-tick tick) + #t)))) (define global-notification-tick (cons false false)) @@ -559,7 +599,7 @@ after the listing is made.)" (output-channel (subprocess-input-channel process)) (output-mark (mark-left-inserting-copy output-mark))) (let loop () - (let ((n (channel-read output-channel buffer 0 512))) + (let ((n (channel-read-block output-channel buffer 0 512))) (if (> n 0) (begin (insert-substring buffer 0 n output-mark) diff --git a/v7/src/edwin/tterm.scm b/v7/src/edwin/tterm.scm index 0d2c494af..470d903ae 100644 --- a/v7/src/edwin/tterm.scm +++ b/v7/src/edwin/tterm.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/tterm.scm,v 1.18 1992/08/27 06:30:57 jinx Exp $ +$Id: tterm.scm,v 1.19 1993/04/27 09:22:31 cph Exp $ -Copyright (c) 1990-1992 Massachusetts Institute of Technology +Copyright (c) 1990-93 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -146,77 +146,78 @@ MIT in each case. |# (let ((channel (input-port/channel console-input-port)) (string (make-string input-buffer-size)) (start input-buffer-size) - (end input-buffer-size) - (pending-event false)) - (let ((read-event - (lambda (block?) - (let ((event pending-event)) - (cond (event - (set! pending-event false) - event) - ((fix:< start end) - (string-ref string start)) - (else - (let loop () - (if block? - (channel-blocking channel) - (channel-nonblocking channel)) - (let ((n - (channel-select-then-read - channel string 0 input-buffer-size))) - (cond ((not n) - (if block? - (error "#F returned from blocking read")) - false) - ((fix:> n 0) - (set! start 0) - (set! end n) - (if transcript-port - (output-port/write-substring - transcript-port string 0 n)) - (string-ref string 0)) - ((or (fix:= n event:process-output) - (fix:= n event:process-status)) - n) - ((fix:= n event:interrupt) - (if inferior-thread-changes? n (loop))) - ((fix:= n 0) - (error "Reached EOF in keyboard input.")) - (else - (error "Illegal return value:" n))))))))))) - (let ((read-until-result - (lambda (block?) - (let loop () - (let ((event - (if block? - (or (read-event false) - (begin - (update-screens! false) - (read-event true))) - (read-event false)))) - (if (fix:fixnum? event) - (begin - (process-change-event event) - (loop)) - event)))))) - (values - (lambda () ;halt-update? - (or pending-event - (fix:< start end) - (let ((event (read-event false))) + (end input-buffer-size)) + (letrec + ((read-char + (lambda (block?) + (if block? + (channel-blocking channel) + (channel-nonblocking channel)) + (let ((n + (channel-read channel + string 0 input-buffer-size))) + (cond ((not n) #f) + ((fix:> n 0) + (set! start 0) + (set! end n) + (if transcript-port + (output-port/write-substring transcript-port + string 0 n)) + (string-ref string 0)) + ((fix:= n 0) + (error "Reached EOF in keyboard input.")) + (else + (error "Illegal return value:" n)))))) + (read-event + (lambda (block?) + (or (read-char #f) + (let loop () + (cond (inferior-thread-changes? event:interrupt) + ((process-output-available?) event:process-output) + (else + (case (test-for-input-on-descriptor + (channel-descriptor-for-select channel) + block?) + ((#F) #f) + ((PROCESS-STATUS-CHANGE) event:process-status) + ((INTERRUPT) (loop)) + (else (read-event block?))))))))) + (guarantee-result + (lambda () + (let ((event (read-event #t))) + (cond ((char? event) + event) + ((process-change-event event) + (make-input-event update-screens! #f)) + (else + (guarantee-result))))))) + (values + (lambda () ;halt-update? + (or (fix:< start end) + (read-char #f))) + (lambda () ;peek-no-hang + (if (fix:< start end) + (string-ref string start) + (let loop () + (let ((event (read-event #f))) (if (fix:fixnum? event) - (set! pending-event event)) - event))) - (lambda () ;peek-no-hang - (read-until-result false)) - (lambda () ;peek - (read-until-result true) - (string-ref string start)) - (lambda () ;read - (read-until-result true) - (let ((char (string-ref string start))) - (set! start (fix:+ start 1)) - char))))))) + (begin + (process-change-event event) + #f) + event))))) + (lambda () ;peek + (if (fix:< start end) + (string-ref string start) + (guarantee-result))) + (lambda () ;read + (if (fix:< start end) + (let ((char (string-ref string start))) + (set! start (fix:+ start 1)) + char) + (let ((event (guarantee-result))) + (if (char? event) + (set! start (fix:+ start 1))) + event))))))) (define-integrable input-buffer-size 16) (define-integrable event:process-output -2) diff --git a/v7/src/edwin/xterm.scm b/v7/src/edwin/xterm.scm index e37860f88..81876db23 100644 --- a/v7/src/edwin/xterm.scm +++ b/v7/src/edwin/xterm.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: xterm.scm,v 1.37 1992/11/20 19:10:11 cph Exp $ +;;; $Id: xterm.scm,v 1.38 1993/04/27 09:22:32 cph Exp $ ;;; -;;; Copyright (c) 1989-92 Massachusetts Institute of Technology +;;; Copyright (c) 1989-93 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -52,6 +52,7 @@ (x-close-all-displays 0) (x-close-display 1) (x-close-window 1) + (x-display-descriptor 1) (x-display-flush 1) (x-display-process-events 2) (x-display-sync 2) @@ -309,19 +310,11 @@ (define (get-xterm-input-operations) (let ((display x-display-data) (queue x-display-events) - (pending-result false) - (string false) + (pending-result #f) + (string #f) (start 0) - (end 0) - (pending-event false)) - (let ((get-next-event - (lambda (time-limit) - (if pending-event - (let ((event pending-event)) - (set! pending-event false) - event) - (read-event queue display time-limit)))) - (process-key-press-event + (end 0)) + (let ((process-key-press-event (lambda (event) (set! last-focus-time (vector-ref event 5)) (set! string (vector-ref event 2)) @@ -341,7 +334,7 @@ (if (and signal-interrupts? (char=? char #\BEL)) (begin (signal-interrupt!) - false) + #f) (begin (maybe-raise-screen) char)))) @@ -362,128 +355,119 @@ (set! start 1) (maybe-raise-screen) (string-ref string 0))))))))) - (let ((guarantee-result - (lambda () - (let loop () - (let ((event - (or (get-next-event 0) - (begin - (update-screens! false) - (get-next-event false))))) - (cond ((not event) - (error "#F returned from blocking read")) - ((not (vector? event)) - (process-change-event event) - (loop)) - (else - (or (if (fix:= event-type:key-press - (vector-ref event 0)) - (process-key-press-event event) - (process-special-event event)) - (loop))))))))) - (values - (lambda () ;halt-update? - (or pending-result - pending-event - (fix:< start end) - (let ((event (read-event queue display 0))) - (if event (set! pending-event event)) - event))) - (lambda () ;peek-no-hang - (or pending-result - (fix:< start end) - (let loop () - (let ((event (get-next-event 0))) - (cond ((not event) - false) - ((not (vector? event)) - (process-change-event event) - (loop)) - (else - (let ((result - (if (fix:= event-type:key-press - (vector-ref event 0)) - (process-key-press-event event) - (process-special-event event)))) - (if result - (begin - (set! pending-result result) - result) - (loop))))))))) - (lambda () ;peek - (or pending-result - (if (fix:< start end) - (string-ref string start) - (let ((result (guarantee-result))) - (set! pending-result result) - result)))) - (lambda () ;read - (cond (pending-result - => (lambda (result) - (set! pending-result false) - result)) - ((fix:< start end) - (let ((char (string-ref string start))) - (set! start (fix:+ start 1)) - char)) - (else - (guarantee-result))))))))) + (let ((process-event + (lambda (event) + (if (fix:= event-type:key-press (vector-ref event 0)) + (process-key-press-event event) + (process-special-event event))))) + (let ((probe + (lambda (block?) + (let loop () + (let ((event (read-event queue display block?))) + (cond ((not event) #f) + ((not (vector? event)) + (process-change-event event) + (loop)) + (else + (let ((result (process-event event))) + (if result + (begin (set! pending-result result) result) + (loop))))))))) + (guarantee-result + (lambda () + (let loop () + (let ((event (read-event queue display #t))) + (cond ((not event) + (error "#F returned from blocking read")) + ((not (vector? event)) + (if (process-change-event event) + (make-input-event update-screens! #f) + (loop))) + (else + (or (process-event event) (loop))))))))) + (values + (lambda () ;halt-update? + (or pending-result + (fix:< start end) + (probe 'IN-UPDATE))) + (lambda () ;peek-no-hang + (or pending-result + (fix:< start end) + (probe #f))) + (lambda () ;peek + (or pending-result + (if (fix:< start end) + (string-ref string start) + (let ((result (guarantee-result))) + (set! pending-result result) + result)))) + (lambda () ;read + (cond (pending-result + => (lambda (result) + (set! pending-result #f) + result)) + ((fix:< start end) + (let ((char (string-ref string start))) + (set! start (fix:+ start 1)) + char)) + (else + (guarantee-result)))))))))) -(define (read-event queue display time-limit) - (dynamic-wind - (lambda () - (lock-thread-mutex event-stream-mutex)) - (lambda () - (let loop () - (let ((event - (if (queue-empty? queue) - (if (and (not time-limit) - (other-running-threads?)) - ;; Don't block process if any other threads - ;; want to run. Mutex will stop previewer. - (or (x-display-process-events display 0) - (begin - (yield-current-thread) - event:interrupt)) - (x-display-process-events display time-limit)) - (dequeue!/unsafe queue)))) - (cond ((eq? event event:interrupt) - (if inferior-thread-changes? event (loop))) - ((and (vector? event) - (fix:= (vector-ref event 0) event-type:expose)) - (xterm-dump-rectangle (vector-ref event 1) - (vector-ref event 2) - (vector-ref event 3) - (vector-ref event 4) - (vector-ref event 5)) - (loop)) - (else event))))) - (lambda () - (unlock-thread-mutex event-stream-mutex)))) - -(define (preview-event-stream) - (detach-thread (current-thread)) - (do () (false) - (lock-thread-mutex event-stream-mutex) - (let loop () - (let ((event (x-display-process-events x-display-data 0))) - (cond ((not (vector? event)) - (if (and event - (or (not (eq? event:interrupt event)) - inferior-thread-changes?) - (not (queued?/unsafe x-display-events event))) - (enqueue!/unsafe x-display-events event))) - ((and signal-interrupts? - (fix:= event-type:key-press (vector-ref event 0)) - (string-find-next-char (vector-ref event 2) #\BEL)) - (clean-event-queue x-display-events) - (signal-thread-event editor-thread signal-interrupt!)) +(define (read-event queue display block?) + (let loop () + (let ((event + (let ((block-events? (block-thread-events))) + (let ((event + (if (queue-empty? queue) + (if (eq? 'IN-UPDATE block?) + (x-display-process-events display 2) + (read-event-1 display block?)) + (dequeue!/unsafe queue)))) + (if (not block-events?) + (unblock-thread-events)) + event)))) + (if (and (vector? event) + (fix:= (vector-ref event 0) event-type:expose)) + (begin + (xterm-dump-rectangle (vector-ref event 1) + (vector-ref event 2) + (vector-ref event 3) + (vector-ref event 4) + (vector-ref event 5)) + (loop)) + event)))) + +(define (read-event-1 display block?) + (or (x-display-process-events display 2) + (let loop () + (cond (inferior-thread-changes? event:interrupt) + ((process-output-available?) event:process-output) (else - (enqueue!/unsafe x-display-events event) - (loop))))) - (unlock-thread-mutex event-stream-mutex) - (sleep-current-thread previewer-interval))) + (case (test-for-input-on-descriptor + (x-display-descriptor display) + block?) + ((#F) #f) + ((PROCESS-STATUS-CHANGE) event:process-status) + ((INTERRUPT) (loop)) + (else (read-event-1 display block?)))))))) +(define (preview-event-stream) + (set! previewer-registration + (permanently-register-input-thread-event + (x-display-descriptor x-display-data) + (current-thread) + (lambda () + (let ((event (x-display-process-events x-display-data 2))) + (if event + (if (and signal-interrupts? + (fix:= event-type:key-press (vector-ref event 0)) + (string-find-next-char (vector-ref event 2) #\BEL)) + (begin + (clean-event-queue x-display-events) + (signal-interrupt!)) + (enqueue!/unsafe x-display-events event))))))) + unspecific) + (define (clean-event-queue queue) ;; Flush keyboard and mouse events from the input queue. Other ;; events are harmless and must be processed regardless. @@ -502,7 +486,7 @@ (cdr events))) ((null? events)) (enqueue!/unsafe queue (car events)))) - + (define (process-change-event event) (cond ((fix:= event event:process-output) (accept-process-output)) ((fix:= event event:process-status) (handle-process-status-changes)) @@ -522,21 +506,6 @@ (define-integrable (define-event-handler event-type handler) (vector-set! event-handlers event-type handler)) -(define-event-handler event-type:configure - (lambda (screen event) - (let ((xterm (screen-xterm screen)) - (x-size (vector-ref event 2)) - (y-size (vector-ref event 3))) - (xterm-reconfigure xterm x-size y-size) - (let ((x-size (xterm-map-x-size xterm x-size)) - (y-size (xterm-map-y-size xterm y-size))) - (if (not (and (= x-size (screen-x-size screen)) - (= y-size (screen-y-size screen)))) - (begin - (set-screen-size! screen x-size y-size) - (update-screen! screen true))))) - false)) - (define-event-handler event-type:button-down (lambda (screen event) (set! last-focus-time (vector-ref event 5)) @@ -556,6 +525,22 @@ (make-up-button (vector-ref event 4)) (xterm-map-x-coordinate xterm (vector-ref event 2)) (xterm-map-y-coordinate xterm (vector-ref event 3)))))) + +(define-event-handler event-type:configure + (lambda (screen event) + (let ((xterm (screen-xterm screen)) + (x-size (vector-ref event 2)) + (y-size (vector-ref event 3))) + (xterm-reconfigure xterm x-size y-size) + (let ((x-size (xterm-map-x-size xterm x-size)) + (y-size (xterm-map-y-size xterm y-size))) + (and (not (and (= x-size (screen-x-size screen)) + (= y-size (screen-y-size screen)))) + (make-input-event + (lambda (screen x-size y-size) + (set-screen-size! screen x-size y-size) + (update-screen! screen #t)) + screen x-size y-size)))))) (define-event-handler event-type:focus-in (lambda (screen event) @@ -567,20 +552,15 @@ (lambda (screen event) event (and (not (screen-deleted? screen)) - (if (selected-screen? screen) - (make-input-event delete-screen! screen) - (begin - (delete-screen! screen) - false))))) + (make-input-event delete-screen! screen)))) (define-event-handler event-type:map (lambda (screen event) event - (if (not (screen-deleted? screen)) - (begin - (set-screen-visibility! screen 'VISIBLE) - (update-screen! screen true))) - false)) + (and (not (screen-deleted? screen)) + (begin + (set-screen-visibility! screen 'VISIBLE) + (make-input-event update-screen! screen #t))))) (define-event-handler event-type:unmap (lambda (screen event) @@ -596,16 +576,15 @@ (define-event-handler event-type:visibility (lambda (screen event) (let ((old-visibility (screen-visibility screen))) - (if (not (eq? old-visibility 'DELETED)) - (begin - (case (vector-ref event 2) - ((0) (set-screen-visibility! screen 'VISIBLE)) - ((1) (set-screen-visibility! screen 'PARTIALLY-OBSCURED)) - ((2) (set-screen-visibility! screen 'OBSCURED))) - (if (or (eq? old-visibility 'UNMAPPED) - (eq? old-visibility 'OBSCURED)) - (update-screen! screen true))))) - false)) + (and (not (eq? old-visibility 'DELETED)) + (begin + (case (vector-ref event 2) + ((0) (set-screen-visibility! screen 'VISIBLE)) + ((1) (set-screen-visibility! screen 'PARTIALLY-OBSCURED)) + ((2) (set-screen-visibility! screen 'OBSCURED))) + (and (or (eq? old-visibility 'UNMAPPED) + (eq? old-visibility 'OBSCURED)) + (make-input-event update-screen! screen #t))))))) (define-event-handler event-type:take-focus (lambda (screen event) @@ -613,16 +592,18 @@ (make-input-event select-screen screen))) (define signal-interrupts?) -(define event-stream-mutex) -(define previewer-interval 1000) (define last-focus-time) +(define previewer-registration) (define (with-editor-interrupts-from-x receiver) (fluid-let ((signal-interrupts? true) - (event-stream-mutex (make-thread-mutex)) - (last-focus-time false)) - (queue-initial-thread preview-event-stream) - (receiver (lambda (thunk) (thunk)) '()))) + (last-focus-time false) + (previewer-registration)) + (dynamic-wind + preview-event-stream + (lambda () (receiver (lambda (thunk) (thunk)) '())) + (lambda () + (deregister-input-thread-event previewer-registration))))) (define (with-x-interrupts-enabled thunk) (with-signal-interrupts true thunk))