From: Chris Hanson Date: Wed, 24 Feb 1999 21:57:17 +0000 (+0000) Subject: Use new procedure WITH-THREAD-EVENTS-BLOCKED. X-Git-Tag: 20090517-FFI~4601 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=adbe28e40862546e696911d602fbd410fc069dcc;p=mit-scheme.git Use new procedure WITH-THREAD-EVENTS-BLOCKED. --- diff --git a/v7/src/runtime/io.scm b/v7/src/runtime/io.scm index 594cc23a4..103926ceb 100644 --- a/v7/src/runtime/io.scm +++ b/v7/src/runtime/io.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: io.scm,v 14.58 1999/02/16 05:38:22 cph Exp $ +$Id: io.scm,v 14.59 1999/02/24 21:57:06 cph Exp $ Copyright (c) 1988-1999 Massachusetts Institute of Technology @@ -235,25 +235,22 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. buffer start end)))) (declare (integrate-operator do-read)) (if (and have-select? (not (channel-type=file? channel))) - (let ((block-events? (block-thread-events))) - (let ((result - (let ((do-test - (lambda (k) - (let ((result (test-for-input-on-channel channel))) - (case result - ((INPUT-AVAILABLE) - (do-read)) - ((PROCESS-STATUS-CHANGE) - (handle-subprocess-status-change) - (if (channel-closed? channel) 0 (k))) - (else - (k))))))) - (if (channel-blocking? channel) - (let loop () (do-test loop)) - (do-test (lambda () #f)))))) - (if (not block-events?) - (unblock-thread-events)) - result)) + (with-thread-events-blocked + (lambda () + (let ((do-test + (lambda (k) + (let ((result (test-for-input-on-channel channel))) + (case result + ((INPUT-AVAILABLE) + (do-read)) + ((PROCESS-STATUS-CHANGE) + (handle-subprocess-status-change) + (if (channel-closed? channel) 0 (k))) + (else + (k))))))) + (if (channel-blocking? channel) + (let loop () (do-test loop)) + (do-test (lambda () #f)))))) (do-read)))) (define (channel-read-block channel buffer start end) diff --git a/v7/src/runtime/os2graph.scm b/v7/src/runtime/os2graph.scm index c806d1f97..cd79c0e06 100644 --- a/v7/src/runtime/os2graph.scm +++ b/v7/src/runtime/os2graph.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: os2graph.scm,v 1.14 1999/01/02 06:11:34 cph Exp $ +$Id: os2graph.scm,v 1.15 1999/02/24 21:57:12 cph Exp $ Copyright (c) 1995-1999 Massachusetts Institute of Technology @@ -692,13 +692,6 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (error "Unknown font name:" font-specifier)) metrics))) -(define (without-thread-events thunk) - (let ((block-events? (block-thread-events))) - (let ((value (thunk))) - (if (not block-events?) - (unblock-thread-events)) - value))) - (define (fix:vector-min v) (let ((length (vector-length v)) (min (vector-ref v 0))) @@ -761,7 +754,8 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (define (pm-synchronize) (os2pm-synchronize) - (without-thread-events (lambda () (do () ((not (read-and-process-event))))))) + (with-thread-events-blocked + (lambda () (do () ((not (read-and-process-event))))))) (define (read-and-process-event) (let ((event (os2win-get-event event-descriptor #f))) @@ -854,7 +848,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (define (os2-graphics/read-user-event device) device - (without-thread-events + (with-thread-events-blocked (lambda () (let loop () (if (queue-empty? user-event-queue) @@ -881,7 +875,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (define (os2-graphics/discard-events device) device - (without-thread-events + (with-thread-events-blocked (lambda () (let loop () (flush-queue! user-event-queue) diff --git a/v7/src/runtime/x11graph.scm b/v7/src/runtime/x11graph.scm index f9f9fa85a..9e5f6783b 100644 --- a/v7/src/runtime/x11graph.scm +++ b/v7/src/runtime/x11graph.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: x11graph.scm,v 1.48 1999/01/02 06:19:10 cph Exp $ +$Id: x11graph.scm,v 1.49 1999/02/24 21:57:17 cph Exp $ Copyright (c) 1989-1999 Massachusetts Institute of Technology @@ -305,18 +305,15 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. registration)) (define (read-event display) - (let ((queue (x-display/event-queue display)) - (block-events? (block-thread-events))) - (let ((event - (let loop () - (if (queue-empty? queue) - (begin - (%read-and-process-event display) - (loop)) - (dequeue! queue))))) - (if (not block-events?) - (unblock-thread-events)) - event))) + (letrec ((loop + (let ((queue (x-display/event-queue display))) + (lambda () + (if (queue-empty? queue) + (begin + (%read-and-process-event display) + (loop)) + (dequeue! queue)))))) + (with-thread-events-blocked loop))) (define (%read-and-process-event display) (let ((event @@ -329,19 +326,18 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (process-event display event)))) (define (discard-events display) - (let ((queue (x-display/event-queue display)) - (block-events? (block-thread-events))) - (let loop () - (cond ((not (queue-empty? queue)) - (dequeue! queue) - (loop)) - ((x-display-process-events (x-display/xd display) 2) - => - (lambda (event) - (process-event display event) - (loop))))) - (if (not block-events?) - (unblock-thread-events)))) + (letrec ((loop + (let ((queue (x-display/event-queue display))) + (lambda () + (cond ((not (queue-empty? queue)) + (dequeue! queue) + (loop)) + ((x-display-process-events (x-display/xd display) 2) + => + (lambda (event) + (process-event display event) + (loop)))))))) + (with-thread-events-blocked loop))) (define (process-event display event) (without-interrupts @@ -512,15 +508,14 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (if (not (boolean? (x-window/mapped? window))) (begin (x-window-flush xw) - (let ((block-events? (block-thread-events)) - (display (x-window/display window))) - (let loop () - (if (not (eq? #t (x-window/mapped? window))) - (begin - (%read-and-process-event display) - (loop)))) - (if (not block-events?) - (unblock-thread-events))))))) + (letrec ((loop + (let ((display (x-window/display window))) + (lambda () + (if (not (eq? #t (x-window/mapped? window))) + (begin + (%read-and-process-event display) + (loop))))))) + (with-thread-events-blocked loop)))))) (define (decode-suppress-map-arg suppress-map? procedure) (cond ((boolean? suppress-map?)