* progmodes/gdb-mi.el: Fix non-responsive gud commands (bug#13845)

(gdb-handler-alist, gdb-handler-number): Remove variables.
(gdb-handler-list): New variable.
(gdb-add-handler, gdb-delete-handler, gdb-get-handler-function)
(gdb-pending-handler-p, gdb-handle-reply)
(gdb-remove-all-pending-triggers): New functions.
(gdb-discard-unordered-replies): New defcustom.
(gdb-handler): New defstruct.
(gdb-wait-for-pending): Fix invalid backquote.  Use gdb-handler-list.
instead of gdb-pending-triggers.  Update docstring.
(gdb-init-1): Remove dead variables.  Initialize gdb-handler-list.
(gdb-speedbar-update, gdb-speedbar-timer-fn, gdb-var-update)
(gdb-var-update-handler, def-gdb-auto-update-trigger)
(def-gdb-auto-update-handler, gdb-get-changed-registers)
(gdb-changed-registers-handler, gdb-get-main-selected-frame)
(gdb-frame-handler): Pending triggers are now automatically managed.
(def-gdb-trigger-and-handler, def-gdb-auto-update-handler):
Remove argument.
(gdb-input): Automatically handles pending triggers.  Update docstring.
(gdb-resync): Replace gdb-pending-triggers by gdb-handler-list.
(gdb-thread-exited, gdb-thread-selected, gdb-register-names-handler):
Update comments.
(gdb-done-or-error): Now use gdb-handle-reply.

1 files changed, 157 insertions, 88 deletions

diff --git a/lisp/progmodes/gdb-mi.el b/lisp/progmodes/gdb-mi.el
index 43eab07fb8d..2799eecb553 100644
--- a/lisp/progmodes/gdb-mi.el
+++ b/lisp/progmodes/gdb-mi.el
@@ -91,7 +91,7 @@
 (require 'gud)
 (require 'json)
 (require 'bindat)
-(eval-when-compile (require 'cl-lib))
+(require 'cl-lib)
 
 (declare-function speedbar-change-initial-expansion-list
                   "speedbar" (new-default))
@@ -206,8 +206,8 @@ Only used for files that Emacs can't find.")
 (defvar gdb-last-command nil)
 (defvar gdb-prompt-name nil)
 (defvar gdb-token-number 0)
-(defvar gdb-handler-alist '())
-(defvar gdb-handler-number nil)
+(defvar gdb-handler-list '()
+  "List of gdb-handler keeping track of all pending GDB commands.")
 (defvar gdb-source-file-list nil
   "List of source files for the current executable.")
 (defvar gdb-first-done-or-error t)
@@ -242,33 +242,114 @@ Possible values are these symbols:
 	       disposition of output generated by commands that
 	       gdb mode sends to gdb on its own behalf.")
 
-;; Pending triggers prevent congestion: Emacs won't send two similar
-;; consecutive requests.
-
-(defvar gdb-pending-triggers '()
-  "A list of trigger functions which have not yet been handled.
-
-Elements are either function names or pairs (buffer . function)")
-
-(defmacro gdb-add-pending (item)
-  `(push ,item gdb-pending-triggers))
-(defmacro gdb-pending-p (item)
-  `(member ,item gdb-pending-triggers))
-(defmacro gdb-delete-pending (item)
-  `(setq gdb-pending-triggers
-         (delete ,item gdb-pending-triggers)))
+(defcustom gdb-discard-unordered-replies t
+  "Non-nil means discard any out-of-order GDB replies.
+This protects against lost GDB replies, assuming that GDB always
+replies in the same order as Emacs sends commands.  When receiving a
+reply with a given token-number, assume any pending messages with a
+lower token-number are out-of-order."
+  :type 'boolean
+  :group 'gud
+  :version "24.4")
+
+(cl-defstruct gdb-handler
+  "Data required to handle the reply of a command sent to GDB."
+  ;; Prefix of the command sent to GDB.  The GDB reply for this command
+  ;; will be prefixed with this same TOKEN-NUMBER
+  (token-number nil :read-only t)
+  ;; Callback to invoke when the reply is received from GDB
+  (function nil :read-only t)
+  ;; PENDING-TRIGGER is used to prevent congestion: Emacs won't send
+  ;; two requests with the same PENDING-TRIGGER until a reply is received
+  ;; for the first one."
+  (pending-trigger nil))
+
+(defun gdb-add-handler (token-number handler-function &optional pending-trigger)
+  "Insert a new GDB command handler in `gdb-handler-list'.
+Handlers are used to keep track of the commands sent to GDB
+and to handle the replies received.
+Upon reception of a reply prefixed with TOKEN-NUMBER,
+invoke the callback HANDLER-FUNCTION.
+If PENDING-TRIGGER is specified, no new GDB commands will be
+sent with this same PENDING-TRIGGER until a reply is received
+for this handler."
+
+  (push (make-gdb-handler :token-number token-number
+                          :function handler-function
+                          :pending-trigger pending-trigger)
+        gdb-handler-list))
+
+(defun gdb-delete-handler (token-number)
+  "Remove the handler TOKEN-NUMBER from `gdb-handler-list'.
+Additionally, if `gdb-discard-unordered-replies' is non-nil,
+discard all handlers having a token number less than TOKEN-NUMBER."
+  (if gdb-discard-unordered-replies
+
+      (setq gdb-handler-list
+            (cl-delete-if
+             (lambda (handler)
+               "Discard any HANDLER with a token number `<=' than TOKEN-NUMBER."
+               (when (< (gdb-handler-token-number handler) token-number)
+                 (message (format
+                           "WARNING! Discarding GDB handler with token #%d\n"
+                           (gdb-handler-token-number handler))))
+               (<= (gdb-handler-token-number handler) token-number))
+             gdb-handler-list))
+
+    (setq gdb-handler-list
+          (cl-delete-if
+           (lambda (handler)
+             "Discard any HANDLER with a token number `eq' to TOKEN-NUMBER."
+             (eq (gdb-handler-token-number handler) token-number))
+           gdb-handler-list))))
+
+(defun gdb-get-handler-function (token-number)
+  "Return the function callback registered with the handler TOKEN-NUMBER."
+  (gdb-handler-function
+   (cl-find-if (lambda (handler) (eq (gdb-handler-token-number handler)
+                                      token-number))
+                gdb-handler-list)))
+
+
+(defun gdb-pending-handler-p (pending-trigger)
+  "Return non-nil if a command handler is pending with trigger PENDING-TRIGGER."
+  (cl-find-if (lambda (handler) (eq (gdb-handler-pending-trigger handler)
+                                     pending-trigger))
+               gdb-handler-list))
+
+
+(defun gdb-handle-reply (token-number)
+  "Handle the GDB reply TOKEN-NUMBER.
+This invokes the handler registered with this token number
+in `gdb-handler-list' and clears all pending handlers invalidated
+by the reception of this reply."
+  (let ((handler-function (gdb-get-handler-function token-number)))
+    (when handler-function
+      (funcall handler-function)
+      (gdb-delete-handler token-number))))
+
+(defun gdb-remove-all-pending-triggers ()
+  "Remove all pending triggers from gdb-handler-list.
+The handlers are left in gdb-handler-list so that replies received
+from GDB could still be handled.  However, removing the pending triggers
+allows Emacs to send new commands even if replies of previous commands
+were not yet received."
+  (dolist (handler gdb-handler-list)
+    (setf (gdb-handler-pending-trigger handler) nil)))
 
 (defmacro gdb-wait-for-pending (&rest body)
-  "Wait until `gdb-pending-triggers' is empty and evaluate FORM.
-
-This function checks `gdb-pending-triggers' value every
-`gdb-wait-for-pending' seconds."
-  (run-with-timer
-   0.5 nil
-   `(lambda ()
-      (if (not gdb-pending-triggers)
-          (progn ,@body)
-        (gdb-wait-for-pending ,@body)))))
+  "Wait for all pending GDB commands to finish and evaluate BODY.
+
+This function checks every 0.5 seconds if there are any pending
+triggers in `gdb-handler-list'."
+  `(run-with-timer
+    0.5 nil
+    '(lambda ()
+       (if (not (gdb-find-if (lambda (handler)
+                               (gdb-handler-pending-trigger handler))
+                             gdb-handler-list))
+	   (progn ,@body)
+	 (gdb-wait-for-pending ,@body)))))
 
 ;; Publish-subscribe
 
@@ -820,14 +901,12 @@ detailed description of this mode.
 	gdb-frame-number nil
         gdb-thread-number nil
 	gdb-var-list nil
-	gdb-pending-triggers nil
 	gdb-output-sink 'user
 	gdb-location-alist nil
 	gdb-source-file-list nil
 	gdb-last-command nil
 	gdb-token-number 0
-	gdb-handler-alist '()
-	gdb-handler-number nil
+	gdb-handler-list '()
 	gdb-prompt-name nil
 	gdb-first-done-or-error t
 	gdb-buffer-fringe-width (car (window-fringes))
@@ -1107,17 +1186,15 @@ With arg, enter name of variable to be watched in the minibuffer."
       (message-box "No symbol \"%s\" in current context." expr))))
 
 (defun gdb-speedbar-update ()
-  (when (and (boundp 'speedbar-frame) (frame-live-p speedbar-frame)
-	     (not (gdb-pending-p 'gdb-speedbar-timer)))
+  (when (and (boundp 'speedbar-frame) (frame-live-p speedbar-frame))
     ;; Dummy command to update speedbar even when idle.
-    (gdb-input "-environment-pwd" 'gdb-speedbar-timer-fn)
-    ;; Keep gdb-pending-triggers non-nil till end.
-    (gdb-add-pending 'gdb-speedbar-timer)))
+    (gdb-input "-environment-pwd"
+               'gdb-speedbar-timer-fn
+               'gdb-speedbar-update)))
 
 (defun gdb-speedbar-timer-fn ()
   (if gdb-speedbar-auto-raise
       (raise-frame speedbar-frame))
-  (gdb-delete-pending 'gdb-speedbar-timer)
   (speedbar-timer-fn))
 
 (defun gdb-var-evaluate-expression-handler (varnum changed)
@@ -1207,9 +1284,9 @@ With arg, enter name of variable to be watched in the minibuffer."
 
                                         ; Uses "-var-update --all-values".  Needs GDB 6.4 onwards.
 (defun gdb-var-update ()
-  (if (not (gdb-pending-p 'gdb-var-update))
-      (gdb-input "-var-update --all-values *" 'gdb-var-update-handler))
-  (gdb-add-pending 'gdb-var-update))
+  (gdb-input "-var-update --all-values *"
+             'gdb-var-update-handler
+             'gdb-var-update))
 
 (defun gdb-var-update-handler ()
   (let ((changelist (bindat-get-field (gdb-json-partial-output) 'changelist)))
@@ -1272,8 +1349,6 @@ With arg, enter name of variable to be watched in the minibuffer."
                   (push var1 var-list))
                 (setq var1 (pop temp-var-list)))
               (setq gdb-var-list (nreverse var-list))))))))
-  (setq gdb-pending-triggers
-	(delq 'gdb-var-update gdb-pending-triggers))
   (gdb-speedbar-update))
 
 (defun gdb-speedbar-expand-node (text token indent)
@@ -1727,19 +1802,25 @@ All embedded quotes, newlines, and backslashes are preceded with a backslash."
   (setq string (replace-regexp-in-string "\n" "\\n" string t t))
   (concat "\"" string "\""))
 
-(defun gdb-input (command handler-function)
+(defun gdb-input (command handler-function &optional trigger-name)
   "Send COMMAND to GDB via the MI interface.
 Run the function HANDLER-FUNCTION, with no arguments, once the command is
-complete."
-  (setq gdb-token-number (1+ gdb-token-number))
-  (setq command (concat (number-to-string gdb-token-number) command))
+complete.  Do not send COMMAND to GDB if TRIGGER-NAME is non-nil and
+Emacs is still waiting for a reply from another command previously
+sent with the same TRIGGER-NAME."
+  (when (or (not trigger-name)
+            (not (gdb-pending-handler-p trigger-name)))
+    (setq gdb-token-number (1+ gdb-token-number))
+    (setq command (concat (number-to-string gdb-token-number) command))
+
+    (if gdb-enable-debug (push (list 'send-item command handler-function)
+                               gdb-debug-log))
 
-  (if gdb-enable-debug (push (list 'send-item command handler-function)
-			     gdb-debug-log))
-  (push (cons gdb-token-number handler-function) gdb-handler-alist)
-  (if gdbmi-debug-mode (message "gdb-input: %s" command))
-  (process-send-string (get-buffer-process gud-comint-buffer)
-		       (concat command "\n")))
+    (gdb-add-handler gdb-token-number handler-function trigger-name)
+
+    (if gdbmi-debug-mode (message "gdb-input: %s" command))
+    (process-send-string (get-buffer-process gud-comint-buffer)
+                         (concat command "\n"))))
 
 ;; NOFRAME is used for gud execution control commands
 (defun gdb-current-context-command (command)
@@ -1775,7 +1856,7 @@ If `gdb-thread-number' is nil, just wrap NAME in asterisks."
 (defun gdb-resync()
   (setq gud-running nil)
   (setq gdb-output-sink 'user)
-  (setq gdb-pending-triggers nil))
+  (gdb-remove-all-pending-triggers))
 
 (defun gdb-update (&optional no-proc)
   "Update buffers showing status of debug session.
@@ -2256,9 +2337,9 @@ Unset `gdb-thread-number' if current thread exited and update threads list."
     (if (string= gdb-thread-number thread-id)
         (gdb-setq-thread-number nil))
     ;; When we continue current thread and it quickly exits,
-    ;; gdb-pending-triggers left after gdb-running disallow us to
-    ;; properly call -thread-info without --thread option. Thus we
-    ;; need to use gdb-wait-for-pending.
+    ;; the pending triggers in gdb-handler-list left after gdb-running
+    ;; disallow us to properly call -thread-info without --thread option.
+    ;; Thus we need to use gdb-wait-for-pending.
     (gdb-wait-for-pending
      (gdb-emit-signal gdb-buf-publisher 'update-threads))))
 
@@ -2273,9 +2354,10 @@ Sets `gdb-thread-number' to new id."
     ;; by `=thread-selected` notification. `^done` causes `gdb-update`
     ;; as usually. Things happen to fast and second call (from
     ;; gdb-thread-selected handler) gets cut off by our beloved
-    ;; gdb-pending-triggers.
-    ;; Solution is `gdb-wait-for-pending` macro: it guarantees that its
-    ;; body will get executed when `gdb-pending-triggers` is empty.
+    ;; pending triggers.
+    ;; Solution is `gdb-wait-for-pending' macro: it guarantees that its
+    ;; body will get executed when `gdb-handler-list' if free of
+    ;; pending triggers.
     (gdb-wait-for-pending
      (gdb-update))))
 
@@ -2439,10 +2521,7 @@ current thread and update GDB buffers."
     (when (and token-number is-complete)
       (with-current-buffer
 	  (gdb-get-buffer-create 'gdb-partial-output-buffer)
-	(funcall
-	 (cdr (assoc (string-to-number token-number) gdb-handler-alist))))
-      (setq gdb-handler-alist
-            (assq-delete-all token-number gdb-handler-alist)))
+	(gdb-handle-reply (string-to-number token-number))))
 
   (when is-complete
     (gdb-clear-partial-output))))
@@ -2660,27 +2739,23 @@ trigger argument when describing buffer types with
      (when
          (or (not ,signal-list)
              (memq signal ,signal-list))
-       (when (not (gdb-pending-p
-                   (cons (current-buffer) ',trigger-name)))
-         (gdb-input ,gdb-command
-		    (gdb-bind-function-to-buffer ',handler-name (current-buffer)))
-         (gdb-add-pending (cons (current-buffer) ',trigger-name))))))
+       (gdb-input ,gdb-command
+                  (gdb-bind-function-to-buffer ',handler-name (current-buffer))
+                  (cons (current-buffer) ',trigger-name)))))
 
 ;; Used by disassembly buffer only, the rest use
 ;; def-gdb-trigger-and-handler
-(defmacro def-gdb-auto-update-handler (handler-name trigger-name custom-defun
+(defmacro def-gdb-auto-update-handler (handler-name custom-defun
                                                     &optional nopreserve)
-  "Define a handler HANDLER-NAME for TRIGGER-NAME with CUSTOM-DEFUN.
+  "Define a handler HANDLER-NAME calling CUSTOM-DEFUN.
 
 Handlers are normally called from the buffers they put output in.
 
-Delete ((current-buffer) . TRIGGER-NAME) from
-`gdb-pending-triggers', erase current buffer and evaluate
-CUSTOM-DEFUN.  Then `gdb-update-buffer-name' is called.
+Erase current buffer and evaluate CUSTOM-DEFUN.
+Then call `gdb-update-buffer-name'.
 
 If NOPRESERVE is non-nil, window point is not restored after CUSTOM-DEFUN."
   `(defun ,handler-name ()
-     (gdb-delete-pending (cons (current-buffer) ',trigger-name))
      (let* ((inhibit-read-only t)
             ,@(unless nopreserve
                 '((window (get-buffer-window (current-buffer) 0))
@@ -2708,7 +2783,7 @@ See `def-gdb-auto-update-handler'."
        ,gdb-command
        ,handler-name ,signal-list)
      (def-gdb-auto-update-handler ,handler-name
-       ,trigger-name ,custom-defun)))
+       ,custom-defun)))
 
 
 
@@ -3625,7 +3700,6 @@ DOC is an optional documentation string."
 
 (def-gdb-auto-update-handler
   gdb-disassembly-handler
-  gdb-invalidate-disassembly
   gdb-disassembly-handler-custom
   t)
 
@@ -4117,21 +4191,19 @@ member."
 
 ;; Needs GDB 6.4 onwards (used to fail with no stack).
 (defun gdb-get-changed-registers ()
-  (when (and (gdb-get-buffer 'gdb-registers-buffer)
-	     (not (gdb-pending-p 'gdb-get-changed-registers)))
+  (when (gdb-get-buffer 'gdb-registers-buffer)
     (gdb-input "-data-list-changed-registers"
-	       'gdb-changed-registers-handler)
-    (gdb-add-pending 'gdb-get-changed-registers)))
+               'gdb-changed-registers-handler
+               'gdb-get-changed-registers)))
 
 (defun gdb-changed-registers-handler ()
-  (gdb-delete-pending 'gdb-get-changed-registers)
   (setq gdb-changed-registers nil)
   (dolist (register-number
            (bindat-get-field (gdb-json-partial-output) 'changed-registers))
     (push register-number gdb-changed-registers)))
 
 (defun gdb-register-names-handler ()
-  ;; Don't use gdb-pending-triggers because this handler is called
+  ;; Don't use pending triggers because this handler is called
   ;; only once (in gdb-init-1)
   (setq gdb-register-names nil)
   (dolist (register-name
@@ -4155,16 +4227,13 @@ is set in them."
 (defun gdb-get-main-selected-frame ()
   "Trigger for `gdb-frame-handler' which uses main current thread.
 Called from `gdb-update'."
-  (if (not (gdb-pending-p 'gdb-get-main-selected-frame))
-      (progn
-	(gdb-input (gdb-current-context-command "-stack-info-frame")
-		   'gdb-frame-handler)
-	(gdb-add-pending 'gdb-get-main-selected-frame))))
+  (gdb-input (gdb-current-context-command "-stack-info-frame")
+             'gdb-frame-handler
+             'gdb-get-main-selected-frame))
 
 (defun gdb-frame-handler ()
   "Set `gdb-selected-frame' and `gdb-selected-file' to show
 overlay arrow in source buffer."
-  (gdb-delete-pending 'gdb-get-main-selected-frame)
   (let ((frame (bindat-get-field (gdb-json-partial-output) 'frame)))
     (when frame
       (setq gdb-selected-frame (bindat-get-field frame 'func))