Mercurial > emacs

comparison lisp/gdb-ui.el @ 54179:faca95e6c032

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
(breakpoint-enabled-icon, breakpoint-disabled-icon): Initialize margin area images to nil. (breakpoint-bitmap): New defvar for breakpoint fringe bitmaps. (breakpoint-enabled-bitmap-face) (breakpoint-disabled-bitmap-face): New faces for bpt in fringe. (gdb-info-breakpoints-custom): Use gdb-remove-breakpoint-icons. (gdb-info-breakpoints-custom): Use gdb-put-breakpoint-icon. (gdb-mouse-toggle-breakpoint): Handle bpt in fringe. (gdb-reset): Use gdb-remove-breakpoint-icons. (gdb-put-string): Add dprop arg to specify alternative display property (for setting fringe bitmap). (gdb-remove-strings): Doc fix. (gdb-put-breakpoint-icon): New defun which displays a breakpoint icon in fringe (if available), or else as icon or text in display margin. Creates necessary icons in breakpoint-bitmap, breakpoint-enabled-icon, and/or breakpoint-disabled-icon. Also make left window margin if required. (gdb-remove-breakpoint-icons): New defun to remove breakpoint icons inserted by gdb-put-breakpoint-icon. Remove left margin if no longer needed. (gdb-assembler-custom): Use gdb-remove-breakpoint-icons and gdb-put-breakpoint-icon. (gdb-assembler-mode): Don't set left-margin-width here.
author Kim F. Storm <storm@cua.dk>
date Sat, 28 Feb 2004 01:32:01 +0000
parents 492d1a28eca8
children e9a21f90fd82
comparison
equal deleted inserted replaced
54178:1ab08664aea0 54179:faca95e6c032
1015 0 1 0 1 0 1 0 1 0 1 1015 0 1 0 1 0 1 0 1 0 1
1016 0 0 1 0 1 0 1 0 1 0 1016 0 0 1 0 1 0 1 0 1 0
1017 0 0 0 1 0 1 0 1 0 0" 1017 0 0 0 1 0 1 0 1 0 0"
1018 "PBM data used for disabled breakpoint icon.") 1018 "PBM data used for disabled breakpoint icon.")
1019 1019
1020 (defvar breakpoint-enabled-icon 1020 (defvar breakpoint-enabled-icon nil
1021 (find-image `((:type xpm :data ,breakpoint-xpm-data :ascent 100)
1022 (:type pbm :data ,breakpoint-enabled-pbm-data :ascent 100)))
1023 "Icon for enabled breakpoint in display margin") 1021 "Icon for enabled breakpoint in display margin")
1024 1022
1025 (defvar breakpoint-disabled-icon 1023 (defvar breakpoint-disabled-icon nil
1026 (find-image `((:type xpm :data ,breakpoint-xpm-data :conversion disabled :ascent 100)
1027 (:type pbm :data ,breakpoint-disabled-pbm-data :ascent 100)))
1028 "Icon for disabled breakpoint in display margin") 1024 "Icon for disabled breakpoint in display margin")
1025
1026 (defvar breakpoint-bitmap nil
1027 "Bitmap for breakpoint in fringe")
1028
1029 (defface breakpoint-enabled-bitmap-face
1030 '((t
1031 :inherit fringe
1032 :foreground "red"))
1033 "Face for enabled breakpoint icon in fringe.")
1034
1035 (defface breakpoint-disabled-bitmap-face
1036 '((t
1037 :inherit fringe
1038 :foreground "grey60"))
1039 "Face for disabled breakpoint icon in fringe.")
1040
1029 1041
1030 ;;-put breakpoint icons in relevant margins (even those set in the GUD buffer) 1042 ;;-put breakpoint icons in relevant margins (even those set in the GUD buffer)
1031 (defun gdb-info-breakpoints-custom () 1043 (defun gdb-info-breakpoints-custom ()
1032 (let ((flag)(address)) 1044 (let ((flag)(address))
1033 ;; 1045 ;;
1034 ;; remove all breakpoint-icons in source buffers but not assembler buffer 1046 ;; remove all breakpoint-icons in source buffers but not assembler buffer
1035 (dolist (buffer (buffer-list)) 1047 (dolist (buffer (buffer-list))
1036 (with-current-buffer buffer 1048 (with-current-buffer buffer
1037 (if (and (eq gud-minor-mode 'gdba) 1049 (if (and (eq gud-minor-mode 'gdba)
1038 (not (string-match "^\*" (buffer-name)))) 1050 (not (string-match "^\*" (buffer-name))))
1039 (if (display-images-p) 1051 (gdb-remove-breakpoint-icons (point-min) (point-max)))))
1040 (remove-images (point-min) (point-max))
1041 (gdb-remove-strings (point-min) (point-max))))))
1042 (with-current-buffer (gdb-get-buffer 'gdb-breakpoints-buffer) 1052 (with-current-buffer (gdb-get-buffer 'gdb-breakpoints-buffer)
1043 (save-excursion 1053 (save-excursion
1044 (goto-char (point-min)) 1054 (goto-char (point-min))
1045 (while (< (point) (- (point-max) 1)) 1055 (while (< (point) (- (point-max) 1))
1046 (forward-line 1) 1056 (forward-line 1)
1062 (if (file-exists-p file) file 1072 (if (file-exists-p file) file
1063 (expand-file-name file gdb-cdir))) 1073 (expand-file-name file gdb-cdir)))
1064 (save-current-buffer 1074 (save-current-buffer
1065 (set (make-local-variable 'gud-minor-mode) 'gdba) 1075 (set (make-local-variable 'gud-minor-mode) 'gdba)
1066 (set (make-local-variable 'tool-bar-map) 1076 (set (make-local-variable 'tool-bar-map)
1067 gud-tool-bar-map) 1077 gud-tool-bar-map))
1068 (setq left-margin-width 2)
1069 (if (get-buffer-window (current-buffer))
1070 (set-window-margins (get-buffer-window
1071 (current-buffer))
1072 left-margin-width
1073 right-margin-width)))
1074 ;; only want one breakpoint icon at each location 1078 ;; only want one breakpoint icon at each location
1075 (save-excursion 1079 (save-excursion
1076 (goto-line (string-to-number line)) 1080 (goto-line (string-to-number line))
1077 (let ((start (progn (beginning-of-line) 1081 (gdb-put-breakpoint-icon (eq flag ?y)))))))))
1078 (- (point) 1)))
1079 (end (progn (end-of-line) (+ (point) 1))))
1080 (if (display-images-p)
1081 (progn
1082 (remove-images start end)
1083 (if (eq ?y flag)
1084 (put-image breakpoint-enabled-icon
1085 (+ start 1)
1086 "breakpoint icon enabled"
1087 'left-margin)
1088 (put-image breakpoint-disabled-icon
1089 (+ start 1)
1090 "breakpoint icon disabled"
1091 'left-margin)))
1092 (gdb-remove-strings start end)
1093 (if (eq ?y flag)
1094 (gdb-put-string "B" (+ start 1))
1095 (gdb-put-string "b" (+ start 1))))))))))))
1096 (end-of-line))))) 1082 (end-of-line)))))
1097 (if (gdb-get-buffer 'gdb-assembler-buffer) (gdb-assembler-custom))) 1083 (if (gdb-get-buffer 'gdb-assembler-buffer) (gdb-assembler-custom)))
1098 1084
1099 (defun gdb-mouse-toggle-breakpoint (event) 1085 (defun gdb-mouse-toggle-breakpoint (event)
1100 "Toggle breakpoint with mouse click in left margin." 1086 "Toggle breakpoint with mouse click in left margin."
1104 (message "pt=%S posn=%S" (posn-point posn) posn) 1090 (message "pt=%S posn=%S" (posn-point posn) posn)
1105 (if (numberp (posn-point posn)) 1091 (if (numberp (posn-point posn))
1106 (with-selected-window (posn-window posn) 1092 (with-selected-window (posn-window posn)
1107 (save-excursion 1093 (save-excursion
1108 (goto-char (posn-point posn)) 1094 (goto-char (posn-point posn))
1109 (if (posn-object posn) 1095 (if (or (posn-object posn)
1096 (and breakpoint-bitmap
1097 (eq (car (fringe-bitmaps-at-pos (posn-point posn)))
1098 breakpoint-bitmap)))
1110 (gud-remove nil) 1099 (gud-remove nil)
1111 (gud-break nil))))))) 1100 (gud-break nil)))))))
1112 1101
1113 (defun gdb-breakpoints-buffer-name () 1102 (defun gdb-breakpoints-buffer-name ()
1114 (with-current-buffer gud-comint-buffer 1103 (with-current-buffer gud-comint-buffer
1689 (if (not (eq buffer gud-comint-buffer)) 1678 (if (not (eq buffer gud-comint-buffer))
1690 (with-current-buffer buffer 1679 (with-current-buffer buffer
1691 (if (memq gud-minor-mode '(gdba pdb)) 1680 (if (memq gud-minor-mode '(gdba pdb))
1692 (if (string-match "^\*.+*$" (buffer-name)) 1681 (if (string-match "^\*.+*$" (buffer-name))
1693 (kill-buffer nil) 1682 (kill-buffer nil)
1694 (if (display-images-p) 1683 (gdb-remove-breakpoint-icons (point-min) (point-max) t)
1695 (remove-images (point-min) (point-max))
1696 (gdb-remove-strings (point-min) (point-max)))
1697 (setq left-margin-width 0)
1698 (setq gud-minor-mode nil) 1684 (setq gud-minor-mode nil)
1699 (kill-local-variable 'tool-bar-map) 1685 (kill-local-variable 'tool-bar-map)
1700 (setq gud-running nil) 1686 (setq gud-running nil)))))))
1701 (if (get-buffer-window (current-buffer))
1702 (set-window-margins (get-buffer-window
1703 (current-buffer))
1704 left-margin-width
1705 right-margin-width))))))))
1706 1687
1707 (defun gdb-source-info () 1688 (defun gdb-source-info ()
1708 "Find the source file where the program starts and displays it with related 1689 "Find the source file where the program starts and displays it with related
1709 buffers." 1690 buffers."
1710 (goto-char (point-min)) 1691 (goto-char (point-min))
1731 (gdb-get-create-buffer 'gdb-assembler-buffer))) 1712 (gdb-get-create-buffer 'gdb-assembler-buffer)))
1732 (setq gdb-source-window (get-buffer-window (current-buffer))) 1713 (setq gdb-source-window (get-buffer-window (current-buffer)))
1733 (other-window 1))) 1714 (other-window 1)))
1734 1715
1735 ;;from put-image 1716 ;;from put-image
1736 (defun gdb-put-string (putstring pos) 1717 (defun gdb-put-string (putstring pos &optional dprop)
1737 "Put string PUTSTRING in front of POS in the current buffer. 1718 "Put string PUTSTRING in front of POS in the current buffer.
1738 PUTSTRING is displayed by putting an overlay into the current buffer with a 1719 PUTSTRING is displayed by putting an overlay into the current buffer with a
1739 `before-string' STRING that has a `display' property whose value is 1720 `before-string' STRING that has a `display' property whose value is
1740 PUTSTRING." 1721 PUTSTRING."
1741 (let ((gdb-string "x") 1722 (let ((gdb-string "x")
1742 (buffer (current-buffer))) 1723 (buffer (current-buffer)))
1743 (let ((overlay (make-overlay pos pos buffer)) 1724 (let ((overlay (make-overlay pos pos buffer))
1744 (prop (list (list 'margin 'left-margin) putstring))) 1725 (prop (or dprop
1726 (list (list 'margin 'left-margin) putstring))))
1745 (put-text-property 0 (length gdb-string) 'display prop gdb-string) 1727 (put-text-property 0 (length gdb-string) 'display prop gdb-string)
1746 (overlay-put overlay 'put-break t) 1728 (overlay-put overlay 'put-break t)
1747 (overlay-put overlay 'before-string gdb-string)))) 1729 (overlay-put overlay 'before-string gdb-string))))
1748 1730
1749 ;;from remove-images 1731 ;;from remove-images
1750 (defun gdb-remove-strings (start end &optional buffer) 1732 (defun gdb-remove-strings (start end &optional buffer)
1751 "Remove strings between START and END in BUFFER. 1733 "Remove strings between START and END in BUFFER.
1752 Remove only strings that were put in BUFFER with calls to `put-string'. 1734 Remove only strings that were put in BUFFER with calls to `gdb-put-string'.
1753 BUFFER nil or omitted means use the current buffer." 1735 BUFFER nil or omitted means use the current buffer."
1754 (unless buffer 1736 (unless buffer
1755 (setq buffer (current-buffer))) 1737 (setq buffer (current-buffer)))
1756 (let ((overlays (overlays-in start end))) 1738 (let ((overlays (overlays-in start end)))
1757 (while overlays 1739 (while overlays
1758 (let ((overlay (car overlays))) 1740 (let ((overlay (car overlays)))
1759 (when (overlay-get overlay 'put-break) 1741 (when (overlay-get overlay 'put-break)
1760 (delete-overlay overlay))) 1742 (delete-overlay overlay)))
1761 (setq overlays (cdr overlays))))) 1743 (setq overlays (cdr overlays)))))
1744
1745 (defun gdb-put-breakpoint-icon (enabled)
1746 (let ((start (progn (beginning-of-line) (- (point) 1)))
1747 (end (progn (end-of-line) (+ (point) 1))))
1748 (gdb-remove-breakpoint-icons start end)
1749 (if (display-images-p)
1750 (if (>= (car (window-fringes)) 8)
1751 (gdb-put-string
1752 nil (1+ start)
1753 `(left-fringe
1754 ,(or breakpoint-bitmap
1755 (setq breakpoint-bitmap
1756 (define-fringe-bitmap
1757 "\x3c\x7e\xff\xff\xff\xff\x7e\x3c")))
1758 ,(if enabled
1759 'breakpoint-enabled-bitmap-face
1760 'breakpoint-disabled-bitmap-face)))
1761 (when (< left-margin-width 2)
1762 (save-current-buffer
1763 (setq left-margin-width 2)
1764 (if (get-buffer-window (current-buffer))
1765 (set-window-margins (get-buffer-window
1766 (current-buffer))
1767 left-margin-width
1768 right-margin-width))))
1769 (put-image
1770 (if enabled
1771 (or breakpoint-enabled-icon
1772 (setq breakpoint-enabled-icon
1773 (find-image `((:type xpm :data
1774 ,breakpoint-xpm-data
1775 :ascent 100 :pointer hand)
1776 (:type pbm :data
1777 ,breakpoint-enabled-pbm-data
1778 :ascent 100 :pointer hand)))))
1779 (or breakpoint-disabled-icon
1780 (setq breakpoint-disabled-icon
1781 (find-image `((:type xpm :data
1782 ,breakpoint-xpm-data
1783 :conversion disabled
1784 :ascent 100)
1785 (:type pbm :data
1786 ,breakpoint-disabled-pbm-data
1787 :ascent 100))))))
1788 (+ start 1) nil 'left-margin))
1789 (when (< left-margin-width 2)
1790 (save-current-buffer
1791 (setq left-margin-width 2)
1792 (if (get-buffer-window (current-buffer))
1793 (set-window-margins (get-buffer-window
1794 (current-buffer))
1795 left-margin-width
1796 right-margin-width))))
1797 (gdb-put-string (if enabled "B" "b") (1+ start)))))
1798
1799 (defun gdb-remove-breakpoint-icons (start end &optional remove-margin)
1800 (gdb-remove-strings start end)
1801 (if (display-images-p)
1802 (remove-images start end))
1803 (when remove-margin
1804 (setq left-margin-width 0)
1805 (if (get-buffer-window (current-buffer))
1806 (set-window-margins (get-buffer-window
1807 (current-buffer))
1808 left-margin-width
1809 right-margin-width))))
1762 1810
1763 (defun gdb-put-arrow (putstring pos) 1811 (defun gdb-put-arrow (putstring pos)
1764 "Put arrow string PUTSTRING in the left margin in front of POS 1812 "Put arrow string PUTSTRING in the left margin in front of POS
1765 in the current buffer. PUTSTRING is displayed by putting an 1813 in the current buffer. PUTSTRING is displayed by putting an
1766 overlay into the current buffer with a `before-string' 1814 overlay into the current buffer with a `before-string'
1811 (if (re-search-forward gdb-current-address nil t) 1859 (if (re-search-forward gdb-current-address nil t)
1812 (progn 1860 (progn
1813 (setq gdb-arrow-position (point)) 1861 (setq gdb-arrow-position (point))
1814 (gdb-put-arrow "=>" (point)))))) 1862 (gdb-put-arrow "=>" (point))))))
1815 ;; remove all breakpoint-icons in assembler buffer before updating. 1863 ;; remove all breakpoint-icons in assembler buffer before updating.
1816 (if (display-images-p) 1864 (gdb-remove-breakpoint-icons (point-min) (point-max)))
1817 (remove-images (point-min) (point-max))
1818 (gdb-remove-strings (point-min) (point-max))))
1819 (with-current-buffer (gdb-get-buffer 'gdb-breakpoints-buffer) 1865 (with-current-buffer (gdb-get-buffer 'gdb-breakpoints-buffer)
1820 (goto-char (point-min)) 1866 (goto-char (point-min))
1821 (while (< (point) (- (point-max) 1)) 1867 (while (< (point) (- (point-max) 1))
1822 (forward-line 1) 1868 (forward-line 1)
1823 (if (looking-at "[^\t].*breakpoint") 1869 (if (looking-at "[^\t].*breakpoint")
1830 (if (string-match "^0+\\(.*\\)" address) 1876 (if (string-match "^0+\\(.*\\)" address)
1831 (setq address (match-string 1 address))) 1877 (setq address (match-string 1 address)))
1832 (with-current-buffer buffer 1878 (with-current-buffer buffer
1833 (goto-char (point-min)) 1879 (goto-char (point-min))
1834 (if (re-search-forward address nil t) 1880 (if (re-search-forward address nil t)
1835 (let ((start (progn (beginning-of-line) (- (point) 1))) 1881 (gdb-put-breakpoint-icon (eq flag ?y))))))))
1836 (end (progn (end-of-line) (+ (point) 1))))
1837 (if (display-images-p)
1838 (progn
1839 (remove-images start end)
1840 (if (eq ?y flag)
1841 (put-image breakpoint-enabled-icon
1842 (+ start 1)
1843 "breakpoint icon enabled"
1844 'left-margin)
1845 (put-image breakpoint-disabled-icon
1846 (+ start 1)
1847 "breakpoint icon disabled"
1848 'left-margin)))
1849 (gdb-remove-strings start end)
1850 (if (eq ?y flag)
1851 (gdb-put-string "B" (+ start 1))
1852 (gdb-put-string "b" (+ start 1)))))))))))
1853 (if (not (equal gdb-current-address "main")) 1882 (if (not (equal gdb-current-address "main"))
1854 (set-window-point (get-buffer-window buffer) gdb-arrow-position)))) 1883 (set-window-point (get-buffer-window buffer) gdb-arrow-position))))
1855 1884
1856 (defvar gdb-assembler-mode-map 1885 (defvar gdb-assembler-mode-map
1857 (let ((map (make-sparse-keymap))) 1886 (let ((map (make-sparse-keymap)))
1862 "Major mode for viewing code assembler. 1891 "Major mode for viewing code assembler.
1863 1892
1864 \\{gdb-assembler-mode-map}" 1893 \\{gdb-assembler-mode-map}"
1865 (setq major-mode 'gdb-assembler-mode) 1894 (setq major-mode 'gdb-assembler-mode)
1866 (setq mode-name "Machine") 1895 (setq mode-name "Machine")
1867 (setq left-margin-width 2)
1868 (setq fringes-outside-margins t) 1896 (setq fringes-outside-margins t)
1869 (setq buffer-read-only t) 1897 (setq buffer-read-only t)
1870 (use-local-map gdb-assembler-mode-map) 1898 (use-local-map gdb-assembler-mode-map)
1871 (gdb-invalidate-assembler)) 1899 (gdb-invalidate-assembler))
1872 1900