Use new procedure WITH-THREAD-EVENTS-BLOCKED.

diff --git a/v7/src/runtime/io.scm b/v7/src/runtime/io.scm
index 594cc23a4e074c9ff5e3278715ea45a27c5eb2a3..103926ceb16fb75085e067b4b92e0e2db2f67d28 100644 (file)
--- 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 c806d1f97d8f81e827119941f91f7dfa1c8636b3..cd79c0e06a3f17de5cda14b16776ca750c6cdbbe 100644 (file)
--- 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 f9f9fa85ae03e530edd9368fea42b9dc5453f061..9e5f6783ba884f3a2b86fc98fe6fcd87d2e0e6b5 100644 (file)
--- 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)))
 \f
 (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?)