edwin/intmod.scm: Call suspend-current-thread with events blocked.
authorMatt Birkholz <puck@birchwood-abbey.net>
Fri, 29 Jul 2016 06:49:29 +0000 (23:49 -0700)
committerMatt Birkholz <puck@birchwood-abbey.net>
Fri, 29 Jul 2016 07:08:47 +0000 (00:08 -0700)
Blocking thread events around these wait loops closes an interrupt
hole between testing and suspending.

src/edwin/intmod.scm

index 4fbc2e738a82e37b8d555ff1d9830d98e6c32c24..72a630bb32f2befb0de9bf8044dae025c73d73d2 100644 (file)
@@ -227,8 +227,10 @@ evaluated in the specified inferior REPL buffer."
         buffer)
        (set-run-light! buffer #f)
        (inferior-thread-run-light! (port/output-registration port)))))
-  (do () ((ready? port))
-    (suspend-current-thread)))
+  (with-thread-events-blocked
+   (lambda ()
+     (do () ((ready? port))
+       (suspend-current-thread)))))
 
 (define (end-input-wait port)
   (set-run-light! (port/buffer port) #t)
@@ -617,8 +619,10 @@ If this is an error, the debugger examines the error condition."
       (lambda ()
        (set! cmdl (nearest-cmdl))
        (signal-thread-event thread #f)))
-    (do () (cmdl)
-      (suspend-current-thread))
+    (with-thread-events-blocked
+     (lambda ()
+       (do () (cmdl)
+        (suspend-current-thread))))
     cmdl))
 
 (define-command inferior-cmdl-self-insert
@@ -1098,10 +1102,12 @@ If this is an error, the debugger examines the error condition."
                               (lambda ()
                                 (continue (procedure prompt))))))))
                    'FORCE-RETURN))))))
-       (let loop ()
-         (cond ((eq? value wait-value) (suspend-current-thread) (loop))
-               ((eq? value abort-value) (abort->nearest))
-               (else value)))))))
+       (with-thread-events-blocked
+        (lambda ()
+          (let loop ()
+            (cond ((eq? value wait-value) (suspend-current-thread) (loop))
+                  ((eq? value abort-value) (abort->nearest))
+                  (else value)))))))))
 \f
 (define (when-buffer-selected buffer thunk)
   (if (current-buffer? buffer)