;;; -*-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
;;;
(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
#| -*-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
screen-discard!
screen-enter!
screen-exit!
+ screen-force-update
screen-get-output-line
screen-in-update?
screen-line-draw-cost
process-list ; always present
process-mark
process-name
+ process-output-available?
process-runnable?
process-send-char
process-send-eof
process-send-substring
process-sentinel
process-status
+ process-status-changes?
process-status-message
quit-process
set-process-buffer!
;;; -*-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
;;;
(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)
#| -*-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
"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
;;; -*-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
;;;
(define (initialize-processes!)
(set! edwin-processes '())
+ (set! process-input-queue (cons '() '()))
(set-variable! exec-path
(parse-path-string
(let ((path (get-environment-variable "PATH")))
(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)))
(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
"<" (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))
(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)
\f
;;;; 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)))))))
+\f
(define (process-send-eof process)
(process-send-char process #\EOT))
(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))
(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)
#| -*-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
(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)))))))
\f
(define-integrable input-buffer-size 16)
(define-integrable event:process-output -2)
;;; -*-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
(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)
(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))
(if (and signal-interrupts? (char=? char #\BEL))
(begin
(signal-interrupt!)
- false)
+ #f)
(begin
(maybe-raise-screen)
char))))
(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))))))))))
\f
-(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)
+\f
(define (clean-event-queue queue)
;; Flush keyboard and mouse events from the input queue. Other
;; events are harmless and must be processed regardless.
(cdr events)))
((null? events))
(enqueue!/unsafe queue (car events))))
-\f
+
(define (process-change-event event)
(cond ((fix:= event event:process-output) (accept-process-output))
((fix:= event event:process-status) (handle-process-status-changes))
(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))
(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))))))
+\f
+(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)
(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)
(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)
(make-input-event select-screen screen)))
\f
(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))
projects / mit-scheme.git / commitdiff