Port memory buffer from gdb-ui.el

(gdb-memory-address): New variable which holds top address of
memory page shown in memory buffer
(gdb-memory-repeat-count, gdb-memory-format, gdb-memory-unit): New
customization variables.
New functions:
(gdb-display-memory-buffer, gdb-frame-memory-buffer): Functions to
display the memory buffer.
(gdb-memory-set-address, gdb-memory-set-repeat-count): Set memory
buffer display parameters.
(def-gdb-memory-format, gdb-memory-format-binary)
(gdb-memory-format-octal, gdb-memory-format-unsigned)
(gdb-memory-format-signed, gdb-memory-format-hexadecimal):
Functions for setting memory buffer format.
(gdb-memory-unit-word, gdb-memory-unit-halfword)
(gdb-memory-unit-giant, gdb-memory-unit-byte): Functions to set
unit size used in memory buffer.
(gdb-memory-show-next-page, gdb-memory-show-previous-page): Switch
to next/previous page of memory buffer.

2 files changed, 409 insertions, 4 deletions

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 6e9bbb1ef46..ec3b9304d37 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,25 @@
+2009-07-07  Dmitry Dzhus  <dima@sphinx.net.ru>
+
+        * progmodes/gdb-mi.el: Port memory buffer from gdb-ui.el
+        (gdb-memory-address): New variable which holds top address of
+        memory page shown in memory buffer
+        (gdb-memory-repeat-count, gdb-memory-format, gdb-memory-unit): New
+        customization variables.
+        New functions:
+        (gdb-display-memory-buffer, gdb-frame-memory-buffer): Functions to
+        display the memory buffer.
+        (gdb-memory-set-address, gdb-memory-set-repeat-count): Set memory
+        buffer display parameters.
+        (def-gdb-memory-format, gdb-memory-format-binary)
+        (gdb-memory-format-octal, gdb-memory-format-unsigned)
+        (gdb-memory-format-signed, gdb-memory-format-hexadecimal):
+        Functions for setting memory buffer format.
+        (gdb-memory-unit-word, gdb-memory-unit-halfword)
+        (gdb-memory-unit-giant, gdb-memory-unit-byte): Functions to set
+        unit size used in memory buffer.
+        (gdb-memory-show-next-page, gdb-memory-show-previous-page): Switch
+        to next/previous page of memory buffer.
+
 2009-07-07  Sam Steingold  <sds@gnu.org>
 
         * vc-cvs.el (vc-cvs-merge-news): Fix message parsing for
diff --git a/lisp/progmodes/gdb-mi.el b/lisp/progmodes/gdb-mi.el
index 4b17405ca63..57c3485b849 100644
--- a/lisp/progmodes/gdb-mi.el
+++ b/lisp/progmodes/gdb-mi.el
@@ -91,7 +91,6 @@
 ;;    line information, e.g., a routine in libc (just a TODO item).
 
 ;; TODO:
-;; 1) Use MI command -data-read-memory for memory window.
 ;; 2) Watch windows to work with threads.
 ;; 3) Use treebuffer.el instead of the speedbar for watch-expressions?
 ;; 4) Mark breakpoint locations on scroll-bar of source buffer?
@@ -107,6 +106,14 @@
 
 (defvar gdb-pc-address nil "Initialization for Assembler buffer.
 Set to \"main\" at start if `gdb-show-main' is t.")
+(defvar gdb-memory-address "main")
+(defvar gdb-memory-last-address nil
+  "Last successfully accessed memory address.")
+(defvar gdb-memory-next-page nil
+  "Address of next memory page for program memory buffer.")
+(defvar gdb-memory-prev-page nil
+  "Address of previous memory page for program memory buffer.")
+
 (defvar gdb-selected-frame nil)
 (defvar gdb-selected-file nil)
 (defvar gdb-selected-line nil)
