dbg.el

(require 'cl)
(require 'peg)

(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 
         (progn ,@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)
         (set-window-point (get-buffer-window) (point))))))

(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))
      (when-let (output (first (dbg-mi-parse-output)))
        (setq dbg-mi-buffer-point (point))
        (dbg-mi-handle-output output)))))

(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))
  (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-output (output)
  (with-read-only-buffer dbg-transcript-buffer
    (save-excursion
      (dolist (record output)
        (pp record dbg-transcript-buffer)
        (insert "\n"))))
  (dolist (record output)
    (let ((type (first record)))
      (case type
        ((result)
         (dbg-mi-handle-result (third record) (fourth record)))
        ((notify exec status)
         (dbg-mi-handle-async type (third record) (fourth 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-mi-parse-output ()
  (peg-parse (output
              records
              "(gdb) " nl
              `(records -- records))
             (records
              `(-- nil) (+ record `(records record -- (cons record records)))
              `(records -- (nreverse records)))
             (record
              (or result-or-async-record stream-record))
             (result-or-async-record
              (or token `(-- nil))
              (or (and "^" `(-- 'result))
                  (and "*" `(-- 'exec))
                  (and "+" `(-- 'status))
                  (and "=" `(-- 'notify)))
              class
              `(-- nil) (* "," result `(results result -- (cons result results))) nl
              `(token type class results -- (list type token class (nreverse results))))
             (stream-record
              (or (and "~" `(-- 'console))
                  (and "@" `(-- `target))
                  (and "&" `(-- 'log)))
              c-string nl
              `(type value -- (list type value)))
             (class
              string
              `(s -- (intern s)))
             (result
              variable "=" value
              `(variable value -- (cons (intern variable) value)))
             (variable
              string)
             (value
              (or const list tuple))
             (const
              c-string)
             (tuple
              "{"
              (or (and "}"
                       `(-- nil))
                  (and result `(result -- (list result))
                       (* "," result `(results result -- (cons result results)))
                       "}"))
              `(value -- (nreverse value)))
             (list
              "["
              (or (and "]"
                       `(-- nil))
                  (and value `(value -- (list value))
                       (* "," value `(values value -- (cons value values)))
                       "]")
                  (and result `(result -- (list result))
                       (* "," result `(results result -- (cons result results)))
                       "]"))
              `(value -- (nreverse value)))
             (nl
              (or "\n" "\r\n"))
             (token
              (substring (+ [0-9]))
              `(s -- (read s)))
             (string
              (substring (+ [a-z A-Z "-_"])))
             (c-string
              (substring "\"" (* (or "\\\"" (and (not "\"") (any)))) "\"")
              `(s -- (read s)))))

(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 results)
  (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)
  (setq dbg-watches nil)
  (setq dbg-vars nil))

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

(defun dbg-restart ()
  (interactive)
  (dbg-reset-execution-state)
  (dbg-render)
  (dbg-mi-command nil "-exec-run"))

(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 '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-watch (expression)
  (interactive "sExpression: ")
  (dbg-mi-command (list 'dbg-watch-handler expression) "-var-create - @ %s" (prin1-to-string expression)))

(defun dbg-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-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 (format "%s%s\n" prefix (dbg-expression-string var)))
  (let ((children (dbg-item var 'children)))
    (dolist (child children)
      (dbg-render-var child (concat "|-- " prefix)))))

(defun dbg-render-watches ()
  (with-read-only-buffer dbg-watches-buffer
    (save-line-and-column
      (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))))

(provide 'dbg)