dbg.el

dbg-test.el

(require 'dbg)

(global-set-key (kbd "<C-S-f5>") 'dbg-restart)
(global-set-key (kbd "<f5>") 'dbg-continue)
(global-set-key (kbd "<f9>") 'dbg-toggle-breakpoint)
(global-set-key (kbd "<f8>") 'dbg-watch)
(global-set-key (kbd "<f10>") 'dbg-next)
(global-set-key (kbd "<C-f10>") 'dbg-continue-to-here)
(global-set-key (kbd "<f11>") 'dbg-step)
(global-set-key (kbd "<C-S-f10>") 'dbg-jump)

;; (global-set-key (kbd "<S-f11>") 'dbg-return)

(dbg-open "~/.emacs.d/dbg/test_struct.exe")

dbg.el

(require 'cl)
(require 'mi)

(defcustom dbg-mi-process-name "dbg-mi" "")

(defcustom dbg-mi-buffer-name "*dbg-mi*" "")

(defvar dbg-mi-process nil)

(defvar dbg-mi-buffer nil)

(defvar dbg-mi-buffer-point 0)

(defcustom dbg-mi-prompt-regexp "(gdb) \n" "")

(defcustom dbg-transcript-buffer-name "*dbg-transcript*" "")

(defvar dbg-transcript-buffer nil)

(defcustom dbg-output-filename (file-truename "~/.dbg-output") "")

(defcustom dbg-output-process-name "dbg-output" "")

(defcustom dbg-output-buffer-name "*dbg-output*" "")

(defvar dbg-output-process nil)

(defvar dbg-output-buffer nil)

(defvar dbg-executable nil)

(defvar dbg-result-handlers nil)

(defcustom dbg-stream-console-buffer-name "*dbg-stream-console*" "")

(defcustom dbg-stream-target-buffer-name "*dbg-stream-target*" "")

(defcustom dbg-stream-log-buffer-name "*dbg-stream-log*" "")

(defvar dbg-stream-console-buffer nil)

(defvar dbg-stream-target-buffer nil)

(defvar dbg-stream-log-buffer nil)

(defvar dbg-source-files nil)

(defvar dbg-breakpoints nil)

(defcustom dbg-breakpoints-buffer-name "*dbg-breakpoints*" "")

(defvar dbg-breakpoints-buffer nil)

(defvar dbg-locals nil)

(defcustom dbg-locals-buffer-name "*dbg-locals*" "")

(defvar dbg-locals-buffer nil)

(defvar dbg-frames nil)

(defcustom dbg-frames-buffer-name "*dbg-frames*" "")

(defvar dbg-frames-buffer nil)

(defvar dbg-watches nil)

(defvar dbg-vars nil)

(defcustom dbg-watches-buffer-name "*dbg-watches*" "")

(defvar dbg-watches-buffer nil)

(defmacro when-let (binding &rest body)
  (declare (indent defun))
  `(let ((,(first binding) ,(second binding)))
     (when ,(first binding)
       ,@body)))

(defmacro dbg-item (alist field &rest fields)
  (let ((form `(cdr (assoc ,field ,alist))))
    (if fields
        `(dbg-item ,form ,@fields)
      form)))

(defun dbg-items (alist field)
  (let (results)
    (dolist (entry alist)
      (when (eq (car entry) field)
        (push (cdr entry) results)))
    (nreverse results)))

(defmacro with-read-only-buffer (buffer &rest body)
  (declare (indent defun))
  `(with-current-buffer ,buffer
     (read-only-mode -1)
     (unwind-protect
	 (save-excursion ,@body)
       (read-only-mode 1))))

(defmacro save-line-and-column (&rest body)
  (declare (indent 0))
  (let ((line (gensym))
        (column (gensym)))
    `(let ((,line (line-number-at-pos))
           (,column (current-column)))
       (unwind-protect
	   (progn ,@body)
	 (goto-char (point-min))
	 (forward-line (1- ,line))
	 (forward-char ,column)))))

(defun dbg-mi-process-filter (process string)
  (with-read-only-buffer dbg-mi-buffer
    (goto-char (point-max))
    (insert string)
    (goto-char dbg-mi-buffer-point)
    (while (save-excursion (re-search-forward dbg-mi-prompt-regexp nil t))
      (let ((records (mi-parse-records)))
      	(setq dbg-mi-buffer-point (point))
      	(dbg-mi-handle-records records)))))

(defun dbg-format (buffer format-string &rest args)
  (with-read-only-buffer buffer
    (goto-char (point-max))
    (insert (apply 'format format-string args))))

(defun dbg-initialize ()
  (setq dbg-result-handlers nil)
  (with-read-only-buffer (setq dbg-breakpoints-buffer (get-buffer-create dbg-breakpoints-buffer-name))
    (erase-buffer))
  (with-read-only-buffer (setq dbg-locals-buffer (get-buffer-create dbg-locals-buffer-name))
    (erase-buffer))
  (with-read-only-buffer (setq dbg-frames-buffer (get-buffer-create dbg-frames-buffer-name))
    (erase-buffer))
  (with-read-only-buffer (setq dbg-watches-buffer (get-buffer-create dbg-watches-buffer-name))
    (erase-buffer)
    (dbg-watches-mode 1))
  (setq dbg-stream-console-buffer (get-buffer-create dbg-stream-console-buffer-name))
  (setq dbg-stream-target-buffer (get-buffer-create dbg-stream-target-buffer-name))
  (setq dbg-stream-log-buffer (get-buffer-create dbg-stream-log-buffer-name))
  (unless dbg-mi-process
    (setq dbg-mi-process (start-process dbg-mi-process-name dbg-mi-buffer-name "gdb" "-i=mi"))
    (setq dbg-mi-buffer (get-buffer dbg-mi-buffer-name))
    (setq dbg-mi-buffer-point 0)
    (set-process-filter dbg-mi-process 'dbg-mi-process-filter))
  (with-read-only-buffer dbg-mi-buffer
    (erase-buffer))
  (setq dbg-transcript-buffer (get-buffer-create dbg-transcript-buffer-name))
  (with-read-only-buffer dbg-transcript-buffer
    (erase-buffer))
  (write-region "" nil dbg-output-filename)
  (dbg-mi-command nil "-inferior-tty-set %s" dbg-output-filename)
  (setq dbg-output-buffer (find-file-noselect dbg-output-filename t))
  (with-current-buffer dbg-output-buffer
    (rename-buffer dbg-output-buffer-name)
    (read-only-mode 1)
    (setq auto-revert-use-notify nil)
    (auto-revert-tail-mode 1)))

(defun dbg-shutdown ()
  (when dbg-mi-process
    (delete-process dbg-mi-process)
    (setq dbg-mi-process nil)
    (kill-buffer dbg-output-buffer)))

(defun dbg-send-to-process (string)
  (process-send-string dbg-mi-process string)
  (dbg-format dbg-transcript-buffer "(gdb) %s" string))

(defun dbg-mi-command (result-handler format-string &rest args)
  (setq dbg-result-handlers (append dbg-result-handlers (list result-handler)))
  (dbg-send-to-process (concat (apply 'format format-string args) "\n")))

(defun dbg-mi-handle-records (records)
  ;; (with-read-only-buffer dbg-transcript-buffer
  ;;   (save-excursion
  ;;     (dolist (record records)
  ;;       (pp record dbg-transcript-buffer)
  ;;       (insert "\n"))))
  (dolist (record records)
    (let ((type (first record)))
      (case type
        ((result)
         (dbg-mi-handle-result (second record) (third record)))
        ((notify exec status)
         (dbg-mi-handle-async type (second record) (third record)))
        ((console target log)
         (dbg-mi-handle-stream type (second record)))))))

(defun dbg-mi-handle-result (status results)
  (let ((handler (pop dbg-result-handlers)))
    (when handler
      (if (listp handler)
          (apply (first handler) status results (rest handler))
        (funcall handler status results)))))

(defun dbg-mi-handle-async (type class results)
  (case class
    ((library-loaded)
     (message "Library loaded: %s" (dbg-item results 'id)))
    ((stopped)
     (dbg-handle-exec-stopped results))))

(defun dbg-mi-handle-stream (type string)
  (with-read-only-buffer (case type
                           ((console) dbg-stream-console-buffer)
                           ((target)  dbg-stream-target-buffer)
                           ((log)     dbg-stream-log-buffer))
    (save-excursion
      (goto-char (point-max))
      (insert string))))

(defun dbg-open (executable &optional args)
  (unless dbg-mi-process
    (dbg-initialize))
  (setq dbg-executable (file-truename executable))
  (dbg-mi-command 'dbg-open-handler "-file-exec-and-symbols %s %s" dbg-executable (apply 'concat args))
  (dbg-reset-program-state)
  (dbg-render))

(defun dbg-open-handler (status result)
  (case status
    ((done)
     (dbg-mi-command 'dbg-source-files-handler "-file-list-exec-source-files"))))

(defun dbg-source-files-handler (status results)
  (case status
    ((done)
     (setq dbg-source-files (dbg-item results 'files)))))

(defun dbg-reset-execution-state ()
  (setq dbg-locals nil)
  (setq dbg-frames nil))

(defun dbg-reset-program-state ()
  (dbg-reset-execution-state)
  (setq dbg-breakpoints nil)
  (setq dbg-watches nil)
  (setq dbg-vars nil))

(defun dbg-restart ()
  (interactive)
  (dbg-reset-execution-state)
  (dbg-mi-command 'dbg-restart-handler "-exec-run"))

(defun dbg-restart-handler (status result)
  (case status
    ((running)
     (dbg-recreate-watches)
     (dbg-render))))

(defun dbg-continue ()
  (interactive)
  (dbg-mi-command 'dbg-continue-handler "-exec-continue"))

(defun dbg-continue-handler (status result)
  (case status
    ((error)
     (dbg-restart))))

(defun dbg-next ()
  (interactive)
  (dbg-mi-command nil "-exec-next"))

(defun dbg-step ()
  (interactive)
  (dbg-mi-command nil "-exec-step"))

(defun dbg-return ()
  (interactive)
  (dbg-mi-command nil "-exec-return"))

(defun dbg-continue-to-here ()
  (interactive)
  (let ((location (dbg-location-at-point)))
    (when location
      (dbg-mi-command nil "-exec-until %s" location))))

(defun dbg-jump ()
  (interactive)
  (when-let (location (dbg-location-at-point))
    (dbg-mi-command nil "-exec-jump %s" location)))

(defun dbg-breakpoint-from-file-and-line (file line)
  (setq line (format "%s" line))
  (catch 'return
    (dolist (breakpoint dbg-breakpoints)
      (when (and (equal (dbg-item breakpoint 'file) file)
                 (equal (dbg-item breakpoint 'line) line))
        (throw 'return breakpoint)))))

(defun dbg-breakpoint-from-number (number)
  (catch 'return
    (dolist (breakpoint dbg-breakpoints)
      (when (equal (dbg-item breakpoint 'number) number)
        (throw 'return breakpoint)))))

(defun dbg-toggle-breakpoint ()
  (interactive)
  (when-let (file-and-line (dbg-file-and-line-at-point))
    (let ((breakpoint (dbg-breakpoint-from-file-and-line (first file-and-line) (second file-and-line))))
      (if breakpoint
          (dbg-delete-breakpoint (dbg-item breakpoint 'number))
        (dbg-insert-breakpoint (dbg-location-at-point))))))

(defun dbg-location-string (object)
  (format "%s:%s:%s" (dbg-item object 'func) (dbg-item object 'file) (dbg-item object 'line)))

(defun dbg-delete-breakpoint (number)
  (dbg-mi-command (list 'dbg-delete-breakpoint-handler number) "-break-delete %s" number))

(defun dbg-delete-breakpoint-handler (status result number)
  (case status
    ((done)
     (message "Deleted breakpoint at %s." (dbg-location-string (dbg-breakpoint-from-number number)))
     (dbg-update-breakpoints))))

(defun dbg-insert-breakpoint (location)
  (dbg-mi-command 'dbg-insert-breakpoint-handler "-break-insert %s" location))

(defun dbg-insert-breakpoint-handler (status results)
  (case status
    ((done)
     (message "Inserted breakpoint at %s." (dbg-location-string (dbg-item results 'bkpt)))
     (dbg-update-breakpoints))))

(defun dbg-update-breakpoints ()
  (dbg-mi-command 'dbg-update-breakpoints-handler "-break-list"))

(defun dbg-update-breakpoints-handler (status results)
  (case status
    ((done)
     (setq dbg-breakpoints (dbg-items (dbg-item results 'BreakpointTable 'body) 'bkpt))
     (dbg-render-breakpoints))))

(defun dbg-render-breakpoints ()
  (with-read-only-buffer dbg-breakpoints-buffer
    (save-excursion
      (erase-buffer)
      (dolist (breakpoint dbg-breakpoints)
        (insert (format "%s\n" (dbg-location-string breakpoint)))))))

(defun dbg-show-location (file line)
  (dolist (source-file dbg-source-files)
    (when (equal (dbg-item source-file 'file) file)
      (let ((buffer (find-file-other-window (dbg-item source-file 'fullname))))
        (with-current-buffer buffer
          (goto-char (point-min))
          (forward-line (1- line)))))))

(defun dbg-file-and-line-at-point ()
  (catch 'return
    (let ((file (buffer-file-name))
          (line (line-number-at-pos)))
      (dolist (source-file dbg-source-files)
        (when (equal (dbg-item source-file 'fullname) file)
          (throw 'return (list (dbg-item source-file 'file) line)))))))

(defun dbg-location-at-point ()
  (when-let (file-and-line (dbg-file-and-line-at-point))
    (format "%s:%s" (first file-and-line) (second file-and-line))))

(defun dbg-handle-exec-stopped (results)
  (dbg-update)
  (let ((frame (dbg-item results 'frame)))
    (dbg-show-location (dbg-item frame 'file) (read (dbg-item frame 'line)))))

(defun dbg-update ()
  (dbg-update-locals)
  (dbg-update-frames)
  (dbg-update-vars))

(defun dbg-render ()
  (dbg-render-breakpoints)
  (dbg-render-frames)
  (dbg-render-locals)
  (dbg-render-watches))

(defun dbg-update-locals ()
  (dbg-mi-command 'dbg-update-locals-handler "-stack-list-variables --simple-values"))

(defun dbg-update-locals-handler (status result)
  (case status
    ((done)
     (setq dbg-locals (dbg-item result 'variables))
     (dbg-render-locals))))

(defun dbg-expression-string (object)
  (let ((expression (or (dbg-item object 'exp)
			(dbg-item object 'expression)
			(dbg-item object 'name)))
        (value      (or (dbg-item object 'value) "...")))
    (format "(%s) %s = %s" (dbg-item object 'type) expression value)))

(defun dbg-render-locals ()
  (with-read-only-buffer dbg-locals-buffer
    (save-excursion
      (erase-buffer)
      (dolist (local dbg-locals)
        (insert (format "%s\n" (dbg-expression-string local)))))))

(defun dbg-update-frames ()
  (dbg-mi-command 'dbg-update-frames-handler "-stack-list-frames"))

(defun dbg-update-frames-handler (status result)
  (case status
    ((done)
     (setq dbg-frames (dbg-items (dbg-item result 'stack) 'frame))
     (dbg-render-frames))))

(defun dbg-render-frames ()
  (with-read-only-buffer dbg-frames-buffer
    (erase-buffer)
    (dolist (frame dbg-frames)
      (insert (format "%s\n" (dbg-location-string frame))))))

(defun dbg-next-symbol ()
  (save-excursion
    (let ((end   (progn (1- (forward-symbol 1)) (point)))
	  (start (progn (forward-symbol -1) (point))))
      (buffer-substring-no-properties start end))))

(defun dbg-expression-at-point ()
  (if mark-active
      (buffer-substring-no-properties (region-beginning) (region-end))
    (dbg-next-symbol)))

(defun dbg-watch ()
  (interactive)
  (let* ((default-expression (dbg-expression-at-point))
         (expression (read-string (format "Expression (default %s): " default-expression) nil nil default-expression)))
    (dbg-add-watch expression)))

(defun dbg-add-watch (expression)
  (dbg-mi-command (list 'dbg-add-watch-handler expression) "-var-create - @ %s" (prin1-to-string expression)))

(defun dbg-add-watch-handler (status result expression)
  (case status
    ((done)
     (let ((var (cons (cons 'expression expression) (cons (cons 'children nil) result))))
       (push var dbg-watches)
       (push var dbg-vars))
     (dbg-render-watches))))

(defun dbg-recreate-watches ()
  (dolist (watch dbg-watches)
    (dbg-mi-command nil "-var-delete %s" (dbg-item watch 'name)))
  (let ((watches dbg-watches))
    (setq dbg-vars nil)
    (setq dbg-watches nil)
    (dolist (watch watches)
      (dbg-add-watch (dbg-item watch 'expression)))))

(defun dbg-update-vars ()
  (dbg-mi-command 'dbg-update-vars-handler "-var-update --all-values *"))

(defun dbg-update-vars-handler (status result)
  (case status
    ((done)
     (dolist (change (dbg-item result 'changelist))
       (dolist (var dbg-vars)
         (when (equal (dbg-item var 'name) (dbg-item change 'name))
           (setf (dbg-item var 'value) (dbg-item change 'value))
           (when-let (type (dbg-item change 'new_type))
             (setf (dbg-item var 'type) type)))))
     (dbg-render-watches))))

(defun dbg-render-var (var prefix)
  (insert (propertize (format "%s%s\n" prefix (dbg-expression-string var))
		      'dbg-var var))
  (let ((children (dbg-item var 'children)))
    (dolist (child children)
      (dbg-render-var child (concat "|-- " prefix)))))

(defun dbg-var-at-point ()
  (get-text-property (point) 'dbg-var))

(defun dbg-var-toggle-children (var)
  (if (dbg-item var 'children)
      (dbg-var-delete-children var)
    (dbg-list-var-children var)))

(defun dbg-toggle-children ()
  (interactive)
  (when-let (var (dbg-var-at-point))
    (dbg-var-toggle-children var)))

(defun dbg-var-delete-children (var)
  (let ((children (dbg-item var 'children)))
    (setq dbg-vars (remove-if (lambda (x) (memq x children)) dbg-vars))
    (setf (dbg-item var 'children) nil)
    (dbg-mi-command nil "-var-delete -c %s" (dbg-item var 'name))
    (dbg-render-watches)))

(defun dbg-render-watches ()
  (save-line-and-column
    (with-read-only-buffer dbg-watches-buffer
      (erase-buffer)
      (dolist (watch dbg-watches)
        (dbg-render-var watch "")))))

(defun dbg-var-from-name (name)
  (catch 'return
    (dolist (var dbg-vars)
      (when (equal (dbg-item var 'name) name)
        (throw 'return var)))))

(defun dbg-list-var-children (var)
  (dbg-mi-command (list 'dbg-list-var-children-handler var) "-var-list-children --all-values %s" (dbg-item var 'name)))

(defun dbg-list-var-children-handler (status result var)
  (case status
    ((done)
     (let ((children (mapcar (lambda (child) (cons (cons 'children nil) child))
                             (dbg-items (dbg-item result 'children) 'child))))
       (setq dbg-vars (append dbg-vars children))
       (setf (dbg-item var 'children) children))
     (dbg-render-watches))))

(defun dbg-var-assign (var expression)
  (dbg-mi-command (list 'dbg-var-assign-handler var)
		  "-var-assign %s %s" (dbg-item var 'name) (prin1-to-string expression)))

(defun dbg-var-assign-handler (status result var)
  (case status
    ((done)
     (setf (dbg-item var 'value) (dbg-item result 'value))
     (dbg-render-watches))
    ((error)
     (message "Not editable."))))

(defun dbg-prompt-assign-var ()
  (interactive)
  (when-let (var (dbg-var-at-point))
    (dbg-var-assign var (read-string "Expression: "))))

(define-minor-mode dbg-watches-mode
  nil
  :keymap (let ((keymap (make-sparse-keymap)))
	    (define-key keymap (kbd "<tab>") 'dbg-toggle-children)
	    (define-key keymap (kbd "<return>") 'dbg-prompt-assign-var)
	    keymap))

(provide 'dbg)

mi.el

(defsubst mi-peek ()
  (char-after))

(defsubst mi-next ()
  (let ((char (mi-peek)))
    (forward-char)
    char))

(defsubst mi-eat (char)
  (when (= (mi-peek) char)
    (mi-next)
    t))

(defsubst mi-parse-type ()
  (case (mi-next)
    ((?^) 'result)
    ((?*) 'exec)
    ((?+) 'status)
    ((?=) 'notify)
    ((?~) 'console)
    ((?@) 'target)
    ((?&) 'log)))

(defun mi-parse-name ()
  (intern (buffer-substring (point) (re-search-forward "[[:alpha:]_-]+"))))

(defsubst mi-parse-string ()
  (read (current-buffer)))

(defsubst mi-parse-result ()
  (let ((name (mi-parse-name)))
    (mi-eat ?=)
    (cons name (mi-parse-value))))

(defun mi-parse-list ()
  (let (values)
    (mi-eat ?\[)
    (while (not (mi-eat ?\]))
      (if (= (char-syntax (mi-peek)) ?w)
	  (push (mi-parse-result) values)
	(push (mi-parse-value) values))
      (mi-eat ?,))
    (nreverse values)))

(defun mi-parse-tuple ()
  (let (results)
    (mi-eat ?{)
    (while (not (mi-eat ?}))
      (push (mi-parse-result) results)
      (mi-eat ?,))
    (nreverse results)))

(defun mi-parse-value ()
  (case (mi-peek)
    ((?\") (mi-parse-string))
    ((?{)  (mi-parse-tuple))
    ((?\[) (mi-parse-list))))

(defun mi-parse-record ()
  (let (type class results)
    (setq type (mi-parse-type))
    (if (memq type '(console target log))
	(list type (mi-parse-string))
      (setq class (mi-parse-name))
      (while (mi-eat ?,)
	(push (mi-parse-result) results))
      (list type class (nreverse results)))))

(defun mi-parse-records ()
  (let (records)
    (while (/= (mi-peek) ?\()
      (push (mi-parse-record) records)
      (mi-eat ?\n))
    (forward-line)
    (nreverse records)))

(provide 'mi)