[Emacs-diffs] master 2461266: Prevent QUIT to top level inside 'while-no-input'

[Eli Zaretskii]

branch: master
commit 2461266be1ea68a8c79af61abe850bb5a2c65040
Author: Eli Zaretskii <address@hidden>
Commit: Eli Zaretskii <address@hidden>

    Prevent QUIT to top level inside 'while-no-input'
    
    * lisp/subr.el (while-no-input): Handle the case when BODY
    never tests quit-flag, and runs to completion even though
    input arrives while BODY executes.  (Bug#31692)
---
 lisp/subr.el | 28 +++++++++++++++++++++++++---
 1 file changed, 25 insertions(+), 3 deletions(-)

diff --git a/lisp/subr.el b/lisp/subr.el
index 914112c..4a2b797 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -3520,9 +3520,31 @@ If BODY finishes, `while-no-input' returns whatever 
value BODY produced."
   (let ((catch-sym (make-symbol "input")))
     `(with-local-quit
        (catch ',catch-sym
-        (let ((throw-on-input ',catch-sym))
-          (or (input-pending-p)
-              (progn ,@body)))))))
+        (let ((throw-on-input ',catch-sym)
+               val)
+           (setq val (or (input-pending-p)
+                        (progn ,@body)))
+           (cond
+            ;; When input arrives while throw-on-input is non-nil,
+            ;; kbd_buffer_store_buffered_event sets quit-flag to the
+            ;; value of throw-on-input.  If, when BODY finishes,
+            ;; quit-flag still has the same value as throw-on-input, it
+            ;; means BODY never tested quit-flag, and therefore ran to
+            ;; completion even though input did arrive before it
+            ;; finished.  In that case, we must manually simulate what
+            ;; 'throw' in process_quit_flag would do, and we must
+            ;; reset quit-flag, because leaving it set will cause us
+            ;; quit to top-level, which has undesirable consequences,
+            ;; such as discarding input etc.  We return t in that case
+            ;; because input did arrive during execution of BODY.
+            ((eq quit-flag throw-on-input)
+             (setq quit-flag nil)
+             t)
+            ;; This is for when the user actually QUITs during
+            ;; execution of BODY.
+            (quit-flag
+             nil)
+            (t val)))))))
 
 (defmacro condition-case-unless-debug (var bodyform &rest handlers)
   "Like `condition-case' except that it does not prevent debugging.