@@ -1207,6 +1214,7 @@ static char *magick[] = {
   (gdb-get-changed-registers)
   (gdb-invalidate-registers)
   (gdb-invalidate-locals)
+  (gdb-invalidate-memory)
   (when (and (boundp 'speedbar-frame) (frame-live-p speedbar-frame))
     (dolist (var gdb-var-list)
       (setcar (nthcdr 5 var) nil))
@@ -1861,10 +1869,385 @@ FILE is a full path."
 
 
 ;;; Memory view
-(defun gdb-todo-memory ()
+
+(defcustom gdb-memory-rows 8
+  "Number of data rows in memory window."
+  :type 'integer
+  :group 'gud
+  :version "23.2")
+
+(defcustom gdb-memory-columns 4
+  "Number of data columns in memory window."
+  :type 'integer
+  :group 'gud
+  :version "23.2")
+
+(defcustom gdb-memory-format "x"
+  "Display format of data items in memory window."
+  :type '(choice (const :tag "Hexadecimal" "x")
+                 (const :tag "Signed decimal" "d")
+                 (const :tag "Unsigned decimal" "u")
+                 (const :tag "Octal" "o")
+                 (const :tag "Binary" "t"))
+  :group 'gud
+  :version "22.1")
+
+(defcustom gdb-memory-unit 4
+  "Unit size of data items in memory window."
+  :type '(choice (const :tag "Byte" 1)
+                 (const :tag "Halfword" 2)
+                 (const :tag "Word" 4)
+                 (const :tag "Giant word" 8))
+  :group 'gud
+  :version "23.2")
+
+(gdb-set-buffer-rules 'gdb-memory-buffer
+                      'gdb-memory-buffer-name
+                      'gdb-memory-mode)
+
+(def-gdb-auto-updated-buffer gdb-memory-buffer
+  gdb-invalidate-memory
+  (format "-data-read-memory %s %s %d %d %d\n" 
+          gdb-memory-address
+          gdb-memory-format
+          gdb-memory-unit
+          gdb-memory-rows
+          gdb-memory-columns)
+  gdb-read-memory-handler
+  gdb-read-memory-custom)
+
+(defun gdb-read-memory-custom ()
+  (let* ((res (json-partial-output))
+         (err-msg (fadr-q "res.msg")))
+    (if (not err-msg)
+      (let ((memory (fadr-q "res.memory")))
+        (setq gdb-memory-address (fadr-q "res.addr"))
+        (setq gdb-memory-next-page (fadr-q "res.next-page"))
+        (setq gdb-memory-prev-page (fadr-q "res.prev-page"))
+        (setq gdb-memory-last-address gdb-memory-address)
+        (dolist (row memory)
+          (insert (concat (fadr-q "row.addr") ": "))
+          (dolist (column (fadr-q "row.data"))
+            (insert (concat column "\t")))
+          (newline)))
+      (progn
+        (let ((gdb-memory-address gdb-memory-last-address))
+          (gdb-invalidate-memory)
+          (error err-msg))))))
+
+(defvar gdb-memory-mode-map
+  (let ((map (make-sparse-keymap)))
+    (suppress-keymap map t)
+    (define-key map "q" 'kill-this-buffer)
+    (define-key map "n" 'gdb-memory-show-next-page)
+    (define-key map "p" 'gdb-memory-show-previous-page)
+    (define-key map "a" 'gdb-memory-set-address)
+    (define-key map "t" 'gdb-memory-format-binary)
+    (define-key map "o" 'gdb-memory-format-octal)
+    (define-key map "u" 'gdb-memory-format-unsigned)
+    (define-key map "d" 'gdb-memory-format-signed)
+    (define-key map "x" 'gdb-memory-format-hexadecimal)
+    (define-key map "b" 'gdb-memory-unit-byte)
+    (define-key map "h" 'gdb-memory-unit-halfword)
+    (define-key map "w" 'gdb-memory-unit-word)
+    (define-key map "g" 'gdb-memory-unit-giant)
+    (define-key map "R" 'gdb-memory-set-rows)
+    (define-key map "C" 'gdb-memory-set-columns)
+     map))
+
+(defun gdb-memory-set-address-event (event)
+  "Handle a click on address field in memory buffer header."
+  (interactive "e")
+  (save-selected-window
+    (select-window (posn-window (event-start event)))
+    (gdb-memory-set-address-1)))
+
+;; Non-event version for use within keymap
+(defun gdb-memory-set-address ()
+  "Set the start memory address."
+  (interactive)
+  (let ((arg (read-from-minibuffer "Memory address: ")))
+    (setq gdb-memory-address arg))
+  (gdb-invalidate-memory))
+
+(defmacro def-gdb-set-positive-number (name variable echo-string &optional doc)
+  "Define a function NAME which reads new VAR value from minibuffer."
+  `(defun ,name (event)
+     ,(when doc doc)
+     (interactive "e")
+     (save-selected-window
+       (select-window (posn-window (event-start event)))
+       (let* ((arg (read-from-minibuffer ,echo-string))
+              (count (string-to-number arg)))
+         (if (<= count 0)
+             (error "Positive number only")
+           (customize-set-variable ',variable count)
+           (gdb-invalidate-memory))))))
+
+(def-gdb-set-positive-number
+  gdb-memory-set-rows
+  gdb-memory-rows
+  "Rows: "
+  "Set the number of data rows in memory window.")
+
+(def-gdb-set-positive-number
+  gdb-memory-set-columns
+  gdb-memory-columns
+  "Columns: "
+  "Set the number of data columns in memory window.")
+
+(defmacro def-gdb-memory-format (name format doc)
+  "Define a function NAME to switch memory buffer to use FORMAT.
+
+DOC is an optional documentation string."
+  `(defun ,name () ,(when doc doc)
+     (interactive)
+     (customize-set-variable 'gdb-memory-format ,format)
+     (gdb-invalidate-memory)))
+
+(def-gdb-memory-format
+  gdb-memory-format-binary "t"
+  "Set the display format to binary.")
+
+(def-gdb-memory-format
+  gdb-memory-format-octal "o"
+  "Set the display format to octal.")
+
+(def-gdb-memory-format
+  gdb-memory-format-unsigned "u"
+  "Set the display format to unsigned decimal.")
+
+(def-gdb-memory-format
+  gdb-memory-format-signed "d"
+  "Set the display format to decimal.")
+
+(def-gdb-memory-format
+  gdb-memory-format-hexadecimal "x"
+  "Set the display format to hexadecimal.")
+
+(defvar gdb-memory-format-map
+  (let ((map (make-sparse-keymap)))
+    (define-key map [header-line down-mouse-3] 'gdb-memory-format-menu-1)
+    map)
+  "Keymap to select format in the header line.")
+
+(defvar gdb-memory-format-menu (make-sparse-keymap "Format")
+  "Menu of display formats in the header line.")
+
+(define-key gdb-memory-format-menu [binary]
+  '(menu-item "Binary" gdb-memory-format-binary
+              :button (:radio . (equal gdb-memory-format "t"))))
+(define-key gdb-memory-format-menu [octal]
+  '(menu-item "Octal" gdb-memory-format-octal
+              :button (:radio . (equal gdb-memory-format "o"))))
+(define-key gdb-memory-format-menu [unsigned]
+  '(menu-item "Unsigned Decimal" gdb-memory-format-unsigned
+              :button (:radio . (equal gdb-memory-format "u"))))
+(define-key gdb-memory-format-menu [signed]
+  '(menu-item "Signed Decimal" gdb-memory-format-signed
+              :button (:radio . (equal gdb-memory-format "d"))))
+(define-key gdb-memory-format-menu [hexadecimal]
+  '(menu-item "Hexadecimal" gdb-memory-format-hexadecimal
+              :button (:radio . (equal gdb-memory-format "x"))))
+
+(defun gdb-memory-format-menu (event)
+  (interactive "@e")
+  (x-popup-menu event gdb-memory-format-menu))
+
+(defun gdb-memory-format-menu-1 (event)
+  (interactive "e")
+  (save-selected-window
+    (select-window (posn-window (event-start event)))
+    (let* ((selection (gdb-memory-format-menu event))
+           (binding (and selection (lookup-key gdb-memory-format-menu
+                                               (vector (car selection))))))
+      (if binding (call-interactively binding)))))
+
+(defun gdb-memory-unit-giant ()
+  "Set the unit size to giant words (eight bytes)."
+  (interactive)
+  (customize-set-variable 'gdb-memory-unit 8)
+  (gdb-invalidate-memory))
+
+(defun gdb-memory-unit-word ()
+  "Set the unit size to words (four bytes)."
+  (interactive)
+  (customize-set-variable 'gdb-memory-unit 4)
+  (gdb-invalidate-memory))
+
+(defun gdb-memory-unit-halfword ()
+  "Set the unit size to halfwords (two bytes)."
+  (interactive)
+  (customize-set-variable 'gdb-memory-unit 2)
+  (gdb-invalidate-memory))
+
+(defun gdb-memory-unit-byte ()
+  "Set the unit size to bytes."
+  (interactive)
+  (customize-set-variable 'gdb-memory-unit 1)
+  (gdb-invalidate-memory))
+
+(defmacro def-gdb-memory-show-page (name address-var &optional doc)
+  "Define a function NAME which show new address in memory buffer.
+
+The defined function switches Memory buffer to show address
+stored in ADDRESS-VAR variable.
+
+DOC is an optional documentation string."
+  `(defun ,name
+     ,(when doc doc)
+     (interactive)
+     (let ((gdb-memory-address ,address-var))
+       (gdb-invalidate-memory))))
+
+(def-gdb-memory-show-page gdb-memory-show-previous-page
+  gdb-memory-prev-page)
+
+(def-gdb-memory-show-page gdb-memory-show-next-page
+  gdb-memory-next-page)
+
+(defvar gdb-memory-unit-map
+  (let ((map (make-sparse-keymap)))
+    (define-key map [header-line down-mouse-3] 'gdb-memory-unit-menu-1)
+    map)
+  "Keymap to select units in the header line.")
+
+(defvar gdb-memory-unit-menu (make-sparse-keymap "Unit")
+  "Menu of units in the header line.")
+
+(define-key gdb-memory-unit-menu [giantwords]
+  '(menu-item "Giant words" gdb-memory-unit-giant
+              :button (:radio . (equal gdb-memory-unit 8))))
+(define-key gdb-memory-unit-menu [words]
+  '(menu-item "Words" gdb-memory-unit-word
+              :button (:radio . (equal gdb-memory-unit 4))))
+(define-key gdb-memory-unit-menu [halfwords]
+  '(menu-item "Halfwords" gdb-memory-unit-halfword
+              :button (:radio . (equal gdb-memory-unit 2))))
+(define-key gdb-memory-unit-menu [bytes]
+  '(menu-item "Bytes" gdb-memory-unit-byte
+              :button (:radio . (equal gdb-memory-unit 1))))
+
+(defun gdb-memory-unit-menu (event)
+  (interactive "@e")
+  (x-popup-menu event gdb-memory-unit-menu))
+
+(defun gdb-memory-unit-menu-1 (event)
+  (interactive "e")
+  (save-selected-window
+    (select-window (posn-window (event-start event)))
+    (let* ((selection (gdb-memory-unit-menu event))
+           (binding (and selection (lookup-key gdb-memory-unit-menu
+                                               (vector (car selection))))))
+      (if binding (call-interactively binding)))))
+
+;;from make-mode-line-mouse-map
+(defun gdb-make-header-line-mouse-map (mouse function) "\
+Return a keymap with single entry for mouse key MOUSE on the header line.
+MOUSE is defined to run function FUNCTION with no args in the buffer
+corresponding to the mode line clicked."
+  (let ((map (make-sparse-keymap)))
+    (define-key map (vector 'header-line mouse) function)
+    (define-key map (vector 'header-line 'down-mouse-1) 'ignore)
+    map))
+
+(defvar gdb-memory-font-lock-keywords
+  '(;; <__function.name+n>
+    ("<\\(\\(\\sw\\|[_.]\\)+\\)\\(\\+[0-9]+\\)?>" (1 font-lock-function-name-face))
+    )
+  "Font lock keywords used in `gdb-memory-mode'.")
+
+(defvar gdb-memory-header
+  '(:eval
+    (concat
+     "Start address["
+     (propertize "-"
+                  'face font-lock-warning-face
+                  'help-echo "mouse-1: decrement address"
+                  'mouse-face 'mode-line-highlight
+                  'local-map (gdb-make-header-line-mouse-map
+                              'mouse-1
+                              #'gdb-memory-show-previous-page))
+     "|"
+     (propertize "+"
+                  'face font-lock-warning-face
+                  'help-echo "mouse-1: increment address"
+                 'mouse-face 'mode-line-highlight
+                 'local-map (gdb-make-header-line-mouse-map
+                             'mouse-1
+                             #'gdb-memory-show-next-page))
+    "]: "
+    (propertize gdb-memory-address
+                 'face font-lock-warning-face
+                 'help-echo "mouse-1: set start address"
+                 'mouse-face 'mode-line-highlight
+                 'local-map (gdb-make-header-line-mouse-map
+                             'mouse-1
+                             #'gdb-memory-set-address-event))
+    "  Rows: "
+    (propertize (number-to-string gdb-memory-rows)
+                 'face font-lock-warning-face
+                 'help-echo "mouse-1: set number of columns"
+                 'mouse-face 'mode-line-highlight
+                 'local-map (gdb-make-header-line-mouse-map
+                             'mouse-1
+                             #'gdb-memory-set-rows))
+    "  Columns: "
+    (propertize (number-to-string gdb-memory-columns)
+                 'face font-lock-warning-face
+                 'help-echo "mouse-1: set number of columns"
+                 'mouse-face 'mode-line-highlight
+                 'local-map (gdb-make-header-line-mouse-map
+                             'mouse-1
+                             #'gdb-memory-set-columns))
+    "  Display Format: "
+    (propertize gdb-memory-format
+                 'face font-lock-warning-face
+                 'help-echo "mouse-3: select display format"
+                 'mouse-face 'mode-line-highlight
+                 'local-map gdb-memory-format-map)
+    "  Unit Size: "
+    (propertize (number-to-string gdb-memory-unit)
+                 'face font-lock-warning-face
+                 'help-echo "mouse-3: select unit size"
+                 'mouse-face 'mode-line-highlight
+                 'local-map gdb-memory-unit-map)))
+  "Header line used in `gdb-memory-mode'.")
+
+(defun gdb-memory-mode ()
+  "Major mode for examining memory.
+
+\\{gdb-memory-mode-map}"
+  (kill-all-local-variables)
+  (setq major-mode 'gdb-memory-mode)
+  (setq mode-name "Memory")
+  (use-local-map gdb-memory-mode-map)
+  (setq buffer-read-only t)
+  (setq header-line-format gdb-memory-header)
+  (set (make-local-variable 'font-lock-defaults)
+       '(gdb-memory-font-lock-keywords))
+  (run-mode-hooks 'gdb-memory-mode-hook)
+  'gdb-invalidate-memory)
+
+(defun gdb-memory-buffer-name ()
+  (with-current-buffer gud-comint-buffer
+    (concat "*memory of " (gdb-get-target-string) "*")))
+
+(def-gdb-display-buffer
+  gdb-display-memory-buffer
+  'gdb-memory-buffer
+  "Display memory contents.")
+
+(defun gdb-frame-memory-buffer ()
+  "Display memory contents in a new frame."
   (interactive)
-  (message-box
-   "TODO: Implement memory buffer using\nMI command -data-read-memory"))
+  (let* ((special-display-regexps (append special-display-regexps '(".*")))
+         (special-display-frame-alist
+          (cons '(left-fringe . 0)
+                (cons '(right-fringe . 0)
+                      (cons '(width . 83) gdb-frame-parameters)))))
+    (display-buffer (gdb-get-buffer-create 'gdb-memory-buffer))))
+
 
 ;;; Disassembly view