diff options
Diffstat (limited to 'lisp/progmodes')
76 files changed, 11236 insertions, 8712 deletions
diff --git a/lisp/progmodes/ada-mode.el b/lisp/progmodes/ada-mode.el index 95f9f6babf3..fe97b1e8a57 100644 --- a/lisp/progmodes/ada-mode.el +++ b/lisp/progmodes/ada-mode.el @@ -1,7 +1,8 @@ ;;; ada-mode.el --- major-mode for editing Ada sources -;; Copyright (C) 1994, 1995, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. +;; Copyright (C) 1994, 1995, 1997, 1998, 1999, 2000, 2001, 2002, 2003, +;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; Free Software Foundation, Inc. ;; Author: Rolf Ebert <ebert@inf.enst.fr> ;; Markus Heritsch <Markus.Heritsch@studbox.uni-stuttgart.de> @@ -834,10 +835,7 @@ the 4 file locations can be clicked on and jumped to." ;; ;; On Emacs, this is done through the `syntax-table' text property. The ;; corresponding action is applied automatically each time the buffer -;; changes. If `font-lock-mode' is enabled (the default) the action is -;; set up by `font-lock-syntactic-keywords'. Otherwise, we do it -;; manually in `ada-after-change-function'. The proper method is -;; installed by `ada-handle-syntax-table-properties'. +;; changes via syntax-propertize-function. ;; ;; on XEmacs, the `syntax-table' property does not exist and we have to use a ;; slow advice to `parse-partial-sexp' to do the same thing. @@ -937,6 +935,12 @@ declares it as a word constituent." (insert (caddar change)) (setq change (cdr change))))))) +(unless (eval-when-compile (fboundp 'syntax-propertize-via-font-lock)) + ;; Before `syntax-propertize', we had to use font-lock to apply syntax-table + ;; properties, and in some cases we even had to do it manually (in + ;; `ada-after-change-function'). `ada-handle-syntax-table-properties' + ;; decides which method to use. + (defun ada-set-syntax-table-properties () "Assign `syntax-table' properties in accessible part of buffer. In particular, character constants are said to be strings, #...# @@ -991,6 +995,8 @@ OLD-LEN indicates what the length of the replaced text was." ;; Take care of `syntax-table' properties manually. (ada-initialize-syntax-table-properties))) +) ;;(not (fboundp 'syntax-propertize)) + ;;------------------------------------------------------------------ ;; Testing the grammatical context ;;------------------------------------------------------------------ @@ -1112,13 +1118,14 @@ the file name." (funcall (symbol-function 'speedbar-add-supported-extension) spec) (funcall (symbol-function 'speedbar-add-supported-extension) - body))) - ) + body)))) +(defvar ada-font-lock-syntactic-keywords) ; defined below ;;;###autoload (defun ada-mode () - "Ada mode is the major mode for editing Ada code." + "Ada mode is the major mode for editing Ada code. +\\{ada-mode-map}" (interactive) (kill-all-local-variables) @@ -1161,9 +1168,9 @@ the file name." (set (make-local-variable 'comment-padding) 0) (set (make-local-variable 'parse-sexp-lookup-properties) t)) - (set 'case-fold-search t) + (setq case-fold-search t) (if (boundp 'imenu-case-fold-search) - (set 'imenu-case-fold-search t)) + (setq imenu-case-fold-search t)) (set (make-local-variable 'fill-paragraph-function) 'ada-fill-comment-paragraph) @@ -1186,8 +1193,13 @@ the file name." '(ada-font-lock-keywords nil t ((?\_ . "w") (?# . ".")) - beginning-of-line - (font-lock-syntactic-keywords . ada-font-lock-syntactic-keywords))) + beginning-of-line)) + + (if (eval-when-compile (fboundp 'syntax-propertize-via-font-lock)) + (set (make-local-variable 'syntax-propertize-function) + (syntax-propertize-via-font-lock ada-font-lock-syntactic-keywords)) + (set (make-local-variable 'font-lock-syntactic-keywords) + ada-font-lock-syntactic-keywords)) ;; Set up support for find-file.el. (set (make-local-variable 'ff-other-file-alist) @@ -1322,22 +1334,24 @@ the file name." ;; To be run after the hook, in case the user modified ;; ada-fill-comment-prefix - (make-local-variable 'comment-start) - (if ada-fill-comment-prefix - (set 'comment-start ada-fill-comment-prefix) - (set 'comment-start "-- ")) + ;; FIXME: if the user modified ada-fill-comment-prefix in his .emacs + ;; then it was already available before running the hook, and if he + ;; modifies it in the hook, he might as well modify comment-start instead. + (set (make-local-variable 'comment-start) (or ada-fill-comment-prefix "-- ")) ;; Run this after the hook to give the users a chance to activate ;; font-lock-mode - (unless (featurep 'xemacs) + (unless (or (eval-when-compile (fboundp 'syntax-propertize-via-font-lock)) + (featurep 'xemacs)) (ada-initialize-syntax-table-properties) (add-hook 'font-lock-mode-hook 'ada-handle-syntax-table-properties nil t)) ;; the following has to be done after running the ada-mode-hook ;; because users might want to set the values of these variable ;; inside the hook - + ;; FIXME: it might even be set later on via file-local vars, no? + ;; so maybe ada-keywords should be set lazily. (cond ((eq ada-language-version 'ada83) (setq ada-keywords ada-83-keywords)) ((eq ada-language-version 'ada95) @@ -1397,25 +1411,21 @@ If WORD is not given, then the current word in the buffer is used instead. The new word is added to the first file in `ada-case-exception-file'. The standard casing rules will no longer apply to this word." (interactive) - (let ((previous-syntax-table (syntax-table)) - file-name - ) - - (cond ((stringp ada-case-exception-file) - (setq file-name ada-case-exception-file)) - ((listp ada-case-exception-file) - (setq file-name (car ada-case-exception-file))) - (t - (error (concat "No exception file specified. " - "See variable ada-case-exception-file")))) + (let ((file-name + (cond ((stringp ada-case-exception-file) + ada-case-exception-file) + ((listp ada-case-exception-file) + (car ada-case-exception-file)) + (t + (error (concat "No exception file specified. " + "See variable ada-case-exception-file")))))) - (set-syntax-table ada-mode-symbol-syntax-table) (unless word - (save-excursion - (skip-syntax-backward "w") - (setq word (buffer-substring-no-properties - (point) (save-excursion (forward-word 1) (point)))))) - (set-syntax-table previous-syntax-table) + (with-syntax-table ada-mode-symbol-syntax-table + (save-excursion + (skip-syntax-backward "w") + (setq word (buffer-substring-no-properties + (point) (save-excursion (forward-word 1) (point))))))) ;; Reread the exceptions file, in case it was modified by some other, (ada-case-read-exceptions-from-file file-name) @@ -1425,11 +1435,9 @@ The standard casing rules will no longer apply to this word." (if (and (not (equal ada-case-exception '())) (assoc-string word ada-case-exception t)) (setcar (assoc-string word ada-case-exception t) word) - (add-to-list 'ada-case-exception (cons word t)) - ) + (add-to-list 'ada-case-exception (cons word t))) - (ada-save-exceptions-to-file file-name) - )) + (ada-save-exceptions-to-file file-name))) (defun ada-create-case-exception-substring (&optional word) "Define the substring WORD as an exception for the casing system. @@ -1464,7 +1472,7 @@ word itself has a special casing." (modify-syntax-entry ?_ "." (syntax-table)) (save-excursion (skip-syntax-backward "w") - (set 'word (buffer-substring-no-properties + (setq word (buffer-substring-no-properties (point) (save-excursion (forward-word 1) (point)))))) (modify-syntax-entry ?_ (make-string 1 underscore-syntax) @@ -1633,37 +1641,30 @@ ARG is the prefix the user entered with \\[universal-argument]." (interactive "P") (if ada-auto-case - (let ((lastk last-command-event) - (previous-syntax-table (syntax-table))) - - (unwind-protect - (progn - (set-syntax-table ada-mode-symbol-syntax-table) - (cond ((or (eq lastk ?\n) - (eq lastk ?\r)) - ;; horrible kludge - (insert " ") - (ada-adjust-case) - ;; horrible dekludge - (delete-backward-char 1) - ;; some special keys and their bindings - (cond - ((eq lastk ?\n) - (funcall ada-lfd-binding)) - ((eq lastk ?\r) - (funcall ada-ret-binding)))) - ((eq lastk ?\C-i) (ada-tab)) - ;; Else just insert the character - ((self-insert-command (prefix-numeric-value arg)))) - ;; if there is a keyword in front of the underscore - ;; then it should be part of an identifier (MH) - (if (eq lastk ?_) - (ada-adjust-case t) - (ada-adjust-case)) - ) - ;; Restore the syntax table - (set-syntax-table previous-syntax-table)) - ) + (let ((lastk last-command-event)) + + (with-syntax-table ada-mode-symbol-syntax-table + (cond ((or (eq lastk ?\n) + (eq lastk ?\r)) + ;; horrible kludge + (insert " ") + (ada-adjust-case) + ;; horrible dekludge + (delete-char -1) + ;; some special keys and their bindings + (cond + ((eq lastk ?\n) + (funcall ada-lfd-binding)) + ((eq lastk ?\r) + (funcall ada-ret-binding)))) + ((eq lastk ?\C-i) (ada-tab)) + ;; Else just insert the character + ((self-insert-command (prefix-numeric-value arg)))) + ;; if there is a keyword in front of the underscore + ;; then it should be part of an identifier (MH) + (if (eq lastk ?_) + (ada-adjust-case t) + (ada-adjust-case)))) ;; Else, no auto-casing (cond @@ -1672,10 +1673,10 @@ ARG is the prefix the user entered with \\[universal-argument]." ((eq last-command-event ?\r) (funcall ada-ret-binding)) (t - (self-insert-command (prefix-numeric-value arg)))) - )) + (self-insert-command (prefix-numeric-value arg)))))) (defun ada-activate-keys-for-case () + ;; FIXME: Use post-self-insert-hook instead of changing key bindings. "Modify the key bindings for all the keys that should readjust the casing." (interactive) ;; Save original key-bindings to allow swapping ret/lfd @@ -1735,44 +1736,41 @@ Attention: This function might take very long for big regions!" (let ((begin nil) (end nil) (keywordp nil) - (attribp nil) - (previous-syntax-table (syntax-table))) + (attribp nil)) (message "Adjusting case ...") - (unwind-protect - (save-excursion - (set-syntax-table ada-mode-symbol-syntax-table) - (goto-char to) - ;; - ;; loop: look for all identifiers, keywords, and attributes - ;; - (while (re-search-backward "\\<\\(\\sw+\\)\\>" from t) - (setq end (match-end 1)) - (setq attribp - (and (> (point) from) - (save-excursion - (forward-char -1) - (setq attribp (looking-at "'.[^']"))))) - (or - ;; do nothing if it is a string or comment - (ada-in-string-or-comment-p) - (progn - ;; - ;; get the identifier or keyword or attribute - ;; - (setq begin (point)) - (setq keywordp (looking-at ada-keywords)) - (goto-char end) - ;; - ;; casing according to user-option - ;; - (if attribp - (funcall ada-case-attribute -1) - (if keywordp - (funcall ada-case-keyword -1) - (ada-adjust-case-identifier))) - (goto-char begin)))) - (message "Adjusting case ... Done")) - (set-syntax-table previous-syntax-table)))) + (with-syntax-table ada-mode-symbol-syntax-table + (save-excursion + (goto-char to) + ;; + ;; loop: look for all identifiers, keywords, and attributes + ;; + (while (re-search-backward "\\<\\(\\sw+\\)\\>" from t) + (setq end (match-end 1)) + (setq attribp + (and (> (point) from) + (save-excursion + (forward-char -1) + (setq attribp (looking-at "'.[^']"))))) + (or + ;; do nothing if it is a string or comment + (ada-in-string-or-comment-p) + (progn + ;; + ;; get the identifier or keyword or attribute + ;; + (setq begin (point)) + (setq keywordp (looking-at ada-keywords)) + (goto-char end) + ;; + ;; casing according to user-option + ;; + (if attribp + (funcall ada-case-attribute -1) + (if keywordp + (funcall ada-case-keyword -1) + (ada-adjust-case-identifier))) + (goto-char begin)))) + (message "Adjusting case ... Done"))))) (defun ada-adjust-case-buffer () "Adjust the case of all words in the whole buffer. @@ -1803,46 +1801,39 @@ ATTENTION: This function might take very long for big buffers!" (let ((begin nil) (end nil) (delend nil) - (paramlist nil) - (previous-syntax-table (syntax-table))) - (unwind-protect - (progn - (set-syntax-table ada-mode-symbol-syntax-table) - - ;; check if really inside parameter list - (or (ada-in-paramlist-p) - (error "Not in parameter list")) + (paramlist nil)) + (with-syntax-table ada-mode-symbol-syntax-table - ;; find start of current parameter-list - (ada-search-ignore-string-comment - (concat ada-subprog-start-re "\\|\\<body\\>" ) t nil) - (down-list 1) - (backward-char 1) - (setq begin (point)) + ;; check if really inside parameter list + (or (ada-in-paramlist-p) + (error "Not in parameter list")) - ;; find end of parameter-list - (forward-sexp 1) - (setq delend (point)) - (delete-char -1) - (insert "\n") + ;; find start of current parameter-list + (ada-search-ignore-string-comment + (concat ada-subprog-start-re "\\|\\<body\\>" ) t nil) + (down-list 1) + (backward-char 1) + (setq begin (point)) - ;; find end of last parameter-declaration - (forward-comment -1000) - (setq end (point)) + ;; find end of parameter-list + (forward-sexp 1) + (setq delend (point)) + (delete-char -1) + (insert "\n") - ;; build a list of all elements of the parameter-list - (setq paramlist (ada-scan-paramlist (1+ begin) end)) + ;; find end of last parameter-declaration + (forward-comment -1000) + (setq end (point)) - ;; delete the original parameter-list - (delete-region begin delend) + ;; build a list of all elements of the parameter-list + (setq paramlist (ada-scan-paramlist (1+ begin) end)) - ;; insert the new parameter-list - (goto-char begin) - (ada-insert-paramlist paramlist)) + ;; delete the original parameter-list + (delete-region begin delend) - ;; restore syntax-table - (set-syntax-table previous-syntax-table) - ))) + ;; insert the new parameter-list + (goto-char begin) + (ada-insert-paramlist paramlist)))) (defun ada-scan-paramlist (begin end) "Scan the parameter list found in between BEGIN and END. @@ -2186,14 +2177,12 @@ Return the new position of point or nil if not found." Return the calculation that was done, including the reference point and the offset." (interactive) - (let ((previous-syntax-table (syntax-table)) - (orgpoint (point-marker)) + (let ((orgpoint (point-marker)) cur-indent tmp-indent prev-indent) (unwind-protect - (progn - (set-syntax-table ada-mode-symbol-syntax-table) + (with-syntax-table ada-mode-symbol-syntax-table ;; This need to be done here so that the advice is not always ;; activated (this might interact badly with other modes) @@ -2203,14 +2192,14 @@ and the offset." (save-excursion (setq cur-indent - ;; Not First line in the buffer ? - (if (save-excursion (zerop (forward-line -1))) - (progn - (back-to-indentation) - (ada-get-current-indent)) + ;; Not First line in the buffer ? + (if (save-excursion (zerop (forward-line -1))) + (progn + (back-to-indentation) + (ada-get-current-indent)) - ;; first line in the buffer - (list (point-min) 0)))) + ;; first line in the buffer + (list (point-min) 0)))) ;; Evaluate the list to get the column to indent to ;; prev-indent contains the column to indent to @@ -2242,14 +2231,10 @@ and the offset." (if (< (current-column) (current-indentation)) (back-to-indentation))) - ;; restore syntax-table - (set-syntax-table previous-syntax-table) (if (featurep 'xemacs) - (ad-deactivate 'parse-partial-sexp)) - ) + (ad-deactivate 'parse-partial-sexp))) - cur-indent - )) + cur-indent)) (defun ada-get-current-indent () "Return the indentation to use for the current line." @@ -2487,8 +2472,7 @@ and the offset." (if (and ada-indent-is-separate (save-excursion (goto-char (match-end 0)) - (ada-goto-next-non-ws (save-excursion (end-of-line) - (point))) + (ada-goto-next-non-ws (point-at-eol)) (looking-at "\\<abstract\\>\\|\\<separate\\>"))) (save-excursion (ada-goto-stmt-start) @@ -2512,11 +2496,11 @@ and the offset." (if (looking-at "renames") (let (pos) (save-excursion - (set 'pos (ada-search-ignore-string-comment ";\\|return\\>" t))) + (setq pos (ada-search-ignore-string-comment ";\\|return\\>" t))) (if (and pos (= (downcase (char-after (car pos))) ?r)) (goto-char (car pos))) - (set 'var 'ada-indent-renames))) + (setq var 'ada-indent-renames))) (forward-comment -1000) (if (= (char-before) ?\)) @@ -2533,7 +2517,7 @@ and the offset." (looking-at "\\(function\\|procedure\\)\\>")) (progn (backward-word 1) - (set 'num-back 2) + (setq num-back 2) (looking-at "\\(function\\|procedure\\)\\>"))))) ;; The indentation depends of the value of ada-indent-return @@ -2595,10 +2579,7 @@ and the offset." (forward-line -1) (beginning-of-line) (while (and (not pos) - (search-forward "--" - (save-excursion - (end-of-line) (point)) - t)) + (search-forward "--" (point-at-eol) t)) (unless (ada-in-string-p) (setq pos (point)))) pos)) @@ -2617,7 +2598,7 @@ and the offset." ((and (= (char-after) ?#) (equal ada-which-compiler 'gnat) (looking-at "#[ \t]*\\(if\\|els\\(e\\|if\\)\\|end[ \t]*if\\)")) - (list (save-excursion (beginning-of-line) (point)) 0)) + (list (point-at-bol) 0)) ;;-------------------------------- ;; starting with ')' (end of a parameter list) @@ -4046,8 +4027,7 @@ Point is moved at the beginning of the SEARCH-RE." (let (found begin end - parse-result - (previous-syntax-table (syntax-table))) + parse-result) ;; FIXME: need to pass BACKWARD to search-func! (unless search-func @@ -4057,67 +4037,61 @@ Point is moved at the beginning of the SEARCH-RE." ;; search until found or end-of-buffer ;; We have to test that we do not look further than limit ;; - (set-syntax-table ada-mode-symbol-syntax-table) - (while (and (not found) - (or (not limit) - (or (and backward (<= limit (point))) - (>= limit (point)))) - (funcall search-func search-re limit 1)) - (setq begin (match-beginning 0)) - (setq end (match-end 0)) - - (setq parse-result (parse-partial-sexp - (save-excursion (beginning-of-line) (point)) - (point))) - - (cond - ;; - ;; If inside a string, skip it (and the following comments) - ;; - ((ada-in-string-p parse-result) - (if (featurep 'xemacs) - (search-backward "\"" nil t) - (goto-char (nth 8 parse-result))) - (unless backward (forward-sexp 1))) - ;; - ;; If inside a comment, skip it (and the following comments) - ;; There is a special code for comments at the end of the file - ;; - ((ada-in-comment-p parse-result) - (if (featurep 'xemacs) - (progn - (forward-line 1) - (beginning-of-line) - (forward-comment -1)) - (goto-char (nth 8 parse-result))) - (unless backward - ;; at the end of the file, it is not possible to skip a comment - ;; so we just go at the end of the line - (if (forward-comment 1) - (progn - (forward-comment 1000) - (beginning-of-line)) - (end-of-line)))) - ;; - ;; directly in front of a comment => skip it, if searching forward - ;; - ((and (= (char-after begin) ?-) (= (char-after (1+ begin)) ?-)) - (unless backward (progn (forward-char -1) (forward-comment 1000)))) - - ;; - ;; found a parameter-list but should ignore it => skip it - ;; - ((and (not paramlists) (ada-in-paramlist-p)) - (if backward - (search-backward "(" nil t) - (search-forward ")" nil t))) - ;; - ;; found what we were looking for - ;; - (t - (setq found t)))) ; end of loop - - (set-syntax-table previous-syntax-table) + (with-syntax-table ada-mode-symbol-syntax-table + (while (and (not found) + (or (not limit) + (or (and backward (<= limit (point))) + (>= limit (point)))) + (funcall search-func search-re limit 1)) + (setq begin (match-beginning 0)) + (setq end (match-end 0)) + (setq parse-result (parse-partial-sexp (point-at-bol) (point))) + (cond + ;; + ;; If inside a string, skip it (and the following comments) + ;; + ((ada-in-string-p parse-result) + (if (featurep 'xemacs) + (search-backward "\"" nil t) + (goto-char (nth 8 parse-result))) + (unless backward (forward-sexp 1))) + ;; + ;; If inside a comment, skip it (and the following comments) + ;; There is a special code for comments at the end of the file + ;; + ((ada-in-comment-p parse-result) + (if (featurep 'xemacs) + (progn + (forward-line 1) + (beginning-of-line) + (forward-comment -1)) + (goto-char (nth 8 parse-result))) + (unless backward + ;; at the end of the file, it is not possible to skip a comment + ;; so we just go at the end of the line + (if (forward-comment 1) + (progn + (forward-comment 1000) + (beginning-of-line)) + (end-of-line)))) + ;; + ;; directly in front of a comment => skip it, if searching forward + ;; + ((and (= (char-after begin) ?-) (= (char-after (1+ begin)) ?-)) + (unless backward (progn (forward-char -1) (forward-comment 1000)))) + + ;; + ;; found a parameter-list but should ignore it => skip it + ;; + ((and (not paramlists) (ada-in-paramlist-p)) + (if backward + (search-backward "(" nil t) + (search-forward ")" nil t))) + ;; + ;; found what we were looking for + ;; + (t + (setq found t))))) ; end of loop (if found (cons begin end) @@ -4290,16 +4264,12 @@ of the region. Otherwise, operate only on the current line." (save-excursion (beginning-of-line) (insert-char ? ada-indent)) - (if (save-excursion (= (point) (progn (beginning-of-line) (point)))) - (forward-char ada-indent))) + (if (bolp) (forward-char ada-indent))) (defun ada-untab-hard () "Indent current line to previous tab stop." (interactive) - (let ((bol (save-excursion (progn (beginning-of-line) (point)))) - (eol (save-excursion (progn (end-of-line) (point))))) - (indent-rigidly bol eol (- 0 ada-indent)))) - + (indent-rigidly (point-at-bol) (point-at-eol) (- 0 ada-indent))) ;; ------------------------------------------------------------ @@ -4398,122 +4368,109 @@ of the region. Otherwise, operate only on the current line." (defun ada-move-to-start () "Move point to the matching start of the current Ada structure." (interactive) - (let ((pos (point)) - (previous-syntax-table (syntax-table))) - (unwind-protect - (progn - (set-syntax-table ada-mode-symbol-syntax-table) - - (save-excursion - ;; - ;; do nothing if in string or comment or not on 'end ...;' - ;; or if an error occurs during processing - ;; - (or - (ada-in-string-or-comment-p) - (and (progn - (or (looking-at "[ \t]*\\<end\\>") - (backward-word 1)) - (or (looking-at "[ \t]*\\<end\\>") - (backward-word 1)) - (or (looking-at "[ \t]*\\<end\\>") - (error "Not on end ...;"))) - (ada-goto-matching-start 1) - (setq pos (point)) - - ;; - ;; on 'begin' => go on, according to user option - ;; - ada-move-to-declaration - (looking-at "\\<begin\\>") - (ada-goto-decl-start) - (setq pos (point)))) - - ) ; end of save-excursion - - ;; now really move to the found position - (goto-char pos)) + (let ((pos (point))) + (with-syntax-table ada-mode-symbol-syntax-table - ;; restore syntax-table - (set-syntax-table previous-syntax-table)))) + (save-excursion + ;; + ;; do nothing if in string or comment or not on 'end ...;' + ;; or if an error occurs during processing + ;; + (or + (ada-in-string-or-comment-p) + (and (progn + (or (looking-at "[ \t]*\\<end\\>") + (backward-word 1)) + (or (looking-at "[ \t]*\\<end\\>") + (backward-word 1)) + (or (looking-at "[ \t]*\\<end\\>") + (error "Not on end ...;"))) + (ada-goto-matching-start 1) + (setq pos (point)) + + ;; + ;; on 'begin' => go on, according to user option + ;; + ada-move-to-declaration + (looking-at "\\<begin\\>") + (ada-goto-decl-start) + (setq pos (point)))) + + ) ; end of save-excursion + + ;; now really move to the found position + (goto-char pos)))) (defun ada-move-to-end () "Move point to the end of the block around point. Moves to 'begin' if in a declarative part." (interactive) (let ((pos (point)) - decl-start - (previous-syntax-table (syntax-table))) - (unwind-protect - (progn - (set-syntax-table ada-mode-symbol-syntax-table) - - (save-excursion - - (cond - ;; Go to the beginning of the current word, and check if we are - ;; directly on 'begin' - ((save-excursion - (skip-syntax-backward "w") - (looking-at "\\<begin\\>")) - (ada-goto-matching-end 1) - ) - - ;; on first line of subprogram body - ;; Do nothing for specs or generic instantion, since these are - ;; handled as the general case (find the enclosing block) - ;; We also need to make sure that we ignore nested subprograms - ((save-excursion - (and (skip-syntax-backward "w") - (looking-at "\\<function\\>\\|\\<procedure\\>" ) - (ada-search-ignore-string-comment "is\\|;") - (not (= (char-before) ?\;)) - )) - (skip-syntax-backward "w") - (ada-goto-matching-end 0 t)) - - ;; on first line of task declaration - ((save-excursion - (and (ada-goto-stmt-start) - (looking-at "\\<task\\>" ) - (forward-word 1) - (ada-goto-next-non-ws) - (looking-at "\\<body\\>"))) - (ada-search-ignore-string-comment "begin" nil nil nil - 'word-search-forward)) - ;; accept block start - ((save-excursion - (and (ada-goto-stmt-start) - (looking-at "\\<accept\\>" ))) - (ada-goto-matching-end 0)) - ;; package start - ((save-excursion - (setq decl-start (and (ada-goto-decl-start t) (point))) - (and decl-start (looking-at "\\<package\\>"))) - (ada-goto-matching-end 1)) - - ;; On a "declare" keyword - ((save-excursion - (skip-syntax-backward "w") - (looking-at "\\<declare\\>")) - (ada-goto-matching-end 0 t)) + decl-start) + (with-syntax-table ada-mode-symbol-syntax-table - ;; inside a 'begin' ... 'end' block - (decl-start - (goto-char decl-start) - (ada-goto-matching-end 0 t)) - - ;; (hopefully ;-) everything else - (t - (ada-goto-matching-end 1))) - (setq pos (point)) - ) - - ;; now really move to the position found - (goto-char pos)) + (save-excursion - ;; restore syntax-table - (set-syntax-table previous-syntax-table)))) + (cond + ;; Go to the beginning of the current word, and check if we are + ;; directly on 'begin' + ((save-excursion + (skip-syntax-backward "w") + (looking-at "\\<begin\\>")) + (ada-goto-matching-end 1)) + + ;; on first line of subprogram body + ;; Do nothing for specs or generic instantion, since these are + ;; handled as the general case (find the enclosing block) + ;; We also need to make sure that we ignore nested subprograms + ((save-excursion + (and (skip-syntax-backward "w") + (looking-at "\\<function\\>\\|\\<procedure\\>" ) + (ada-search-ignore-string-comment "is\\|;") + (not (= (char-before) ?\;)) + )) + (skip-syntax-backward "w") + (ada-goto-matching-end 0 t)) + + ;; on first line of task declaration + ((save-excursion + (and (ada-goto-stmt-start) + (looking-at "\\<task\\>" ) + (forward-word 1) + (ada-goto-next-non-ws) + (looking-at "\\<body\\>"))) + (ada-search-ignore-string-comment "begin" nil nil nil + 'word-search-forward)) + ;; accept block start + ((save-excursion + (and (ada-goto-stmt-start) + (looking-at "\\<accept\\>" ))) + (ada-goto-matching-end 0)) + ;; package start + ((save-excursion + (setq decl-start (and (ada-goto-decl-start t) (point))) + (and decl-start (looking-at "\\<package\\>"))) + (ada-goto-matching-end 1)) + + ;; On a "declare" keyword + ((save-excursion + (skip-syntax-backward "w") + (looking-at "\\<declare\\>")) + (ada-goto-matching-end 0 t)) + + ;; inside a 'begin' ... 'end' block + (decl-start + (goto-char decl-start) + (ada-goto-matching-end 0 t)) + + ;; (hopefully ;-) everything else + (t + (ada-goto-matching-end 1))) + (setq pos (point)) + ) + + ;; now really move to the position found + (goto-char pos)))) (defun ada-next-procedure () "Move point to next procedure." @@ -4818,7 +4775,7 @@ Moves to 'begin' if in a declarative part." (if (featurep 'xemacs) (progn (define-key ada-mode-map [menu-bar] ada-mode-menu) - (set 'mode-popup-menu (cons "Ada mode" ada-mode-menu)))))) + (setq mode-popup-menu (cons "Ada mode" ada-mode-menu)))))) ;; ------------------------------------------------------- @@ -5040,7 +4997,7 @@ or the spec otherwise." (ada-find-src-file-in-dir (file-name-nondirectory (concat name (car suffixes)))))) (if other - (set 'is-spec other))) + (setq is-spec other))) ;; Else search in the current directory (if (file-exists-p (concat name (car suffixes))) @@ -5324,11 +5281,7 @@ Use \\[widen] to go back to the full visibility for the buffer." (widen) (forward-line 1) (ada-previous-procedure) - - (save-excursion - (beginning-of-line) - (setq end (point))) - + (setq end (point-at-bol)) (ada-move-to-end) (end-of-line) (narrow-to-region end (point)) @@ -5570,5 +5523,4 @@ This function typically is to be hooked into `ff-file-created-hook'." ;;; provide ourselves (provide 'ada-mode) -;; arch-tag: 1b7d45ec-1698-43b5-8d4a-e479ea023270 ;;; ada-mode.el ends here diff --git a/lisp/progmodes/ada-prj.el b/lisp/progmodes/ada-prj.el index 0ae93c392a7..c726c06d1d3 100644 --- a/lisp/progmodes/ada-prj.el +++ b/lisp/progmodes/ada-prj.el @@ -6,6 +6,7 @@ ;; Author: Emmanuel Briot <briot@gnat.com> ;; Maintainer: Stephen Leake <stephen_leake@stephe-leake.org> ;; Keywords: languages, ada, project file +;; Package: ada-mode ;; This file is part of GNU Emacs. @@ -195,21 +196,17 @@ One item per line should be found in the file." (widen) (goto-char (point-min)) (while (not (eobp)) - (set 'line (buffer-substring-no-properties - (point) (save-excursion (end-of-line) (point)))) + (set 'line (buffer-substring-no-properties (point) (point-at-eol))) (add-to-list 'list line) - (forward-line 1) - ) + (forward-line 1)) (kill-buffer nil) (set-buffer buffer) (set 'ada-prj-current-values (plist-put ada-prj-current-values symbol (append (plist-get ada-prj-current-values symbol) - (reverse list)))) - ) - (ada-prj-display-page 2) - )) + (reverse list))))) + (ada-prj-display-page 2))) (defun ada-prj-subdirs-of (dir) "Return a list of all the subdirectories of DIR, recursively." @@ -567,8 +564,7 @@ Parameters WIDGET-MODIFIED, EVENT match :notify for the widget." ;; variables (momentary-string-display (concat "*****Help*****\n" text "\n**************\n") - (save-excursion (forward-line) (beginning-of-line) (point))) - ))) + (point-at-bol 2))))) (defun ada-prj-show-value (widget widget-modified event) "Show the current field value in WIDGET. @@ -680,5 +676,4 @@ AFTER-TEXT is inserted just after the widget." (provide 'ada-prj) -;; arch-tag: 65978c77-816e-49c6-896e-6905605d1b4c ;;; ada-prj.el ends here diff --git a/lisp/progmodes/ada-stmt.el b/lisp/progmodes/ada-stmt.el index 103bc093bdb..b618b26c73a 100644 --- a/lisp/progmodes/ada-stmt.el +++ b/lisp/progmodes/ada-stmt.el @@ -9,6 +9,7 @@ ;; Rolf Ebert <ebert@waporo.muc.de> ;; Maintainer: Stephen Leake <stephen_leake@stephe-leake.org> ;; Keywords: languages, ada +;; Package: ada-mode ;; This file is part of GNU Emacs. diff --git a/lisp/progmodes/ada-xref.el b/lisp/progmodes/ada-xref.el index bf836b20eee..36e297182cf 100644 --- a/lisp/progmodes/ada-xref.el +++ b/lisp/progmodes/ada-xref.el @@ -1,13 +1,15 @@ ;; ada-xref.el --- for lookup and completion in Ada mode -;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, -;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. +;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, +;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; Free Software Foundation, Inc. ;; Author: Markus Heritsch <Markus.Heritsch@studbox.uni-stuttgart.de> ;; Rolf Ebert <ebert@inf.enst.fr> ;; Emmanuel Briot <briot@gnat.com> ;; Maintainer: Stephen Leake <stephen_leake@stephe-leake.org> ;; Keywords: languages ada xref +;; Package: ada-mode ;; This file is part of GNU Emacs. @@ -108,10 +110,9 @@ the Ada mode project." :type 'string :group 'ada) (defcustom ada-prj-ada-project-path-sep - (if (or (equal system-type 'windows-nt) - (equal system-type 'ms-dos)) - ";" - ":") + (cond ((boundp 'path-separator) path-separator) ; 20.3+ + ((memq system-type '(windows-nt ms-dos)) ";") + (t ":")) "Default separator for ada_project_path project variable." :type 'string :group 'ada) @@ -166,7 +167,7 @@ This has the same syntax as in the project file (with variable substitution)." Otherwise, ask the user for the name of the project file to use." :type 'boolean :group 'ada) -(defconst is-windows (memq system-type (quote (windows-nt))) +(defconst ada-on-ms-windows (memq system-type '(windows-nt)) "True if we are running on Windows.") (defcustom ada-tight-gvd-integration nil @@ -221,7 +222,7 @@ Used to go back to these positions.") On Windows systems using `cmdproxy.exe' as the shell, we need to use `/d' or the drive is never changed.") -(defvar ada-command-separator (if is-windows " && " "\n") +(defvar ada-command-separator (if ada-on-ms-windows " && " "\n") "Separator to use between multiple commands to `compile' or `start-process'. `cmdproxy.exe' doesn't recognize multiple-line commands, so we have to use \"&&\" for now.") @@ -324,7 +325,7 @@ CROSS-PREFIX is the prefix to use for the `gnatls' command." (add-to-list 'ada-xref-runtime-library-specs-path (buffer-substring-no-properties (point) - (save-excursion (end-of-line) (point))))) + (point-at-eol)))) (forward-line 1)) ;; Object path @@ -338,7 +339,7 @@ CROSS-PREFIX is the prefix to use for the `gnatls' command." (add-to-list 'ada-xref-runtime-library-ali-path (buffer-substring-no-properties (point) - (save-excursion (end-of-line) (point))))) + (point-at-eol)))) (forward-line 1)) ) (kill-buffer nil)))) @@ -381,9 +382,9 @@ Assumes environment variable ADA_PROJECT_PATH is set properly." (forward-line 1) ; first directory in list (while (not (looking-at "^$")) ; terminate on blank line (back-to-indentation) ; skip whitespace - (if (looking-at "<Current_Directory>") - (add-to-list 'src-dir (expand-file-name ".")) - (add-to-list 'src-dir + (add-to-list 'src-dir + (if (looking-at "<Current_Directory>") + default-directory (expand-file-name (buffer-substring-no-properties (point) (line-end-position))))) @@ -395,9 +396,9 @@ Assumes environment variable ADA_PROJECT_PATH is set properly." (forward-line 1) (while (not (looking-at "^$")) (back-to-indentation) - (if (looking-at "<Current_Directory>") - (add-to-list 'obj-dir (expand-file-name ".")) - (add-to-list 'obj-dir + (add-to-list 'obj-dir + (if (looking-at "<Current_Directory>") + default-directory (expand-file-name (buffer-substring-no-properties (point) (line-end-position))))) @@ -767,7 +768,7 @@ is non-nil, prompt the user to select one. If none are found, return 'comp_opt ada-prj-default-comp-opt 'cross_prefix "" 'debug_cmd (concat ada-prj-default-debugger - " ${main}" (if is-windows ".exe")) ;; FIXME: don't need .exe? + " ${main}" (if ada-on-ms-windows ".exe")) ;; FIXME: don't need .exe? 'debug_post_cmd (list nil) 'debug_pre_cmd (list (concat ada-cd-command " ${build_dir}")) 'gnatmake_opt ada-prj-default-gnatmake-opt @@ -781,7 +782,7 @@ is non-nil, prompt the user to select one. If none are found, return 'make_cmd (list ada-prj-default-make-cmd) ;; FIXME: should not a list 'obj_dir (list ".") 'remote_machine "" - 'run_cmd (list (concat "./${main}" (if is-windows ".exe"))) + 'run_cmd (list (concat "./${main}" (if ada-on-ms-windows ".exe"))) ;; FIXME: should not a list ;; FIXME: don't need .exe? 'src_dir (list ".") @@ -1015,7 +1016,7 @@ existing buffer `*gnatfind*', if there is one." ;; processed (gnatfind \"+\":...). (let* ((quote-entity (if (= (aref entity 0) ?\") - (if is-windows + (if ada-on-ms-windows (concat "\\\"" (substring entity 1 -1) "\\\"") (concat "'\"" (substring entity 1 -1) "\"'")) entity)) @@ -1817,7 +1818,7 @@ Information is extracted from the ali file." (beginning-of-line) (if declaration-found (let ((current-line (buffer-substring - (point) (save-excursion (end-of-line) (point))))) + (point) (point-at-eol)))) (save-excursion (forward-line 1) (beginning-of-line) @@ -2379,5 +2380,4 @@ For instance, it creates the gnat-specific menus, sets some hooks for (provide 'ada-xref) -;; arch-tag: 415a39fe-577b-4676-b3b1-6ff6db7ca24e ;;; ada-xref.el ends here diff --git a/lisp/progmodes/antlr-mode.el b/lisp/progmodes/antlr-mode.el index 82b532e9cd5..742bcf726eb 100644 --- a/lisp/progmodes/antlr-mode.el +++ b/lisp/progmodes/antlr-mode.el @@ -5,7 +5,7 @@ ;; Author: Christoph.Wedler@sap.com ;; Keywords: languages, ANTLR, code generator -;; Version: (see `antlr-version' below) +;; Version: 2.2c ;; X-URL: http://antlr-mode.sourceforge.net/ ;; This file is part of GNU Emacs. diff --git a/lisp/progmodes/asm-mode.el b/lisp/progmodes/asm-mode.el index 0ce7d780d1f..f5fef76a009 100644 --- a/lisp/progmodes/asm-mode.el +++ b/lisp/progmodes/asm-mode.el @@ -109,7 +109,7 @@ "Additional expressions to highlight in Assembler mode.") ;;;###autoload -(defun asm-mode () +(define-derived-mode asm-mode prog-mode "Assembler" "Major mode for editing typical assembler code. Features a private abbrev table and the following bindings: @@ -128,13 +128,8 @@ Turning on Asm mode runs the hook `asm-mode-hook' at the end of initialization. Special commands: \\{asm-mode-map}" - (interactive) - (kill-all-local-variables) - (setq mode-name "Assembler") - (setq major-mode 'asm-mode) (setq local-abbrev-table asm-mode-abbrev-table) - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults '(asm-font-lock-keywords)) + (set (make-local-variable 'font-lock-defaults) '(asm-font-lock-keywords)) (set (make-local-variable 'indent-line-function) 'asm-indent-line) ;; Stay closer to the old TAB behavior (was tab-to-tab-stop). (set (make-local-variable 'tab-always-indent) nil) @@ -157,8 +152,7 @@ Special commands: (setq comment-end-skip "[ \t]*\\(\\s>\\|\\*+/\\)") (make-local-variable 'comment-end) (setq comment-end "") - (setq fill-prefix "\t") - (run-mode-hooks 'asm-mode-hook)) + (setq fill-prefix "\t")) (defun asm-indent-line () "Auto-indent the current line." diff --git a/lisp/progmodes/autoconf.el b/lisp/progmodes/autoconf.el index a56623f22da..004bb3de78d 100644 --- a/lisp/progmodes/autoconf.el +++ b/lisp/progmodes/autoconf.el @@ -43,9 +43,6 @@ (defvar autoconf-mode-hook nil "Hook run by `autoconf-mode'.") -(defconst autoconf-font-lock-syntactic-keywords - '(("\\<dnl\\>" 0 '(11)))) - (defconst autoconf-definition-regexp "AC_\\(SUBST\\|DEFINE\\(_UNQUOTED\\)?\\)(\\[*\\(\\sw+\\)\\]*") @@ -94,8 +91,8 @@ searching backwards at another AC_... command." "^[ \t]*A[CM]_\\(\\sw\\|\\s_\\)+") (set (make-local-variable 'comment-start) "dnl ") (set (make-local-variable 'comment-start-skip) "\\(?:\\<dnl\\|#\\) +") - (set (make-local-variable 'font-lock-syntactic-keywords) - autoconf-font-lock-syntactic-keywords) + (set (make-local-variable 'syntax-propertize-function) + (syntax-propertize-rules ("\\<dnl\\>" (0 "<")))) (set (make-local-variable 'font-lock-defaults) `(autoconf-font-lock-keywords nil nil (("_" . "w")))) (set (make-local-variable 'imenu-generic-expression) diff --git a/lisp/progmodes/bug-reference.el b/lisp/progmodes/bug-reference.el index d0cc5541b8a..4897581252f 100644 --- a/lisp/progmodes/bug-reference.el +++ b/lisp/progmodes/bug-reference.el @@ -41,13 +41,28 @@ (defvar bug-reference-url-format nil "Format used to turn a bug number into a URL. The bug number is supplied as a string, so this should have a single %s. -There is no default setting for this, it must be set per file.") +This can also be a function designator; it is called without arguments + and should return a string. +It can use `match-string' to get parts matched against +`bug-reference-bug-regexp', specifically: + 1. issue kind (bug, patch, rfe &c) + 2. issue number. + +There is no default setting for this, it must be set per file. +If you set it to a symbol in the file Local Variables section, +you need to add a `bug-reference-url-format' property to it: +\(put 'my-bug-reference-url-format 'bug-reference-url-format t) +so that it is considered safe, see `enable-local-variables'.") ;;;###autoload -(put 'bug-reference-url-format 'safe-local-variable 'stringp) +(put 'bug-reference-url-format 'safe-local-variable + (lambda (s) + (or (stringp s) + (and (symbolp s) + (get s 'bug-reference-url-format))))) (defconst bug-reference-bug-regexp - "\\(?:[Bb]ug ?#\\|PR [a-z-+]+/\\)\\([0-9]+\\)" + "\\([Bb]ug ?#\\|[Pp]atch ?#\\|RFE ?#\\|PR [a-z-+]+/\\)\\([0-9]+\\)" "Regular expression which matches bug references.") (defun bug-reference-set-overlay-properties () @@ -87,9 +102,11 @@ There is no default setting for this, it must be set per file.") (overlay-put overlay 'category 'bug-reference) ;; Don't put a link if format is undefined (when bug-reference-url-format - (overlay-put overlay 'bug-reference-url - (format bug-reference-url-format - (match-string-no-properties 1)))))))))) + (overlay-put overlay 'bug-reference-url + (if (stringp bug-reference-url-format) + (format bug-reference-url-format + (match-string-no-properties 2)) + (funcall bug-reference-url-format)))))))))) ;; Taken from button.el. (defun bug-reference-push-button (&optional pos use-mouse-action) diff --git a/lisp/progmodes/cc-align.el b/lisp/progmodes/cc-align.el index e52a0d70e48..8224db79ace 100644 --- a/lisp/progmodes/cc-align.el +++ b/lisp/progmodes/cc-align.el @@ -12,8 +12,8 @@ ;; 1985 Richard M. Stallman ;; Maintainer: bug-cc-mode@gnu.org ;; Created: 22-Apr-1997 (split from cc-mode.el) -;; Version: See cc-mode.el -;; Keywords: c languages oop +;; Keywords: c languages +;; Package: cc-mode ;; This file is part of GNU Emacs. diff --git a/lisp/progmodes/cc-awk.el b/lisp/progmodes/cc-awk.el index 25dc27a08ea..6c7db25612d 100644 --- a/lisp/progmodes/cc-awk.el +++ b/lisp/progmodes/cc-awk.el @@ -6,6 +6,7 @@ ;; Author: Alan Mackenzie <acm@muc.de> (originally based on awk-mode.el) ;; Maintainer: FSF ;; Keywords: AWK, cc-mode, unix, languages +;; Package: cc-mode ;; This file is part of GNU Emacs. @@ -244,7 +245,7 @@ ;; REGEXPS USED FOR FINDING THE POSITION OF A "virtual semicolon" (defconst c-awk-_-harmless-nonws-char-re "[^#/\"\\\\\n\r \t]") -;;;; NEW VERSION! (which will be restricted to the current line) +;; NEW VERSION! (which will be restricted to the current line) (defconst c-awk-one-line-non-syn-ws*-re (concat "\\([ \t]*" "\\(" c-awk-_-harmless-nonws-char-re "\\|" @@ -503,7 +504,7 @@ (insert-char ?\n 1) ; ...artificial eol is needed for comment detection. (setq extra-nl t)) (prog1 (c-awk-get-NL-prop-prev-line do-lim) - (if extra-nl (delete-backward-char 1)))))) + (if extra-nl (delete-char -1)))))) (defsubst c-awk-prev-line-incomplete-p (&optional do-lim) ;; Is there an incomplete statement at the end of the previous line? @@ -519,14 +520,14 @@ ;; This function might do hidden buffer changes. (memq (c-awk-get-NL-prop-cur-line do-lim) '(?\\ ?\{))) -;;;; NOTES ON "VIRTUAL SEMICOLONS" -;;;; -;;;; A "virtual semicolon" is what terminates a statement when there is no ; -;;;; or } to do the job. Like point, it is considered to lie _between_ two -;;;; characters. As from mid-March 2004, it is considered to lie just after -;;;; the last non-syntactic-whitespace character on the line; (previously, it -;;;; was considered an attribute of the EOL on the line). A real semicolon -;;;; never counts as a virtual one. +;; NOTES ON "VIRTUAL SEMICOLONS" +;; +;; A "virtual semicolon" is what terminates a statement when there is no ; +;; or } to do the job. Like point, it is considered to lie _between_ two +;; characters. As from mid-March 2004, it is considered to lie just after +;; the last non-syntactic-whitespace character on the line; (previously, it +;; was considered an attribute of the EOL on the line). A real semicolon +;; never counts as a virtual one. (defun c-awk-at-vsemi-p (&optional pos) ;; Is there a virtual semicolon at POS (or POINT)? diff --git a/lisp/progmodes/cc-bytecomp.el b/lisp/progmodes/cc-bytecomp.el index cde38d872b0..597267d4e5d 100644 --- a/lisp/progmodes/cc-bytecomp.el +++ b/lisp/progmodes/cc-bytecomp.el @@ -6,8 +6,8 @@ ;; Author: Martin Stjernholm ;; Maintainer: bug-cc-mode@gnu.org ;; Created: 15-Jul-2000 -;; Version: See cc-mode.el -;; Keywords: c languages oop +;; Keywords: c languages +;; Package: cc-mode ;; This file is part of GNU Emacs. diff --git a/lisp/progmodes/cc-cmds.el b/lisp/progmodes/cc-cmds.el index 4eade6edf58..112fa50ce8f 100644 --- a/lisp/progmodes/cc-cmds.el +++ b/lisp/progmodes/cc-cmds.el @@ -12,8 +12,8 @@ ;; 1985 Richard M. Stallman ;; Maintainer: bug-cc-mode@gnu.org ;; Created: 22-Apr-1997 (split from cc-mode.el) -;; Version: See cc-mode.el -;; Keywords: c languages oop +;; Keywords: c languages +;; Package: cc-mode ;; This file is part of GNU Emacs. @@ -1086,104 +1086,76 @@ numeric argument is supplied, or the point is inside a literal." (interactive "*P") (let ((c-echo-syntactic-information-p nil) - final-pos close-paren-inserted) + final-pos close-paren-inserted found-delim) (self-insert-command (prefix-numeric-value arg)) (setq final-pos (point)) - (c-save-buffer-state (c-parse-and-markup-<>-arglists - c-restricted-<>-arglists - <-pos) +;;;; 2010-01-31: There used to be code here to put a syntax-table text +;;;; property on the new < or > and its mate (if any) when they are template +;;;; parens. This is now done in an after-change function. - (when c-recognize-<>-arglists - (if (eq last-command-event ?<) - (when (and (progn - (backward-char) - (= (point) - (progn - (c-beginning-of-current-token) - (point)))) + ;; Indent the line if appropriate. + (when (and c-electric-flag c-syntactic-indentation c-recognize-<>-arglists) + (setq found-delim + (if (eq last-command-event ?<) + ;; If a <, basically see if it's got "template" before it ..... + (or (and (progn + (backward-char) + (= (point) + (progn (c-beginning-of-current-token) (point)))) + (progn + (c-backward-token-2) + (looking-at c-opt-<>-sexp-key))) + ;; ..... or is a C++ << operator. + (and (c-major-mode-is 'c++-mode) + (progn + (goto-char (1- final-pos)) + (c-beginning-of-current-token) + (looking-at "<<")) + (>= (match-end 0) final-pos))) + + ;; It's a >. Either a C++ >> operator. ...... + (or (and (c-major-mode-is 'c++-mode) (progn - (c-backward-token-2) - (looking-at c-opt-<>-sexp-key))) - (c-mark-<-as-paren (1- final-pos))) - - ;; It's a ">". Check if there's an earlier "<" which either has - ;; open paren syntax already or that can be recognized as an arglist - ;; together with this ">". Note that this won't work in cases like - ;; "template <x, a < b, y>" but they ought to be rare. - - (save-restriction - ;; Narrow to avoid that `c-forward-<>-arglist' below searches past - ;; our position. - (narrow-to-region (point-min) final-pos) - - (while (and - (progn - (goto-char final-pos) - (c-syntactic-skip-backward "^<;}" nil t) - (eq (char-before) ?<)) - (progn - (backward-char) - ;; If the "<" already got open paren syntax we know we - ;; have the matching closer. Handle it and exit the - ;; loop. - (if (looking-at "\\s\(") - (progn - (c-mark->-as-paren (1- final-pos)) - (setq close-paren-inserted t) - nil) - t)) + (goto-char (1- final-pos)) + (c-beginning-of-current-token) + (looking-at ">>")) + (>= (match-end 0) final-pos)) + ;; ...., or search back for a < which isn't already marked as an + ;; opening template delimiter. + (save-restriction + (widen) + ;; Narrow to avoid `c-forward-<>-arglist' below searching past + ;; our position. + (narrow-to-region (point-min) final-pos) + (goto-char final-pos) + (while + (and + (progn + (c-syntactic-skip-backward "^<;}" nil t) + (eq (char-before) ?<)) + (progn + (backward-char) + (looking-at "\\s\(")))) + (and (eq (char-after) ?<) + (not (looking-at "\\s\(")) + (progn (c-backward-syntactic-ws) + (c-simple-skip-symbol-backward)) + (or (looking-at c-opt-<>-sexp-key) + (not (looking-at c-keywords-regexp))))))))) - (progn - (setq <-pos (point)) - (c-backward-syntactic-ws) - (c-simple-skip-symbol-backward)) - (or (looking-at c-opt-<>-sexp-key) - (not (looking-at c-keywords-regexp))) - - (let ((c-parse-and-markup-<>-arglists t) - c-restricted-<>-arglists - (containing-sexp - (c-most-enclosing-brace (c-parse-state)))) - (when (and containing-sexp - (progn (goto-char containing-sexp) - (eq (char-after) ?\()) - (not (eq (get-text-property (point) 'c-type) - 'c-decl-arg-start))) - (setq c-restricted-<>-arglists t)) - (goto-char <-pos) - (c-forward-<>-arglist nil)) - - ;; Loop here if the "<" we found above belongs to a nested - ;; angle bracket sexp. When we start over we'll find the - ;; previous or surrounding sexp. - (if (< (point) final-pos) - t - (setq close-paren-inserted t) - nil))))))) (goto-char final-pos) - - ;; Indent the line if appropriate. - (when (and c-electric-flag c-syntactic-indentation) - (backward-char) - (when (prog1 (or (looking-at "\\s\(\\|\\s\)") - (and (c-major-mode-is 'c++-mode) - (progn - (c-beginning-of-current-token) - (looking-at "<<\\|>>")) - (= (match-end 0) final-pos))) - (goto-char final-pos)) - (indent-according-to-mode))) - - (when (and close-paren-inserted - (not executing-kbd-macro) - blink-paren-function) - ;; Note: Most paren blink functions, such as the standard - ;; `blink-matching-open', currently doesn't handle paren chars - ;; marked with text properties very well. Maybe we should avoid - ;; this call for the time being? - (funcall blink-paren-function)))) + (when found-delim + (indent-according-to-mode) + (when (and (eq (char-before) ?>) + (not executing-kbd-macro) + blink-paren-function) + ;; Note: Most paren blink functions, such as the standard + ;; `blink-matching-open', currently doesn't handle paren chars + ;; marked with text properties very well. Maybe we should avoid + ;; this call for the time being? + (funcall blink-paren-function))))) (defun c-electric-paren (arg) "Insert a parenthesis. @@ -1529,6 +1501,11 @@ defun." (interactive "p") (or arg (setq arg 1)) + (or (not (eq this-command 'c-beginning-of-defun)) + (eq last-command 'c-beginning-of-defun) + (and transient-mark-mode mark-active) + (push-mark)) + (c-save-buffer-state (beginning-of-defun-function end-of-defun-function (start (point)) @@ -1632,6 +1609,11 @@ the open-parenthesis that starts a defun; see `beginning-of-defun'." (interactive "p") (or arg (setq arg 1)) + (or (not (eq this-command 'c-end-of-defun)) + (eq last-command 'c-end-of-defun) + (and transient-mark-mode mark-active) + (push-mark)) + (c-save-buffer-state (beginning-of-defun-function end-of-defun-function (start (point)) @@ -3992,16 +3974,19 @@ command to conveniently insert and align the necessary backslashes." ;; "Invalid search bound (wrong side of point)" ;; error in the subsequent re-search. Maybe ;; another fix would be needed (2007-12-08). - (and (> (- (cdr c-lit-limits) 2) (point)) - (search-forward-regexp - (concat "\\=[ \t]*\\(" c-current-comment-prefix "\\)") - (- (cdr c-lit-limits) 2) t) - (not (search-forward-regexp - "\\(\\s \\|\\sw\\)" - (- (cdr c-lit-limits) 2) 'limit)) - ;; The comment ender IS on its own line. Exclude - ;; this line from the filling. - (set-marker end (c-point 'bol)))) +; (or (<= (- (cdr c-lit-limits) 2) (point)) +; 2010-10-17 Construct removed. +; (or (< (- (cdr c-lit-limits) 2) (point)) + (and + (search-forward-regexp + (concat "\\=[ \t]*\\(" c-current-comment-prefix "\\)") + (- (cdr c-lit-limits) 2) t) + (not (search-forward-regexp + "\\(\\s \\|\\sw\\)" + (- (cdr c-lit-limits) 2) 'limit)) + ;; The comment ender IS on its own line. Exclude this + ;; line from the filling. + (set-marker end (c-point 'bol))));) ;; The comment ender is hanging. Replace all space between it ;; and the last word either by one or two 'x's (when @@ -4018,6 +4003,14 @@ command to conveniently insert and align the necessary backslashes." (goto-char ender-start) (current-column))) (point-rel (- ender-start here)) + (sentence-ends-comment + (save-excursion + (goto-char ender-start) + (and (search-backward-regexp + (c-sentence-end) (c-point 'bol) t) + (goto-char (match-end 0)) + (looking-at "[ \t]*") + (= (match-end 0) ender-start)))) spaces) (save-excursion @@ -4060,7 +4053,9 @@ command to conveniently insert and align the necessary backslashes." (setq spaces (max (min spaces - (if sentence-end-double-space 2 1)) + (if (and sentence-ends-comment + sentence-end-double-space) + 2 1)) 1))) ;; Insert the filler first to keep marks right. (insert-char ?x spaces t) @@ -4270,8 +4265,11 @@ Optional prefix ARG means justify paragraph as well." (let ((fill-paragraph-function ;; Avoid infinite recursion. (if (not (eq fill-paragraph-function 'c-fill-paragraph)) - fill-paragraph-function))) - (c-mask-paragraph t nil 'fill-paragraph arg)) + fill-paragraph-function)) + (start-point (point-marker))) + (c-mask-paragraph + t nil (lambda () (fill-region-as-paragraph (point-min) (point-max) arg))) + (goto-char start-point)) ;; Always return t. This has the effect that if filling isn't done ;; above, it isn't done at all, and it's therefore effectively ;; disabled in normal code. diff --git a/lisp/progmodes/cc-compat.el b/lisp/progmodes/cc-compat.el index 59a336f3c69..adfac2f5f9e 100644 --- a/lisp/progmodes/cc-compat.el +++ b/lisp/progmodes/cc-compat.el @@ -8,8 +8,8 @@ ;; 1994-1999 Barry A. Warsaw ;; Maintainer: bug-cc-mode@gnu.org ;; Created: August 1994, split from cc-mode.el -;; Version: See cc-mode.el -;; Keywords: c languages oop +;; Keywords: c languages +;; Package: cc-mode ;; This file is part of GNU Emacs. diff --git a/lisp/progmodes/cc-defs.el b/lisp/progmodes/cc-defs.el index 39036b743c6..147a0e2dc2a 100644 --- a/lisp/progmodes/cc-defs.el +++ b/lisp/progmodes/cc-defs.el @@ -12,8 +12,8 @@ ;; 1985 Richard M. Stallman ;; Maintainer: bug-cc-mode@gnu.org ;; Created: 22-Apr-1997 (split from cc-mode.el) -;; Version: See cc-mode.el -;; Keywords: c languages oop +;; Keywords: c languages +;; Package: cc-mode ;; This file is part of GNU Emacs. @@ -1029,6 +1029,44 @@ MODE is either a mode symbol or a list of mode symbols." ;; Emacs. `(remove-text-properties ,from ,to '(,property nil)))) +(defmacro c-search-forward-char-property (property value &optional limit) + "Search forward for a text-property PROPERTY having value VALUE. +LIMIT bounds the search. The comparison is done with `equal'. + +Leave point just after the character, and set the match data on +this character, and return point. If VALUE isn't found, Return +nil; point is then left undefined." + `(let ((place (point))) + (while + (and + (< place ,(or limit '(point-max))) + (not (equal (get-text-property place ,property) ,value))) + (setq place (next-single-property-change + place ,property nil ,(or limit '(point-max))))) + (when (< place ,(or limit '(point-max))) + (goto-char place) + (search-forward-regexp ".") ; to set the match-data. + (point)))) + +(defmacro c-search-backward-char-property (property value &optional limit) + "Search backward for a text-property PROPERTY having value VALUE. +LIMIT bounds the search. The comparison is done with `equal'. + +Leave point just before the character, set the match data on this +character, and return point. If VALUE isn't found, Return nil; +point is then left undefined." + `(let ((place (point))) + (while + (and + (> place ,(or limit '(point-min))) + (not (equal (get-text-property (1- place) ,property) ,value))) + (setq place (previous-single-property-change + place ,property nil ,(or limit '(point-min))))) + (when (> place ,(or limit '(point-max))) + (goto-char place) + (search-backward-regexp ".") ; to set the match-data. + (point)))) + (defun c-clear-char-property-with-value-function (from to property value) "Remove all text-properties PROPERTY from the region (FROM, TO) which have the value VALUE, as tested by `equal'. These @@ -1044,7 +1082,7 @@ been put there by c-put-char-property. POINT remains unchanged." (setq place (next-single-property-change place property nil to))) (< place to)) (setq end-place (next-single-property-change place property nil to)) - (put-text-property place end-place property nil) + (remove-text-properties place end-place (cons property nil)) ;; Do we have to do anything with stickiness here? (setq place end-place)))) @@ -1145,23 +1183,117 @@ been put there by c-put-char-property. POINT remains unchanged." (goto-char (point-max))))) (defconst c-<-as-paren-syntax '(4 . ?>)) +(put 'c-<-as-paren-syntax 'syntax-table c-<-as-paren-syntax) (defsubst c-mark-<-as-paren (pos) - ;; Mark the "<" character at POS as an sexp list opener using the - ;; syntax-table property. + ;; Mark the "<" character at POS as a template opener using the + ;; `syntax-table' property via the `category' property. ;; - ;; This function does a hidden buffer change. - (c-put-char-property pos 'syntax-table c-<-as-paren-syntax)) + ;; This function does a hidden buffer change. Note that we use + ;; indirection through the `category' text property. This allows us to + ;; toggle the property in all template brackets simultaneously and + ;; cheaply. We use this, for instance, in `c-parse-state'. + (c-put-char-property pos 'category 'c-<-as-paren-syntax)) (defconst c->-as-paren-syntax '(5 . ?<)) +(put 'c->-as-paren-syntax 'syntax-table c->-as-paren-syntax) (defsubst c-mark->-as-paren (pos) ;; Mark the ">" character at POS as an sexp list closer using the ;; syntax-table property. ;; - ;; This function does a hidden buffer change. - (c-put-char-property pos 'syntax-table c->-as-paren-syntax)) - + ;; This function does a hidden buffer change. Note that we use + ;; indirection through the `category' text property. This allows us to + ;; toggle the property in all template brackets simultaneously and + ;; cheaply. We use this, for instance, in `c-parse-state'. + (c-put-char-property pos 'category 'c->-as-paren-syntax)) + +(defsubst c-unmark-<->-as-paren (pos) + ;; Unmark the "<" or "<" character at POS as an sexp list opener using + ;; the syntax-table property indirectly through the `category' text + ;; property. + ;; + ;; This function does a hidden buffer change. Note that we use + ;; indirection through the `category' text property. This allows us to + ;; toggle the property in all template brackets simultaneously and + ;; cheaply. We use this, for instance, in `c-parse-state'. + (c-clear-char-property pos 'category)) + +(defsubst c-suppress-<->-as-parens () + ;; Suppress the syntactic effect of all marked < and > as parens. Note + ;; that this effect is NOT buffer local. You should probably not use + ;; this directly, but only through the macro + ;; `c-with-<->-as-parens-suppressed' + (put 'c-<-as-paren-syntax 'syntax-table nil) + (put 'c->-as-paren-syntax 'syntax-table nil)) + +(defsubst c-restore-<->-as-parens () + ;; Restore the syntactic effect of all marked <s and >s as parens. This + ;; has no effect on unmarked <s and >s + (put 'c-<-as-paren-syntax 'syntax-table c-<-as-paren-syntax) + (put 'c->-as-paren-syntax 'syntax-table c->-as-paren-syntax)) + +(defmacro c-with-<->-as-parens-suppressed (&rest forms) + ;; Like progn, except that the paren property is suppressed on all + ;; template brackets whilst they are running. This macro does a hidden + ;; buffer change. + `(unwind-protect + (progn + (c-suppress-<->-as-parens) + ,@forms) + (c-restore-<->-as-parens))) + +;;;;;;;;;;;;;;; + +(defconst c-cpp-delimiter '(14)) ; generic comment syntax +;; This is the value of the `category' text property placed on every # +;; which introduces a CPP construct and every EOL (or EOB, or character +;; preceding //, etc.) which terminates it. We can instantly "comment +;; out" all CPP constructs by giving `c-cpp-delimiter' a syntax-table +;; propery '(14) (generic comment delimiter). +(defmacro c-set-cpp-delimiters (beg end) + ;; This macro does a hidden buffer change. + `(progn + (c-put-char-property ,beg 'category 'c-cpp-delimiter) + (if (< ,end (point-max)) + (c-put-char-property ,end 'category 'c-cpp-delimiter)))) +(defmacro c-clear-cpp-delimiters (beg end) + ;; This macro does a hidden buffer change. + `(progn + (c-clear-char-property ,beg 'category) + (if (< ,end (point-max)) + (c-clear-char-property ,end 'category)))) + +(defsubst c-comment-out-cpps () + ;; Render all preprocessor constructs syntactically commented out. + (put 'c-cpp-delimiter 'syntax-table c-cpp-delimiter)) +(defsubst c-uncomment-out-cpps () + ;; Restore the syntactic visibility of preprocessor constructs. + (put 'c-cpp-delimiter 'syntax-table nil)) + +(defmacro c-with-cpps-commented-out (&rest forms) + ;; Execute FORMS... whilst the syntactic effect of all characters in + ;; all CPP regions is suppressed. In particular, this is to suppress + ;; the syntactic significance of parens/braces/brackets to functions + ;; such as `scan-lists' and `parse-partial-sexp'. + `(unwind-protect + (c-save-buffer-state () + (c-comment-out-cpps) + ,@forms) + (c-save-buffer-state () + (c-uncomment-out-cpps)))) + +(defmacro c-with-all-but-one-cpps-commented-out (beg end &rest forms) + ;; Execute FORMS... whilst the syntactic effect of all characters in + ;; every CPP region APART FROM THE ONE BETWEEN BEG and END is + ;; suppressed. + `(unwind-protect + (c-save-buffer-state () + (c-clear-cpp-delimiters ,beg ,end) + ,`(c-with-cpps-commented-out ,@forms)) + (c-save-buffer-state () + (c-set-cpp-delimiters ,beg ,end)))) + (defsubst c-intersect-lists (list alist) ;; return the element of ALIST that matches the first element found ;; in LIST. Uses assq. diff --git a/lisp/progmodes/cc-engine.el b/lisp/progmodes/cc-engine.el index 9c04920a208..18010407eda 100644 --- a/lisp/progmodes/cc-engine.el +++ b/lisp/progmodes/cc-engine.el @@ -1,8 +1,8 @@ ;;; cc-engine.el --- core syntax guessing engine for CC mode ;; Copyright (C) 1985, 1987, 1992, 1993, 1994, 1995, 1996, 1997, 1998, -;; 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. +;; 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, +;; 2010 Free Software Foundation, Inc. ;; Authors: 2001- Alan Mackenzie ;; 1998- Martin Stjernholm @@ -12,8 +12,8 @@ ;; 1985 Richard M. Stallman ;; Maintainer: bug-cc-mode@gnu.org ;; Created: 22-Apr-1997 (split from cc-mode.el) -;; Version: See cc-mode.el -;; Keywords: c languages oop +;; Keywords: c languages +;; Package: cc-mode ;; This file is part of GNU Emacs. @@ -79,6 +79,10 @@ ;; Note: This doc is for internal use only. Other packages should not ;; assume that these text properties are used as described here. ;; +;; 'category +;; Used for "indirection". With its help, some other property can +;; be cheaply and easily switched on or off everywhere it occurs. +;; ;; 'syntax-table ;; Used to modify the syntax of some characters. It is used to ;; mark the "<" and ">" of angle bracket parens with paren syntax, and @@ -256,6 +260,27 @@ comment at the start of cc-engine.el for more info." (forward-char) t)))) +(defun c-syntactic-end-of-macro () + ;; Go to the end of a CPP directive, or a "safe" pos just before. + ;; + ;; This is normally the end of the next non-escaped line. A "safe" + ;; position is one not within a string or comment. (The EOL on a line + ;; comment is NOT "safe"). + ;; + ;; This function must only be called from the beginning of a CPP construct. + ;; + ;; Note that this function might do hidden buffer changes. See the comment + ;; at the start of cc-engine.el for more info. + (let* ((here (point)) + (there (progn (c-end-of-macro) (point))) + (s (parse-partial-sexp here there))) + (while (and (or (nth 3 s) ; in a string + (nth 4 s)) ; in a comment (maybe at end of line comment) + (> there here)) ; No infinite loops, please. + (setq there (1- (nth 8 s))) + (setq s (parse-partial-sexp here there))) + (point))) + (defun c-forward-over-cpp-define-id () ;; Assuming point is at the "#" that introduces a preprocessor ;; directive, it's moved forward to the end of the identifier which is @@ -1947,10 +1972,18 @@ comment at the start of cc-engine.el for more info." ;; A system for finding noteworthy parens before the point. +(defconst c-state-cache-too-far 5000) +;; A maximum comfortable scanning distance, e.g. between +;; `c-state-cache-good-pos' and "HERE" (where we call c-parse-state). When +;; this distance is exceeded, we take "emergency meausures", e.g. by clearing +;; the cache and starting again from point-min or a beginning of defun. This +;; value can be tuned for efficiency or set to a lower value for testing. + (defvar c-state-cache nil) (make-variable-buffer-local 'c-state-cache) ;; The state cache used by `c-parse-state' to cut down the amount of -;; searching. It's the result from some earlier `c-parse-state' call. +;; searching. It's the result from some earlier `c-parse-state' call. See +;; `c-parse-state''s doc string for details of its structure. ;; ;; The use of the cached info is more effective if the next ;; `c-parse-state' call is on a line close by the one the cached state @@ -1959,18 +1992,12 @@ comment at the start of cc-engine.el for more info." ;; most effective if `c-parse-state' is used on each line while moving ;; forward. -(defvar c-state-cache-start 1) -(make-variable-buffer-local 'c-state-cache-start) -;; This is (point-min) when `c-state-cache' was calculated, since a -;; change of narrowing is likely to affect the parens that are visible -;; before the point. - (defvar c-state-cache-good-pos 1) (make-variable-buffer-local 'c-state-cache-good-pos) -;; This is a position where `c-state-cache' is known to be correct. -;; It's a position inside one of the recorded unclosed parens or the -;; top level, but not further nested inside any literal or subparen -;; that is closed before the last recorded position. +;; This is a position where `c-state-cache' is known to be correct, or +;; nil (see below). It's a position inside one of the recorded unclosed +;; parens or the top level, but not further nested inside any literal or +;; subparen that is closed before the last recorded position. ;; ;; The exact position is chosen to try to be close to yet earlier than ;; the position where `c-state-cache' will be called next. Right now @@ -1978,313 +2005,1074 @@ comment at the start of cc-engine.el for more info." ;; closing paren (of any type) before the line on which ;; `c-parse-state' was called. That is chosen primarily to work well ;; with refontification of the current line. +;; +;; 2009-07-28: When `c-state-point-min' and the last position where +;; `c-parse-state' or for which `c-invalidate-state-cache' was called, are +;; both in the same literal, there is no such "good position", and +;; c-state-cache-good-pos is then nil. This is the ONLY circumstance in which +;; it can be nil. In this case, `c-state-point-min-literal' will be non-nil. +;; +;; 2009-06-12: In a brace desert, c-state-cache-good-pos may also be in +;; the middle of the desert, as long as it is not within a brace pair +;; recorded in `c-state-cache' or a paren/bracket pair. + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; We maintain a simple cache of positions which aren't in a literal, so as to +;; speed up testing for non-literality. +(defconst c-state-nonlit-pos-interval 10000) +;; The approximate interval between entries in `c-state-nonlit-pos-cache'. + +(defvar c-state-nonlit-pos-cache nil) +(make-variable-buffer-local 'c-state-nonlit-pos-cache) +;; A list of buffer positions which are known not to be in a literal. This is +;; ordered with higher positions at the front of the list. Only those which +;; are less than `c-state-nonlit-pos-cache-limit' are valid. + +(defvar c-state-nonlit-pos-cache-limit 1) +(make-variable-buffer-local 'c-state-nonlit-pos-cache-limit) +;; An upper limit on valid entries in `c-state-nonlit-pos-cache'. This is +;; reduced by buffer changes, and increased by invocations of +;; `c-state-literal-at'. + +(defsubst c-state-pp-to-literal (from to) + ;; Do a parse-partial-sexp from FROM to TO, returning the bounds of any + ;; literal at TO as a cons, otherwise NIL. + ;; FROM must not be in a literal, and the buffer should already be wide + ;; enough. + (save-excursion + (let ((s (parse-partial-sexp from to))) + (when (or (nth 3 s) (nth 4 s)) ; in a string or comment + (parse-partial-sexp (point) (point-max) + nil ; TARGETDEPTH + nil ; STOPBEFORE + s ; OLDSTATE + 'syntax-table) ; stop at end of literal + (cons (nth 8 s) (point)))))) + +(defun c-state-literal-at (here) + ;; If position HERE is inside a literal, return (START . END), the + ;; boundaries of the literal (which may be outside the accessible bit of the + ;; buffer). Otherwise, return nil. + ;; + ;; This function is almost the same as `c-literal-limits'. It differs in + ;; that it is a lower level function, and that it rigourously follows the + ;; syntax from BOB, whereas `c-literal-limits' uses a "local" safe position. + (save-restriction + (widen) + (save-excursion + (let ((c c-state-nonlit-pos-cache) + pos npos lit) + ;; Trim the cache to take account of buffer changes. + (while (and c (> (car c) c-state-nonlit-pos-cache-limit)) + (setq c (cdr c))) + (setq c-state-nonlit-pos-cache c) + + (while (and c (> (car c) here)) + (setq c (cdr c))) + (setq pos (or (car c) (point-min))) + + (while (<= (setq npos (+ pos c-state-nonlit-pos-interval)) + here) + (setq lit (c-state-pp-to-literal pos npos)) + (setq pos (or (cdr lit) npos)) ; end of literal containing npos. + (setq c-state-nonlit-pos-cache (cons pos c-state-nonlit-pos-cache))) + + (if (> pos c-state-nonlit-pos-cache-limit) + (setq c-state-nonlit-pos-cache-limit pos)) + (if (< pos here) + (setq lit (c-state-pp-to-literal pos here))) + lit)))) + +(defsubst c-state-lit-beg (pos) + ;; Return the start of the literal containing POS, or POS itself. + (or (car (c-state-literal-at pos)) + pos)) + +(defsubst c-state-cache-non-literal-place (pos state) + ;; Return a position outside of a string/comment at or before POS. + ;; STATE is the parse-partial-sexp state at POS. + (if (or (nth 3 state) ; in a string? + (nth 4 state)) ; in a comment? + (nth 8 state) + pos)) -(defsubst c-invalidate-state-cache (pos) - ;; Invalidate all info on `c-state-cache' that applies to the buffer - ;; at POS or higher. This is much like `c-whack-state-after', but - ;; it never changes a paren pair element into an open paren element. - ;; Doing that would mean that the new open paren wouldn't have the - ;; required preceding paren pair element. - (while (and (or c-state-cache - (when (< pos c-state-cache-good-pos) - (setq c-state-cache-good-pos 1) - nil)) - (let ((elem (car c-state-cache))) - (if (consp elem) - (or (< pos (cdr elem)) - (when (< pos c-state-cache-good-pos) - (setq c-state-cache-good-pos (cdr elem)) - nil)) - (or (<= pos elem) - (when (< pos c-state-cache-good-pos) - (setq c-state-cache-good-pos (1+ elem)) - nil))))) - (setq c-state-cache (cdr c-state-cache)))) - -(defun c-get-fallback-start-pos (here) - ;; Return the start position for building `c-state-cache' from - ;; scratch. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Stuff to do with point-min, and coping with any literal there. +(defvar c-state-point-min 1) +(make-variable-buffer-local 'c-state-point-min) +;; This is (point-min) when `c-state-cache' was last calculated. A change of +;; narrowing is likely to affect the parens that are visible before the point. + +(defvar c-state-point-min-lit-type nil) +(make-variable-buffer-local 'c-state-point-min-lit-type) +(defvar c-state-point-min-lit-start nil) +(make-variable-buffer-local 'c-state-point-min-lit-start) +;; These two variables define the literal, if any, containing point-min. +;; Their values are, respectively, 'string, c, or c++, and the start of the +;; literal. If there's no literal there, they're both nil. + +(defvar c-state-min-scan-pos 1) +(make-variable-buffer-local 'c-state-min-scan-pos) +;; This is the earliest buffer-pos from which scanning can be done. It is +;; either the end of the literal containing point-min, or point-min itself. +;; It becomes nil if the buffer is changed earlier than this point. +(defun c-state-get-min-scan-pos () + ;; Return the lowest valid scanning pos. This will be the end of the + ;; literal enclosing point-min, or point-min itself. + (or c-state-min-scan-pos + (save-restriction + (save-excursion + (widen) + (goto-char c-state-point-min-lit-start) + (if (eq c-state-point-min-lit-type 'string) + (forward-sexp) + (forward-comment 1)) + (setq c-state-min-scan-pos (point)))))) + +(defun c-state-mark-point-min-literal () + ;; Determine the properties of any literal containing POINT-MIN, setting the + ;; variables `c-state-point-min-lit-type', `c-state-point-min-lit-start', + ;; and `c-state-min-scan-pos' accordingly. The return value is meaningless. + (let ((p-min (point-min)) + lit) + (save-restriction + (widen) + (setq lit (c-state-literal-at p-min)) + (if lit + (setq c-state-point-min-lit-type + (save-excursion + (goto-char (car lit)) + (cond + ((looking-at c-block-comment-start-regexp) 'c) + ((looking-at c-line-comment-starter) 'c++) + (t 'string))) + c-state-point-min-lit-start (car lit) + c-state-min-scan-pos (cdr lit)) + (setq c-state-point-min-lit-type nil + c-state-point-min-lit-start nil + c-state-min-scan-pos p-min))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; A variable which signals a brace dessert - helpful for reducing the number +;; of fruitless backward scans. +(defvar c-state-brace-pair-desert nil) +(make-variable-buffer-local 'c-state-brace-pair-desert) +;; Used only in `c-append-lower-brace-pair-to-state-cache'. It is set when an +;; that defun has searched backwards for a brace pair and not found one. Its +;; value is either nil or a cons (PA . FROM), where PA is the position of the +;; enclosing opening paren/brace/bracket which bounds the backwards search (or +;; nil when at top level) and FROM is where the backward search started. It +;; is reset to nil in `c-invalidate-state-cache'. + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Lowish level functions/macros which work directly on `c-state-cache', or a +;; list of like structure. +(defmacro c-state-cache-top-lparen (&optional cache) + ;; Return the address of the top left brace/bracket/paren recorded in CACHE + ;; (default `c-state-cache') (or nil). + (let ((cash (or cache 'c-state-cache))) + `(if (consp (car ,cash)) + (caar ,cash) + (car ,cash)))) + +(defmacro c-state-cache-top-paren (&optional cache) + ;; Return the address of the latest brace/bracket/paren (whether left or + ;; right) recorded in CACHE (default `c-state-cache') or nil. + (let ((cash (or cache 'c-state-cache))) + `(if (consp (car ,cash)) + (cdar ,cash) + (car ,cash)))) + +(defmacro c-state-cache-after-top-paren (&optional cache) + ;; Return the position just after the latest brace/bracket/paren (whether + ;; left or right) recorded in CACHE (default `c-state-cache') or nil. + (let ((cash (or cache 'c-state-cache))) + `(if (consp (car ,cash)) + (cdar ,cash) + (and (car ,cash) + (1+ (car ,cash)))))) + +(defun c-get-cache-scan-pos (here) + ;; From the state-cache, determine the buffer position from which we might + ;; scan forward to HERE to update this cache. This position will be just + ;; after a paren/brace/bracket recorded in the cache, if possible, otherwise + ;; return the earliest position in the accessible region which isn't within + ;; a literal. If the visible portion of the buffer is entirely within a + ;; literal, return NIL. + (let ((c c-state-cache) elt) + ;(while (>= (or (c-state-cache-top-lparen c) 1) here) + (while (and c + (>= (c-state-cache-top-lparen c) here)) + (setq c (cdr c))) + + (setq elt (car c)) + (cond + ((consp elt) + (if (> (cdr elt) here) + (1+ (car elt)) + (cdr elt))) + (elt (1+ elt)) + ((<= (c-state-get-min-scan-pos) here) + (c-state-get-min-scan-pos)) + (t nil)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Variables which keep track of preprocessor constructs. +(defvar c-state-old-cpp-beg nil) +(make-variable-buffer-local 'c-state-old-cpp-beg) +(defvar c-state-old-cpp-end nil) +(make-variable-buffer-local 'c-state-old-cpp-end) +;; These are the limits of the macro containing point at the previous call of +;; `c-parse-state', or nil. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Defuns which analyse the buffer, yet don't change `c-state-cache'. +(defun c-get-fallback-scan-pos (here) + ;; Return a start position for building `c-state-cache' from + ;; scratch. This will be at the top level, 2 defuns back. (save-excursion ;; Go back 2 bods, but ignore any bogus positions returned by ;; beginning-of-defun (i.e. open paren in column zero). (goto-char here) (let ((cnt 2)) (while (not (or (bobp) (zerop cnt))) - (c-beginning-of-defun-1) + (c-beginning-of-defun-1) ; Pure elisp BOD. (if (eq (char-after) ?\{) (setq cnt (1- cnt))))) (point))) -(defun c-parse-state () - ;; Find and record all noteworthy parens between some good point - ;; earlier in the file and point. That good point is at least the - ;; beginning of the top-level construct we are in, or the beginning - ;; of the preceding top-level construct if we aren't in one. - ;; - ;; The returned value is a list of the noteworthy parens with the - ;; last one first. If an element in the list is an integer, it's - ;; the position of an open paren which has not been closed before - ;; the point. If an element is a cons, it gives the position of a - ;; closed brace paren pair; the car is the start paren position and - ;; the cdr is the position following the closing paren. Only the - ;; last closed brace paren pair before each open paren and before - ;; the point is recorded, and thus the state never contains two cons - ;; elements in succession. +(defun c-state-balance-parens-backwards (here- here+ top) + ;; Return the position of the opening paren/brace/bracket before HERE- which + ;; matches the outermost close p/b/b between HERE+ and TOP. Except when + ;; there's a macro, HERE- and HERE+ are the same. Like this: + ;; + ;; ............................................ + ;; | | + ;; ( [ ( .........#macro.. ) ( ) ] ) + ;; ^ ^ ^ ^ + ;; | | | | + ;; return HERE- HERE+ TOP + ;; + ;; If there aren't enough opening paren/brace/brackets, return the position + ;; of the outermost one found, or HERE- if there are none. If there are no + ;; closeing p/b/bs between HERE+ and TOP, return HERE-. HERE-/+ and TOP + ;; must not be inside literals. Only the accessible portion of the buffer + ;; will be scanned. + + ;; PART 1: scan from `here+' up to `top', accumulating ")"s which enclose + ;; `here'. Go round the next loop each time we pass over such a ")". These + ;; probably match "("s before `here-'. + (let (pos pa ren+1 lonely-rens) + (save-excursion + (save-restriction + (narrow-to-region (point-min) top) ; This can move point, sometimes. + (setq pos here+) + (c-safe + (while + (setq ren+1 (scan-lists pos 1 1)) ; might signal + (setq lonely-rens (cons ren+1 lonely-rens) + pos ren+1))))) + + ;; PART 2: Scan back before `here-' searching for the "("s + ;; matching/mismatching the ")"s found above. We only need to direct the + ;; caller to scan when we've encountered unmatched right parens. + (setq pos here-) + (when lonely-rens + (c-safe + (while + (and lonely-rens ; actual values aren't used. + (setq pa (scan-lists pos -1 1))) + (setq pos pa) + (setq lonely-rens (cdr lonely-rens))))) + pos)) + +(defun c-parse-state-get-strategy (here good-pos) + ;; Determine the scanning strategy for adjusting `c-parse-state', attempting + ;; to minimise the amount of scanning. HERE is the pertinent position in + ;; the buffer, GOOD-POS is a position where `c-state-cache' (possibly with + ;; its head trimmed) is known to be good, or nil if there is no such + ;; position. + ;; + ;; The return value is a list, one of the following: + ;; + ;; o - ('forward CACHE-POS START-POINT) - scan forward from START-POINT, + ;; which is not less than CACHE-POS. + ;; o - ('backward CACHE-POS nil) - scan backwards (from HERE). + ;; o - ('BOD nil START-POINT) - scan forwards from START-POINT, which is at the + ;; top level. + ;; o - ('IN-LIT nil nil) - point is inside the literal containing point-min. + ;; , where CACHE-POS is the highest position recorded in `c-state-cache' at + ;; or below HERE. + (let ((cache-pos (c-get-cache-scan-pos here)) ; highest position below HERE in cache (or 1) + BOD-pos ; position of 2nd BOD before HERE. + strategy ; 'forward, 'backward, 'BOD, or 'IN-LIT. + start-point + how-far) ; putative scanning distance. + (setq good-pos (or good-pos (c-state-get-min-scan-pos))) + (cond + ((< here (c-state-get-min-scan-pos)) + (setq strategy 'IN-LIT + start-point nil + cache-pos nil + how-far 0)) + ((<= good-pos here) + (setq strategy 'forward + start-point (max good-pos cache-pos) + how-far (- here start-point))) + ((< (- good-pos here) (- here cache-pos)) ; FIXME!!! ; apply some sort of weighting. + (setq strategy 'backward + how-far (- good-pos here))) + (t + (setq strategy 'forward + how-far (- here cache-pos) + start-point cache-pos))) + + ;; Might we be better off starting from the top level, two defuns back, + ;; instead? + (when (> how-far c-state-cache-too-far) + (setq BOD-pos (c-get-fallback-scan-pos here)) ; somewhat EXPENSIVE!!! + (if (< (- here BOD-pos) how-far) + (setq strategy 'BOD + start-point BOD-pos))) + + (list + strategy + (and (memq strategy '(forward backward)) cache-pos) + (and (memq strategy '(forward BOD)) start-point)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Routines which change `c-state-cache' and associated values. +(defun c-renarrow-state-cache () + ;; The region (more precisely, point-min) has changed since we + ;; calculated `c-state-cache'. Amend `c-state-cache' accordingly. + (if (< (point-min) c-state-point-min) + ;; If point-min has MOVED BACKWARDS then we drop the state completely. + ;; It would be possible to do a better job here and recalculate the top + ;; only. + (progn + (c-state-mark-point-min-literal) + (setq c-state-cache nil + c-state-cache-good-pos c-state-min-scan-pos + c-state-brace-pair-desert nil)) + + ;; point-min has MOVED FORWARD. + + ;; Is the new point-min inside a (different) literal? + (unless (and c-state-point-min-lit-start ; at prev. point-min + (< (point-min) (c-state-get-min-scan-pos))) + (c-state-mark-point-min-literal)) + + ;; Cut off a bit of the tail from `c-state-cache'. + (let ((ptr (cons nil c-state-cache)) + pa) + (while (and (setq pa (c-state-cache-top-lparen (cdr ptr))) + (>= pa (point-min))) + (setq ptr (cdr ptr))) + + (when (consp ptr) + (if (eq (cdr ptr) c-state-cache) + (setq c-state-cache nil + c-state-cache-good-pos c-state-min-scan-pos) + (setcdr ptr nil) + (setq c-state-cache-good-pos (1+ (c-state-cache-top-lparen)))) + ))) + + (setq c-state-point-min (point-min))) + +(defun c-append-lower-brace-pair-to-state-cache (from &optional upper-lim) + ;; If there is a brace pair preceding FROM in the buffer (not necessarily + ;; immediately preceding), push a cons onto `c-state-cache' to represent it. + ;; FROM must not be inside a literal. If UPPER-LIM is non-nil, we append + ;; the highest brace pair whose "}" is below UPPER-LIM. + ;; + ;; Return non-nil when this has been done. + ;; + ;; This routine should be fast. Since it can get called a LOT, we maintain + ;; `c-state-brace-pair-desert', a small cache of "failures", such that we + ;; reduce the time wasted in repeated fruitless searches in brace deserts. + (save-excursion + (save-restriction + (let ((bra from) ce ; Positions of "{" and "}". + new-cons + (cache-pos (c-state-cache-top-lparen)) ; might be nil. + (macro-start-or-from + (progn (goto-char from) + (c-beginning-of-macro) + (point)))) + (or upper-lim (setq upper-lim from)) + + ;; If we're essentially repeating a fruitless search, just give up. + (unless (and c-state-brace-pair-desert + (eq cache-pos (car c-state-brace-pair-desert)) + (<= from (cdr c-state-brace-pair-desert))) + ;; Only search what we absolutely need to: + (if (and c-state-brace-pair-desert + (> from (cdr c-state-brace-pair-desert))) + (narrow-to-region (cdr c-state-brace-pair-desert) (point-max))) + + ;; In the next pair of nested loops, the inner one moves back past a + ;; pair of (mis-)matching parens or brackets; the outer one moves + ;; back over a sequence of unmatched close brace/paren/bracket each + ;; time round. + (while + (progn + (c-safe + (while + (and (setq ce (scan-lists bra -1 -1)) ; back past )/]/}; might signal + (setq bra (scan-lists ce -1 1)) ; back past (/[/{; might signal + (or (> ce upper-lim) + (not (eq (char-after bra) ?\{)) + (and (goto-char bra) + (c-beginning-of-macro) + (< (point) macro-start-or-from)))))) + (and ce (< ce bra))) + (setq bra ce)) ; If we just backed over an unbalanced closing + ; brace, ignore it. + + (if (and ce (< bra ce) (eq (char-after bra) ?\{)) + ;; We've found the desired brace-pair. + (progn + (setq new-cons (cons bra (1+ ce))) + (cond + ((consp (car c-state-cache)) + (setcar c-state-cache new-cons)) + ((and (numberp (car c-state-cache)) ; probably never happens + (< ce (car c-state-cache))) + (setcdr c-state-cache + (cons new-cons (cdr c-state-cache)))) + (t (setq c-state-cache (cons new-cons c-state-cache))))) + + ;; We haven't found a brace pair. Record this. + (setq c-state-brace-pair-desert (cons cache-pos from)))))))) + +(defsubst c-state-push-any-brace-pair (bra+1 macro-start-or-here) + ;; If BRA+1 is nil, do nothing. Otherwise, BRA+1 is the buffer position + ;; following a {, and that brace has a (mis-)matching } (or ]), and we + ;; "push" "a" brace pair onto `c-state-cache'. + ;; + ;; Here "push" means overwrite the top element if it's itself a brace-pair, + ;; otherwise push it normally. + ;; + ;; The brace pair we push is normally the one surrounding BRA+1, but if the + ;; latter is inside a macro, not being a macro containing + ;; MACRO-START-OR-HERE, we scan backwards through the buffer for a non-macro + ;; base pair. This latter case is assumed to be rare. + ;; + ;; Note: POINT is not preserved in this routine. + (if bra+1 + (if (or (> bra+1 macro-start-or-here) + (progn (goto-char bra+1) + (not (c-beginning-of-macro)))) + (setq c-state-cache + (cons (cons (1- bra+1) + (scan-lists bra+1 1 1)) + (if (consp (car c-state-cache)) + (cdr c-state-cache) + c-state-cache))) + ;; N.B. This defsubst codes one method for the simple, normal case, + ;; and a more sophisticated, slower way for the general case. Don't + ;; eliminate this defsubst - it's a speed optimisation. + (c-append-lower-brace-pair-to-state-cache (1- bra+1))))) + +(defun c-append-to-state-cache (from) + ;; Scan the buffer from FROM to (point-max), adding elements into + ;; `c-state-cache' for braces etc. Return a candidate for + ;; `c-state-cache-good-pos'. + ;; + ;; FROM must be after the latest brace/paren/bracket in `c-state-cache', if + ;; any. Typically, it is immediately after it. It must not be inside a + ;; literal. + (let ((here-bol (c-point 'bol (point-max))) + (macro-start-or-here + (save-excursion (goto-char (point-max)) + (if (c-beginning-of-macro) + (point) + (point-max)))) + pa+1 ; pos just after an opening PAren (or brace). + (ren+1 from) ; usually a pos just after an closing paREN etc. + ; Is actually the pos. to scan for a (/{/[ from, + ; which sometimes is after a silly )/}/]. + paren+1 ; Pos after some opening or closing paren. + paren+1s ; A list of `paren+1's; used to determine a + ; good-pos. + bra+1 ce+1 ; just after L/R bra-ces. + bra+1s ; list of OLD values of bra+1. + mstart) ; start of a macro. + + (save-excursion + ;; Each time round the following loop, we enter a succesively deeper + ;; level of brace/paren nesting. (Except sometimes we "continue at + ;; the existing level".) `pa+1' is a pos inside an opening + ;; brace/paren/bracket, usually just after it. + (while + (progn + ;; Each time round the next loop moves forward over an opening then + ;; a closing brace/bracket/paren. This loop is white hot, so it + ;; plays ugly tricks to go fast. DON'T PUT ANYTHING INTO THIS + ;; LOOP WHICH ISN'T ABSOLUTELY NECESSARY!!! It terminates when a + ;; call of `scan-lists' signals an error, which happens when there + ;; are no more b/b/p's to scan. + (c-safe + (while t + (setq pa+1 (scan-lists ren+1 1 -1) ; Into (/{/[; might signal + paren+1s (cons pa+1 paren+1s)) + (setq ren+1 (scan-lists pa+1 1 1)) ; Out of )/}/]; might signal + (if (and (eq (char-before pa+1) ?{)) ; Check for a macro later. + (setq bra+1 pa+1)) + (setcar paren+1s ren+1))) + + (if (and pa+1 (> pa+1 ren+1)) + ;; We've just entered a deeper nesting level. + (progn + ;; Insert the brace pair (if present) and the single open + ;; paren/brace/bracket into `c-state-cache' It cannot be + ;; inside a macro, except one around point, because of what + ;; `c-neutralize-syntax-in-CPP' has done. + (c-state-push-any-brace-pair bra+1 macro-start-or-here) + ;; Insert the opening brace/bracket/paren position. + (setq c-state-cache (cons (1- pa+1) c-state-cache)) + ;; Clear admin stuff for the next more nested part of the scan. + (setq ren+1 pa+1 pa+1 nil bra+1 nil bra+1s nil) + t) ; Carry on the loop + + ;; All open p/b/b's at this nesting level, if any, have probably + ;; been closed by matching/mismatching ones. We're probably + ;; finished - we just need to check for having found an + ;; unmatched )/}/], which we ignore. Such a )/}/] can't be in a + ;; macro, due the action of `c-neutralize-syntax-in-CPP'. + (c-safe (setq ren+1 (scan-lists ren+1 1 1)))))) ; acts as loop control. + + ;; Record the final, innermost, brace-pair if there is one. + (c-state-push-any-brace-pair bra+1 macro-start-or-here) + + ;; Determine a good pos + (while (and (setq paren+1 (car paren+1s)) + (> (if (> paren+1 macro-start-or-here) + paren+1 + (goto-char paren+1) + (setq mstart (and (c-beginning-of-macro) + (point))) + (or mstart paren+1)) + here-bol)) + (setq paren+1s (cdr paren+1s))) + (cond + ((and paren+1 mstart) + (min paren+1 mstart)) + (paren+1) + (t from))))) + +(defun c-remove-stale-state-cache (good-pos pps-point) + ;; Remove stale entries from the `c-cache-state', i.e. those which will + ;; not be in it when it is amended for position (point-max). + ;; Additionally, the "outermost" open-brace entry before (point-max) + ;; will be converted to a cons if the matching close-brace is scanned. + ;; + ;; GOOD-POS is a "maximal" "safe position" - there must be no open + ;; parens/braces/brackets between GOOD-POS and (point-max). + ;; + ;; As a second thing, calculate the result of parse-partial-sexp at + ;; PPS-POINT, w.r.t. GOOD-POS. The motivation here is that + ;; `c-state-cache-good-pos' may become PPS-POINT, but the caller may need to + ;; adjust it to get outside a string/comment. (Sorry about this! The code + ;; needs to be FAST). + ;; + ;; Return a list (GOOD-POS SCAN-BACK-POS PPS-STATE), where + ;; o - GOOD-POS is a position where the new value `c-state-cache' is known + ;; to be good (we aim for this to be as high as possible); + ;; o - SCAN-BACK-POS, if not nil, indicates there may be a brace pair + ;; preceding POS which needs to be recorded in `c-state-cache'. It is a + ;; position to scan backwards from. + ;; o - PPS-STATE is the parse-partial-sexp state at PPS-POINT. + (save-restriction + (narrow-to-region 1 (point-max)) + (save-excursion + (let* ((in-macro-start ; start of macro containing (point-max) or nil. + (save-excursion + (goto-char (point-max)) + (and (c-beginning-of-macro) + (point)))) + (good-pos-actual-macro-start ; Start of macro containing good-pos + ; or nil + (and (< good-pos (point-max)) + (save-excursion + (goto-char good-pos) + (and (c-beginning-of-macro) + (point))))) + (good-pos-actual-macro-end ; End of this macro, (maybe + ; (point-max)), or nil. + (and good-pos-actual-macro-start + (save-excursion + (goto-char good-pos-actual-macro-start) + (c-end-of-macro) + (point)))) + pps-state ; Will be 9 or 10 elements long. + pos + upper-lim ; ,beyond which `c-state-cache' entries are removed + scan-back-pos + pair-beg pps-point-state target-depth) + + ;; Remove entries beyond (point-max). Also remove any entries inside + ;; a macro, unless (point-max) is in the same macro. + (setq upper-lim + (if (or (null c-state-old-cpp-beg) + (and (> (point-max) c-state-old-cpp-beg) + (< (point-max) c-state-old-cpp-end))) + (point-max) + (min (point-max) c-state-old-cpp-beg))) + (while (and c-state-cache (>= (c-state-cache-top-lparen) upper-lim)) + (setq c-state-cache (cdr c-state-cache))) + ;; If `upper-lim' is inside the last recorded brace pair, remove its + ;; RBrace and indicate we'll need to search backwards for a previous + ;; brace pair. + (when (and c-state-cache + (consp (car c-state-cache)) + (> (cdar c-state-cache) upper-lim)) + (setcar c-state-cache (caar c-state-cache)) + (setq scan-back-pos (car c-state-cache))) + + ;; The next loop jumps forward out of a nested level of parens each + ;; time round; the corresponding elements in `c-state-cache' are + ;; removed. `pos' is just after the brace-pair or the open paren at + ;; (car c-state-cache). There can be no open parens/braces/brackets + ;; between `good-pos'/`good-pos-actual-macro-start' and (point-max), + ;; due to the interface spec to this function. + (setq pos (if (and good-pos-actual-macro-end + (not (eq good-pos-actual-macro-start + in-macro-start))) + (1+ good-pos-actual-macro-end) ; get outside the macro as + ; marked by a `category' text property. + good-pos)) + (goto-char pos) + (while (and c-state-cache + (< (point) (point-max))) + (cond + ((null pps-state) ; first time through + (setq target-depth -1)) + ((eq (car pps-state) target-depth) ; found closing ),},] + (setq target-depth (1- (car pps-state)))) + ;; Do nothing when we've merely reached pps-point. + ) + + ;; Scan! + (setq pps-state + (parse-partial-sexp + (point) (if (< (point) pps-point) pps-point (point-max)) + target-depth + nil pps-state)) + + (if (= (point) pps-point) + (setq pps-point-state pps-state)) + + (when (eq (car pps-state) target-depth) + (setq pos (point)) ; POS is now just after an R-paren/brace. + (cond + ((and (consp (car c-state-cache)) + (eq (point) (cdar c-state-cache))) + ;; We've just moved out of the paren pair containing the brace-pair + ;; at (car c-state-cache). `pair-beg' is where the open paren is, + ;; and is potentially where the open brace of a cons in + ;; c-state-cache will be. + (setq pair-beg (car-safe (cdr c-state-cache)) + c-state-cache (cdr-safe (cdr c-state-cache)))) ; remove {}pair + containing Lparen. + ((numberp (car c-state-cache)) + (setq pair-beg (car c-state-cache) + c-state-cache (cdr c-state-cache))) ; remove this + ; containing Lparen + ((numberp (cadr c-state-cache)) + (setq pair-beg (cadr c-state-cache) + c-state-cache (cddr c-state-cache))) ; Remove a paren pair + ; together with enclosed brace pair. + ;; (t nil) ; Ignore an unmated Rparen. + ))) + + (if (< (point) pps-point) + (setq pps-state (parse-partial-sexp (point) pps-point + nil nil ; TARGETDEPTH, STOPBEFORE + pps-state))) + + ;; If the last paren pair we moved out of was actually a brace pair, + ;; insert it into `c-state-cache'. + (when (and pair-beg (eq (char-after pair-beg) ?{)) + (if (consp (car-safe c-state-cache)) + (setq c-state-cache (cdr c-state-cache))) + (setq c-state-cache (cons (cons pair-beg pos) + c-state-cache))) + + (list pos scan-back-pos pps-state))))) + +(defun c-remove-stale-state-cache-backwards (here cache-pos) + ;; Strip stale elements of `c-state-cache' by moving backwards through the + ;; buffer, and inform the caller of the scenario detected. + ;; + ;; HERE is the position we're setting `c-state-cache' for. + ;; CACHE-POS is just after the latest recorded position in `c-state-cache' + ;; before HERE, or a position at or near point-min which isn't in a + ;; literal. + ;; + ;; This function must only be called only when (> `c-state-cache-good-pos' + ;; HERE). Usually the gap between CACHE-POS and HERE is large. It is thus + ;; optimised to eliminate (or minimise) scanning between these two + ;; positions. + ;; + ;; Return a three element list (GOOD-POS SCAN-BACK-POS FWD-FLAG), where: + ;; o - GOOD-POS is a "good position", where `c-state-cache' is valid, or + ;; could become so after missing elements are inserted into + ;; `c-state-cache'. This is JUST AFTER an opening or closing + ;; brace/paren/bracket which is already in `c-state-cache' or just before + ;; one otherwise. exceptionally (when there's no such b/p/b handy) the BOL + ;; before `here''s line, or the start of the literal containing it. + ;; o - SCAN-BACK-POS, if non-nil, indicates there may be a brace pair + ;; preceding POS which isn't recorded in `c-state-cache'. It is a position + ;; to scan backwards from. + ;; o - FWD-FLAG, if non-nil, indicates there may be parens/braces between + ;; POS and HERE which aren't recorded in `c-state-cache'. + ;; + ;; The comments in this defun use "paren" to mean parenthesis or square + ;; bracket (as contrasted with a brace), and "(" and ")" likewise. + ;; + ;; . {..} (..) (..) ( .. { } ) (...) ( .... . ..) + ;; | | | | | | + ;; CP E here D C good + (let ((pos c-state-cache-good-pos) + pa ren ; positions of "(" and ")" + dropped-cons ; whether the last element dropped from `c-state-cache' + ; was a cons (representing a brace-pair) + good-pos ; see above. + lit ; (START . END) of a literal containing some point. + here-lit-start here-lit-end ; bounds of literal containing `here' + ; or `here' itself. + here- here+ ; start/end of macro around HERE, or HERE + (here-bol (c-point 'bol here)) + (too-far-back (max (- here c-state-cache-too-far) 1))) + + ;; Remove completely irrelevant entries from `c-state-cache'. + (while (and c-state-cache + (>= (setq pa (c-state-cache-top-lparen)) here)) + (setq dropped-cons (consp (car c-state-cache))) + (setq c-state-cache (cdr c-state-cache)) + (setq pos pa)) + ;; At this stage, (> pos here); + ;; (< (c-state-cache-top-lparen) here) (or is nil). + + (cond + ((and (consp (car c-state-cache)) + (> (cdar c-state-cache) here)) + ;; CASE 1: The top of the cache is a brace pair which now encloses + ;; `here'. As good-pos, return the address. of the "{". Since we've no + ;; knowledge of what's inside these braces, we have no alternative but + ;; to direct the caller to scan the buffer from the opening brace. + (setq pos (caar c-state-cache)) + (setcar c-state-cache pos) + (list (1+ pos) pos t)) ; return value. We've just converted a brace pair + ; entry into a { entry, so the caller needs to + ; search for a brace pair before the {. + + ;; `here' might be inside a literal. Check for this. + ((progn + (setq lit (c-state-literal-at here) + here-lit-start (or (car lit) here) + here-lit-end (or (cdr lit) here)) + ;; Has `here' just "newly entered" a macro? + (save-excursion + (goto-char here-lit-start) + (if (and (c-beginning-of-macro) + (or (null c-state-old-cpp-beg) + (not (= (point) c-state-old-cpp-beg)))) + (progn + (setq here- (point)) + (c-end-of-macro) + (setq here+ (point))) + (setq here- here-lit-start + here+ here-lit-end))) + + ;; `here' might be nested inside any depth of parens (or brackets but + ;; not braces). Scan backwards to find the outermost such opening + ;; paren, if there is one. This will be the scan position to return. + (save-restriction + (narrow-to-region cache-pos (point-max)) + (setq pos (c-state-balance-parens-backwards here- here+ pos))) + nil)) ; for the cond + + ((< pos here-lit-start) + ;; CASE 2: Address of outermost ( or [ which now encloses `here', but + ;; didn't enclose the (previous) `c-state-cache-good-pos'. If there is + ;; a brace pair preceding this, it will already be in `c-state-cache', + ;; unless there was a brace pair after it, i.e. there'll only be one to + ;; scan for if we've just deleted one. + (list pos (and dropped-cons pos) t)) ; Return value. + + ;; `here' isn't enclosed in a (previously unrecorded) bracket/paren. + ;; Further forward scanning isn't needed, but we still need to find a + ;; GOOD-POS. Step out of all enclosing "("s on HERE's line. + ((progn + (save-restriction + (narrow-to-region here-bol (point-max)) + (setq pos here-lit-start) + (c-safe (while (setq pa (scan-lists pos -1 1)) + (setq pos pa)))) ; might signal + nil)) ; for the cond + + ((setq ren (c-safe-scan-lists pos -1 -1 too-far-back)) + ;; CASE 3: After a }/)/] before `here''s BOL. + (list (1+ ren) (and dropped-cons pos) nil)) ; Return value + + (t + ;; CASE 4; Best of a bad job: BOL before `here-bol', or beginning of + ;; literal containing it. + (setq good-pos (c-state-lit-beg (c-point 'bopl here-bol))) + (list good-pos (and dropped-cons good-pos) nil))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Externally visible routines. + +(defun c-state-cache-init () + (setq c-state-cache nil + c-state-cache-good-pos 1 + c-state-nonlit-pos-cache nil + c-state-nonlit-pos-cache-limit 1 + c-state-brace-pair-desert nil + c-state-point-min 1 + c-state-point-min-lit-type nil + c-state-point-min-lit-start nil + c-state-min-scan-pos 1 + c-state-old-cpp-beg nil + c-state-old-cpp-end nil) + (c-state-mark-point-min-literal)) + +(defun c-invalidate-state-cache-1 (here) + ;; Invalidate all info on `c-state-cache' that applies to the buffer at HERE + ;; or higher and set `c-state-cache-good-pos' accordingly. The cache is + ;; left in a consistent state. + ;; + ;; This is much like `c-whack-state-after', but it never changes a paren + ;; pair element into an open paren element. Doing that would mean that the + ;; new open paren wouldn't have the required preceding paren pair element. + ;; + ;; This function is called from c-after-change. + + ;; The cache of non-literals: + (if (< here c-state-nonlit-pos-cache-limit) + (setq c-state-nonlit-pos-cache-limit here)) + + ;; `c-state-cache': + ;; Case 1: if `here' is in a literal containing point-min, everything + ;; becomes (or is already) nil. + (if (or (null c-state-cache-good-pos) + (< here (c-state-get-min-scan-pos))) + (setq c-state-cache nil + c-state-cache-good-pos nil + c-state-min-scan-pos nil) + +;;; Truncate `c-state-cache' and set `c-state-cache-good-pos' to a value below +;;; `here'. To maintain its consistency, we may need to insert a new brace +;;; pair. + (let ((here-bol (c-point 'bol here)) + too-high-pa ; recorded {/(/[ next above here, or nil. + dropped-cons ; was the last removed element a brace pair? + pa) + ;; The easy bit - knock over-the-top bits off `c-state-cache'. + (while (and c-state-cache + (>= (setq pa (c-state-cache-top-paren)) here)) + (setq dropped-cons (consp (car c-state-cache)) + too-high-pa (c-state-cache-top-lparen) + c-state-cache (cdr c-state-cache))) + + ;; Do we need to add in an earlier brace pair, having lopped one off? + (if (and dropped-cons + (< too-high-pa (+ here c-state-cache-too-far))) + (c-append-lower-brace-pair-to-state-cache too-high-pa here-bol)) + (setq c-state-cache-good-pos (or (c-state-cache-after-top-paren) + (c-state-get-min-scan-pos))))) + + ;; The brace-pair desert marker: + (when (car c-state-brace-pair-desert) + (if (< here (car c-state-brace-pair-desert)) + (setq c-state-brace-pair-desert nil) + (if (< here (cdr c-state-brace-pair-desert)) + (setcdr c-state-brace-pair-desert here))))) + +(defun c-parse-state-1 () + ;; Find and record all noteworthy parens between some good point earlier in + ;; the file and point. That good point is at least the beginning of the + ;; top-level construct we are in, or the beginning of the preceding + ;; top-level construct if we aren't in one. + ;; + ;; The returned value is a list of the noteworthy parens with the last one + ;; first. If an element in the list is an integer, it's the position of an + ;; open paren (of any type) which has not been closed before the point. If + ;; an element is a cons, it gives the position of a closed BRACE paren + ;; pair[*]; the car is the start brace position and the cdr is the position + ;; following the closing brace. Only the last closed brace paren pair + ;; before each open paren and before the point is recorded, and thus the + ;; state never contains two cons elements in succession. When a close brace + ;; has no matching open brace (e.g., the matching brace is outside the + ;; visible region), it is not represented in the returned value. + ;; + ;; [*] N.B. The close "brace" might be a mismatching close bracket or paren. + ;; This defun explicitly treats mismatching parens/braces/brackets as + ;; matching. It is the open brace which makes it a "brace" pair. + ;; + ;; If POINT is within a macro, open parens and brace pairs within + ;; THIS macro MIGHT be recorded. This depends on whether their + ;; syntactic properties have been suppressed by + ;; `c-neutralize-syntax-in-CPP'. This might need fixing (2008-12-11). ;; ;; Currently no characters which are given paren syntax with the ;; syntax-table property are recorded, i.e. angle bracket arglist ;; parens are never present here. Note that this might change. ;; ;; BUG: This function doesn't cope entirely well with unbalanced - ;; parens in macros. E.g. in the following case the brace before - ;; the macro isn't balanced with the one after it: + ;; parens in macros. (2008-12-11: this has probably been resolved + ;; by the function `c-neutralize-syntax-in-CPP'.) E.g. in the + ;; following case the brace before the macro isn't balanced with the + ;; one after it: ;; ;; { ;; #define X { ;; } ;; + ;; Note to maintainers: this function DOES get called with point + ;; within comments and strings, so don't assume it doesn't! + ;; ;; This function might do hidden buffer changes. + (let* ((here (point)) + (here-bopl (c-point 'bopl)) + strategy ; 'forward, 'backward etc.. + ;; Candidate positions to start scanning from: + cache-pos ; highest position below HERE already existing in + ; cache (or 1). + good-pos + start-point + bopl-state + res + scan-backward-pos scan-forward-p) ; used for 'backward. + ;; If POINT-MIN has changed, adjust the cache + (unless (= (point-min) c-state-point-min) + (c-renarrow-state-cache)) + + ;; Strategy? + (setq res (c-parse-state-get-strategy here c-state-cache-good-pos) + strategy (car res) + cache-pos (cadr res) + start-point (nth 2 res)) + + (when (eq strategy 'BOD) + (setq c-state-cache nil + c-state-cache-good-pos start-point)) + + ;; SCAN! + (save-restriction + (cond + ((memq strategy '(forward BOD)) + (narrow-to-region (point-min) here) + (setq res (c-remove-stale-state-cache start-point here-bopl)) + (setq cache-pos (car res) + scan-backward-pos (cadr res) + bopl-state (car (cddr res))) ; will be nil if (< here-bopl + ; start-point) + (if scan-backward-pos + (c-append-lower-brace-pair-to-state-cache scan-backward-pos)) + (setq good-pos + (c-append-to-state-cache cache-pos)) + (setq c-state-cache-good-pos + (if (and bopl-state + (< good-pos (- here c-state-cache-too-far))) + (c-state-cache-non-literal-place here-bopl bopl-state) + good-pos))) + + ((eq strategy 'backward) + (setq res (c-remove-stale-state-cache-backwards here cache-pos) + good-pos (car res) + scan-backward-pos (cadr res) + scan-forward-p (car (cddr res))) + (if scan-backward-pos + (c-append-lower-brace-pair-to-state-cache + scan-backward-pos)) + (setq c-state-cache-good-pos + (if scan-forward-p + (progn (narrow-to-region (point-min) here) + (c-append-to-state-cache good-pos)) + + (c-get-cache-scan-pos good-pos)))) + + (t ; (eq strategy 'IN-LIT) + (setq c-state-cache nil + c-state-cache-good-pos nil))))) + + c-state-cache) + +(defun c-invalidate-state-cache (here) + ;; This is a wrapper over `c-invalidate-state-cache-1'. + ;; + ;; It suppresses the syntactic effect of the < and > (template) brackets and + ;; of all parens in preprocessor constructs, except for any such construct + ;; containing point. We can then call `c-invalidate-state-cache-1' without + ;; worrying further about macros and template delimiters. + (c-with-<->-as-parens-suppressed + (if (and c-state-old-cpp-beg + (< c-state-old-cpp-beg here)) + (c-with-all-but-one-cpps-commented-out + c-state-old-cpp-beg + (min c-state-old-cpp-end here) + (c-invalidate-state-cache-1 here)) + (c-with-cpps-commented-out + (c-invalidate-state-cache-1 here))))) - (save-restriction - (let* ((here (point)) - (here-bol (c-point 'bol)) - (c-macro-start (c-query-macro-start)) - (in-macro-start (or c-macro-start (point))) - old-state last-pos brace-pair-open brace-pair-close - pos save-pos) - (c-invalidate-state-cache here) - - ;; If the minimum position has changed due to narrowing then we - ;; have to fix the tail of `c-state-cache' accordingly. - (unless (= c-state-cache-start (point-min)) - (if (> (point-min) c-state-cache-start) - ;; If point-min has moved forward then we just need to cut - ;; off a bit of the tail. - (let ((ptr (cons nil c-state-cache)) elem) - (while (and (setq elem (car-safe (cdr ptr))) - (>= (if (consp elem) (car elem) elem) - (point-min))) - (setq ptr (cdr ptr))) - (when (consp ptr) - (if (eq (cdr ptr) c-state-cache) - (setq c-state-cache nil - c-state-cache-good-pos 1) - (setcdr ptr nil)))) - ;; If point-min has moved backward then we drop the state - ;; completely. It's possible to do a better job here and - ;; recalculate the top only. - (setq c-state-cache nil - c-state-cache-good-pos 1)) - (setq c-state-cache-start (point-min))) - - ;; Get the latest position we know are directly inside the - ;; closest containing paren of the cached state. - (setq last-pos (and c-state-cache - (if (consp (car c-state-cache)) - (cdr (car c-state-cache)) - (1+ (car c-state-cache))))) - (if (or (not last-pos) - (< last-pos c-state-cache-good-pos)) - (setq last-pos c-state-cache-good-pos) - ;; Take the opportunity to move the cached good position - ;; further down. - (if (< last-pos here-bol) - (setq c-state-cache-good-pos last-pos))) +(defun c-parse-state () + ;; This is a wrapper over `c-parse-state-1'. See that function for a + ;; description of the functionality and return value. + ;; + ;; It suppresses the syntactic effect of the < and > (template) brackets and + ;; of all parens in preprocessor constructs, except for any such construct + ;; containing point. We can then call `c-parse-state-1' without worrying + ;; further about macros and template delimiters. + (let (here-cpp-beg here-cpp-end) + (save-excursion + (when (c-beginning-of-macro) + (setq here-cpp-beg (point)) + (unless + (> (setq here-cpp-end (c-syntactic-end-of-macro)) + here-cpp-beg) + (setq here-cpp-beg nil here-cpp-end nil)))) + ;; FIXME!!! Put in a `condition-case' here to protect the integrity of the + ;; subsystem. + (prog1 + (c-with-<->-as-parens-suppressed + (if (and here-cpp-beg (> here-cpp-end here-cpp-beg)) + (c-with-all-but-one-cpps-commented-out + here-cpp-beg here-cpp-end + (c-parse-state-1)) + (c-with-cpps-commented-out + (c-parse-state-1)))) + (setq c-state-old-cpp-beg (and here-cpp-beg (copy-marker here-cpp-beg t)) + c-state-old-cpp-end (and here-cpp-end (copy-marker here-cpp-end t))) + ))) - ;; Check if `last-pos' is in a macro. If it is, and we're not - ;; in the same macro, we must discard everything on - ;; `c-state-cache' that is inside the macro before using it. - (save-excursion - (goto-char last-pos) - (when (and (c-beginning-of-macro) - (/= (point) in-macro-start)) - (c-invalidate-state-cache (point)) - ;; Set `last-pos' again just like above except that there's - ;; no use looking at `c-state-cache-good-pos' here. - (setq last-pos (if c-state-cache - (if (consp (car c-state-cache)) - (cdr (car c-state-cache)) - (1+ (car c-state-cache))) - 1)))) - - ;; If we've moved very far from the last cached position then - ;; it's probably better to redo it from scratch, otherwise we - ;; might spend a lot of time searching from `last-pos' down to - ;; here. - (when (< last-pos (- here 20000)) - ;; First get the fallback start position. If it turns out - ;; that it's so far back that the cached state is closer then - ;; we'll keep it afterall. - (setq pos (c-get-fallback-start-pos here)) - (if (<= pos last-pos) - (setq pos nil) - (setq last-pos nil - c-state-cache nil - c-state-cache-good-pos 1))) - - ;; Find the start position for the forward search. (Can't - ;; search in the backward direction since the point might be in - ;; some kind of literal.) - - (unless pos - (setq old-state c-state-cache) - - ;; There's a cached state with a containing paren. Pop off - ;; the stale containing sexps from it by going forward out of - ;; parens as far as possible. - (narrow-to-region (point-min) here) - (let (placeholder pair-beg) - (while (and c-state-cache - (setq placeholder - (c-up-list-forward last-pos))) - (setq last-pos placeholder) - (if (consp (car c-state-cache)) - (setq pair-beg (car-safe (cdr c-state-cache)) - c-state-cache (cdr-safe (cdr c-state-cache))) - (setq pair-beg (car c-state-cache) - c-state-cache (cdr c-state-cache)))) - - (when (and pair-beg (eq (char-after pair-beg) ?{)) - ;; The last paren pair we moved out from was a brace - ;; pair. Modify the state to record this as a closed - ;; pair now. - (if (consp (car-safe c-state-cache)) - (setq c-state-cache (cdr c-state-cache))) - (setq c-state-cache (cons (cons pair-beg last-pos) - c-state-cache)))) - - ;; Check if the preceding balanced paren is within a - ;; macro; it should be ignored if we're outside the - ;; macro. There's no need to check any further upwards; - ;; if the macro contains an unbalanced opening paren then - ;; we're smoked anyway. - (when (and (<= (point) in-macro-start) - (consp (car c-state-cache))) - (save-excursion - (goto-char (car (car c-state-cache))) - (when (c-beginning-of-macro) - (setq here (point) - c-state-cache (cdr c-state-cache))))) - - (unless (eq c-state-cache old-state) - ;; Have to adjust the cached good position if state has been - ;; popped off. - (setq c-state-cache-good-pos - (if c-state-cache - (if (consp (car c-state-cache)) - (cdr (car c-state-cache)) - (1+ (car c-state-cache))) - 1) - old-state c-state-cache)) - - (when c-state-cache - (setq pos last-pos))) - - ;; Get the fallback start position. - (unless pos - (setq pos (c-get-fallback-start-pos here) - c-state-cache nil - c-state-cache-good-pos 1)) - - (narrow-to-region (point-min) here) - - (while pos - (setq save-pos pos - brace-pair-open nil) - - ;; Find the balanced brace pairs. This loop is hot, so it - ;; does ugly tricks to go faster. - (c-safe - (let (set-good-pos set-brace-pair) - (while t - (setq last-pos nil - last-pos (scan-lists pos 1 -1)) ; Might signal. - (setq pos (scan-lists last-pos 1 1) ; Might signal. - set-good-pos (< pos here-bol) - set-brace-pair (eq (char-before last-pos) ?{)) - - ;; Update the cached good position and record the brace - ;; pair, whichever is applicable for the paren we've - ;; just jumped over. But first check that it isn't - ;; inside a macro and the point isn't inside the same - ;; one. - (when (and (or set-good-pos set-brace-pair) - (or (>= pos in-macro-start) - (save-excursion - (goto-char pos) - (not (c-beginning-of-macro))))) - (if set-good-pos - (setq c-state-cache-good-pos pos)) - (if set-brace-pair - (setq brace-pair-open last-pos - brace-pair-close pos)))))) - - ;; Record the last brace pair. - (when brace-pair-open - (let ((head (car-safe c-state-cache))) - (if (consp head) - (progn - (setcar head (1- brace-pair-open)) - (setcdr head brace-pair-close)) - (setq c-state-cache (cons (cons (1- brace-pair-open) - brace-pair-close) - c-state-cache))))) - - (if last-pos - ;; Prepare to loop, but record the open paren only if it's - ;; outside a macro or within the same macro as point, and - ;; if it is a legitimate open paren and not some character - ;; that got an open paren syntax-table property. - (progn - (setq pos last-pos) - (when (and (or (>= last-pos in-macro-start) - (save-excursion - (goto-char last-pos) - (not (c-beginning-of-macro)))) - ;; Check for known types of parens that we - ;; want to record. The syntax table is not to - ;; be trusted here since the caller might be - ;; using e.g. `c++-template-syntax-table'. - (memq (char-before last-pos) '(?{ ?\( ?\[))) - (if (< last-pos here-bol) - (setq c-state-cache-good-pos last-pos)) - (setq c-state-cache (cons (1- last-pos) c-state-cache)))) - - (if (setq last-pos (c-up-list-forward pos)) - ;; Found a close paren without a corresponding opening - ;; one. Maybe we didn't go back far enough, so try to - ;; scan backward for the start paren and then start over. - (progn - (setq pos (c-up-list-backward pos) - c-state-cache nil - c-state-cache-good-pos c-state-cache-start) - (when (or (not pos) - ;; Emacs (up to at least 21.2) can get confused by - ;; open parens in column zero inside comments: The - ;; sexp functions can then misbehave and bring us - ;; back to the same point again. Check this so that - ;; we don't get an infinite loop. - (>= pos save-pos)) - (setq pos last-pos - c-parsing-error - (format "Unbalanced close paren at line %d" - (1+ (count-lines (point-min) - (c-point 'bol last-pos))))))) - (setq pos nil)))) - - ;;(message "c-parse-state: %S end: %S" c-state-cache c-state-cache-good-pos) - c-state-cache))) - -;; Debug tool to catch cache inconsistencies. +;; Debug tool to catch cache inconsistencies. This is called from +;; 000tests.el. (defvar c-debug-parse-state nil) (unless (fboundp 'c-real-parse-state) (fset 'c-real-parse-state (symbol-function 'c-parse-state))) (cc-bytecomp-defun c-real-parse-state) (defun c-debug-parse-state () - (let ((res1 (c-real-parse-state)) res2) + (let ((here (point)) (res1 (c-real-parse-state)) res2) (let ((c-state-cache nil) - (c-state-cache-start 1) - (c-state-cache-good-pos 1)) + (c-state-cache-good-pos 1) + (c-state-nonlit-pos-cache nil) + (c-state-nonlit-pos-cache-limit 1) + (c-state-brace-pair-desert nil) + (c-state-point-min 1) + (c-state-point-min-lit-type nil) + (c-state-point-min-lit-start nil) + (c-state-min-scan-pos 1) + (c-state-old-cpp-beg nil) + (c-state-old-cpp-end nil)) (setq res2 (c-real-parse-state))) (unless (equal res1 res2) ;; The cache can actually go further back due to the ad-hoc way @@ -2296,10 +3084,11 @@ comment at the start of cc-engine.el for more info." (while (not (or (bobp) (eq (char-after) ?{))) (c-beginning-of-defun-1)) (unless (equal (c-whack-state-before (point) res1) res2) - (message (concat "c-parse-state inconsistency: " + (message (concat "c-parse-state inconsistency at %s: " "using cache: %s, from scratch: %s") - res1 res2)))) + here res1 res2)))) res1)) + (defun c-toggle-parse-state-debug (&optional arg) (interactive "P") (setq c-debug-parse-state (c-calculate-state arg c-debug-parse-state)) @@ -2310,6 +3099,7 @@ comment at the start of cc-engine.el for more info." (when c-debug-parse-state (c-toggle-parse-state-debug 1)) + (defun c-whack-state-before (bufpos paren-state) ;; Whack off any state information from PAREN-STATE which lies ;; before BUFPOS. Not destructive on PAREN-STATE. @@ -4109,7 +4899,190 @@ comment at the start of cc-engine.el for more info." ))) -;; Handling of small scale constructs like types and names. +;; Setting and removing syntax properties on < and > in languages (C++ +;; and Java) where they can be template/generic delimiters as well as +;; their normal meaning of "less/greater than". + +;; Normally, < and > have syntax 'punctuation'. When they are found to +;; be delimiters, they are marked as such with the category properties +;; c-<-as-paren-syntax, c->-as-paren-syntax respectively. + +;; STRATEGY: +;; +;; It is impossible to determine with certainty whether a <..> pair in +;; C++ is two comparison operators or is template delimiters, unless +;; one duplicates a lot of a C++ compiler. For example, the following +;; code fragment: +;; +;; foo (a < b, c > d) ; +;; +;; could be a function call with two integer parameters (each a +;; relational expression), or it could be a constructor for class foo +;; taking one parameter d of templated type "a < b, c >". They are +;; somewhat easier to distinguish in Java. +;; +;; The strategy now (2010-01) adopted is to mark and unmark < and +;; > IN MATCHING PAIRS ONLY. [Previously, they were marked +;; individually when their context so indicated. This gave rise to +;; intractible problems when one of a matching pair was deleted, or +;; pulled into a literal.] +;; +;; At each buffer change, the syntax-table properties are removed in a +;; before-change function and reapplied, when needed, in an +;; after-change function. It is far more important that the +;; properties get removed when they they are spurious than that they +;; be present when wanted. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun c-clear-<-pair-props (&optional pos) + ;; POS (default point) is at a < character. If it is marked with + ;; open paren syntax-table text property, remove the property, + ;; together with the close paren property on the matching > (if + ;; any). + (save-excursion + (if pos + (goto-char pos) + (setq pos (point))) + (when (equal (c-get-char-property (point) 'syntax-table) + c-<-as-paren-syntax) + (with-syntax-table c-no-parens-syntax-table ; ignore unbalanced [,{,(,.. + (c-go-list-forward)) + (when (equal (c-get-char-property (1- (point)) 'syntax-table) + c->-as-paren-syntax) ; should always be true. + (c-clear-char-property (1- (point)) 'category)) + (c-clear-char-property pos 'category)))) + +(defun c-clear->-pair-props (&optional pos) + ;; POS (default point) is at a > character. If it is marked with + ;; close paren syntax-table property, remove the property, together + ;; with the open paren property on the matching < (if any). + (save-excursion + (if pos + (goto-char pos) + (setq pos (point))) + (when (equal (c-get-char-property (point) 'syntax-table) + c->-as-paren-syntax) + (with-syntax-table c-no-parens-syntax-table ; ignore unbalanced [,{,(,.. + (c-go-up-list-backward)) + (when (equal (c-get-char-property (point) 'syntax-table) + c-<-as-paren-syntax) ; should always be true. + (c-clear-char-property (point) 'category)) + (c-clear-char-property pos 'category)))) + +(defun c-clear-<>-pair-props (&optional pos) + ;; POS (default point) is at a < or > character. If it has an + ;; open/close paren syntax-table property, remove this property both + ;; from the current character and its partner (which will also be + ;; thusly marked). + (cond + ((eq (char-after) ?\<) + (c-clear-<-pair-props pos)) + ((eq (char-after) ?\>) + (c-clear->-pair-props pos)) + (t (c-benign-error + "c-clear-<>-pair-props called from wrong position")))) + +(defun c-clear-<-pair-props-if-match-after (lim &optional pos) + ;; POS (default point) is at a < character. If it is both marked + ;; with open/close paren syntax-table property, and has a matching > + ;; (also marked) which is after LIM, remove the property both from + ;; the current > and its partner. Return t when this happens, nil + ;; when it doesn't. + (save-excursion + (if pos + (goto-char pos) + (setq pos (point))) + (when (equal (c-get-char-property (point) 'syntax-table) + c-<-as-paren-syntax) + (with-syntax-table c-no-parens-syntax-table ; ignore unbalanced [,{,(,.. + (c-go-list-forward)) + (when (and (>= (point) lim) + (equal (c-get-char-property (1- (point)) 'syntax-table) + c->-as-paren-syntax)) ; should always be true. + (c-unmark-<->-as-paren (1- (point))) + (c-unmark-<->-as-paren pos)) + t))) + +(defun c-clear->-pair-props-if-match-before (lim &optional pos) + ;; POS (default point) is at a > character. If it is both marked + ;; with open/close paren syntax-table property, and has a matching < + ;; (also marked) which is before LIM, remove the property both from + ;; the current < and its partner. Return t when this happens, nil + ;; when it doesn't. + (save-excursion + (if pos + (goto-char pos) + (setq pos (point))) + (when (equal (c-get-char-property (point) 'syntax-table) + c->-as-paren-syntax) + (with-syntax-table c-no-parens-syntax-table ; ignore unbalanced [,{,(,.. + (c-go-up-list-backward)) + (when (and (<= (point) lim) + (equal (c-get-char-property (point) 'syntax-table) + c-<-as-paren-syntax)) ; should always be true. + (c-unmark-<->-as-paren (point)) + (c-unmark-<->-as-paren pos)) + t))) + +;; Set by c-common-init in cc-mode.el. +(defvar c-new-BEG) +(defvar c-new-END) + +(defun c-before-change-check-<>-operators (beg end) + ;; Unmark certain pairs of "< .... >" which are currently marked as + ;; template/generic delimiters. (This marking is via syntax-table + ;; text properties). + ;; + ;; These pairs are those which are in the current "statement" (i.e., + ;; the region between the {, }, or ; before BEG and the one after + ;; END), and which enclose any part of the interval (BEG END). + ;; + ;; Note that in C++ (?and Java), template/generic parens cannot + ;; enclose a brace or semicolon, so we use these as bounds on the + ;; region we must work on. + ;; + ;; This function is called from before-change-functions (via + ;; c-get-state-before-change-functions). Thus the buffer is widened, + ;; and point is undefined, both at entry and exit. + ;; + ;; FIXME!!! This routine ignores the possibility of macros entirely. + ;; 2010-01-29. + (save-excursion + (let ((beg-lit-limits (progn (goto-char beg) (c-literal-limits))) + (end-lit-limits (progn (goto-char end) (c-literal-limits))) + new-beg new-end need-new-beg need-new-end) + ;; Locate the barrier before the changed region + (goto-char (if beg-lit-limits (car beg-lit-limits) beg)) + (c-syntactic-skip-backward "^;{}" (max (- beg 2048) (point-min))) + (setq new-beg (point)) + + ;; Remove the syntax-table properties from each pertinent <...> pair. + ;; Firsly, the ones with the < before beg and > after beg. + (while (c-search-forward-char-property 'category 'c-<-as-paren-syntax beg) + (if (c-clear-<-pair-props-if-match-after beg (1- (point))) + (setq need-new-beg t))) + + ;; Locate the barrier after END. + (goto-char (if end-lit-limits (cdr end-lit-limits) end)) + (c-syntactic-re-search-forward "[;{}]" + (min (+ end 2048) (point-max)) 'end) + (setq new-end (point)) + + ;; Remove syntax-table properties from the remaining pertinent <...> + ;; pairs, those with a > after end and < before end. + (while (c-search-backward-char-property 'category 'c->-as-paren-syntax end) + (if (c-clear->-pair-props-if-match-before end) + (setq need-new-end t))) + + ;; Extend the fontification region, if needed. + (when need-new-beg + (goto-char new-beg) + (c-forward-syntactic-ws) + (and (< (point) c-new-BEG) (setq c-new-BEG (point)))) + + (when need-new-end + (and (> new-end c-new-END) (setq c-new-END new-end)))))) + + (defun c-after-change-check-<>-operators (beg end) ;; This is called from `after-change-functions' when @@ -4131,7 +5104,7 @@ comment at the start of cc-engine.el for more info." (< beg (setq beg (match-end 0)))) (while (progn (skip-chars-forward "^<>" beg) (< (point) beg)) - (c-clear-char-property (point) 'syntax-table) + (c-clear-<>-pair-props) (forward-char)))) (when (< beg end) @@ -4146,9 +5119,13 @@ comment at the start of cc-engine.el for more info." (< end (setq end (match-end 0)))) (while (progn (skip-chars-forward "^<>" end) (< (point) end)) - (c-clear-char-property (point) 'syntax-table) + (c-clear-<>-pair-props) (forward-char))))))) + + +;; Handling of small scale constructs like types and names. + ;; Dynamically bound variable that instructs `c-forward-type' to also ;; treat possible types (i.e. those that it normally returns 'maybe or ;; 'found for) as actual types (and always return 'found for them). @@ -4393,6 +5370,9 @@ comment at the start of cc-engine.el for more info." (goto-char safe-pos) t))) +;; cc-mode requires cc-fonts. +(declare-function c-fontify-recorded-types-and-refs "cc-fonts" ()) + (defun c-forward-<>-arglist (all-types) ;; The point is assumed to be at a "<". Try to treat it as the open ;; paren of an angle bracket arglist and move forward to the @@ -4428,6 +5408,7 @@ comment at the start of cc-engine.el for more info." ;; `nconc' doesn't mind that the tail of ;; `c-record-found-types' is t. (nconc c-record-found-types c-record-type-identifiers))) + (if (c-major-mode-is 'java-mode) (c-fontify-recorded-types-and-refs)) t) (goto-char start) @@ -4447,7 +5428,6 @@ comment at the start of cc-engine.el for more info." ;; List that collects the positions after the argument ;; separating ',' in the arglist. arg-start-pos) - ;; If the '<' has paren open syntax then we've marked it as an angle ;; bracket arglist before, so skip to the end. (if (and (not c-parse-and-markup-<>-arglists) @@ -4458,7 +5438,6 @@ comment at the start of cc-engine.el for more info." (if (and (c-go-up-list-forward) (eq (char-before) ?>)) t - ;; Got unmatched paren angle brackets. We don't clear the paren ;; syntax properties and retry, on the basis that it's very ;; unlikely that paren angle brackets become operators by code @@ -4468,67 +5447,46 @@ comment at the start of cc-engine.el for more info." nil)) (forward-char) + (unless (looking-at c-<-op-cont-regexp) (while (and (progn - - (when c-record-type-identifiers - (if all-types - - ;; All encountered identifiers are types, so set the - ;; promote flag and parse the type. - (progn - (c-forward-syntactic-ws) + (c-forward-syntactic-ws) + (let ((orig-record-found-types c-record-found-types)) + (when (or (and c-record-type-identifiers all-types) + (c-major-mode-is 'java-mode)) + ;; All encountered identifiers are types, so set the + ;; promote flag and parse the type. + (progn + (c-forward-syntactic-ws) + (if (looking-at "\\?") + (forward-char) (when (looking-at c-identifier-start) - (let ((c-promote-possible-types t)) + (let ((c-promote-possible-types t) + (c-record-found-types t)) (c-forward-type)))) - ;; Check if this arglist argument is a sole type. If - ;; it's known then it's recorded in - ;; `c-record-type-identifiers'. If it only is found - ;; then it's recorded in `c-record-found-types' which we - ;; might roll back if it turns out that this isn't an - ;; angle bracket arglist afterall. - (when (memq (char-before) '(?, ?<)) - (let ((orig-record-found-types c-record-found-types)) + (c-forward-syntactic-ws) + + (when (or (looking-at "extends") + (looking-at "super")) + (forward-word) (c-forward-syntactic-ws) - (and (memq (c-forward-type) '(known found)) - (not (looking-at "[,>]")) - ;; A found type was recorded but it's not the - ;; only thing in the arglist argument, so reset - ;; `c-record-found-types'. - (setq c-record-found-types - orig-record-found-types)))))) + (let ((c-promote-possible-types t) + (c-record-found-types t)) + (c-forward-type) + (c-forward-syntactic-ws)))))) (setq pos (point)) - (or (when (eq (char-after) ?>) - ;; Must check for '>' at the very start separately, - ;; since the regexp below has to avoid ">>" without - ;; using \\=. - (forward-char) - t) - - ;; Note: These regexps exploit the match order in \| so - ;; that "<>" is matched by "<" rather than "[^>:-]>". - (c-syntactic-re-search-forward - (if c-restricted-<>-arglists - ;; Stop on ',', '|', '&', '+' and '-' to catch - ;; common binary operators that could be between - ;; two comparison expressions "a<b" and "c>d". - "[<;{},|&+-]\\|\\([^>:-]>\\)" - ;; Otherwise we still stop on ',' to find the - ;; argument start positions. - "[<;{},]\\|\\([^>:-]>\\)") - nil 'move t t 1) - - ;; If the arglist starter has lost its open paren - ;; syntax but not the closer, we won't find the - ;; closer above since we only search in the - ;; balanced sexp. In that case we stop just short - ;; of it so check if the following char is the closer. - (when (eq (char-after) ?>) - (forward-char) - t))) + + ;; Note: These regexps exploit the match order in \| so + ;; that "<>" is matched by "<" rather than "[^>:-]>". + (c-syntactic-re-search-forward + ;; Stop on ',', '|', '&', '+' and '-' to catch + ;; common binary operators that could be between + ;; two comparison expressions "a<b" and "c>d". + "[<;{},|+&-]\\|[>)]" + nil t t)) (cond ((eq (char-before) ?>) @@ -4553,7 +5511,6 @@ comment at the start of cc-engine.el for more info." ((eq (char-before) ?<) ;; Either an operator starting with '<' or a nested arglist. - (setq pos (point)) (let (id-start id-end subres keyword-match) (if (if (looking-at c-<-op-cont-regexp) @@ -4576,8 +5533,8 @@ comment at the start of cc-engine.el for more info." (setq id-start (point)))) (setq subres - (let ((c-record-type-identifiers nil) - (c-record-found-types nil)) + (let ((c-promote-possible-types t) + (c-record-found-types t)) (c-forward-<>-arglist-recur (and keyword-match (c-keyword-member @@ -4604,9 +5561,11 @@ comment at the start of cc-engine.el for more info." (c-record-type-id (cons id-start id-end)))))) t) - ((and (eq (char-before) ?,) - (not c-restricted-<>-arglists)) - ;; Just another argument. Record the position. The + ((and (not c-restricted-<>-arglists) + (or (and (eq (char-before) ?&) + (not (eq (char-after) ?&))) + (eq (char-before) ?,))) + ;; Just another argument. Record the position. The ;; type check stuff that made us stop at it is at ;; the top of the loop. (setq arg-start-pos (cons (point) arg-start-pos))) @@ -4617,7 +5576,6 @@ comment at the start of cc-engine.el for more info." ;; it's useless to try to find a surrounding arglist ;; if we're nested. (throw 'angle-bracket-arglist-escape nil)))))) - (if res (or c-record-found-types t))))) @@ -4688,17 +5646,23 @@ comment at the start of cc-engine.el for more info." (defun c-forward-name () ;; Move forward over a complete name if at the beginning of one, - ;; stopping at the next following token. If the point is not at - ;; something that are recognized as name then it stays put. A name - ;; could be something as simple as "foo" in C or something as + ;; stopping at the next following token. A keyword, as such, + ;; doesn't count as a name. If the point is not at something that + ;; is recognized as a name then it stays put. + ;; + ;; A name could be something as simple as "foo" in C or something as ;; complex as "X<Y<class A<int>::B, BIT_MAX >> b>, ::operator<> :: ;; Z<(a>b)> :: operator const X<&foo>::T Q::G<unsigned short ;; int>::*volatile const" in C++ (this function is actually little ;; more than a `looking-at' call in all modes except those that, - ;; like C++, have `c-recognize-<>-arglists' set). Return nil if no - ;; name is found, 'template if it's an identifier ending with an - ;; angle bracket arglist, 'operator of it's an operator identifier, - ;; or t if it's some other kind of name. + ;; like C++, have `c-recognize-<>-arglists' set). + ;; + ;; Return + ;; o - nil if no name is found; + ;; o - 'template if it's an identifier ending with an angle bracket + ;; arglist; + ;; o - 'operator of it's an operator identifier; + ;; o - t if it's some other kind of name. ;; ;; This function records identifier ranges on ;; `c-record-type-identifiers' and `c-record-ref-identifiers' if @@ -4820,9 +5784,8 @@ comment at the start of cc-engine.el for more info." ((and c-recognize-<>-arglists (eq (char-after) ?<)) ;; Maybe an angle bracket arglist. - - (when (let (c-record-type-identifiers - c-record-found-types) + (when (let ((c-record-type-identifiers t) + (c-record-found-types t)) (c-forward-<>-arglist nil)) (c-add-type start (1+ pos)) @@ -4851,16 +5814,28 @@ comment at the start of cc-engine.el for more info." (goto-char pos) res)) -(defun c-forward-type () +(defun c-forward-type (&optional brace-block-too) ;; Move forward over a type spec if at the beginning of one, - ;; stopping at the next following token. Return t if it's a known - ;; type that can't be a name or other expression, 'known if it's an - ;; otherwise known type (according to `*-font-lock-extra-types'), - ;; 'prefix if it's a known prefix of a type, 'found if it's a type - ;; that matches one in `c-found-types', 'maybe if it's an identfier - ;; that might be a type, or nil if it can't be a type (the point - ;; isn't moved then). The point is assumed to be at the beginning - ;; of a token. + ;; stopping at the next following token. The keyword "typedef" + ;; isn't part of a type spec here. + ;; + ;; BRACE-BLOCK-TOO, when non-nil, means move over the brace block in + ;; constructs like "struct foo {...} bar ;" or "struct {...} bar;". + ;; The current (2009-03-10) intention is to convert all uses of + ;; `c-forward-type' to call with this parameter set, then to + ;; eliminate it. + ;; + ;; Return + ;; o - t if it's a known type that can't be a name or other + ;; expression; + ;; o - 'known if it's an otherwise known type (according to + ;; `*-font-lock-extra-types'); + ;; o - 'prefix if it's a known prefix of a type; + ;; o - 'found if it's a type that matches one in `c-found-types'; + ;; o - 'maybe if it's an identfier that might be a type; or + ;; o - nil if it can't be a type (the point isn't moved then). + ;; + ;; The point is assumed to be at the beginning of a token. ;; ;; Note that this function doesn't skip past the brace definition ;; that might be considered part of the type, e.g. @@ -4871,37 +5846,47 @@ comment at the start of cc-engine.el for more info." ;; `c-record-type-identifiers' is non-nil. ;; ;; This function might do hidden buffer changes. + (when (looking-at "<") + (c-forward-<>-arglist t) + (c-forward-syntactic-ws)) (let ((start (point)) pos res name-res id-start id-end id-range) ;; Skip leading type modifiers. If any are found we know it's a ;; prefix of a type. - (when c-opt-type-modifier-key + (when c-opt-type-modifier-key ; e.g. "const" "volatile", but NOT "typedef" (while (looking-at c-opt-type-modifier-key) (goto-char (match-end 1)) (c-forward-syntactic-ws) (setq res 'prefix))) (cond - ((looking-at c-type-prefix-key) - ;; Looking at a keyword that prefixes a type identifier, - ;; e.g. "class". + ((looking-at c-type-prefix-key) ; e.g. "struct", "class", but NOT + ; "typedef". (goto-char (match-end 1)) (c-forward-syntactic-ws) (setq pos (point)) - (if (memq (setq name-res (c-forward-name)) '(t template)) - (progn - (when (eq name-res t) - ;; In many languages the name can be used without the - ;; prefix, so we add it to `c-found-types'. - (c-add-type pos (point)) - (when (and c-record-type-identifiers - c-last-identifier-range) - (c-record-type-id c-last-identifier-range))) - (setq res t)) - ;; Invalid syntax. - (goto-char start) - (setq res nil))) + + (setq name-res (c-forward-name)) + (setq res (not (null name-res))) + (when (eq name-res t) + ;; In many languages the name can be used without the + ;; prefix, so we add it to `c-found-types'. + (c-add-type pos (point)) + (when (and c-record-type-identifiers + c-last-identifier-range) + (c-record-type-id c-last-identifier-range))) + (when (and brace-block-too + (memq res '(t nil)) + (eq (char-after) ?\{) + (save-excursion + (c-safe + (progn (c-forward-sexp) + (c-forward-syntactic-ws) + (setq pos (point)))))) + (goto-char pos) + (setq res t)) + (unless res (goto-char start))) ; invalid syntax ((progn (setq pos nil) @@ -4991,14 +5976,13 @@ comment at the start of cc-engine.el for more info." (setq res nil))))) (when res - ;; Skip trailing type modifiers. If any are found we know it's + ;; Skip trailing type modifiers. If any are found we know it's ;; a type. (when c-opt-type-modifier-key - (while (looking-at c-opt-type-modifier-key) + (while (looking-at c-opt-type-modifier-key) ; e.g. "const", "volatile" (goto-char (match-end 1)) (c-forward-syntactic-ws) (setq res t))) - ;; Step over any type suffix operator. Do not let the existence ;; of these alter the classification of the found type, since ;; these operators typically are allowed in normal expressions @@ -5008,7 +5992,7 @@ comment at the start of cc-engine.el for more info." (goto-char (match-end 1)) (c-forward-syntactic-ws))) - (when c-opt-type-concat-key + (when c-opt-type-concat-key ; Only/mainly for pike. ;; Look for a trailing operator that concatenates the type ;; with a following one, and if so step past that one through ;; a recursive call. Note that we don't record concatenated @@ -5070,6 +6054,18 @@ comment at the start of cc-engine.el for more info." res)) +(defun c-forward-annotation () + ;; Used for Java code only at the moment. Assumes point is on the + ;; @, moves forward an annotation. returns nil if there is no + ;; annotation at point. + (and (looking-at "@") + (progn (forward-char) t) + (c-forward-type) + (progn (c-forward-syntactic-ws) t) + (if (looking-at "(") + (c-go-list-forward) + t))) + ;; Handling of large scale constructs like statements and declarations. @@ -5147,11 +6143,15 @@ comment at the start of cc-engine.el for more info." ;; car ^ ^ point ;; Foo::Foo (int b) : Base (b) {} ;; car ^ ^ point - ;; - ;; The cdr of the return value is non-nil iff a `c-typedef-decl-kwds' - ;; specifier (e.g. class, struct, enum, typedef) is found in the - ;; declaration, i.e. the declared identifier(s) are types. - ;; + ;; + ;; The cdr of the return value is non-nil when a + ;; `c-typedef-decl-kwds' specifier is found in the declaration. + ;; Specifically it is a dotted pair (A . B) where B is t when a + ;; `c-typedef-kwds' ("typedef") is present, and A is t when some + ;; other `c-typedef-decl-kwds' (e.g. class, struct, enum) + ;; specifier is present. I.e., (some of) the declared + ;; identifier(s) are types. + ;; ;; If a cast is parsed: ;; ;; The point is left at the first token after the closing paren of @@ -5209,9 +6209,11 @@ comment at the start of cc-engine.el for more info." ;; If `backup-at-type' is nil then the other variables have ;; undefined values. backup-at-type backup-type-start backup-id-start - ;; Set if we've found a specifier that makes the defined - ;; identifier(s) types. + ;; Set if we've found a specifier (apart from "typedef") that makes + ;; the defined identifier(s) types. at-type-decl + ;; Set if we've a "typedef" keyword. + at-typedef ;; Set if we've found a specifier that can start a declaration ;; where there's no type. maybe-typeless @@ -5239,6 +6241,9 @@ comment at the start of cc-engine.el for more info." (save-rec-type-ids c-record-type-identifiers) (save-rec-ref-ids c-record-ref-identifiers)) + (while (c-forward-annotation) + (c-forward-syntactic-ws)) + ;; Check for a type. Unknown symbols are treated as possible ;; types, but they could also be specifiers disguised through ;; macros like __INLINE__, so we recognize both types and known @@ -5248,12 +6253,14 @@ comment at the start of cc-engine.el for more info." ;; Look for a specifier keyword clause. (when (looking-at c-prefix-spec-kwds-re) + (if (looking-at c-typedef-key) + (setq at-typedef t)) (setq kwd-sym (c-keyword-sym (match-string 1))) (save-excursion (c-forward-keyword-clause 1) (setq kwd-clause-end (point)))) - (when (setq found-type (c-forward-type)) + (when (setq found-type (c-forward-type t)) ; brace-block-too ;; Found a known or possible type or a prefix of a known type. (when at-type @@ -5318,6 +6325,8 @@ comment at the start of cc-engine.el for more info." (setq backup-maybe-typeless t))) (when (c-keyword-member kwd-sym 'c-typedef-decl-kwds) + ;; This test only happens after we've scanned a type. + ;; So, with valid syntax, kwd-sym can't be 'typedef. (setq at-type-decl t)) (when (c-keyword-member kwd-sym 'c-typeless-decl-kwds) (setq maybe-typeless t)) @@ -5572,13 +6581,14 @@ comment at the start of cc-engine.el for more info." ;; CASE 3 (when (= (point) start) ;; Got a plain list of identifiers. If a colon follows it's - ;; a valid label. Otherwise the last one probably is the - ;; declared identifier and we should back up to the previous - ;; type, providing it isn't a cast. - (if (eq (char-after) ?:) - ;; If we've found a specifier keyword then it's a - ;; declaration regardless. - (throw 'at-decl-or-cast (eq at-decl-or-cast t)) + ;; a valid label. Otherwise the last one probably is the + ;; declared identifier and we should back up to the previous + ;; type, providing it isn't a cast. + (if (and (eq (char-after) ?:) + (not (c-major-mode-is 'java-mode))) + ;; If we've found a specifier keyword then it's a + ;; declaration regardless. + (throw 'at-decl-or-cast (eq at-decl-or-cast t)) (setq backup-if-not-cast t) (throw 'at-decl-or-cast t))) @@ -5916,7 +6926,9 @@ comment at the start of cc-engine.el for more info." (goto-char type-start) (c-forward-type)))) - (cons id-start at-type-decl)) + (cons id-start + (and (or at-type-decl at-typedef) + (cons at-type-decl at-typedef)))) (t ;; False alarm. Restore the recorded ranges. @@ -7539,7 +8551,7 @@ comment at the start of cc-engine.el for more info." ;; ;; This function might do hidden buffer changes. - (let (special-brace-list) + (let (special-brace-list placeholder) (goto-char indent-point) (skip-chars-forward " \t") @@ -7646,6 +8658,22 @@ comment at the start of cc-engine.el for more info." (c-add-stmt-syntax 'func-decl-cont nil t containing-sexp paren-state)) + ;;CASE F: continued statement and the only preceding items are + ;;annotations. + ((and (c-major-mode-is 'java-mode) + (setq placeholder (point)) + (c-beginning-of-statement-1) + (progn + (while (and (c-forward-annotation) + (< (point) placeholder)) + (c-forward-syntactic-ws)) + t) + (prog1 + (>= (point) placeholder) + (goto-char placeholder))) + (c-beginning-of-statement-1 containing-sexp) + (c-add-syntax 'annotation-var-cont (point))) + ;; CASE D: continued statement. (t (c-beginning-of-statement-1 containing-sexp) @@ -7745,7 +8773,6 @@ comment at the start of cc-engine.el for more info." (when (and containing-sexp (eq (char-after containing-sexp) ?\()) (setq c-stmt-delim-chars c-stmt-delim-chars-with-comma)) - ;; cache char before and after indent point, and move point to ;; the most likely position to perform the majority of tests (goto-char indent-point) @@ -8495,23 +9522,36 @@ comment at the start of cc-engine.el for more info." (c-add-syntax 'objc-method-args-cont placeholder)) ;; CASE 5L: we are at the first argument of a template - ;; arglist that begins on the previous line. - ((and c-recognize-<>-arglists - (eq (char-before) ?<) - (setq placeholder (1- (point))) - (not (and c-overloadable-operators-regexp - (c-after-special-operator-id lim)))) - (c-beginning-of-statement-1 (c-safe-position (point) paren-state)) - (c-add-syntax 'template-args-cont (c-point 'boi) placeholder)) - - ;; CASE 5Q: we are at a statement within a macro. - (macro-start - (c-beginning-of-statement-1 containing-sexp) - (c-add-stmt-syntax 'statement nil t containing-sexp paren-state)) - - ;; CASE 5M: we are at a topmost continuation line - (t - (c-beginning-of-statement-1 (c-safe-position (point) paren-state)) + ;; arglist that begins on the previous line. + ((and c-recognize-<>-arglists + (eq (char-before) ?<) + (not (and c-overloadable-operators-regexp + (c-after-special-operator-id lim)))) + (c-beginning-of-statement-1 (c-safe-position (point) paren-state)) + (c-add-syntax 'template-args-cont (c-point 'boi))) + + ;; CASE 5Q: we are at a statement within a macro. + (macro-start + (c-beginning-of-statement-1 containing-sexp) + (c-add-stmt-syntax 'statement nil t containing-sexp paren-state)) + + ;;CASE 5N: We are at a tompmost continuation line and the only + ;;preceding items are annotations. + ((and (c-major-mode-is 'java-mode) + (setq placeholder (point)) + (c-beginning-of-statement-1) + (progn + (while (and (c-forward-annotation)) + (c-forward-syntactic-ws)) + t) + (prog1 + (>= (point) placeholder) + (goto-char placeholder))) + (c-add-syntax 'annotation-top-cont (c-point 'boi))) + + ;; CASE 5M: we are at a topmost continuation line + (t + (c-beginning-of-statement-1 (c-safe-position (point) paren-state)) (when (c-major-mode-is 'objc-mode) (setq placeholder (point)) (while (and (c-forward-objc-directive) @@ -8522,43 +9562,20 @@ comment at the start of cc-engine.el for more info." (c-add-syntax 'topmost-intro-cont (c-point 'boi))) )) - ;; (CASE 6 has been removed.) - ;; CASE 19: line is an expression, not a statement, and is directly - ;; contained by a template delimiter. Most likely, we are in a - ;; template arglist within a statement. This case is based on CASE - ;; 7. At some point in the future, we may wish to create more - ;; syntactic symbols such as `template-intro', - ;; `template-cont-nonempty', etc., and distinguish between them as we - ;; do for `arglist-intro' etc. (2009-12-07). - ((and c-recognize-<>-arglists - (setq containing-< (c-up-list-backward indent-point containing-sexp)) - (eq (char-after containing-<) ?\<)) - (setq placeholder (c-point 'boi containing-<)) - (goto-char containing-sexp) ; Most nested Lbrace/Lparen (but not - ; '<') before indent-point. - (if (>= (point) placeholder) - (progn - (forward-char) - (skip-chars-forward " \t")) - (goto-char placeholder)) - (c-add-stmt-syntax 'template-args-cont (list containing-<) t - (c-most-enclosing-brace c-state-cache (point)) - paren-state)) - + ;; (CASE 6 has been removed.) - ;; CASE 7: line is an expression, not a statement. Most - ;; likely we are either in a function prototype or a function - ;; call argument list, or a template argument list. - ((not (or (and c-special-brace-lists - (save-excursion - (goto-char containing-sexp) - (c-looking-at-special-brace-list))) - (eq (char-after containing-sexp) ?{) - (eq (char-after containing-sexp) ?<))) - (cond + ;; CASE 7: line is an expression, not a statement. Most + ;; likely we are either in a function prototype or a function + ;; call argument list + ((not (or (and c-special-brace-lists + (save-excursion + (goto-char containing-sexp) + (c-looking-at-special-brace-list))) + (eq (char-after containing-sexp) ?{))) + (cond - ;; CASE 7A: we are looking at the arglist closing paren. + ;; CASE 7A: we are looking at the arglist closing paren. ;; C.f. case 7F. ((memq char-after-ip '(?\) ?\])) (goto-char containing-sexp) @@ -8570,12 +9587,34 @@ comment at the start of cc-engine.el for more info." (skip-chars-forward " \t")) (goto-char placeholder)) (c-add-stmt-syntax 'arglist-close (list containing-sexp) t - (c-most-enclosing-brace paren-state (point)) - paren-state)) + (c-most-enclosing-brace paren-state (point)) + paren-state)) - ;; CASE 7B: Looking at the opening brace of an - ;; in-expression block or brace list. C.f. cases 4, 16A - ;; and 17E. + ;; CASE 19: line is an expression, not a statement, and is directly + ;; contained by a template delimiter. Most likely, we are in a + ;; template arglist within a statement. This case is based on CASE + ;; 7. At some point in the future, we may wish to create more + ;; syntactic symbols such as `template-intro', + ;; `template-cont-nonempty', etc., and distinguish between them as we + ;; do for `arglist-intro' etc. (2009-12-07). + ((and c-recognize-<>-arglists + (setq containing-< (c-up-list-backward indent-point containing-sexp)) + (eq (char-after containing-<) ?\<)) + (setq placeholder (c-point 'boi containing-<)) + (goto-char containing-sexp) ; Most nested Lbrace/Lparen (but not + ; '<') before indent-point. + (if (>= (point) placeholder) + (progn + (forward-char) + (skip-chars-forward " \t")) + (goto-char placeholder)) + (c-add-stmt-syntax 'template-args-cont (list containing-<) t + (c-most-enclosing-brace c-state-cache (point)) + paren-state)) + + ;; CASE 7B: Looking at the opening brace of an + ;; in-expression block or brace list. C.f. cases 4, 16A + ;; and 17E. ((and (eq char-after-ip ?{) (progn (setq placeholder (c-inside-bracelist-p (point) diff --git a/lisp/progmodes/cc-fonts.el b/lisp/progmodes/cc-fonts.el index 80783670f66..d2e5657d34a 100644 --- a/lisp/progmodes/cc-fonts.el +++ b/lisp/progmodes/cc-fonts.el @@ -6,8 +6,8 @@ ;; 2002- Martin Stjernholm ;; Maintainer: bug-cc-mode@gnu.org ;; Created: 07-Jan-2002 -;; Version: See cc-mode.el -;; Keywords: c languages oop +;; Keywords: c languages +;; Package: cc-mode ;; This file is part of GNU Emacs. @@ -194,6 +194,10 @@ (unless (face-property-instance oldface 'reverse) (invert-face newface))))) +(defvar c-annotation-face (make-face 'c-annotation-face) + "Face used to highlight annotations in java-mode and other modes that may wish to use it.") +(set-face-foreground 'c-annotation-face "blue") + (eval-and-compile ;; We need the following functions during compilation since they're ;; called when the `c-lang-defconst' initializers are evaluated. @@ -285,7 +289,7 @@ ;; bit of the overhead compared to a real matcher. The main reason ;; is however to pass the real search limit to the anchored ;; matcher(s), since most (if not all) font-lock implementations - ;; arbitrarily limits anchored matchers to the same line, and also + ;; arbitrarily limit anchored matchers to the same line, and also ;; to insulate against various other irritating differences between ;; the different (X)Emacs font-lock packages. ;; @@ -306,7 +310,7 @@ ;; covered by the font-lock context.) ;; Note: Replace `byte-compile' with `eval' to debug the generated - ;; lambda easier. + ;; lambda more easily. (byte-compile `(lambda (limit) (let (;; The font-lock package in Emacs is known to clobber @@ -426,7 +430,8 @@ stuff. Used on level 1 and higher." (progn (c-mark-<-as-paren beg) (c-mark->-as-paren end)) - (c-clear-char-property beg 'syntax-table))) + ;; (c-clear-char-property beg 'syntax-table) + (c-clear-char-property beg 'category))) nil))))))) ;; #define. @@ -716,16 +721,26 @@ casts and declarations are fontified. Used on level 2 and higher." ;; Clear the list of found types if we start from the start of the ;; buffer, to make it easier to get rid of misspelled types and - ;; variables that has gotten recognized as types in malformed code. + ;; variables that have gotten recognized as types in malformed code. (when (bobp) (c-clear-found-types)) - ;; Clear the c-type char properties in the region to recalculate - ;; them properly. This is necessary e.g. to handle constructs that - ;; might been required as declarations temporarily during editing. - ;; The interesting properties are anyway those put on the closest - ;; token before the region. - (c-clear-char-properties (point) limit 'c-type) + ;; Clear the c-type char properties which mark the region, to recalculate + ;; them properly. The most interesting properties are those put on the + ;; closest token before the region. + (save-excursion + (let ((pos (point))) + (c-backward-syntactic-ws) + (c-clear-char-properties + (if (and (not (bobp)) + (memq (c-get-char-property (1- (point)) 'c-type) + '(c-decl-arg-start + c-decl-end + c-decl-id-start + c-decl-type-start))) + (1- (point)) + pos) + limit 'c-type))) ;; Update `c-state-cache' to the beginning of the region. This will ;; make `c-beginning-of-syntax' go faster when it's used later on, @@ -734,6 +749,8 @@ casts and declarations are fontified. Used on level 2 and higher." ;; Check if the fontified region starts inside a declarator list so ;; that `c-font-lock-declarators' should be called at the start. + ;; The declared identifiers are font-locked correctly as types, if + ;; that is what they are. (let ((prop (save-excursion (c-backward-syntactic-ws) (unless (bobp) @@ -826,12 +843,19 @@ casts and declarations are fontified. Used on level 2 and higher." nil) (defun c-font-lock-declarators (limit list types) - ;; Assuming the point is at the start of a declarator in a - ;; declaration, fontify it. If LIST is non-nil, fontify also all - ;; following declarators in a comma separated list (e.g. "foo" and - ;; "bar" in "int foo = 17, bar;"). Stop at LIMIT. If TYPES is - ;; non-nil, fontify all identifiers as types. Nil is always - ;; returned. + ;; Assuming the point is at the start of a declarator in a declaration, + ;; fontify the identifier it declares. (If TYPES is set, it does this via + ;; the macro `c-fontify-types-and-refs'.) + ;; + ;; If LIST is non-nil, also fontify the ids in any following declarators in + ;; a comma separated list (e.g. "foo" and "*bar" in "int foo = 17, *bar;"); + ;; additionally, mark the commas with c-type property 'c-decl-id-start or + ;; 'c-decl-type-start (according to TYPES). Stop at LIMIT. + ;; + ;; If TYPES is non-nil, fontify all identifiers as types. + ;; + ;; Nil is always returned. The function leaves point at the delimiter after + ;; the last declarator it processes. ;; ;; This function might do hidden buffer changes. @@ -843,18 +867,31 @@ casts and declarations are fontified. Used on level 2 and higher." c-last-identifier-range (separator-prop (if types 'c-decl-type-start 'c-decl-id-start))) - (while (and + ;; The following `while' fontifies a single declarator id each time round. + ;; It loops only when LIST is non-nil. + (while + ;; Inside the following "condition form", we move forward over the + ;; declarator's identifier up as far as any opening bracket (for array + ;; size) or paren (for parameters of function-type) or brace (for + ;; array/struct initialisation) or "=" or terminating delimiter + ;; (e.g. "," or ";" or "}"). + (and pos (< (point) limit) + ;; The following form moves forward over the declarator's + ;; identifier (and what precedes it), returning t. If there + ;; wasn't one, it returns nil, terminating the `while'. (let (got-identifier) (setq paren-depth 0) - ;; Skip over type decl prefix operators. (Note similar - ;; code in `c-forward-decl-or-cast-1'.) + ;; Skip over type decl prefix operators, one for each iteration + ;; of the while. These are, e.g. "*" in "int *foo" or "(" and + ;; "*" in "int (*foo) (void)" (Note similar code in + ;; `c-forward-decl-or-cast-1'.) (while (and (looking-at c-type-decl-prefix-key) (if (and (c-major-mode-is 'c++-mode) - (match-beginning 2)) - ;; If the second submatch matches in C++ then + (match-beginning 3)) + ;; If the third submatch matches in C++ then ;; we're looking at an identifier that's a ;; prefix only if it specifies a member pointer. (progn @@ -877,7 +914,7 @@ casts and declarations are fontified. Used on level 2 and higher." (goto-char (match-end 1))) (c-forward-syntactic-ws)) - ;; If we didn't pass the identifier above already, do it now. + ;; If we haven't passed the identifier already, do it now. (unless got-identifier (setq id-start (point)) (c-forward-name)) @@ -885,12 +922,14 @@ casts and declarations are fontified. Used on level 2 and higher." (/= id-end pos)) - ;; Skip out of the parens surrounding the identifier. + ;; Skip out of the parens surrounding the identifier. If closing + ;; parens are missing, this form returns nil. (or (= paren-depth 0) (c-safe (goto-char (scan-lists (point) 1 paren-depth)))) (<= (point) limit) + ;; Skip over any trailing bit, such as "__attribute__". (progn (when (looking-at c-decl-hangon-key) (c-forward-keyword-clause 1)) @@ -931,7 +970,7 @@ casts and declarations are fontified. Used on level 2 and higher." id-face))) (goto-char next-pos) - (setq pos nil) + (setq pos nil) ; So as to terminate the enclosing `while' form. (when list ;; Jump past any initializer or function prototype to see if ;; there's a ',' to continue at. @@ -939,11 +978,11 @@ casts and declarations are fontified. Used on level 2 and higher." (cond ((eq id-face 'font-lock-function-name-face) ;; Skip a parenthesized initializer (C++) or a function ;; prototype. - (if (c-safe (c-forward-sexp 1) t) + (if (c-safe (c-forward-sexp 1) t) ; over the parameter list. (c-forward-syntactic-ws limit) - (goto-char limit))) + (goto-char limit))) ; unbalanced parens - (got-init + (got-init ; "=" sign OR opening "(", "[", or "{" ;; Skip an initializer expression. If we're at a '=' ;; then accept a brace list directly after it to cope ;; with array initializers. Otherwise stop at braces @@ -951,7 +990,7 @@ casts and declarations are fontified. Used on level 2 and higher." (and (if (and (eq got-init ?=) (= (c-forward-token-2 1 nil limit) 0) (looking-at "{")) - (c-safe (c-forward-sexp) t) + (c-safe (c-forward-sexp) t) ; over { .... } t) ;; FIXME: Should look for c-decl-end markers here; ;; we might go far into the following declarations @@ -966,7 +1005,7 @@ casts and declarations are fontified. Used on level 2 and higher." (c-put-char-property (point) 'c-type separator-prop) (forward-char) (c-forward-syntactic-ws limit) - (setq pos (point)))))) + (setq pos (point)))))) ; acts to make the `while' form continue. nil) (defconst c-font-lock-maybe-decl-faces @@ -979,31 +1018,39 @@ casts and declarations are fontified. Used on level 2 and higher." font-lock-keyword-face)) (defun c-font-lock-declarations (limit) + ;; Fontify all the declarations, casts and labels from the point to LIMIT. + ;; Assumes that strings and comments have been fontified already. + ;; ;; This function will be called from font-lock for a region bounded by POINT ;; and LIMIT, as though it were to identify a keyword for ;; font-lock-keyword-face. It always returns NIL to inhibit this and ;; prevent a repeat invocation. See elisp/lispref page "Search-based ;; Fontification". ;; - ;; Fontify all the declarations, casts and labels from the point to LIMIT. - ;; Assumes that strings and comments have been fontified already. - ;; ;; This function might do hidden buffer changes. ;;(message "c-font-lock-declarations search from %s to %s" (point) limit) (save-restriction - (let (;; The position where `c-find-decl-spots' stopped. + (let (;; The position where `c-find-decl-spots' last stopped. start-pos - ;; 'decl if we're in an arglist containing declarations (but - ;; if `c-recognize-paren-inits' is set it might also be an - ;; initializer arglist), '<> if the arglist is of angle - ;; bracket type, 'arglist if it's some other arglist, or nil - ;; if not in an arglist at all. + ;; o - 'decl if we're in an arglist containing declarations + ;; (but if `c-recognize-paren-inits' is set it might also be + ;; an initializer arglist); + ;; o - '<> if the arglist is of angle bracket type; + ;; o - 'arglist if it's some other arglist; + ;; o - nil, if not in an arglist at all. This includes the + ;; parenthesised condition which follows "if", "while", etc. context ;; The position of the next token after the closing paren of ;; the last detected cast. last-cast-end + ;; Start of containing declaration (if any); limit for searching + ;; backwards for it. + decl-start decl-search-lim + ;; Start of containing declaration (if any); limit for searching + ;; backwards for it. + decl-start decl-search-lim ;; The result from `c-forward-decl-or-cast-1'. decl-or-cast ;; The maximum of the end positions of all the checked type @@ -1077,57 +1124,115 @@ casts and declarations are fontified. Used on level 2 and higher." ;; can't start a declaration. t - ;; Set `context'. Look for "<" for the sake of C++-style template - ;; arglists. - (if (memq (char-before match-pos) '(?\( ?, ?\[ ?<)) - - ;; Find out the type of the arglist. - (if (<= match-pos (point-min)) - (setq context 'arglist) - (let ((type (c-get-char-property (1- match-pos) 'c-type))) - (cond ((eq type 'c-decl-arg-start) - ;; Got a cached hit in a declaration arglist. - (setq context 'decl)) - ((or (eq type 'c-<>-arg-sep) - (eq (char-before match-pos) ?<)) - ;; Inside an angle bracket arglist. - (setq context '<>)) - (type - ;; Got a cached hit in some other type of arglist. - (setq context 'arglist)) - ((if inside-macro - (< match-pos max-type-decl-end-before-token) - (< match-pos max-type-decl-end)) - ;; The point is within the range of a previously - ;; encountered type decl expression, so the arglist - ;; is probably one that contains declarations. - ;; However, if `c-recognize-paren-inits' is set it - ;; might also be an initializer arglist. - (setq context 'decl) - ;; The result of this check is cached with a char - ;; property on the match token, so that we can look - ;; it up again when refontifying single lines in a - ;; multiline declaration. - (c-put-char-property (1- match-pos) - 'c-type 'c-decl-arg-start)) - (t - (setq context 'arglist))))) - - (setq context nil)) - - ;; If we're in a normal arglist context we don't want to - ;; recognize commas in nested angle bracket arglists since - ;; those commas could be part of our own arglist. - (setq c-restricted-<>-arglists (and c-recognize-<>-arglists - (eq context 'arglist)) - - ;; Now analyze the construct. - decl-or-cast (c-forward-decl-or-cast-1 + ;; Set `context' and `c-restricted-<>-arglists'. Look for + ;; "<" for the sake of C++-style template arglists. + ;; Ignore "(" when it's part of a control flow construct + ;; (e.g. "for ("). + (let ((type (and (> match-pos (point-min)) + (c-get-char-property (1- match-pos) 'c-type)))) + (cond ((not (memq (char-before match-pos) '(?\( ?, ?\[ ?<))) + (setq context nil + c-restricted-<>-arglists nil)) + ;; A control flow expression + ((and (eq (char-before match-pos) ?\() + (save-excursion + (goto-char match-pos) + (backward-char) + (c-backward-token-2) + (looking-at c-block-stmt-2-key))) + (setq context nil + c-restricted-<>-arglists t)) + ;; Near BOB. + ((<= match-pos (point-min)) + (setq context 'arglist + c-restricted-<>-arglists t)) + ;; Got a cached hit in a declaration arglist. + ((eq type 'c-decl-arg-start) + (setq context 'decl + c-restricted-<>-arglists nil)) + ;; Inside an angle bracket arglist. + ((or (eq type 'c-<>-arg-sep) + (eq (char-before match-pos) ?<)) + (setq context '<> + c-restricted-<>-arglists nil)) + ;; Got a cached hit in some other type of arglist. + (type + (setq context 'arglist + c-restricted-<>-arglists t)) + ((if inside-macro + (< match-pos max-type-decl-end-before-token) + (< match-pos max-type-decl-end)) + ;; The point is within the range of a previously + ;; encountered type decl expression, so the arglist + ;; is probably one that contains declarations. + ;; However, if `c-recognize-paren-inits' is set it + ;; might also be an initializer arglist. + (setq context 'decl + c-restricted-<>-arglists nil) + ;; The result of this check is cached with a char + ;; property on the match token, so that we can look + ;; it up again when refontifying single lines in a + ;; multiline declaration. + (c-put-char-property (1- match-pos) + 'c-type 'c-decl-arg-start)) + (t (setq context 'arglist + c-restricted-<>-arglists t)))) + + ;; Check we haven't missed a preceding "typedef". + (when (not (looking-at c-typedef-key)) + (c-backward-syntactic-ws) + (c-backward-token-2) + (or (looking-at c-typedef-key) + (goto-char start-pos))) + + ;; Now analyze the construct. + (setq decl-or-cast (c-forward-decl-or-cast-1 match-pos context last-cast-end)) (if (not decl-or-cast) - ;; False alarm. Return t to go on to the next check. - t + ;; Are we at a declarator? Try to go back to the declaration + ;; to check this. Note that `c-beginning-of-decl-1' is slow, + ;; so we cache its result between calls. + (let (paren-state bod-res encl-pos is-typedef) + (goto-char start-pos) + (save-excursion + (unless (and decl-search-lim + (eq decl-search-lim + (save-excursion + (c-syntactic-skip-backward "^;" nil t) + (point)))) + (setq decl-search-lim + (and (c-syntactic-skip-backward "^;" nil t) (point))) + (setq bod-res (car (c-beginning-of-decl-1 decl-search-lim))) + (if (and (eq bod-res 'same) + (progn + (c-backward-syntactic-ws) + (eq (char-before) ?\}))) + (c-beginning-of-decl-1 decl-search-lim)) + (setq decl-start (point)))) + + (save-excursion + (goto-char decl-start) + ;; We're now putatively at the declaration. + (setq paren-state (c-parse-state)) + ;; At top level or inside a "{"? + (if (or (not (setq encl-pos + (c-most-enclosing-brace paren-state))) + (eq (char-after encl-pos) ?\{)) + (progn + (when (looking-at c-typedef-key) ; "typedef" + (setq is-typedef t) + (goto-char (match-end 0)) + (c-forward-syntactic-ws)) + ;; At a real declaration? + (if (memq (c-forward-type t) '(t known found)) + (progn + (c-font-lock-declarators limit t is-typedef) + nil) + ;; False alarm. Return t to go on to the next check. + (goto-char start-pos) + t)) + t))) (if (eq decl-or-cast 'cast) ;; Save the position after the previous cast so we can feed @@ -1216,6 +1321,40 @@ casts and declarations are fontified. Used on level 2 and higher." nil))) +(defun c-font-lock-enum-tail (limit) + ;; Fontify an enum's identifiers when POINT is within the enum's brace + ;; block. + ;; + ;; This function will be called from font-lock for a region bounded by POINT + ;; and LIMIT, as though it were to identify a keyword for + ;; font-lock-keyword-face. It always returns NIL to inhibit this and + ;; prevent a repeat invocation. See elisp/lispref page "Search-based + ;; Fontification". + ;; + ;; Note that this function won't attempt to fontify beyond the end of the + ;; current enum block, if any. + (let* ((paren-state (c-parse-state)) + (encl-pos (c-most-enclosing-brace paren-state)) + (start (point)) + ) + (when (and + encl-pos + (eq (char-after encl-pos) ?\{) + (save-excursion + (goto-char encl-pos) + (c-backward-syntactic-ws) + (c-simple-skip-symbol-backward) + (or (looking-at c-brace-list-key) ; "enum" + (progn (c-backward-syntactic-ws) + (c-simple-skip-symbol-backward) + (looking-at c-brace-list-key))))) + (c-syntactic-skip-backward "^{," nil t) + (c-put-char-property (1- (point)) 'c-type 'c-decl-id-start) + + (c-forward-syntactic-ws) + (c-font-lock-declarators limit t nil))) + nil) + (c-lang-defconst c-simple-decl-matchers "Simple font lock matchers for types and declarations. These are used on level 2 only and so aren't combined with `c-complex-decl-matchers'." @@ -1291,7 +1430,7 @@ on level 2 only and so aren't combined with `c-complex-decl-matchers'." "Complex font lock matchers for types and declarations. Used on level 3 and higher." - ;; Note: This code in this form dumps a number of funtions into the + ;; Note: This code in this form dumps a number of functions into the ;; resulting constant, `c-matchers-3'. At run time, font lock will call ;; each of them as a "FUNCTION" (see Elisp page "Search-based ;; Fontification"). The font lock region is delimited by POINT and the @@ -1343,7 +1482,7 @@ on level 2 only and so aren't combined with `c-complex-decl-matchers'." `(,(concat "\\<\\(" re "\\)\\>") 1 'font-lock-type-face))) - ;; Fontify types preceded by `c-type-prefix-kwds'. + ;; Fontify types preceded by `c-type-prefix-kwds' (e.g. "struct"). ,@(when (c-lang-const c-type-prefix-kwds) `((,(byte-compile `(lambda (limit) @@ -1391,23 +1530,25 @@ on level 2 only and so aren't combined with `c-complex-decl-matchers'." ;; override it if it turns out to be an new declaration, but ;; it will be wrong if it's an expression (see the test ;; decls-8.cc). - ,@(when (c-lang-const c-opt-block-decls-with-vars-key) - `((,(c-make-font-lock-search-function - (concat "}" - (c-lang-const c-single-line-syntactic-ws) - "\\(" ; 1 + c-single-line-syntactic-ws-depth - (c-lang-const c-type-decl-prefix-key) - "\\|" - (c-lang-const c-symbol-key) - "\\)") - `((c-font-lock-declarators limit t nil) - (progn - (c-put-char-property (match-beginning 0) 'c-type - 'c-decl-id-start) - (goto-char (match-beginning - ,(1+ (c-lang-const - c-single-line-syntactic-ws-depth))))) - (goto-char (match-end 0))))))) +;; ,@(when (c-lang-const c-opt-block-decls-with-vars-key) +;; `((,(c-make-font-lock-search-function +;; (concat "}" +;; (c-lang-const c-single-line-syntactic-ws) +;; "\\(" ; 1 + c-single-line-syntactic-ws-depth +;; (c-lang-const c-type-decl-prefix-key) +;; "\\|" +;; (c-lang-const c-symbol-key) +;; "\\)") +;; `((c-font-lock-declarators limit t nil) ; That `nil' says use `font-lock-variable-name-face'; +;; ; `t' would mean `font-lock-function-name-face'. +;; (progn +;; (c-put-char-property (match-beginning 0) 'c-type +;; 'c-decl-id-start) +;; ; 'c-decl-type-start) +;; (goto-char (match-beginning +;; ,(1+ (c-lang-const +;; c-single-line-syntactic-ws-depth))))) +;; (goto-char (match-end 0))))))) ;; Fontify the type in C++ "new" expressions. ,@(when (c-major-mode-is 'c++-mode) @@ -1478,11 +1619,14 @@ on level 2 only and so aren't combined with `c-complex-decl-matchers'." generic casts and declarations are fontified. Used on level 2 and higher." - t `(;; Fontify the identifiers inside enum lists. (The enum type + t `(,@(when (c-lang-const c-brace-id-list-kwds) + ;; Fontify the remaining identifiers inside an enum list when we start + ;; inside it. + `(c-font-lock-enum-tail + ;; Fontify the identifiers inside enum lists. (The enum type ;; name is handled by `c-simple-decl-matchers' or ;; `c-complex-decl-matchers' below. - ,@(when (c-lang-const c-brace-id-list-kwds) - `((,(c-make-font-lock-search-function + (,(c-make-font-lock-search-function (concat "\\<\\(" (c-make-keywords-re nil (c-lang-const c-brace-id-list-kwds)) @@ -1537,6 +1681,9 @@ higher." '((c-fontify-types-and-refs ((c-promote-possible-types t)) (c-forward-keyword-clause 1) (if (> (point) limit) (goto-char limit)))))))) + + ,@(when (c-major-mode-is 'java-mode) + `((eval . (list "\\<\\(@[a-zA-Z0-9]+\\)\\>" 1 c-annotation-face)))) )) (c-lang-defconst c-matchers-1 @@ -1652,6 +1799,10 @@ need for `c-font-lock-extra-types'.") ;;; C++. (defun c-font-lock-c++-new (limit) + ;; FIXME!!! Put in a comment about the context of this function's + ;; invocation. I think it's called as an ANCHORED-MATCHER within an + ;; ANCHORED-HIGHLIGHTER. (2007/2/10). + ;; ;; Assuming point is after a "new" word, check that it isn't inside ;; a string or comment, and if so try to fontify the type in the ;; allocation expression. Nil is always returned. diff --git a/lisp/progmodes/cc-langs.el b/lisp/progmodes/cc-langs.el index ac6ff40b4c0..ad6b6787652 100644 --- a/lisp/progmodes/cc-langs.el +++ b/lisp/progmodes/cc-langs.el @@ -12,8 +12,8 @@ ;; 1985 Richard M. Stallman ;; Maintainer: bug-cc-mode@gnu.org ;; Created: 22-Apr-1997 (split from cc-mode.el) -;; Version: See cc-mode.el -;; Keywords: c languages oop +;; Keywords: c languages +;; Package: cc-mode ;; This file is part of GNU Emacs. @@ -359,7 +359,7 @@ The syntax tables aren't stored directly since they're quite large." (let ((table (make-syntax-table))) (c-populate-syntax-table table) ;; Mode specific syntaxes. - ,(cond ((c-major-mode-is 'objc-mode) + ,(cond ((or (c-major-mode-is 'objc-mode) (c-major-mode-is 'java-mode)) ;; Let '@' be part of symbols in ObjC to cope with ;; its compiler directives as single keyword tokens. ;; This is then necessary since it's assumed that @@ -382,7 +382,7 @@ The syntax tables aren't stored directly since they're quite large." ;; '<' and '>' characters. Therefore this syntax table might go ;; away when CC Mode handles templates correctly everywhere. t nil - c++ `(lambda () + (java c++) `(lambda () (let ((table (funcall ,(c-lang-const c-make-mode-syntax-table)))) (modify-syntax-entry ?< "(>" table) (modify-syntax-entry ?> ")<" table) @@ -391,6 +391,27 @@ The syntax tables aren't stored directly since they're quite large." (and (c-lang-const c++-make-template-syntax-table) (funcall (c-lang-const c++-make-template-syntax-table)))) +(c-lang-defconst c-no-parens-syntax-table + ;; A variant of the standard syntax table which is used to find matching + ;; "<"s and ">"s which have been marked as parens using syntax table + ;; properties. The other paren characters (e.g. "{", ")" "]") are given a + ;; non-paren syntax here. so that the list commands will work on "< ... >" + ;; even when there's unbalanced other parens inside them. + ;; + ;; This variable is nil for languages which don't have template stuff. + t `(lambda () + (if (c-lang-const c-recognize-<>-arglists) + (let ((table (funcall ,(c-lang-const c-make-mode-syntax-table)))) + (modify-syntax-entry ?\( "." table) + (modify-syntax-entry ?\) "." table) + (modify-syntax-entry ?\[ "." table) + (modify-syntax-entry ?\] "." table) + (modify-syntax-entry ?\{ "." table) + (modify-syntax-entry ?\} "." table) + table)))) +(c-lang-defvar c-no-parens-syntax-table + (funcall (c-lang-const c-no-parens-syntax-table))) + (c-lang-defconst c-identifier-syntax-modifications "A list that describes the modifications that should be done to the mode syntax table to get a syntax table that matches all identifiers @@ -404,7 +425,7 @@ the new syntax, as accepted by `modify-syntax-entry'." ;; it as an indentifier character since it's often used in various ;; machine generated identifiers. t '((?_ . "w") (?$ . "w")) - objc (append '((?@ . "w")) + (objc java) (append '((?@ . "w")) (c-lang-const c-identifier-syntax-modifications)) awk '((?_ . "w"))) (c-lang-defvar c-identifier-syntax-modifications @@ -423,26 +444,36 @@ the new syntax, as accepted by `modify-syntax-entry'." classifies symbol constituents like '_' and '$' as word constituents, so that all identifiers are recognized as words.") -(c-lang-defconst c-get-state-before-change-function - "If non-nil, a function called from c-before-change-hook. -Typically it will record enough state to allow +(c-lang-defconst c-get-state-before-change-functions + ;; For documentation see the following c-lang-defvar of the same name. + ;; The value here may be a list of functions or a single function. + t nil + c++ '(c-extend-region-for-CPP c-before-change-check-<>-operators) + (c objc) 'c-extend-region-for-CPP + ;; java 'c-before-change-check-<>-operators + awk 'c-awk-record-region-clear-NL) +(c-lang-defvar c-get-state-before-change-functions + (let ((fs (c-lang-const c-get-state-before-change-functions))) + (if (listp fs) + fs + (list fs))) + "If non-nil, a list of functions called from c-before-change-hook. +Typically these will record enough state to allow `c-before-font-lock-function' to extend the region to fontify, and may do such things as removing text-properties which must be recalculated. -It takes 2 parameters, the BEG and END supplied to every +These functions will be run in the order given. Each of them +takes 2 parameters, the BEG and END supplied to every before-change function; on entry, the buffer will have been widened and match-data will have been saved; point is undefined on both entry and exit; the return value is ignored. -When the mode is initialized, this function is called with -parameters \(point-min) and \(point-max)." - t nil - (c c++ objc) 'c-extend-region-for-CPP - awk 'c-awk-record-region-clear-NL) -(c-lang-defvar c-get-state-before-change-function - (c-lang-const c-get-state-before-change-function)) - +The functions are called even when font locking isn't enabled. + +When the mode is initialized, the functions are called with +parameters \(point-min) and \(point-max).") + (c-lang-defconst c-before-font-lock-function "If non-nil, a function called just before font locking. Typically it will extend the region about to be fontified \(see @@ -461,7 +492,7 @@ The function is called even when font locking is disabled. When the mode is initialized, this function is called with parameters \(point-min), \(point-max) and <buffer size>." t nil - (c c++ objc) 'c-extend-and-neutralize-syntax-in-CPP + (c c++ objc) 'c-neutralize-syntax-in-and-mark-CPP awk 'c-awk-extend-and-syntax-tablify-region) (c-lang-defvar c-before-font-lock-function (c-lang-const c-before-font-lock-function)) @@ -471,9 +502,10 @@ parameters \(point-min), \(point-max) and <buffer size>." (c-lang-defconst c-symbol-start "Regexp that matches the start of a symbol, i.e. any identifier or -keyword. It's unspecified how far it matches. Does not contain a \\| +keyword. It's unspecified how far it matches. Does not contain a \\| operator at the top level." t (concat "[" c-alpha "_]") + java (concat "[" c-alpha "_@]") objc (concat "[" c-alpha "@]") pike (concat "[" c-alpha "_`]")) (c-lang-defvar c-symbol-start (c-lang-const c-symbol-start)) @@ -828,7 +860,7 @@ since CC Mode treats every identifier as an expression." ;; Primary. ,@(c-lang-const c-identifier-ops) - ,@(cond ((c-major-mode-is 'c++-mode) + ,@(cond ((or (c-major-mode-is 'c++-mode) (c-major-mode-is 'java-mode)) `((postfix-if-paren "<" ">"))) ; Templates. ((c-major-mode-is 'pike-mode) `((prefix "global" "predef"))) @@ -1087,6 +1119,7 @@ operators." t "\\`<." (lambda (op) (substring op 1))))) + (c-lang-defvar c-<-op-cont-regexp (c-lang-const c-<-op-cont-regexp)) (c-lang-defconst c->-op-cont-regexp @@ -1096,7 +1129,13 @@ operators." (c-filter-ops (c-lang-const c-all-op-syntax-tokens) t "\\`>." - (lambda (op) (substring op 1))))) + (lambda (op) (substring op 1)))) + java (c-make-keywords-re nil + (c-filter-ops (c-lang-const c-all-op-syntax-tokens) + t + "\\`>[^>]\\|\\`>>[^>]" + (lambda (op) (substring op 1))))) + (c-lang-defvar c->-op-cont-regexp (c-lang-const c->-op-cont-regexp)) (c-lang-defconst c-stmt-delim-chars @@ -1526,6 +1565,17 @@ be a subset of `c-primitive-type-kwds'." ;; In CORBA PSDL: "strong")) +(c-lang-defconst c-typedef-kwds + "Prefix keyword\(s\) like \"typedef\" which make a type declaration out +of a variable declaration." + t '("typedef") + (awk idl java) nil) + +(c-lang-defconst c-typedef-key + ;; Adorned regexp matching `c-typedef-kwds'. + t (c-make-keywords-re t (c-lang-const c-typedef-kwds))) +(c-lang-defvar c-typedef-key (c-lang-const c-typedef-key)) + (c-lang-defconst c-type-prefix-kwds "Keywords where the following name - if any - is a type name, and where the keyword together with the symbol works as a type in @@ -1597,7 +1647,7 @@ following identifier as a type; the keyword must also be present on c++ '("class" "struct" "union") objc '("struct" "union" "@interface" "@implementation" "@protocol") - java '("class" "interface") + java '("class" "@interface" "interface") idl '("component" "eventtype" "exception" "home" "interface" "struct" "union" "valuetype" ;; In CORBA PSDL: @@ -1620,7 +1670,7 @@ If any of these also are on `c-type-list-kwds', `c-ref-list-kwds', `c-<>-type-kwds', or `c-<>-arglist-kwds' then the associated clauses will be handled." t '("enum") - (java awk) nil) + (awk) nil) (c-lang-defconst c-brace-list-key ;; Regexp matching the start of declarations where the following @@ -1692,6 +1742,10 @@ will be handled." ;; types in IDL since they only can occur in "raises" specs. idl (delete "exception" (append (c-lang-const c-typedef-decl-kwds) nil))) +(c-lang-defconst c-typedef-decl-key + t (c-make-keywords-re t (c-lang-const c-typedef-decl-kwds))) +(c-lang-defvar c-typedef-decl-key (c-lang-const c-typedef-decl-key)) + (c-lang-defconst c-typeless-decl-kwds "Keywords introducing declarations where the \(first) identifier \(declarator) follows directly after the keyword, without any type. @@ -1741,7 +1795,7 @@ will be handled." "bindsTo" "delegatesTo" "implements" "proxy" "storedOn") ;; Note: "const" is not used in Java, but it's still a reserved keyword. java '("abstract" "const" "final" "native" "private" "protected" "public" - "static" "strictfp" "synchronized" "transient" "volatile") + "static" "strictfp" "synchronized" "transient" "volatile" "@[A-Za-z0-9]+") pike '("final" "inline" "local" "nomask" "optional" "private" "protected" "public" "static" "variant")) @@ -1827,7 +1881,11 @@ one of `c-type-list-kwds', `c-ref-list-kwds', (c-lang-defconst c-prefix-spec-kwds-re ;; Adorned regexp of `c-prefix-spec-kwds'. - t (c-make-keywords-re t (c-lang-const c-prefix-spec-kwds))) + t (c-make-keywords-re t (c-lang-const c-prefix-spec-kwds)) + java (replace-regexp-in-string + "\\\\\\[" "[" + (replace-regexp-in-string "\\\\\\+" "+" (c-make-keywords-re t (c-lang-const c-prefix-spec-kwds))))) + (c-lang-defvar c-prefix-spec-kwds-re (c-lang-const c-prefix-spec-kwds-re)) (c-lang-defconst c-specifier-key @@ -1919,7 +1977,7 @@ or variable identifier (that's being defined)." t nil c++ '("operator") objc '("@class") - java '("import" "new" "extends" "implements" "throws") + java '("import" "new" "extends" "super" "implements" "throws") idl '("manages" "native" "primarykey" "supports" ;; In CORBA PSDL: "as" "implements" "of" "scope") @@ -2468,7 +2526,7 @@ more info." ;; in all languages except Java for when a cpp macro definition ;; begins with a declaration. t "\\([\{\}\(\);,]+\\)" - java "\\([\{\}\(;,]+\\)" + java "\\([\{\}\(;,<]+\\)" ;; Match "<" in C++ to get the first argument in a template arglist. ;; In that case there's an additional check in `c-find-decl-spots' ;; that it got open paren syntax. @@ -2618,15 +2676,15 @@ Identifier syntax is in effect when this is matched \(see c++ (concat "\\(" "[*\(&]" "\\|" - (concat "\\(" ; 2 + (c-lang-const c-type-decl-prefix-key) + "\\|" + (concat "\\(" ; 3 ;; If this matches there's special treatment in ;; `c-font-lock-declarators' and ;; `c-font-lock-declarations' that check for a ;; complete name followed by ":: *". (c-lang-const c-identifier-start) "\\)") - "\\|" - (c-lang-const c-type-decl-prefix-key) "\\)" "\\([^=]\\|$\\)") pike "\\(\\*\\)\\([^=]\\|$\\)") @@ -2728,7 +2786,7 @@ It's undefined whether identifier syntax (see `c-identifier-syntax-table') is in effect or not." t nil (c c++ objc pike) "\\(\\.\\.\\.\\)" - java (concat "\\(\\[" (c-lang-const c-simple-ws) "*\\]\\)")) + java (concat "\\(\\[" (c-lang-const c-simple-ws) "*\\]\\|\\.\\.\\.\\)")) (c-lang-defvar c-opt-type-suffix-key (c-lang-const c-opt-type-suffix-key)) (c-lang-defvar c-known-type-key diff --git a/lisp/progmodes/cc-menus.el b/lisp/progmodes/cc-menus.el index ae346afa548..e27335e1f58 100644 --- a/lisp/progmodes/cc-menus.el +++ b/lisp/progmodes/cc-menus.el @@ -11,8 +11,8 @@ ;; 1985 Richard M. Stallman ;; Maintainer: bug-cc-mode@gnu.org ;; Created: 22-Apr-1997 (split from cc-mode.el) -;; Version: See cc-mode.el -;; Keywords: c languages oop +;; Keywords: c languages +;; Package: cc-mode ;; This file is part of GNU Emacs. diff --git a/lisp/progmodes/cc-mode.el b/lisp/progmodes/cc-mode.el index 6b0d3f8b423..9524ff27d24 100644 --- a/lisp/progmodes/cc-mode.el +++ b/lisp/progmodes/cc-mode.el @@ -1,8 +1,8 @@ ;;; cc-mode.el --- major mode for editing C and similar languages ;; Copyright (C) 1985, 1987, 1992, 1993, 1994, 1995, 1996, 1997, 1998, -;; 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. +;; 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, +;; 2010 Free Software Foundation, Inc. ;; Authors: 2003- Alan Mackenzie ;; 1998- Martin Stjernholm @@ -12,7 +12,7 @@ ;; 1985 Richard M. Stallman ;; Maintainer: bug-cc-mode@gnu.org ;; Created: a long, long, time ago. adapted from the original c-mode.el -;; Keywords: c languages oop +;; Keywords: c languages ;; This file is part of GNU Emacs. @@ -100,7 +100,6 @@ (cc-bytecomp-defvar adaptive-fill-first-line-regexp) ; Emacs (cc-bytecomp-defun set-keymap-parents) ; XEmacs (cc-bytecomp-defun run-mode-hooks) ; Emacs 21.1 -(cc-bytecomp-obsolete-fun make-local-hook) ; Marked obsolete in Emacs 21.1. ;; We set these variables during mode init, yet we don't require ;; font-lock. @@ -410,7 +409,7 @@ preferably use the `c-mode-menu' language constant directly." ;; temporary changes in some font lock support modes, causing extra ;; unnecessary work and font lock glitches due to interactions between ;; various text properties. -;; +;; ;; (2007-02-12): The macro `combine-after-change-calls' ISN'T used any ;; more. @@ -451,18 +450,18 @@ preferably use the `c-mode-menu' language constant directly." end (point)))))))) ;; c-maybe-stale-found-type records a place near the region being -;; changed where an element of `found-types' might become stale. It +;; changed where an element of `found-types' might become stale. It ;; is set in c-before-change and is either nil, or has the form: ;; ;; (c-decl-id-start "foo" 97 107 " (* ooka) " "o"), where -;; +;; ;; o - `c-decl-id-start' is the c-type text property value at buffer ;; pos 96. -;; +;; ;; o - 97 107 is the region potentially containing the stale type - ;; this is delimited by a non-nil c-type text property at 96 and ;; either another one or a ";", "{", or "}" at 107. -;; +;; ;; o - " (* ooka) " is the (before change) buffer portion containing ;; the suspect type (here "ooka"). ;; @@ -517,9 +516,12 @@ that requires a literal mode spec at compile time." (make-local-variable 'fill-paragraph-function) (setq fill-paragraph-function 'c-fill-paragraph) + ;; Initialise the cache of brace pairs, and opening braces/brackets/parens. + (c-state-cache-init) + (when (or c-recognize-<>-arglists (c-major-mode-is 'awk-mode) - (c-major-mode-is '(c-mode c++-mode objc-mode))) + (c-major-mode-is '(java-mode c-mode c++-mode objc-mode))) ;; We'll use the syntax-table text property to change the syntax ;; of some chars for this language, so do the necessary setup for ;; that. @@ -597,9 +599,10 @@ that requires a literal mode spec at compile time." ;; Install the functions that ensure that various internal caches ;; don't become invalid due to buffer changes. - (make-local-hook 'before-change-functions) + (when (featurep 'xemacs) + (make-local-hook 'before-change-functions) + (make-local-hook 'after-change-functions)) (add-hook 'before-change-functions 'c-before-change nil t) - (make-local-hook 'after-change-functions) (add-hook 'after-change-functions 'c-after-change nil t) (set (make-local-variable 'font-lock-extend-after-change-region-function) 'c-extend-after-change-region)) ; Currently (2009-05) used by all @@ -613,6 +616,15 @@ that requires a literal mode spec at compile time." (font-lock-mode 0) (font-lock-mode 1))) +;; Buffer local variables defining the region to be fontified by a font lock +;; after-change function. They are set in c-after-change to +;; after-change-function's BEG and END, and may be modified by a +;; `c-before-font-lock-function'. +(defvar c-new-BEG 0) +(make-variable-buffer-local 'c-new-BEG) +(defvar c-new-END 0) +(make-variable-buffer-local 'c-new-END) + (defun c-common-init (&optional mode) "Common initialization for all CC Mode modes. In addition to the work done by `c-basic-common-init' and @@ -637,9 +649,13 @@ compatible with old code; callers should always specify it." ;; Starting a mode is a sort of "change". So call the change functions... (save-restriction (widen) + (setq c-new-BEG (point-min)) + (setq c-new-END (point-max)) (save-excursion - (if c-get-state-before-change-function - (funcall c-get-state-before-change-function (point-min) (point-max))) + (if c-get-state-before-change-functions + (mapc (lambda (fn) + (funcall fn (point-min) (point-max))) + c-get-state-before-change-functions)) (if c-before-font-lock-function (funcall c-before-font-lock-function (point-min) (point-max) (- (point-max) (point-min)))))) @@ -655,6 +671,17 @@ compatible with old code; callers should always specify it." (and (cdr rfn) (setq require-final-newline mode-require-final-newline))))) +(defun c-count-cfss (lv-alist) + ;; LV-ALIST is an alist like `file-local-variables-alist'. Count how many + ;; elements with the key `c-file-style' there are in it. + (let ((elt-ptr lv-alist) elt (cownt 0)) + (while elt-ptr + (setq elt (car elt-ptr) + elt-ptr (cdr elt-ptr)) + (when (eq (car elt) 'c-file-style) + (setq cownt (1+ cownt)))) + cownt)) + (defun c-before-hack-hook () "Set the CC Mode style and \"offsets\" when in the buffer's local variables. They are set only when, respectively, the pseudo variables @@ -671,7 +698,15 @@ This function is called from the hook `before-hack-local-variables-hook'." (delq mode-cons file-local-variables-alist))) (when stile (or (stringp stile) (error "c-file-style is not a string")) - (c-set-style stile)) + (if (boundp 'dir-local-variables-alist) + ;; Determine whether `c-file-style' was set in the file's local + ;; variables or in a .dir-locals.el (a directory setting). + (let ((cfs-in-file-and-dir-count + (c-count-cfss file-local-variables-alist)) + (cfs-in-dir-count (c-count-cfss dir-local-variables-alist))) + (c-set-style stile + (= cfs-in-file-and-dir-count cfs-in-dir-count))) + (c-set-style stile))) (when offsets (mapc (lambda (langentry) @@ -777,7 +812,7 @@ Note that the style variables are always made local to the buffer." (defmacro c-run-mode-hooks (&rest hooks) ;; Emacs 21.1 has introduced a system with delayed mode hooks that - ;; require the use of the new function `run-mode-hooks'. + ;; requires the use of the new function `run-mode-hooks'. (if (cc-bytecomp-fboundp 'run-mode-hooks) `(run-mode-hooks ,@hooks) `(progn ,@(mapcar (lambda (hook) `(run-hooks ,hook)) hooks)))) @@ -785,15 +820,6 @@ Note that the style variables are always made local to the buffer." ;;; Change hooks, linking with Font Lock. -;; Buffer local variables defining the region to be fontified by a font lock -;; after-change function. They are set in c-after-change to -;; after-change-function's BEG and END, and may be modified by a -;; `c-before-font-lock-function'. -(defvar c-new-BEG 0) -(make-variable-buffer-local 'c-new-BEG) -(defvar c-new-END 0) -(make-variable-buffer-local 'c-new-END) - ;; Buffer local variables recording Beginning/End-of-Macro position before a ;; change, when a macro straddles, respectively, the BEG or END (or both) of ;; the change region. Otherwise these have the values BEG/END. @@ -810,16 +836,18 @@ Note that the style variables are always made local to the buffer." ;; has already been widened, and match-data saved. The return value is ;; meaningless. ;; - ;; This function is the C/C++/ObjC value of - ;; `c-get-state-before-change-function' and is called exclusively as a + ;; This function is in the C/C++/ObjC values of + ;; `c-get-state-before-change-functions' and is called exclusively as a ;; before change function. (goto-char beg) (c-beginning-of-macro) (setq c-old-BOM (point)) (goto-char end) - (if (c-beginning-of-macro) - (c-end-of-macro)) + (when (c-beginning-of-macro) + (c-end-of-macro) + (or (eobp) (forward-char))) ; Over the terminating NL which may be marked + ; with a c-cpp-delimiter category property (setq c-old-EOM (point))) (defun c-neutralize-CPP-line (beg end) @@ -848,7 +876,7 @@ Note that the style variables are always made local to the buffer." t) (t nil))))))) -(defun c-extend-and-neutralize-syntax-in-CPP (begg endd old-len) +(defun c-neutralize-syntax-in-and-mark-CPP (begg endd old-len) ;; (i) Extend the font lock region to cover all changed preprocessor ;; regions; it does this by setting the variables `c-new-BEG' and ;; `c-new-END' to the new boundaries. @@ -857,10 +885,15 @@ Note that the style variables are always made local to the buffer." ;; extended changed region. "Restore" lines which were CPP lines before the ;; change and are no longer so; these can be located from the Buffer local ;; variables `c-old-BOM' and `c-old-EOM'. - ;; + ;; + ;; (iii) Mark every CPP construct by placing a `category' property value + ;; `c-cpp-delimiter' at its start and end. The marked characters are the + ;; opening # and usually the terminating EOL, but sometimes the character + ;; before a comment/string delimiter. + ;; ;; That is, set syntax-table properties on characters that would otherwise ;; interact syntactically with those outside the CPP line(s). - ;; + ;; ;; This function is called from an after-change function, BEGG ENDD and ;; OLD-LEN being the standard parameters. It prepares the buffer for font ;; locking, hence must get called before `font-lock-after-change-function'. @@ -871,32 +904,36 @@ Note that the style variables are always made local to the buffer." ;; This function is the C/C++/ObjC value of `c-before-font-lock-function'. ;; ;; Note: SPEED _MATTERS_ IN THIS FUNCTION!!! - ;; + ;; ;; This function might make hidden buffer changes. - (c-save-buffer-state (limits mbeg+1) + (c-save-buffer-state (limits) ;; First determine the region, (c-new-BEG c-new-END), which will get font ;; locked. It might need "neutralizing". This region may not start ;; inside a string, comment, or macro. (goto-char c-old-BOM) ; already set to old start of macro or begg. (setq c-new-BEG - (if (setq limits (c-literal-limits)) - (cdr limits) ; go forward out of any string or comment. - (point))) + (min c-new-BEG + (if (setq limits (c-state-literal-at (point))) + (cdr limits) ; go forward out of any string or comment. + (point)))) (goto-char endd) - (if (setq limits (c-literal-limits)) + (if (setq limits (c-state-literal-at (point))) (goto-char (car limits))) ; go backward out of any string or comment. (if (c-beginning-of-macro) (c-end-of-macro)) - (setq c-new-END (max (+ (- c-old-EOM old-len) (- endd begg)) - (point))) + (setq c-new-END (max c-new-END + (+ (- c-old-EOM old-len) (- endd begg)) + (point))) - ;; Clear any existing punctuation properties. + ;; Clear all old relevant properties. (c-clear-char-property-with-value c-new-BEG c-new-END 'syntax-table '(1)) + (c-clear-char-property-with-value c-new-BEG c-new-END 'category 'c-cpp-delimiter) + ;; FIXME!!! What about the "<" and ">" category properties? 2009-11-16 ;; Add needed properties to each CPP construct in the region. (goto-char c-new-BEG) - (let ((pps-position c-new-BEG) pps-state) + (let ((pps-position c-new-BEG) pps-state mbeg) (while (and (< (point) c-new-END) (search-forward-regexp c-anchored-cpp-prefix c-new-END t)) ;; If we've found a "#" inside a string/comment, ignore it. @@ -905,18 +942,24 @@ Note that the style variables are always made local to the buffer." pps-position (point)) (unless (or (nth 3 pps-state) ; in a string? (nth 4 pps-state)) ; in a comment? - (setq mbeg+1 (point)) - (c-end-of-macro) ; Do we need to go forward 1 char here? No! - (c-neutralize-CPP-line mbeg+1 (point)) - (setq pps-position (point))))))) ; no need to update pps-state. + (goto-char (match-beginning 0)) + (setq mbeg (point)) + (if (> (c-syntactic-end-of-macro) mbeg) + (progn + (c-neutralize-CPP-line mbeg (point)) + (c-set-cpp-delimiters mbeg (point)) + ;(setq pps-position (point)) + ) + (forward-line)) ; no infinite loop with, e.g., "#//" + ))))) (defun c-before-change (beg end) - ;; Function to be put on `before-change-function'. Primarily, this calls - ;; the language dependent `c-get-state-before-change-function'. It is + ;; Function to be put on `before-change-functions'. Primarily, this calls + ;; the language dependent `c-get-state-before-change-functions'. It is ;; otherwise used only to remove stale entries from the `c-found-types' ;; cache, and to record entries which a `c-after-change' function might ;; confirm as stale. - ;; + ;; ;; Note that this function must be FAST rather than accurate. Note ;; also that it only has any effect when font locking is enabled. ;; We exploit this by checking for font-lock-*-face instead of doing @@ -986,12 +1029,10 @@ Note that the style variables are always made local to the buffer." (buffer-substring-no-properties type-pos term-pos) (buffer-substring-no-properties beg end))))))) - ;; (c-new-BEG c-new-END) will be the region to fontify. It may become - ;; larger than (beg end). - (setq c-new-BEG beg - c-new-END end) - (if c-get-state-before-change-function - (funcall c-get-state-before-change-function beg end)) + (if c-get-state-before-change-functions + (mapc (lambda (fn) + (funcall fn beg end)) + c-get-state-before-change-functions)) )))) (defun c-after-change (beg end old-len) @@ -1025,6 +1066,14 @@ Note that the style variables are always made local to the buffer." (when (> beg end) (setq beg end))) + ;; C-y is capable of spuriously converting category properties + ;; c-</>-as-paren-syntax into hard syntax-table properties. Remove + ;; these when it happens. + (c-clear-char-property-with-value beg end 'syntax-table + c-<-as-paren-syntax) + (c-clear-char-property-with-value beg end 'syntax-table + c->-as-paren-syntax) + (c-trim-found-types beg end old-len) ; maybe we don't need all of these. (c-invalidate-sws-region-after beg end) (c-invalidate-state-cache beg) @@ -1033,6 +1082,10 @@ Note that the style variables are always made local to the buffer." (when c-recognize-<>-arglists (c-after-change-check-<>-operators beg end)) + ;; (c-new-BEG c-new-END) will be the region to fontify. It may become + ;; larger than (beg end). + (setq c-new-BEG beg + c-new-END end) (if c-before-font-lock-function (save-excursion (funcall c-before-font-lock-function beg end old-len))))))) @@ -1060,8 +1113,8 @@ This does not load the font-lock package. Use after c-beginning-of-syntax (font-lock-mark-block-function . c-mark-function))) - - (make-local-hook 'font-lock-mode-hook) + (if (featurep 'xemacs) + (make-local-hook 'font-lock-mode-hook)) (add-hook 'font-lock-mode-hook 'c-after-font-lock-init nil t)) (defun c-extend-after-change-region (beg end old-len) diff --git a/lisp/progmodes/cc-styles.el b/lisp/progmodes/cc-styles.el index ec9ffe34624..15d44f6538a 100644 --- a/lisp/progmodes/cc-styles.el +++ b/lisp/progmodes/cc-styles.el @@ -12,8 +12,8 @@ ;; 1985 Richard M. Stallman ;; Maintainer: bug-cc-mode@gnu.org ;; Created: 22-Apr-1997 (split from cc-mode.el) -;; Version: See cc-mode.el -;; Keywords: c languages oop +;; Keywords: c languages +;; Package: cc-mode ;; This file is part of GNU Emacs. @@ -50,7 +50,6 @@ ;; Silence the compiler. (cc-bytecomp-defvar adaptive-fill-first-line-regexp) ; Emacs -(cc-bytecomp-obsolete-fun make-local-hook) ; Marked obsolete in Emacs 21.1. (defvar c-style-alist @@ -649,7 +648,7 @@ any reason to call this function directly." (mapc func varsyms) ;; Hooks must be handled specially (if this-buf-only-p - (make-local-hook 'c-special-indent-hook) + (if (featurep 'xemacs) (make-local-hook 'c-special-indent-hook)) (with-no-warnings (make-variable-buffer-local 'c-special-indent-hook)) (setq c-style-variables-are-local-p t)) )) diff --git a/lisp/progmodes/cc-vars.el b/lisp/progmodes/cc-vars.el index 82015687cb2..e965cc21928 100644 --- a/lisp/progmodes/cc-vars.el +++ b/lisp/progmodes/cc-vars.el @@ -12,8 +12,8 @@ ;; 1985 Richard M. Stallman ;; Maintainer: bug-cc-mode@gnu.org ;; Created: 22-Apr-1997 (split from cc-mode.el) -;; Version: See cc-mode.el -;; Keywords: c languages oop +;; Keywords: c languages +;; Package: cc-mode ;; This file is part of GNU Emacs. @@ -1056,9 +1056,13 @@ can always override the use of `c-default-style' by making calls to ;; Anchor pos: Boi at the topmost intro line. (knr-argdecl . 0) ;; Anchor pos: At the beginning of the first K&R argdecl. - (topmost-intro . 0) + (topmost-intro . 0) ;; Anchor pos: Bol at the last line of previous construct. (topmost-intro-cont . c-lineup-topmost-intro-cont) + ;;Anchor pos: Bol at the topmost annotation line + (annotation-top-cont . 0) + ;;Anchor pos: Bol at the topmost annotation line + (annotation-var-cont . +) ;; Anchor pos: Boi at the topmost intro line. (member-init-intro . +) ;; Anchor pos: Boi at the func decl arglist open. @@ -1285,12 +1289,16 @@ Here is the current list of valid syntactic element symbols: between them; in C++ and Java, throws declarations and other things can appear in this context. knr-argdecl-intro -- First line of a K&R C argument declaration. - knr-argdecl -- Subsequent lines in a K&R C argument declaration. - topmost-intro -- The first line in a topmost construct definition. - topmost-intro-cont -- Topmost definition continuation lines. - member-init-intro -- First line in a member initialization list. - member-init-cont -- Subsequent member initialization list lines. - inher-intro -- First line of a multiple inheritance list. + knr-argdecl -- Subsequent lines in a K&R C argument declaration. + topmost-intro -- The first line in a topmost construct definition. + topmost-intro-cont -- Topmost definition continuation lines. + annotation-top-cont -- Topmost definition continuation line where only + annotations are on previous lines. + annotation-var-cont -- A continuation of a C (or like) statement where + only annotations are on previous lines. + member-init-intro -- First line in a member initialization list. + member-init-cont -- Subsequent member initialization list lines. + inher-intro -- First line of a multiple inheritance list. inher-cont -- Subsequent multiple inheritance lines. block-open -- Statement block open brace. block-close -- Statement block close brace. @@ -1376,7 +1384,7 @@ Here is the current list of valid syntactic element symbols: '(defun-block-intro block-open block-close statement statement-cont statement-block-intro statement-case-intro statement-case-open substatement substatement-open substatement-label case-label label - do-while-closure else-clause catch-clause inlambda)) + do-while-closure else-clause catch-clause inlambda annotation-var-cont)) (defcustom c-style-variables-are-local-p t "*Whether style variables should be buffer local by default. @@ -1577,7 +1585,7 @@ names).")) :group 'c) (defcustom java-font-lock-extra-types - (list (concat "[" c-upper "]\\sw*[" c-lower "]\\sw*")) + (list (concat "[" c-upper "]\\sw*[" c-lower "]\\sw")) (c-make-font-lock-extra-types-blurb "Java" "java-mode" (concat "For example, a value of (\"[" c-upper "]\\\\sw*[" c-lower "]\\\\sw*\") means capitalized words are treated as type names (the requirement for a diff --git a/lisp/progmodes/cfengine.el b/lisp/progmodes/cfengine.el index 86a6be40cc5..e074e92fbe5 100644 --- a/lisp/progmodes/cfengine.el +++ b/lisp/progmodes/cfengine.el @@ -83,12 +83,6 @@ This includes those for cfservd as well as cfagent.")) ;; File, acl &c in group: { token ... } ("{[ \t]*\\([^ \t\n]+\\)" 1 font-lock-constant-face))) -(defconst cfengine-font-lock-syntactic-keywords - ;; In the main syntax-table, backslash is marked as a punctuation, because - ;; of its use in DOS-style directory separators. Here we try to recognize - ;; the cases where backslash is used as an escape inside strings. - '(("\\(\\(?:\\\\\\)+\\)\"" 1 "\\"))) - (defvar cfengine-imenu-expression `((nil ,(concat "^[ \t]*" (eval-when-compile (regexp-opt cfengine-actions t)) @@ -237,13 +231,15 @@ to the action header." (set (make-local-variable 'fill-paragraph-function) #'cfengine-fill-paragraph) (define-abbrev-table 'cfengine-mode-abbrev-table cfengine-mode-abbrevs) - ;; Fixme: Use `font-lock-syntactic-keywords' to set the args of - ;; functions in evaluated classes to string syntax, and then obey - ;; syntax properties. (setq font-lock-defaults - '(cfengine-font-lock-keywords nil nil nil beginning-of-line - (font-lock-syntactic-keywords - . cfengine-font-lock-syntactic-keywords))) + '(cfengine-font-lock-keywords nil nil nil beginning-of-line)) + ;; Fixme: set the args of functions in evaluated classes to string + ;; syntax, and then obey syntax properties. + (set (make-local-variable 'syntax-propertize-function) + ;; In the main syntax-table, \ is marked as a punctuation, because + ;; of its use in DOS-style directory separators. Here we try to + ;; recognize the cases where \ is used as an escape inside strings. + (syntax-propertize-rules ("\\(\\(?:\\\\\\)+\\)\"" (1 "\\")))) (setq imenu-generic-expression cfengine-imenu-expression) (set (make-local-variable 'beginning-of-defun-function) #'cfengine-beginning-of-defun) diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el index c8f9834cf64..dd30212085e 100644 --- a/lisp/progmodes/compile.el +++ b/lisp/progmodes/compile.el @@ -164,7 +164,7 @@ and a string describing how the process finished.") (defvar compilation-num-errors-found) -(defconst compilation-error-regexp-alist-alist +(defvar compilation-error-regexp-alist-alist '((absoft "^\\(?:[Ee]rror on \\|[Ww]arning on\\( \\)\\)?[Ll]ine[ \t]+\\([0-9]+\\)[ \t]+\ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1)) @@ -196,6 +196,10 @@ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1)) "^\"\\([^,\" \n\t]+\\)\", line \\([0-9]+\\)\ \\(?:[(. pos]+\\([0-9]+\\))?\\)?[:.,; (-]\\( warning:\\|[-0-9 ]*(W)\\)?" 1 2 3 (4)) + (cucumber + "\\(?:^cucumber\\(?: -p [^[:space:]]+\\)?\\|#\\)\ +\\(?: \\)\\([^\(].*\\):\\([1-9][0-9]*\\)" 1 2) + (edg-1 "^\\([^ \n]+\\)(\\([0-9]+\\)): \\(?:error\\|warnin\\(g\\)\\|remar\\(k\\)\\)" 1 2 nil (3 . 4)) @@ -233,6 +237,10 @@ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1)) nil 1 nil 2 0 (2 (compilation-face '(3)))) + (gcc-include + "^\\(?:In file included \\| \\|\t\\)from \ +\\(.+\\):\\([0-9]+\\)\\(?:\\(:\\)\\|\\(,\\|$\\)\\)?" 1 2 nil (3 . 4)) + (gnu ;; The first line matches the program name for @@ -255,9 +263,11 @@ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1)) ;; The core of the regexp is the one with *?. It says that a file name ;; can be composed of any non-newline char, but it also rules out some ;; valid but unlikely cases, such as a trailing space or a space - ;; followed by a -. - "^\\(?:[[:alpha:]][-[:alnum:].]+: ?\\)?\ -\\([0-9]*[^0-9\n]\\(?:[^\n ]\\| [^-/\n]\\)*?\\): ?\ + ;; followed by a -, or a colon followed by a space. + + ;; The "in \\|from " exception was added to handle messages from Ruby. + "^\\(?:[[:alpha:]][-[:alnum:].]+: ?\\|[ \t]+\\(?:in \\|from \\)\\)?\ +\\([0-9]*[^0-9\n]\\(?:[^\n :]\\| [^-/\n]\\|:[^ \n]\\)*?\\): ?\ \\([0-9]+\\)\\(?:\\([.:]\\)\\([0-9]+\\)\\)?\ \\(?:-\\([0-9]+\\)?\\(?:\\.\\([0-9]+\\)\\)?\\)?:\ \\(?: *\\(\\(?:Future\\|Runtime\\)?[Ww]arning\\|W:\\)\\|\ @@ -265,12 +275,6 @@ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1)) \[0-9]?\\(?:[^0-9\n]\\|$\\)\\|[0-9][0-9][0-9]\\)" 1 (2 . 5) (4 . 6) (7 . 8)) - ;; The `gnu' style above can incorrectly match gcc's "In file - ;; included from" message, so we process that first. -- cyd - (gcc-include - "^\\(?:In file included\\| \\) from \ -\\(.+\\):\\([0-9]+\\)\\(?:\\(:\\)\\|\\(,\\)\\)?" 1 2 nil (3 . 4)) - (lcc "^\\(?:E\\|\\(W\\)\\), \\([^(\n]+\\)(\\([0-9]+\\),[ \t]*\\([0-9]+\\)" 2 3 4 (1)) @@ -325,6 +329,9 @@ during global destruction\\.$\\)" 1 2) "\\(?:Parse\\|Fatal\\) error: \\(.*\\) in \\(.*\\) on line \\([0-9]+\\)" 2 3 nil nil) + (ruby-Test::Unit + "[\t ]*\\[\\([^\(].*\\):\\([1-9][0-9]*\\)\\(\\]\\)?:$" 1 2) + (rxp "^\\(?:Error\\|Warnin\\(g\\)\\):.*\n.* line \\([0-9]+\\) char\ \\([0-9]+\\) of file://\\(.+\\)" @@ -536,7 +543,7 @@ you may also want to change `compilation-page-delimiter'.") ;; Command output lines. Recognize `make[n]:' lines too. ("^\\([[:alnum:]_/.+-]+\\)\\(\\[\\([0-9]+\\)\\]\\)?[ \t]*:" (1 font-lock-function-name-face) (3 compilation-line-face nil t)) - (" --?o\\(?:utfile\\|utput\\)?[= ]?\\(\\S +\\)" . 1) + (" -\\(?:o[= ]?\\|-\\(?:outfile\\|output\\)[= ]\\)\\(\\S +\\)" . 1) ("^Compilation \\(finished\\).*" (0 '(face nil message nil help-echo nil mouse-face nil) t) (1 compilation-info-face)) @@ -583,6 +590,21 @@ Otherwise, it saves all modified buffers without asking." :type 'boolean :group 'compilation) +(defcustom compilation-save-buffers-predicate nil + "The second argument (PRED) passed to `save-some-buffers' before compiling. +E.g., one can set this to + (lambda () + (string-prefix-p my-compilation-root (file-truename (buffer-file-name)))) +to limit saving to files located under `my-compilation-root'. +Note, that, in general, `compilation-directory' cannot be used instead +of `my-compilation-root' here." + :type '(choice + (const :tag "Default (save all file-visiting buffers)" nil) + (const :tag "Save all buffers" t) + function) + :group 'compilation + :version "24.1") + ;;;###autoload (defcustom compilation-search-path '(nil) "List of directories to search for source files named in error messages. @@ -733,6 +755,9 @@ Faces `compilation-error-face', `compilation-warning-face', "If non-nil, automatically jump to the next error encountered.") (make-variable-buffer-local 'compilation-auto-jump-to-next) +(defvar compilation-buffer-modtime nil + "The buffer modification time, for buffers not associated with files.") +(make-variable-buffer-local 'compilation-buffer-modtime) (defvar compilation-skip-to-next-location t "*If non-nil, skip multiple error messages for the same source location.") @@ -743,12 +768,27 @@ The value can be either 2 -- skip anything less than error, 1 -- skip anything less than warning or 0 -- don't skip any messages. Note that all messages not positively identified as warning or info, are considered errors." - :type '(choice (const :tag "Warnings and info" 2) - (const :tag "Info" 1) - (const :tag "None" 0)) + :type '(choice (const :tag "Skip warnings and info" 2) + (const :tag "Skip info" 1) + (const :tag "No skip" 0)) :group 'compilation :version "22.1") +(defun compilation-set-skip-threshold (level) + "Switch the `compilation-skip-threshold' level." + (interactive + (list + (mod (if current-prefix-arg + (prefix-numeric-value current-prefix-arg) + (1+ compilation-skip-threshold)) + 3))) + (setq compilation-skip-threshold level) + (message "Skipping %s" + (case compilation-skip-threshold + (0 "Nothing") + (1 "Info messages") + (2 "Warnings and info")))) + (defcustom compilation-skip-visited nil "Compilation motion commands skip visited messages if this is t. Visited messages are ones for which the file, line and column have been jumped @@ -1094,7 +1134,8 @@ to a function that generates a unique name." (consp current-prefix-arg))) (unless (equal command (eval compile-command)) (setq compile-command command)) - (save-some-buffers (not compilation-ask-about-save) nil) + (save-some-buffers (not compilation-ask-about-save) + compilation-save-buffers-predicate) (setq-default compilation-directory default-directory) (compilation-start command comint)) @@ -1105,7 +1146,8 @@ If this is run in a Compilation mode buffer, re-use the arguments from the original use. Otherwise, recompile using `compile-command'. If the optional argument `edit-command' is non-nil, the command can be edited." (interactive "P") - (save-some-buffers (not compilation-ask-about-save) nil) + (save-some-buffers (not compilation-ask-about-save) + compilation-save-buffers-predicate) (let ((default-directory (or compilation-directory default-directory))) (when edit-command (setcar compilation-arguments @@ -1187,7 +1229,7 @@ Returns the compilation buffer created." (let* ((name-of-mode (if (eq mode t) "compilation" - (replace-regexp-in-string "-mode$" "" (symbol-name mode)))) + (replace-regexp-in-string "-mode\\'" "" (symbol-name mode)))) (thisdir default-directory) outwin outbuf) (with-current-buffer @@ -1217,7 +1259,8 @@ Returns the compilation buffer created." ;; Then evaluate a cd command if any, but don't perform it yet, else ;; start-command would do it again through the shell: (cd "..") AND ;; sh -c "cd ..; make" - (cd (if (string-match "^\\s *cd\\(?:\\s +\\(\\S +?\\)\\)?\\s *[;&\n]" command) + (cd (if (string-match "\\`\\s *cd\\(?:\\s +\\(\\S +?\\)\\)?\\s *[;&\n]" + command) (if (match-end 1) (substitute-env-vars (match-string 1 command)) "~") @@ -1244,7 +1287,8 @@ Returns the compilation buffer created." (set (make-local-variable 'compilation-auto-jump-to-next) t)) ;; Output a mode setter, for saving and later reloading this buffer. (insert "-*- mode: " name-of-mode - "; default-directory: " (prin1-to-string default-directory) + "; default-directory: " + (prin1-to-string (abbreviate-file-name default-directory)) " -*-\n" (format "%s started at %s\n\n" mode-name @@ -1566,6 +1610,7 @@ Runs `compilation-mode-hook' with `run-mode-hooks' (which see). mode-name (or name-of-mode "Compilation")) (set (make-local-variable 'page-delimiter) compilation-page-delimiter) + (set (make-local-variable 'compilation-buffer-modtime) nil) (compilation-setup) (setq buffer-read-only t) (run-mode-hooks 'compilation-mode-hook)) @@ -1781,6 +1826,7 @@ and runs `compilation-filter-hook'." (unless comint-inhibit-carriage-motion (comint-carriage-motion (process-mark proc) (point))) (set-marker (process-mark proc) (point)) + (set (make-local-variable 'compilation-buffer-modtime) (current-time)) (run-hooks 'compilation-filter-hook)) (goto-char pos) (narrow-to-region min max) @@ -1950,16 +1996,11 @@ This is the value of `next-error-function' in Compilation buffers." ;; (`omake -P' polls filesystem for changes and recompiles when needed ;; in the same process and buffer). ;; So, recalculate all markers for that file. - (unless (and (nth 3 loc) (marker-buffer (nth 3 loc)) - ;; There may be no timestamp info if the loc is a `fake-loc'. - ;; So we skip the time-check here, although we should maybe - ;; change `compilation-fake-loc' to add timestamp info. - (or (null (nth 4 loc)) - (equal (nth 4 loc) - (setq timestamp - (with-current-buffer - (marker-buffer (nth 3 loc)) - (visited-file-modtime)))))) + (unless (and (nth 3 loc) (marker-buffer (nth 3 loc)) (nthcdr 4 loc) + ;; There may be no timestamp info if the loc is a `fake-loc', + ;; but we just checked that the file has been visited before! + (equal (nth 4 loc) + (setq timestamp compilation-buffer-modtime))) (with-current-buffer (compilation-find-file marker (caar (nth 2 loc)) (cadr (car (nth 2 loc)))) (save-restriction @@ -2064,7 +2105,7 @@ and overlay is highlighted between MK and END-MK." pre-existing (let ((display-buffer-reuse-frames t) (pop-up-windows t)) - ;; Pop up a window. + ;; Pop up a window. (display-buffer (marker-buffer msg))))) (highlight-regexp (with-current-buffer (marker-buffer msg) ;; also do this while we change buffer @@ -2353,7 +2394,7 @@ The file-structure looks like this: (defun compilation-forget-errors () ;; In case we hit the same file/line specs, we want to recompute a new ;; marker for them, so flush our cache. - (setq compilation-locs (make-hash-table :test 'equal :weakness 'value)) + (clrhash compilation-locs) (setq compilation-gcpro nil) ;; FIXME: the old code reset the directory-stack, so maybe we should ;; put a `directory change' marker of some sort, but where? -stef @@ -2384,9 +2425,6 @@ The file-structure looks like this: (or compilation-auto-jump-to-first-error (eq compilation-scroll-output 'first-error)))) -;;;###autoload -(add-to-list 'auto-mode-alist (cons (purecopy "\\.gcov\\'") 'compilation-mode)) - (provide 'compile) ;; arch-tag: 12465727-7382-4f72-b234-79855a00dd8c diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el index 2f751f2a0dc..6f8c1261510 100644 --- a/lisp/progmodes/cperl-mode.el +++ b/lisp/progmodes/cperl-mode.el @@ -1,8 +1,8 @@ ;;; cperl-mode.el --- Perl code editing commands for Emacs -;; Copyright (C) 1985, 1986, 1987, 1991, 1992, 1993, 1994, 1995, 1996, 1997, -;; 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. +;; Copyright (C) 1985, 1986, 1987, 1991, 1992, 1993, 1994, 1995, 1996, +;; 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, +;; 2008, 2009, 2010 Free Software Foundation, Inc. ;; Author: Ilya Zakharevich ;; Bob Olson @@ -1802,13 +1802,12 @@ or as help on variables `cperl-tips', `cperl-problems', (set 'vc-rcs-header cperl-vc-rcs-header) (make-local-variable 'vc-sccs-header) (set 'vc-sccs-header cperl-vc-sccs-header) - ;; This one is obsolete... - (make-local-variable 'vc-header-alist) - (with-no-warnings - (set 'vc-header-alist (or cperl-vc-header-alist ; Avoid warning - `((SCCS ,(car cperl-vc-sccs-header)) - (RCS ,(car cperl-vc-rcs-header))))) - ) + (when (featurep 'xemacs) + ;; This one is obsolete... + (make-local-variable 'vc-header-alist) + (set 'vc-header-alist (or cperl-vc-header-alist ; Avoid warning + `((SCCS ,(car cperl-vc-sccs-header)) + (RCS ,(car cperl-vc-rcs-header)))))) (cond ((boundp 'compilation-error-regexp-alist-alist);; xemacs 20.x (make-local-variable 'compilation-error-regexp-alist-alist) (set 'compilation-error-regexp-alist-alist @@ -1840,7 +1839,13 @@ or as help on variables `cperl-tips', `cperl-problems', (make-local-variable 'cperl-syntax-state) (setq cperl-syntax-state nil) ; reset syntaxification cache (if cperl-use-syntax-table-text-property - (progn + (if (boundp 'syntax-propertize-function) + (progn + ;; Reset syntaxification cache. + (set (make-local-variable 'cperl-syntax-done-to) nil) + (set (make-local-variable 'syntax-propertize-function) + (lambda (start end) + (goto-char start) (cperl-fontify-syntaxically end)))) (make-local-variable 'parse-sexp-lookup-properties) ;; Do not introduce variable if not needed, we check it! (set 'parse-sexp-lookup-properties t) @@ -2140,7 +2145,7 @@ char is \"{\", insert extra newline before only if "Insert an opening parenthesis or a matching pair of parentheses. See `cperl-electric-parens'." (interactive "P") - (let ((beg (save-excursion (beginning-of-line) (point))) + (let ((beg (point-at-bol)) (other-end (if (and cperl-electric-parens-mark (cperl-mark-active) (> (mark) (point))) @@ -2177,7 +2182,7 @@ See `cperl-electric-parens'." If not, or if we are not at the end of marking range, would self-insert. Affected by `cperl-electric-parens'." (interactive "P") - (let ((beg (save-excursion (beginning-of-line) (point))) + (let ((beg (point-at-bol)) (other-end (if (and cperl-electric-parens-mark (cperl-val 'cperl-electric-parens) (memq last-command-event @@ -2210,7 +2215,7 @@ Affected by `cperl-electric-parens'." "Insert a construction appropriate after a keyword. Help message may be switched off by setting `cperl-message-electric-keyword' to nil." - (let ((beg (save-excursion (beginning-of-line) (point))) + (let ((beg (point-at-bol)) (dollar (and (eq last-command-event ?$) (eq this-command 'self-insert-command))) (delete (and (memq last-command-event '(?\s ?\n ?\t ?\f)) @@ -2353,7 +2358,7 @@ to nil." "Insert a construction appropriate after a keyword. Help message may be switched off by setting `cperl-message-electric-keyword' to nil." - (let ((beg (save-excursion (beginning-of-line) (point)))) + (let ((beg (point-at-bol))) (and (save-excursion (backward-sexp 1) (cperl-after-expr-p nil "{;:")) @@ -2392,8 +2397,8 @@ to nil." "Go to end of line, open a new line and indent appropriately. If in POD, insert appropriate lines." (interactive) - (let ((beg (save-excursion (beginning-of-line) (point))) - (end (save-excursion (end-of-line) (point))) + (let ((beg (point-at-bol)) + (end (point-at-eol)) (pos (point)) start over cut res) (if (and ; Check if we need to split: ; i.e., on a boundary and inside "{...}" @@ -2471,12 +2476,8 @@ If in POD, insert appropriate lines." (forward-paragraph -1) (forward-word 1) (setq pos (point)) - (setq cut (buffer-substring (point) - (save-excursion - (end-of-line) - (point)))) - (delete-char (- (save-excursion (end-of-line) (point)) - (point))) + (setq cut (buffer-substring (point) (point-at-eol))) + (delete-char (- (point-at-eol) (point))) (setq res (expand-abbrev)) (save-excursion (goto-char pos) @@ -2941,8 +2942,7 @@ Will not look before LIM." (point-max)))) ; do not loop if no syntaxification ;; label: (t - (save-excursion (end-of-line) - (setq colon-line-end (point))) + (setq colon-line-end (point-at-eol)) (search-forward ":")))) ;; We are at beginning of code (NOT label or comment) ;; First, the following code counts @@ -2984,8 +2984,7 @@ Will not look before LIM." (looking-at "sub\\>"))) (setq p (nth 1 ; start of innermost containing list (parse-partial-sexp - (save-excursion (beginning-of-line) - (point)) + (point-at-bol) (point))))) (progn (goto-char (1+ p)) ; enclosing block on the same line @@ -3215,7 +3214,7 @@ the current line is to be regarded as part of a block comment." Returns true if comment is found. In POD will not move the point." ;; If the line is inside other syntax groups (qq-style strings, HERE-docs) ;; then looks for literal # or end-of-line. - (let (state stop-in cpoint (lim (progn (end-of-line) (point))) pr e) + (let (state stop-in cpoint (lim (point-at-eol)) pr e) (or cperl-font-locking (cperl-update-syntaxification lim lim)) (beginning-of-line) @@ -3804,12 +3803,13 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', indentable t)) ;; Need to remove face as well... (goto-char min) - (and (eq system-type 'emx) + ;; 'emx not supported by Emacs since at least 21.1. + (and (featurep 'xemacs) (eq system-type 'emx) (eq (point) 1) (let ((case-fold-search t)) (looking-at "extproc[ \t]")) ; Analogue of #! (cperl-commentify min - (save-excursion (end-of-line) (point)) + (point-at-eol) nil)) (while (and (< (point) max) @@ -4048,10 +4048,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', "") tb (match-beginning 0)) (setq argument nil) - (put-text-property (save-excursion - (beginning-of-line) - (point)) - b 'first-format-line 't) + (put-text-property (point-at-bol) b 'first-format-line 't) (if cperl-pod-here-fontify (while (and (eq (forward-line) 0) (not (looking-at "^[.;]$"))) @@ -4997,7 +4994,7 @@ If `cperl-indent-region-fix-constructs', will improve spacing on conditional/loop constructs." (interactive) (save-excursion - (let ((tmp-end (progn (end-of-line) (point))) top done) + (let ((tmp-end (point-at-eol)) top done) (save-excursion (beginning-of-line) (while (null done) @@ -5040,13 +5037,9 @@ conditional/loop constructs." "\\<\\(else\\|elsif\|continue\\)\\>")) (progn (goto-char (match-end 0)) - (save-excursion - (end-of-line) - (setq tmp-end (point)))) + (setq tmp-end (point-at-eol))) (setq done t)))) - (save-excursion - (end-of-line) - (setq tmp-end (point)))) + (setq tmp-end (point-at-eol))) (goto-char tmp-end) (setq tmp-end (point-marker))) (if cperl-indent-region-fix-constructs @@ -5059,7 +5052,7 @@ Returns some position at the last line." (interactive) (or end (setq end (point-max))) - (let ((ee (save-excursion (end-of-line) (point))) + (let ((ee (point-at-eol)) (cperl-indent-region-fix-constructs (or cperl-indent-region-fix-constructs 1)) p pp ml have-brace ret) @@ -5212,7 +5205,7 @@ Returns some position at the last line." (if (cperl-indent-line parse-data) (setq ret (cperl-fix-line-spacing end parse-data))))))))))) (beginning-of-line) - (setq p (point) pp (save-excursion (end-of-line) (point))) ; May be different from ee. + (setq p (point) pp (point-at-eol)) ; May be different from ee. ;; Now check whether there is a hanging `}' ;; Looking at: ;; } blah @@ -7046,7 +7039,7 @@ Use as (or topdir (setq topdir default-directory)) (let ((tags-file-name "TAGS") - (case-fold-search (eq system-type 'emx)) + (case-fold-search (and (featurep 'xemacs) (eq system-type 'emx))) xs rel tm) (save-excursion (cond (inbuffer nil) ; Already there @@ -7474,7 +7467,7 @@ Currently it is tuned to C and Perl syntax." ;; Get to the something meaningful (or (eobp) (eolp) (forward-char 1)) (re-search-backward "[-a-zA-Z0-9_:!&*+,-./<=>?\\\\^|~$%@]" - (save-excursion (beginning-of-line) (point)) + (point-at-bol) 'to-beg) ;; (cond ;; ((or (eobp) (looking-at "[][ \t\n{}();,]")) ; Not at a symbol @@ -8980,7 +8973,18 @@ do extra unwind via `cperl-unwind-to-safe'." (substring v (match-beginning 1) (match-end 1))) "Version of IZ-supported CPerl package this file is based on.") +(defun cperl-mode-unload-function () + "Unload the Cperl mode library." + (let ((new-mode (if (eq (symbol-function 'perl-mode) 'cperl-mode) + 'fundamental-mode + 'perl-mode))) + (dolist (buf (buffer-list)) + (with-current-buffer buf + (when (eq major-mode 'cperl-mode) + (funcall new-mode))))) + ;; continue standard unloading + nil) + (provide 'cperl-mode) -;; arch-tag: 42e5b19b-e187-4537-929f-1a7408980ce6 ;;; cperl-mode.el ends here diff --git a/lisp/progmodes/cwarn.el b/lisp/progmodes/cwarn.el index e4b380995d5..00c11086ce1 100644 --- a/lisp/progmodes/cwarn.el +++ b/lisp/progmodes/cwarn.el @@ -6,7 +6,7 @@ ;; Author: Anders Lindgren <andersl@andersl.com> ;; Keywords: c, languages, faces ;; X-Url: http://www.andersl.com/emacs -;; Version: 1.3.1 1999-12-13 +;; Version: 1.3.1 ;; This file is part of GNU Emacs. diff --git a/lisp/progmodes/dcl-mode.el b/lisp/progmodes/dcl-mode.el index c3a68c3be99..dd7aa0eddfb 100644 --- a/lisp/progmodes/dcl-mode.el +++ b/lisp/progmodes/dcl-mode.el @@ -1,7 +1,7 @@ ;;; dcl-mode.el --- major mode for editing DCL command files -;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. +;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, +;; 2009, 2010 Free Software Foundation, Inc. ;; Author: Odd Gripenstam <gripenstamol@decus.se> ;; Maintainer: Odd Gripenstam <gripenstamol@decus.se> @@ -821,7 +821,7 @@ by the numbers in order 1-2-3-1-... : ;; text ;; 1 - (let* ((default-limit (save-excursion (end-of-line) (1+ (point)))) + (let* ((default-limit (1+ (line-end-position))) (limit (or limit default-limit)) (last-good-point (point)) (opoint (point))) @@ -1549,13 +1549,11 @@ Also remove the continuation mark if easily detected." (interactive "*P") (delete-indentation arg) (let ((type (dcl-get-line-type))) - (if (and (or (equal type '$) - (equal type '-) - (equal type 'empty-$)) + (if (and (member type '($ - empty-$)) (not (bobp)) - (= (char-after (1- (point))) ?-)) + (= (char-before) ?-)) (progn - (delete-backward-char 1) + (delete-char -1) (fixup-whitespace))))) @@ -1785,7 +1783,7 @@ Set or update the value of VAR in the current buffers (skip-chars-forward " \t") (or (eolp) (setq suffix-string (buffer-substring (point) - (progn (end-of-line) (point))))) + (line-end-position)))) (goto-char (match-beginning 0)) (or (bolp) (setq prefix-string @@ -2216,5 +2214,4 @@ otherwise return nil." (run-hooks 'dcl-mode-load-hook) ; for your customizations -;; arch-tag: e00d421b-f26c-483e-a8bd-af412ea7764a ;;; dcl-mode.el ends here diff --git a/lisp/progmodes/delphi.el b/lisp/progmodes/delphi.el index 1e5f1f506b3..2558456bc07 100644 --- a/lisp/progmodes/delphi.el +++ b/lisp/progmodes/delphi.el @@ -628,7 +628,9 @@ routine.") (defun delphi-token-at (p) ;; Returns the token from parsing text at point p. (when (and (<= (point-min) p) (<= p (point-max))) - (cond ((delphi-literal-token-at p)) + (cond ((delphi-char-token-at p ?\n 'newline)) + + ((delphi-literal-token-at p)) ((delphi-space-token-at p)) @@ -638,7 +640,6 @@ routine.") ((delphi-char-token-at p ?\) 'close-group)) ((delphi-char-token-at p ?\[ 'open-group)) ((delphi-char-token-at p ?\] 'close-group)) - ((delphi-char-token-at p ?\n 'newline)) ((delphi-char-token-at p ?\; 'semicolon)) ((delphi-char-token-at p ?. 'dot)) ((delphi-char-token-at p ?, 'comma)) @@ -888,7 +889,24 @@ non-delphi buffer. Set to nil in a delphi buffer. To override, just do: (setq token (delphi-block-start token))) ;; Regular block start found. - ((delphi-is token-kind delphi-block-statements) (throw 'done token)) + ((delphi-is token-kind delphi-block-statements) + (throw 'done + ;; As a special case, when a "case" block appears + ;; within a record declaration (to denote a variant + ;; part), the record declaration should be considered + ;; the enclosing block. + (if (eq 'case token-kind) + (let ((enclosing-token + (delphi-block-start token + 'stop-on-class))) + (if + (eq 'record + (delphi-token-kind enclosing-token)) + (if stop-on-class + enclosing-token + (delphi-previous-token enclosing-token)) + token)) + token))) ;; A class/record start also begins a block. ((delphi-composite-type-start token last-token) @@ -1058,6 +1076,7 @@ non-delphi buffer. Set to nil in a delphi buffer. To override, just do: (token-kind nil) (from-kind (delphi-token-kind from-token)) (last-colon nil) + (last-of nil) (last-token nil)) (catch 'done (while token @@ -1101,9 +1120,17 @@ non-delphi buffer. Set to nil in a delphi buffer. To override, just do: ;; Ignore whitespace. ((delphi-is token-kind delphi-whitespace)) - ;; Remember any ':' we encounter, since that affects how we indent to - ;; a case statement. - ((eq 'colon token-kind) (setq last-colon token)) + ;; Remember any "of" we encounter, since that affects how we + ;; indent to a case statement within a record declaration + ;; (i.e. a variant part). + ((eq 'of token-kind) + (setq last-of token)) + + ;; Remember any ':' we encounter (until we reach an "of"), + ;; since that affects how we indent to case statements in + ;; general. + ((eq 'colon token-kind) + (unless last-of (setq last-colon token))) ;; A case statement delimits a previous statement. We indent labels ;; specially. diff --git a/lisp/progmodes/ebnf-abn.el b/lisp/progmodes/ebnf-abn.el index 17173bd0458..a8741a30cf2 100644 --- a/lisp/progmodes/ebnf-abn.el +++ b/lisp/progmodes/ebnf-abn.el @@ -7,6 +7,7 @@ ;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br> ;; Keywords: wp, ebnf, PostScript ;; Version: 1.2 +;; Package: ebnf2ps ;; This file is part of GNU Emacs. diff --git a/lisp/progmodes/ebnf-bnf.el b/lisp/progmodes/ebnf-bnf.el index 3c71f29b236..45f2fe727e8 100644 --- a/lisp/progmodes/ebnf-bnf.el +++ b/lisp/progmodes/ebnf-bnf.el @@ -7,6 +7,7 @@ ;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br> ;; Keywords: wp, ebnf, PostScript ;; Version: 1.10 +;; Package: ebnf2ps ;; This file is part of GNU Emacs. diff --git a/lisp/progmodes/ebnf-dtd.el b/lisp/progmodes/ebnf-dtd.el index 2bd527a0222..2ca38406d4f 100644 --- a/lisp/progmodes/ebnf-dtd.el +++ b/lisp/progmodes/ebnf-dtd.el @@ -7,6 +7,7 @@ ;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br> ;; Keywords: wp, ebnf, PostScript ;; Version: 1.1 +;; Package: ebnf2ps ;; This file is part of GNU Emacs. diff --git a/lisp/progmodes/ebnf-ebx.el b/lisp/progmodes/ebnf-ebx.el index 901c80a7225..dd94f9e638a 100644 --- a/lisp/progmodes/ebnf-ebx.el +++ b/lisp/progmodes/ebnf-ebx.el @@ -7,6 +7,7 @@ ;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br> ;; Keywords: wp, ebnf, PostScript ;; Version: 1.2 +;; Package: ebnf2ps ;; This file is part of GNU Emacs. diff --git a/lisp/progmodes/ebnf-iso.el b/lisp/progmodes/ebnf-iso.el index ad5683cb7f5..fa1592bb17f 100644 --- a/lisp/progmodes/ebnf-iso.el +++ b/lisp/progmodes/ebnf-iso.el @@ -7,6 +7,7 @@ ;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br> ;; Keywords: wp, ebnf, PostScript ;; Version: 1.9 +;; Package: ebnf2ps ;; This file is part of GNU Emacs. diff --git a/lisp/progmodes/ebnf-otz.el b/lisp/progmodes/ebnf-otz.el index a9c4838d9e1..b005d95a806 100644 --- a/lisp/progmodes/ebnf-otz.el +++ b/lisp/progmodes/ebnf-otz.el @@ -7,6 +7,7 @@ ;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br> ;; Keywords: wp, ebnf, PostScript ;; Version: 1.0 +;; Package: ebnf2ps ;; This file is part of GNU Emacs. diff --git a/lisp/progmodes/ebnf-yac.el b/lisp/progmodes/ebnf-yac.el index e2a35dbc943..a7f1851cffb 100644 --- a/lisp/progmodes/ebnf-yac.el +++ b/lisp/progmodes/ebnf-yac.el @@ -7,6 +7,7 @@ ;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br> ;; Keywords: wp, ebnf, PostScript ;; Version: 1.4 +;; Package: ebnf2ps ;; This file is part of GNU Emacs. diff --git a/lisp/progmodes/ebnf2ps.el b/lisp/progmodes/ebnf2ps.el index 201a091cc26..a4d1fe85c30 100644 --- a/lisp/progmodes/ebnf2ps.el +++ b/lisp/progmodes/ebnf2ps.el @@ -1,7 +1,7 @@ ;;; ebnf2ps.el --- translate an EBNF to a syntactic chart on PostScript -;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. +;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, +;; 2008, 2009, 2010 Free Software Foundation, Inc. ;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br> ;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br> @@ -5279,7 +5279,7 @@ killed after process termination." (goto-char (point-min)) (and (search-forward "%%Creator: " nil t) (not (search-forward "& ebnf2ps v" - (save-excursion (end-of-line) (point)) + (line-end-position) t)) (progn ;; adjust creator comment @@ -6395,5 +6395,4 @@ killed after process termination." (provide 'ebnf2ps) -;; arch-tag: 148bc8af-5398-468b-b922-eeb7afef3e4f ;;; ebnf2ps.el ends here diff --git a/lisp/progmodes/ebrowse.el b/lisp/progmodes/ebrowse.el index e32c453b91f..7101bf21ade 100644 --- a/lisp/progmodes/ebrowse.el +++ b/lisp/progmodes/ebrowse.el @@ -1,8 +1,8 @@ ;;; ebrowse.el --- Emacs C++ class browser & tags facility -;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, -;; 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 -;; Free Software Foundation Inc. +;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, +;; 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; Free Software Foundation Inc. ;; Author: Gerd Moellmann <gerd@gnu.org> ;; Maintainer: FSF @@ -1313,7 +1313,7 @@ With PREFIX, insert that many filenames." (skip-chars-forward " \t*a-zA-Z0-9_") (setq start (point) file-name-existing (looking-at "(")) - (delete-region start (save-excursion (end-of-line) (point))) + (delete-region start (line-end-position)) (unless file-name-existing (indent-to ebrowse-source-file-column) (insert "(" (or (ebrowse-cs-file @@ -4491,5 +4491,4 @@ EVENT is the mouse event." ;; eval:(put 'ebrowse-for-all-trees 'lisp-indent-hook 1) ;; End: -;; arch-tag: 4fa3c8bf-1771-479b-bcd7-b029c7c9677b ;;; ebrowse.el ends here diff --git a/lisp/progmodes/etags.el b/lisp/progmodes/etags.el index 23e175cbe7d..0d11fd6423d 100644 --- a/lisp/progmodes/etags.el +++ b/lisp/progmodes/etags.el @@ -1,8 +1,8 @@ ;;; etags.el --- etags facility for Emacs -;; Copyright (C) 1985, 1986, 1988, 1989, 1992, 1993, 1994, 1995, 1996, 1998, -;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. +;; Copyright (C) 1985, 1986, 1988, 1989, 1992, 1993, 1994, 1995, 1996, +;; 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, +;; 2010 Free Software Foundation, Inc. ;; Author: Roland McGrath <roland@gnu.org> ;; Maintainer: FSF @@ -40,6 +40,7 @@ If you set this variable, do not also set `tags-table-list'. Use the `etags' program to make a tags table file.") ;; Make M-x set-variable tags-file-name like M-x visit-tags-table. ;;;###autoload (put 'tags-file-name 'variable-interactive (purecopy "fVisit tags table: ")) +;;;###autoload (put 'tags-file-name 'safe-local-variable 'stringp) (defgroup etags nil "Tags tables." :group 'tools) @@ -67,12 +68,14 @@ Use the `etags' program to make a tags table file." :type '(repeat file)) ;;;###autoload -(defcustom tags-compression-info-list (purecopy '("" ".Z" ".bz2" ".gz" ".tgz")) +(defcustom tags-compression-info-list + (purecopy '("" ".Z" ".bz2" ".gz" ".xz" ".tgz")) "*List of extensions tried by etags when jka-compr is used. An empty string means search the non-compressed file. These extensions will be tried only if jka-compr was activated \(i.e. via customize of `auto-compression-mode' or by calling the function `auto-compression-mode')." + :version "24.1" ; added xz :type '(repeat string) :group 'etags) @@ -423,9 +426,9 @@ Returns non-nil if it is a valid table." (if (get-file-buffer file) ;; The file is already in a buffer. Check for the visited file ;; having changed since we last used it. - (let (win) + (progn (set-buffer (get-file-buffer file)) - (setq win (or verify-tags-table-function (tags-table-mode))) + (or verify-tags-table-function (tags-table-mode)) (if (or (verify-visited-file-modtime (current-buffer)) ;; Decide whether to revert the file. ;; revert-without-query can say to revert @@ -471,7 +474,7 @@ Subroutine of `visit-tags-table-buffer'. Looks for a tags table that has such tags or that includes a table that has them. Returns the name of the first such table. Non-nil CORE-ONLY means check only tags tables that are already in -buffers. Nil CORE-ONLY is ignored." +buffers. If CORE-ONLY is nil, it is ignored." (let ((tables tags-table-computed-list) (found nil)) ;; Loop over the list, looking for a table containing tags for THIS-FILE. @@ -787,6 +790,30 @@ tags table and its (recursively) included tags tables." (let ((enable-recursive-minibuffers t)) (visit-tags-table-buffer)) (complete-with-action action (tags-completion-table) string pred)))))) + +;;;###autoload (defun tags-completion-at-point-function () +;;;###autoload (if (or tags-table-list tags-file-name) +;;;###autoload (progn +;;;###autoload (load "etags") +;;;###autoload (tags-completion-at-point-function)))) + +(defun tags-completion-at-point-function () + "Using tags, return a completion table for the text around point. +If no tags table is loaded, do nothing and return nil." + (when (or tags-table-list tags-file-name) + (let ((completion-ignore-case (if (memq tags-case-fold-search '(t nil)) + tags-case-fold-search + case-fold-search)) + (pattern (funcall (or find-tag-default-function + (get major-mode 'find-tag-default-function) + 'find-tag-default))) + beg) + (when pattern + (save-excursion + (search-backward pattern) ;FIXME: will fail if we're inside pattern. + (setq beg (point)) + (forward-char (length pattern)) + (list beg (point) (tags-lazy-completion-table))))))) (defun find-tag-tag (string) "Read a tag name, with defaulting and completion." @@ -1106,9 +1133,7 @@ error message." ;; Naive match found. Qualify the match. (and (funcall (car order) pattern) ;; Make sure it is not a previous qualified match. - (not (member (set-marker match-marker (save-excursion - (beginning-of-line) - (point))) + (not (member (set-marker match-marker (point-at-bol)) tag-lines-already-matched)) (throw 'qualified-match-found nil)) (if next-line-after-failure-p @@ -1286,13 +1311,11 @@ buffer-local values of tags table format variables." ;; Find the end of the tag and record the whole tag text. (search-forward "\177") - (setq tag-text (buffer-substring (1- (point)) - (save-excursion (beginning-of-line) - (point)))) + (setq tag-text (buffer-substring (1- (point)) (point-at-bol))) ;; If use-explicit is non nil and explicit tag is present, use it as part of ;; return value. Else just skip it. (setq explicit-start (point)) - (when (and (search-forward "\001" (save-excursion (forward-line 1) (point)) t) + (when (and (search-forward "\001" (point-at-bol 2) t) use-explicit) (setq tag-text (buffer-substring explicit-start (1- (point))))) @@ -1654,7 +1677,7 @@ Point should be just after a string that matches TAG." (save-excursion (beginning-of-line) (let ((bol (point))) - (and (search-forward "\177" (save-excursion (end-of-line) (point)) t) + (and (search-forward "\177" (line-end-position) t) (re-search-backward re bol t))))) (defcustom tags-loop-revert-buffers nil @@ -2039,20 +2062,10 @@ for \\[find-tag] (which see)." (error "%s" (substitute-command-keys "No tags table loaded; try \\[visit-tags-table]"))) - (let ((completion-ignore-case (if (memq tags-case-fold-search '(t nil)) - tags-case-fold-search - case-fold-search)) - (pattern (funcall (or find-tag-default-function - (get major-mode 'find-tag-default-function) - 'find-tag-default))) - (comp-table (tags-lazy-completion-table)) - beg) - (or pattern - (error "Nothing to complete")) - (search-backward pattern) - (setq beg (point)) - (forward-char (length pattern)) - (completion-in-region beg (point) comp-table))) + (let ((comp-data (tags-completion-at-point-function))) + (if (null comp-data) + (error "Nothing to complete") + (apply 'completion-in-region comp-data)))) (dolist (x '("^No tags table in use; use .* to select one$" "^There is no default tag$" @@ -2069,5 +2082,4 @@ for \\[find-tag] (which see)." (provide 'etags) -;; arch-tag: b897c2b5-08f3-4837-b2d3-0e7d6db1b63e ;;; etags.el ends here diff --git a/lisp/progmodes/f90.el b/lisp/progmodes/f90.el index 0a3c96d7894..b6c42d2c550 100644 --- a/lisp/progmodes/f90.el +++ b/lisp/progmodes/f90.el @@ -657,6 +657,7 @@ Can be overridden by the value of `font-lock-maximum-decoration'.") (define-key map "\C-c\C-f" 'f90-fill-region) (define-key map "\C-c\C-p" 'f90-previous-statement) (define-key map "\C-c\C-n" 'f90-next-statement) + (define-key map "\C-c]" 'f90-insert-end) (define-key map "\C-c\C-w" 'f90-insert-end) ;; Standard tab binding will call this, and also handle regions. ;;; (define-key map "\t" 'f90-indent-line) @@ -1008,7 +1009,7 @@ Set subexpression 1 in the match-data to the name of the type." :regexp "\\(?:[^[:word:]_`]\\|^\\)\\(`?[[:word:]_]+\\)[^[:word:]_]*") ;;;###autoload -(defun f90-mode () +(define-derived-mode f90-mode prog-mode "F90" "Major mode for editing Fortran 90,95 code in free format. For fixed format code, use `fortran-mode'. @@ -1065,13 +1066,9 @@ Variables controlling indentation style and extra features: Turning on F90 mode calls the value of the variable `f90-mode-hook' with no args, if that value is non-nil." - (interactive) - (kill-all-local-variables) - (setq major-mode 'f90-mode - mode-name "F90" - local-abbrev-table f90-mode-abbrev-table) - (set-syntax-table f90-mode-syntax-table) - (use-local-map f90-mode-map) + :group 'f90 + :syntax-table f90-mode-syntax-table + :abbrev-table f90-mode-abbrev-table (set (make-local-variable 'indent-line-function) 'f90-indent-line) (set (make-local-variable 'indent-region-function) 'f90-indent-region) (set (make-local-variable 'require-final-newline) mode-require-final-newline) @@ -1094,8 +1091,7 @@ with no args, if that value is non-nil." 'f90-beginning-of-subprogram) (set (make-local-variable 'end-of-defun-function) 'f90-end-of-subprogram) (set (make-local-variable 'add-log-current-defun-function) - #'f90-current-defun) - (run-mode-hooks 'f90-mode-hook)) + #'f90-current-defun)) ;; Inline-functions. diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el index 712af6fd288..6346ab50e96 100644 --- a/lisp/progmodes/flymake.el +++ b/lisp/progmodes/flymake.el @@ -106,16 +106,6 @@ Zero-length substrings at the beginning and end of the list are omitted." 'temp-directory (lambda () temporary-file-directory))) -(defalias 'flymake-line-beginning-position - (if (fboundp 'line-beginning-position) - 'line-beginning-position - (lambda (&optional arg) (save-excursion (beginning-of-line arg) (point))))) - -(defalias 'flymake-line-end-position - (if (fboundp 'line-end-position) - 'line-end-position - (lambda (&optional arg) (save-excursion (end-of-line arg) (point))))) - (defun flymake-posn-at-point-as-event (&optional position window dx dy) "Return pixel position of top left corner of glyph at POSITION, relative to top left corner of WINDOW, as a mouse-1 click @@ -808,8 +798,8 @@ Return t if it has at least one flymake overlay, nil if no overlay." Perhaps use text from LINE-ERR-INFO-LIST to enhance highlighting." (goto-char (point-min)) (forward-line (1- line-no)) - (let* ((line-beg (flymake-line-beginning-position)) - (line-end (flymake-line-end-position)) + (let* ((line-beg (point-at-bol)) + (line-end (point-at-eol)) (beg line-beg) (end line-end) (tooltip-text (flymake-ler-text (nth 0 line-err-info-list))) @@ -1764,5 +1754,4 @@ Use CREATE-TEMP-F for creating temp copy." (provide 'flymake) -;; arch-tag: 8f0d6090-061d-4cac-8862-7c151c4a02dd ;;; flymake.el ends here diff --git a/lisp/progmodes/fortran.el b/lisp/progmodes/fortran.el index 3784ba787c4..c8bbbf48343 100644 --- a/lisp/progmodes/fortran.el +++ b/lisp/progmodes/fortran.el @@ -488,13 +488,22 @@ Consists of level 3 plus all other intrinsics not already highlighted.") ;; (We can do so for F90-style). Therefore an unmatched quote in a ;; standard comment will throw fontification off on the wrong track. ;; So we do syntactic fontification with regexps. -(defun fortran-font-lock-syntactic-keywords () - "Return a value for `font-lock-syntactic-keywords' in Fortran mode. -This varies according to the value of `fortran-line-length'. +(defun fortran-make-syntax-propertize-function (line-length) + "Return a value for `syntax-propertize-function' in Fortran mode. +This varies according to the value of LINE-LENGTH. This is used to fontify fixed-format Fortran comments." - `(("^[cd\\*]" 0 (11)) - (,(format "^[^cd\\*\t\n].\\{%d\\}\\([^\n]+\\)" (1- fortran-line-length)) - 1 (11)))) + ;; This results in a non-byte-compiled function. We could pass it through + ;; `byte-compile', but simple benchmarks indicate that it's probably not + ;; worth the trouble (about ½% of slow down). + (eval ;I hate `eval', but it's hard to avoid it here. + `(syntax-propertize-rules + ("^[cd\\*]" (0 "<")) + ;; We mark all chars after line-length as "comment-start", rather than + ;; just the first one. This is so that a closing ' that's past the + ;; line-length will indeed be ignored (and will result in a string that + ;; leaks into subsequent lines). + ((format "^[^cd\\*\t\n].\\{%d\\}\\(.+\\)" (1- line-length)) + (1 "<"))))) (defvar fortran-font-lock-keywords fortran-font-lock-keywords-1 "Default expressions to highlight in Fortran mode.") @@ -778,7 +787,7 @@ Used in the Fortran entry in `hs-special-modes-alist'.") ;;;###autoload -(defun fortran-mode () +(define-derived-mode fortran-mode prog-mode "Fortran" "Major mode for editing Fortran code in fixed format. For free format code, use `f90-mode'. @@ -848,13 +857,9 @@ Variables controlling indentation style and extra features: Turning on Fortran mode calls the value of the variable `fortran-mode-hook' with no args, if that value is non-nil." - (interactive) - (kill-all-local-variables) - (setq major-mode 'fortran-mode - mode-name "Fortran" - local-abbrev-table fortran-mode-abbrev-table) - (set-syntax-table fortran-mode-syntax-table) - (use-local-map fortran-mode-map) + :group 'fortran + :syntax-table fortran-mode-syntax-table + :abbrev-table fortran-mode-abbrev-table (set (make-local-variable 'indent-line-function) 'fortran-indent-line) (set (make-local-variable 'indent-region-function) (lambda (start end) @@ -891,9 +896,9 @@ with no args, if that value is non-nil." fortran-font-lock-keywords-3 fortran-font-lock-keywords-4) nil t ((?/ . "$/") ("_$" . "w")) - fortran-beginning-of-subprogram - (font-lock-syntactic-keywords - . fortran-font-lock-syntactic-keywords))) + fortran-beginning-of-subprogram)) + (set (make-local-variable 'syntax-propertize-function) + (fortran-make-syntax-propertize-function fortran-line-length)) (set (make-local-variable 'imenu-case-fold-search) t) (set (make-local-variable 'imenu-generic-expression) fortran-imenu-generic-expression) @@ -906,33 +911,37 @@ with no args, if that value is non-nil." #'fortran-current-defun) (set (make-local-variable 'dabbrev-case-fold-search) 'case-fold-search) (set (make-local-variable 'gud-find-expr-function) 'fortran-gud-find-expr) - (add-hook 'hack-local-variables-hook 'fortran-hack-local-variables nil t) - (run-mode-hooks 'fortran-mode-hook)) + (add-hook 'hack-local-variables-hook 'fortran-hack-local-variables nil t)) (defun fortran-line-length (nchars &optional global) "Set the length of fixed-form Fortran lines to NCHARS. This normally only affects the current buffer, which must be in Fortran mode. If the optional argument GLOBAL is non-nil, it -affects all Fortran buffers, and also the default." - (interactive "p") - (let (new) - (mapc (lambda (buff) - (with-current-buffer buff - (when (eq major-mode 'fortran-mode) - (setq fortran-line-length nchars - fill-column fortran-line-length - new (fortran-font-lock-syntactic-keywords)) - ;; Refontify only if necessary. - (unless (equal new font-lock-syntactic-keywords) - (setq font-lock-syntactic-keywords - (fortran-font-lock-syntactic-keywords)) - (if font-lock-mode (font-lock-mode 1)))))) +affects all Fortran buffers, and also the default. +If a numeric prefix argument is specified, it will be used as NCHARS, +otherwise is a non-numeric prefix arg is specified, the length will be +provided via the minibuffer, and otherwise the current column is used." + (interactive + (list (cond + ((numberp current-prefix-arg) current-prefix-arg) + (current-prefix-arg + (read-number "Line length: " (default-value 'fortran-line-length))) + (t (current-column))))) + (dolist (buff (if global + (buffer-list) + (list (current-buffer)))) + (with-current-buffer buff + (when (derived-mode-p 'fortran-mode) + (unless (eq fortran-line-length nchars) + (setq fortran-line-length nchars + fill-column fortran-line-length + syntax-propertize-function + (fortran-make-syntax-propertize-function nchars)) + (syntax-ppss-flush-cache (point-min)) + (if font-lock-mode (font-lock-mode 1)))))) (if global - (buffer-list) - (list (current-buffer)))) - (if global - (setq-default fortran-line-length nchars)))) + (setq-default fortran-line-length nchars))) (defun fortran-hack-local-variables () "Fortran mode adds this to `hack-local-variables-hook'." @@ -1306,8 +1315,7 @@ Directive lines are treated as comments." (if i (save-excursion (goto-char i) - (beginning-of-line) - (= (point) p))))) + (= (line-beginning-position) p))))) ;; Used in hs-special-modes-alist. (defun fortran-end-of-block (&optional num) @@ -2198,5 +2206,4 @@ arg DO-SPACE prevents stripping the whitespace." (provide 'fortran) -;; arch-tag: 74935096-21c4-4cab-8ee5-6ef16090dc04 ;;; fortran.el ends here diff --git a/lisp/progmodes/gdb-mi.el b/lisp/progmodes/gdb-mi.el new file mode 100644 index 00000000000..3019f8bbf04 --- /dev/null +++ b/lisp/progmodes/gdb-mi.el @@ -0,0 +1,4195 @@ +;;; gdb-mi.el --- User Interface for running GDB + +;; Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc. + +;; Author: Nick Roberts <nickrob@gnu.org> +;; Maintainer: FSF +;; Keywords: unix, tools + +;; This file is part of GNU Emacs. + +;; Homepage: http://www.emacswiki.org/emacs/GDB-MI + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Credits: + +;; This file was written by by Nick Roberts following the general design +;; used in gdb-ui.el for Emacs 22.1 - 23.1. It is currently being developed +;; by Dmitry Dzhus <dima@sphinx.net.ru> as part of the Google Summer +;; of Code 2009 Project "Emacs GDB/MI migration". + +;;; Commentary: + +;; This mode acts as a graphical user interface to GDB. You can interact with +;; GDB through the GUD buffer in the usual way, but there are also further +;; buffers which control the execution and describe the state of your program. +;; It separates the input/output of your program from that of GDB and displays +;; expressions and their current values in their own buffers. It also uses +;; features of Emacs 21 such as the fringe/display margin for breakpoints, and +;; the toolbar (see the GDB Graphical Interface section in the Emacs info +;; manual). + +;; M-x gdb will start the debugger. + +;; This file uses GDB/MI as the primary interface to GDB. It is still under +;; development and is part of a process to migrate Emacs from annotations (as +;; used in gdb-ui.el) to GDB/MI. It runs gdb with GDB/MI (-interp=mi) and +;; access CLI using "-interpreter-exec console cli-command". This code works +;; without gdb-ui.el and uses MI tokens instead of queues. Eventually MI +;; should be asynchronous. + +;; This mode will PARTLY WORK WITH RECENT GDB RELEASES (status in modeline +;; doesn't update properly when execution commands are issued from GUD buffer) +;; and WORKS BEST when GDB runs asynchronously: maint set linux-async on. +;; +;; You need development version of GDB 7.0 for the thread buffer to work. + +;; This file replaces gdb-ui.el and is for development with GDB. Use the +;; release branch of Emacs 22 for the latest version of gdb-ui.el. + +;; Windows Platforms: + +;; If you are using Emacs and GDB on Windows you will need to flush the buffer +;; explicitly in your program if you want timely display of I/O in Emacs. +;; Alternatively you can make the output stream unbuffered, for example, by +;; using a macro: + +;; #ifdef UNBUFFERED +;; setvbuf (stdout, (char *) NULL, _IONBF, 0); +;; #endif + +;; and compiling with -DUNBUFFERED while debugging. + +;; If you are using Cygwin GDB and find that the source is not being displayed +;; in Emacs when you step through it, possible solutions are to: + +;; 1) Use Cygwin X Windows and Cygwin Emacs. +;; (Since 22.1 Emacs builds under Cygwin.) +;; 2) Use MinGW GDB instead. +;; 3) Use cygwin-mount.el + +;;; Mac OSX: + +;; GDB in Emacs on Mac OSX works best with FSF GDB as Apple have made +;; some changes to the version that they include as part of Mac OSX. +;; This requires GDB version 7.0 or later (estimated release date Aug 2009) +;; as earlier versions don not compile on Mac OSX. + +;;; Known Bugs: + +;; 1) Stack buffer doesn't parse MI output if you stop in a routine without +;; line information, e.g., a routine in libc (just a TODO item). + +;; TODO: +;; 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? + +;;; Code: + +(require 'gud) +(require 'json) +(require 'bindat) +(eval-when-compile (require 'cl)) + +(defvar tool-bar-map) +(defvar speedbar-initial-expansion-list-name) +(defvar speedbar-frame) + +(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-thread-number nil + "Main current thread. + +Invalidation triggers use this variable to query GDB for +information on the specified thread by wrapping GDB/MI commands +in `gdb-current-context-command'. + +This variable may be updated implicitly by GDB via `gdb-stopped' +or explicitly by `gdb-select-thread'. + +Only `gdb-setq-thread-number' should be used to change this +value.") + +(defvar gdb-frame-number nil + "Selected frame level for main current thread. + +Updated according to the following rules: + +When a thread is selected or current thread stops, set to \"0\". + +When current thread goes running (and possibly exits eventually), +set to nil. + +May be manually changed by user with `gdb-select-frame'.") + +(defvar gdb-frame-address nil "Identity of frame for watch expression.") + +;; Used to show overlay arrow in source buffer. All set in +;; gdb-get-main-selected-frame. Disassembly buffer should not use +;; these but rely on buffer-local thread information instead. +(defvar gdb-selected-frame nil + "Name of selected function for main current thread.") +(defvar gdb-selected-file nil + "Name of selected file for main current thread.") +(defvar gdb-selected-line nil + "Number of selected line for main current thread.") + +(defvar gdb-threads-list nil + "Associative list of threads provided by \"-thread-info\" MI command. + +Keys are thread numbers (in strings) and values are structures as +returned from -thread-info by `gdb-json-partial-output'. Updated in +`gdb-thread-list-handler-custom'.") + +(defvar gdb-running-threads-count nil + "Number of currently running threads. + +If nil, no information is available. + +Updated in `gdb-thread-list-handler-custom'.") + +(defvar gdb-stopped-threads-count nil + "Number of currently stopped threads. + +See also `gdb-running-threads-count'.") + +(defvar gdb-breakpoints-list nil + "Associative list of breakpoints provided by \"-break-list\" MI command. + +Keys are breakpoint numbers (in string) and values are structures +as returned from \"-break-list\" by `gdb-json-partial-output' +\(\"body\" field is used). Updated in +`gdb-breakpoints-list-handler-custom'.") + +(defvar gdb-current-language nil) +(defvar gdb-var-list nil + "List of variables in watch window. +Each element has the form (VARNUM EXPRESSION NUMCHILD TYPE VALUE STATUS HAS_MORE FP) +where STATUS is nil (`unchanged'), `changed' or `out-of-scope', FP the frame +address for root variables.") +(defvar gdb-main-file nil "Source file from which program execution begins.") + +;; Overlay arrow markers +(defvar gdb-stack-position nil) +(defvar gdb-thread-position nil) +(defvar gdb-disassembly-position nil) + +(defvar gdb-location-alist nil + "Alist of breakpoint numbers and full filenames. Only used for files that +Emacs can't find.") +(defvar gdb-active-process nil + "GUD tooltips display variable values when t, and macro definitions otherwise.") +(defvar gdb-error "Non-nil when GDB is reporting an error.") +(defvar gdb-macro-info nil + "Non-nil if GDB knows that the inferior includes preprocessor macro info.") +(defvar gdb-register-names nil "List of register names.") +(defvar gdb-changed-registers nil + "List of changed register numbers (strings).") +(defvar gdb-buffer-fringe-width nil) +(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-source-file-list nil + "List of source files for the current executable.") +(defvar gdb-first-done-or-error t) +(defvar gdb-source-window nil) +(defvar gdb-inferior-status nil) +(defvar gdb-continuation nil) +(defvar gdb-version nil) +(defvar gdb-filter-output nil + "Message to be shown in GUD console. + +This variable is updated in `gdb-done-or-error' and returned by +`gud-gdbmi-marker-filter'.") + +(defvar gdb-non-stop nil + "Indicates whether current GDB session is using non-stop mode. + +It is initialized to `gdb-non-stop-setting' at the beginning of +every GDB session.") + +(defvar gdb-buffer-type nil + "One of the symbols bound in `gdb-buffer-rules'.") +(make-variable-buffer-local 'gdb-buffer-type) + +(defvar gdb-output-sink 'nil + "The disposition of the output of the current gdb command. +Possible values are these symbols: + + `user' -- gdb output should be copied to the GUD buffer + for the user to see. + + `emacs' -- output should be collected in the partial-output-buffer + for subsequent processing by a command. This is the + 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))) + +(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))))) + +;; Publish-subscribe + +(defmacro gdb-add-subscriber (publisher subscriber) + "Register new PUBLISHER's SUBSCRIBER. + +SUBSCRIBER must be a pair, where cdr is a function of one +argument (see `gdb-emit-signal')." + `(add-to-list ',publisher ,subscriber t)) + +(defmacro gdb-delete-subscriber (publisher subscriber) + "Unregister SUBSCRIBER from PUBLISHER." + `(setq ,publisher (delete ,subscriber + ,publisher))) + +(defun gdb-get-subscribers (publisher) + publisher) + +(defun gdb-emit-signal (publisher &optional signal) + "Call cdr for each subscriber of PUBLISHER with SIGNAL as argument." + (dolist (subscriber (gdb-get-subscribers publisher)) + (funcall (cdr subscriber) signal))) + +(defvar gdb-buf-publisher '() + "Used to invalidate GDB buffers by emitting a signal in +`gdb-update'. + +Must be a list of pairs with cars being buffers and cdr's being +valid signal handlers.") + +(defgroup gdb nil + "GDB graphical interface" + :group 'tools + :link '(info-link "(emacs)GDB Graphical Interface") + :version "23.2") + +(defgroup gdb-non-stop nil + "GDB non-stop debugging settings" + :group 'gdb + :version "23.2") + +(defgroup gdb-buffers nil + "GDB buffers" + :group 'gdb + :version "23.2") + +(defcustom gdb-debug-log-max 128 + "Maximum size of `gdb-debug-log'. If nil, size is unlimited." + :group 'gdb + :type '(choice (integer :tag "Number of elements") + (const :tag "Unlimited" nil)) + :version "22.1") + +(defcustom gdb-non-stop-setting t + "When in non-stop mode, stopped threads can be examined while +other threads continue to execute. + +GDB session needs to be restarted for this setting to take +effect." + :type 'boolean + :group 'gdb-non-stop + :version "23.2") + +;; TODO Some commands can't be called with --all (give a notice about +;; it in setting doc) +(defcustom gdb-gud-control-all-threads t + "When enabled, GUD execution commands affect all threads when +in non-stop mode. Otherwise, only current thread is affected." + :type 'boolean + :group 'gdb-non-stop + :version "23.2") + +(defcustom gdb-switch-reasons t + "List of stop reasons which cause Emacs to switch to the thread +which caused the stop. When t, switch to stopped thread no matter +what the reason was. When nil, never switch to stopped thread +automatically. + +This setting is used in non-stop mode only. In all-stop mode, +Emacs always switches to the thread which caused the stop." + ;; exited, exited-normally and exited-signalled are not + ;; thread-specific stop reasons and therefore are not included in + ;; this list + :type '(choice + (const :tag "All reasons" t) + (set :tag "Selection of reasons..." + (const :tag "A breakpoint was reached." "breakpoint-hit") + (const :tag "A watchpoint was triggered." "watchpoint-trigger") + (const :tag "A read watchpoint was triggered." "read-watchpoint-trigger") + (const :tag "An access watchpoint was triggered." "access-watchpoint-trigger") + (const :tag "Function finished execution." "function-finished") + (const :tag "Location reached." "location-reached") + (const :tag "Watchpoint has gone out of scope" "watchpoint-scope") + (const :tag "End of stepping range reached." "end-stepping-range") + (const :tag "Signal received (like interruption)." "signal-received")) + (const :tag "None" nil)) + :group 'gdb-non-stop + :version "23.2" + :link '(info-link "(gdb)GDB/MI Async Records")) + +(defcustom gdb-stopped-hooks nil + "This variable holds a list of functions to be called whenever +GDB stops. + +Each function takes one argument, a parsed MI response, which +contains fields of corresponding MI *stopped async record: + + ((stopped-threads . \"all\") + (thread-id . \"1\") + (frame (line . \"38\") + (fullname . \"/home/sphinx/projects/gsoc/server.c\") + (file . \"server.c\") + (args ((value . \"0x804b038\") + (name . \"arg\"))) + (func . \"hello\") + (addr . \"0x0804869e\")) + (reason . \"end-stepping-range\")) + +Note that \"reason\" is only present in non-stop debugging mode. + +`bindat-get-field' may be used to access the fields of response. + +Each function is called after the new current thread was selected +and GDB buffers were updated in `gdb-stopped'." + :type '(repeat function) + :group 'gdb + :version "23.2" + :link '(info-link "(gdb)GDB/MI Async Records")) + +(defcustom gdb-switch-when-another-stopped t + "When nil, Emacs won't switch to stopped thread if some other +stopped thread is already selected." + :type 'boolean + :group 'gdb-non-stop + :version "23.2") + +(defcustom gdb-stack-buffer-locations t + "Show file information or library names in stack buffers." + :type 'boolean + :group 'gdb-buffers + :version "23.2") + +(defcustom gdb-stack-buffer-addresses nil + "Show frame addresses in stack buffers." + :type 'boolean + :group 'gdb-buffers + :version "23.2") + +(defcustom gdb-thread-buffer-verbose-names t + "Show long thread names in threads buffer." + :type 'boolean + :group 'gdb-buffers + :version "23.2") + +(defcustom gdb-thread-buffer-arguments t + "Show function arguments in threads buffer." + :type 'boolean + :group 'gdb-buffers + :version "23.2") + +(defcustom gdb-thread-buffer-locations t + "Show file information or library names in threads buffer." + :type 'boolean + :group 'gdb-buffers + :version "23.2") + +(defcustom gdb-thread-buffer-addresses nil + "Show addresses for thread frames in threads buffer." + :type 'boolean + :group 'gdb-buffers + :version "23.2") + +(defcustom gdb-show-threads-by-default nil + "Show threads list buffer instead of breakpoints list by +default." + :type 'boolean + :group 'gdb-buffers + :version "23.2") + +(defvar gdb-debug-log nil + "List of commands sent to and replies received from GDB. +Most recent commands are listed first. This list stores only the last +`gdb-debug-log-max' values. This variable is used to debug GDB-MI.") + +;;;###autoload +(defcustom gdb-enable-debug nil + "Non-nil means record the process input and output in `gdb-debug-log'." + :type 'boolean + :group 'gdb + :version "22.1") + +(defcustom gdb-cpp-define-alist-program "gcc -E -dM -" + "Shell command for generating a list of defined macros in a source file. +This list is used to display the #define directive associated +with an identifier as a tooltip. It works in a debug session with +GDB, when `gud-tooltip-mode' is t. + +Set `gdb-cpp-define-alist-flags' for any include paths or +predefined macros." + :type 'string + :group 'gdb + :version "22.1") + +(defcustom gdb-cpp-define-alist-flags "" + "Preprocessor flags for `gdb-cpp-define-alist-program'." + :type 'string + :group 'gdb + :version "22.1") + + (defcustom gdb-create-source-file-list t + "Non-nil means create a list of files from which the executable was built. + Set this to nil if the GUD buffer displays \"initializing...\" in the mode + line for a long time when starting, possibly because your executable was + built from a large number of files. This allows quicker initialization + but means that these files are not automatically enabled for debugging, + e.g., you won't be able to click in the fringe to set a breakpoint until + execution has already stopped there." + :type 'boolean + :group 'gdb + :version "23.1") + +(defcustom gdb-show-main nil + "Non-nil means display source file containing the main routine at startup. +Also display the main routine in the disassembly buffer if present." + :type 'boolean + :group 'gdb + :version "22.1") + +(defun gdb-force-mode-line-update (status) + (let ((buffer gud-comint-buffer)) + (if (and buffer (buffer-name buffer)) + (with-current-buffer buffer + (setq mode-line-process + (format ":%s [%s]" + (process-status (get-buffer-process buffer)) status)) + ;; Force mode line redisplay soon. + (force-mode-line-update))))) + +(defun gdb-enable-debug (arg) + "Toggle logging of transaction between Emacs and Gdb. +The log is stored in `gdb-debug-log' as an alist with elements +whose cons is send, send-item or recv and whose cdr is the string +being transferred. This list may grow up to a size of +`gdb-debug-log-max' after which the oldest element (at the end of +the list) is deleted every time a new one is added (at the front)." + (interactive "P") + (setq gdb-enable-debug + (if (null arg) + (not gdb-enable-debug) + (> (prefix-numeric-value arg) 0))) + (message (format "Logging of transaction %sabled" + (if gdb-enable-debug "en" "dis")))) + +;; These two are used for menu and toolbar +(defun gdb-control-all-threads () + "Switch to non-stop/A mode." + (interactive) + (setq gdb-gud-control-all-threads t) + ;; Actually forcing the tool-bar to update. + (force-mode-line-update) + (message "Now in non-stop/A mode.")) + +(defun gdb-control-current-thread () + "Switch to non-stop/T mode." + (interactive) + (setq gdb-gud-control-all-threads nil) + ;; Actually forcing the tool-bar to update. + (force-mode-line-update) + (message "Now in non-stop/T mode.")) + +(defun gdb-find-watch-expression () + (let* ((var (nth (- (line-number-at-pos (point)) 2) gdb-var-list)) + (varnum (car var)) expr array) + (string-match "\\(var[0-9]+\\)\\.\\(.*\\)" varnum) + (let ((var1 (assoc (match-string 1 varnum) gdb-var-list)) var2 varnumlet + (component-list (split-string (match-string 2 varnum) "\\." t))) + (setq expr (nth 1 var1)) + (setq varnumlet (car var1)) + (dolist (component component-list) + (setq var2 (assoc varnumlet gdb-var-list)) + (setq expr (concat expr + (if (string-match ".*\\[[0-9]+\\]$" (nth 3 var2)) + (concat "[" component "]") + (concat "." component)))) + (setq varnumlet (concat varnumlet "." component))) + expr))) + +;; noall is used for commands which don't take --all, but only +;; --thread. +(defun gdb-gud-context-command (command &optional noall) + "When `gdb-non-stop' is t, add --thread option to COMMAND if +`gdb-gud-control-all-threads' is nil and --all option otherwise. +If NOALL is t, always add --thread option no matter what +`gdb-gud-control-all-threads' value is. + +When `gdb-non-stop' is nil, return COMMAND unchanged." + (if gdb-non-stop + (if (and gdb-gud-control-all-threads + (not noall) + (string-equal gdb-version "7.0+")) + (concat command " --all ") + (gdb-current-context-command command)) + command)) + +(defmacro gdb-gud-context-call (cmd1 &optional cmd2 noall noarg) + "`gud-call' wrapper which adds --thread/--all options between +CMD1 and CMD2. NOALL is the same as in `gdb-gud-context-command'. + +NOARG must be t when this macro is used outside `gud-def'" + `(gud-call + (concat (gdb-gud-context-command ,cmd1 ,noall) " " ,cmd2) + ,(when (not noarg) 'arg))) + +;;;###autoload +(defun gdb (command-line) + "Run gdb on program FILE in buffer *gud-FILE*. +The directory containing FILE becomes the initial working directory +and source-file directory for your debugger. + +If `gdb-many-windows' is nil (the default value) then gdb just +pops up the GUD buffer unless `gdb-show-main' is t. In this case +it starts with two windows: one displaying the GUD buffer and the +other with the source file with the main routine of the inferior. + +If `gdb-many-windows' is t, regardless of the value of +`gdb-show-main', the layout below will appear. Keybindings are +shown in some of the buffers. + +Watch expressions appear in the speedbar/slowbar. + +The following commands help control operation : + +`gdb-many-windows' - Toggle the number of windows gdb uses. +`gdb-restore-windows' - To restore the window layout. + +See Info node `(emacs)GDB Graphical Interface' for a more +detailed description of this mode. + + ++----------------------------------------------------------------------+ +| GDB Toolbar | ++-----------------------------------+----------------------------------+ +| GUD buffer (I/O of GDB) | Locals buffer | +| | | +| | | +| | | ++-----------------------------------+----------------------------------+ +| Source buffer | I/O buffer (of debugged program) | +| | (comint-mode) | +| | | +| | | +| | | +| | | +| | | +| | | ++-----------------------------------+----------------------------------+ +| Stack buffer | Breakpoints buffer | +| RET gdb-select-frame | SPC gdb-toggle-breakpoint | +| | RET gdb-goto-breakpoint | +| | D gdb-delete-breakpoint | ++-----------------------------------+----------------------------------+" + ;; + (interactive (list (gud-query-cmdline 'gdb))) + + (when (and gud-comint-buffer + (buffer-name gud-comint-buffer) + (get-buffer-process gud-comint-buffer) + (with-current-buffer gud-comint-buffer (eq gud-minor-mode 'gdba))) + (gdb-restore-windows) + (error + "Multiple debugging requires restarting in text command mode")) + ;; + (gud-common-init command-line nil 'gud-gdbmi-marker-filter) + (set (make-local-variable 'gud-minor-mode) 'gdbmi) + (setq comint-input-sender 'gdb-send) + + (gud-def gud-tbreak "tbreak %f:%l" "\C-t" + "Set temporary breakpoint at current line.") + (gud-def gud-jump + (progn (gud-call "tbreak %f:%l") (gud-call "jump %f:%l")) + "\C-j" "Set execution address to current line.") + + (gud-def gud-up "up %p" "<" "Up N stack frames (numeric arg).") + (gud-def gud-down "down %p" ">" "Down N stack frames (numeric arg).") + (gud-def gud-print "print %e" "\C-p" "Evaluate C expression at point.") + (gud-def gud-pstar "print* %e" nil + "Evaluate C dereferenced pointer expression at point.") + + (gud-def gud-step (gdb-gud-context-call "-exec-step" "%p" t) + "\C-s" + "Step one source line with display.") + (gud-def gud-stepi (gdb-gud-context-call "-exec-step-instruction" "%p" t) + "\C-i" + "Step one instruction with display.") + (gud-def gud-next (gdb-gud-context-call "-exec-next" "%p" t) + "\C-n" + "Step one line (skip functions).") + (gud-def gud-nexti (gdb-gud-context-call "-exec-next-instruction" "%p" t) + nil + "Step one instruction (skip functions).") + (gud-def gud-cont (gdb-gud-context-call "-exec-continue") + "\C-r" + "Continue with display.") + (gud-def gud-finish (gdb-gud-context-call "-exec-finish" nil t) + "\C-f" + "Finish executing current function.") + (gud-def gud-run "-exec-run" + nil + "Run the program.") + + (gud-def gud-break (if (not (string-match "Disassembly" mode-name)) + (gud-call "break %f:%l" arg) + (save-excursion + (beginning-of-line) + (forward-char 2) + (gud-call "break *%a" arg))) + "\C-b" "Set breakpoint at current line or address.") + + (gud-def gud-remove (if (not (string-match "Disassembly" mode-name)) + (gud-call "clear %f:%l" arg) + (save-excursion + (beginning-of-line) + (forward-char 2) + (gud-call "clear *%a" arg))) + "\C-d" "Remove breakpoint at current line or address.") + + ;; -exec-until doesn't support --all yet + (gud-def gud-until (if (not (string-match "Disassembly" mode-name)) + (gud-call "-exec-until %f:%l" arg) + (save-excursion + (beginning-of-line) + (forward-char 2) + (gud-call "-exec-until *%a" arg))) + "\C-u" "Continue to current line or address.") + ;; TODO Why arg here? + (gud-def + gud-go (gud-call (if gdb-active-process + (gdb-gud-context-command "-exec-continue") + "-exec-run") arg) + nil "Start or continue execution.") + + ;; For debugging Emacs only. + (gud-def gud-pp + (gud-call + (concat + "pp1 " (if (eq (buffer-local-value + 'major-mode (window-buffer)) 'speedbar-mode) + (gdb-find-watch-expression) "%e")) arg) + nil "Print the Emacs s-expression.") + + (define-key gud-minor-mode-map [left-margin mouse-1] + 'gdb-mouse-set-clear-breakpoint) + (define-key gud-minor-mode-map [left-fringe mouse-1] + 'gdb-mouse-set-clear-breakpoint) + (define-key gud-minor-mode-map [left-margin C-mouse-1] + 'gdb-mouse-toggle-breakpoint-margin) + (define-key gud-minor-mode-map [left-fringe C-mouse-1] + 'gdb-mouse-toggle-breakpoint-fringe) + + (define-key gud-minor-mode-map [left-margin drag-mouse-1] + 'gdb-mouse-until) + (define-key gud-minor-mode-map [left-fringe drag-mouse-1] + 'gdb-mouse-until) + (define-key gud-minor-mode-map [left-margin mouse-3] + 'gdb-mouse-until) + (define-key gud-minor-mode-map [left-fringe mouse-3] + 'gdb-mouse-until) + + (define-key gud-minor-mode-map [left-margin C-drag-mouse-1] + 'gdb-mouse-jump) + (define-key gud-minor-mode-map [left-fringe C-drag-mouse-1] + 'gdb-mouse-jump) + (define-key gud-minor-mode-map [left-fringe C-mouse-3] + 'gdb-mouse-jump) + (define-key gud-minor-mode-map [left-margin C-mouse-3] + 'gdb-mouse-jump) + + (local-set-key "\C-i" 'gud-gdb-complete-command) + (setq gdb-first-prompt t) + (setq gud-running nil) + + (gdb-update) + + (run-hooks 'gdb-mode-hook)) + +(defun gdb-init-1 () + ;; (re-)initialise + (setq gdb-selected-frame nil + 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-prompt-name nil + gdb-first-done-or-error t + gdb-buffer-fringe-width (car (window-fringes)) + gdb-debug-log nil + gdb-source-window nil + gdb-inferior-status nil + gdb-continuation nil + gdb-buf-publisher '() + gdb-threads-list '() + gdb-breakpoints-list '() + gdb-register-names '() + gdb-non-stop gdb-non-stop-setting) + ;; + (setq gdb-buffer-type 'gdbmi) + ;; + (gdb-force-mode-line-update + (propertize "initializing..." 'face font-lock-variable-name-face)) + + (gdb-get-buffer-create 'gdb-inferior-io) + (gdb-clear-inferior-io) + (set-process-filter (get-process "gdb-inferior") 'gdb-inferior-filter) + (gdb-input + ;; Needs GDB 6.4 onwards + (list (concat "-inferior-tty-set " + (or + ;; The process can run on a remote host. + (process-get (get-process "gdb-inferior") 'remote-tty) + (process-tty-name (get-process "gdb-inferior")))) + 'ignore)) + (if (eq window-system 'w32) + (gdb-input (list "-gdb-set new-console off" 'ignore))) + (gdb-input (list "-gdb-set height 0" 'ignore)) + + (when gdb-non-stop + (gdb-input (list "-gdb-set non-stop 1" 'gdb-non-stop-handler))) + + ;; find source file and compilation directory here + (gdb-input + ; Needs GDB 6.2 onwards. + (list "-file-list-exec-source-files" 'gdb-get-source-file-list)) + (if gdb-create-source-file-list + (gdb-input + ; Needs GDB 6.0 onwards. + (list "-file-list-exec-source-file" 'gdb-get-source-file))) + (gdb-input + (list "-gdb-show prompt" 'gdb-get-prompt))) + +(defun gdb-non-stop-handler () + (goto-char (point-min)) + (if (re-search-forward "No symbol" nil t) + (progn + (message "This version of GDB doesn't support non-stop mode. Turning it off.") + (setq gdb-non-stop nil) + (setq gdb-version "pre-7.0")) + (setq gdb-version "7.0+") + (gdb-input (list "-gdb-set target-async 1" 'ignore)) + (gdb-input (list "-enable-pretty-printing" 'ignore)))) + +(defvar gdb-define-alist nil "Alist of #define directives for GUD tooltips.") + +(defun gdb-create-define-alist () + "Create an alist of #define directives for GUD tooltips." + (let* ((file (buffer-file-name)) + (output + (with-output-to-string + (with-current-buffer standard-output + (and file + (file-exists-p file) + ;; call-process doesn't work with remote file names. + (not (file-remote-p default-directory)) + (call-process shell-file-name file + (list t nil) nil "-c" + (concat gdb-cpp-define-alist-program " " + gdb-cpp-define-alist-flags)))))) + (define-list (split-string output "\n" t)) + (name)) + (setq gdb-define-alist nil) + (dolist (define define-list) + (setq name (nth 1 (split-string define "[( ]"))) + (push (cons name define) gdb-define-alist)))) + +(declare-function tooltip-show "tooltip" (text &optional use-echo-area)) +(defvar tooltip-use-echo-area) + +(defun gdb-tooltip-print (expr) + (with-current-buffer (gdb-get-buffer 'gdb-partial-output-buffer) + (goto-char (point-min)) + (if (re-search-forward ".*value=\\(\".*\"\\)" nil t) + (tooltip-show + (concat expr " = " (read (match-string 1))) + (or gud-tooltip-echo-area tooltip-use-echo-area + (not (display-graphic-p))))))) + +;; If expr is a macro for a function don't print because of possible dangerous +;; side-effects. Also printing a function within a tooltip generates an +;; unexpected starting annotation (phase error). +(defun gdb-tooltip-print-1 (expr) + (with-current-buffer (gdb-get-buffer 'gdb-partial-output-buffer) + (goto-char (point-min)) + (if (search-forward "expands to: " nil t) + (unless (looking-at "\\S-+.*(.*).*") + (gdb-input + (list (concat "-data-evaluate-expression " expr) + `(lambda () (gdb-tooltip-print ,expr)))))))) + +(defun gdb-init-buffer () + (set (make-local-variable 'gud-minor-mode) 'gdbmi) + (set (make-local-variable 'tool-bar-map) gud-tool-bar-map) + (when gud-tooltip-mode + (make-local-variable 'gdb-define-alist) + (gdb-create-define-alist) + (add-hook 'after-save-hook 'gdb-create-define-alist nil t))) + +(defmacro gdb-if-arrow (arrow-position &rest body) + `(if ,arrow-position + (let ((buffer (marker-buffer ,arrow-position)) (line)) + (if (equal buffer (window-buffer (posn-window end))) + (with-current-buffer buffer + (when (or (equal start end) + (equal (posn-point start) + (marker-position ,arrow-position))) + ,@body)))))) + +(defun gdb-mouse-until (event) + "Continue running until a source line past the current line. +The destination source line can be selected either by clicking +with mouse-3 on the fringe/margin or dragging the arrow +with mouse-1 (default bindings)." + (interactive "e") + (let ((start (event-start event)) + (end (event-end event))) + (gdb-if-arrow gud-overlay-arrow-position + (setq line (line-number-at-pos (posn-point end))) + (gud-call (concat "until " (number-to-string line)))) + (gdb-if-arrow gdb-disassembly-position + (save-excursion + (goto-char (point-min)) + (forward-line (1- (line-number-at-pos (posn-point end)))) + (forward-char 2) + (gud-call (concat "until *%a")))))) + +(defun gdb-mouse-jump (event) + "Set execution address/line. +The destination source line can be selected either by clicking with C-mouse-3 +on the fringe/margin or dragging the arrow with C-mouse-1 (default bindings). +Unlike `gdb-mouse-until' the destination address can be before the current +line, and no execution takes place." + (interactive "e") + (let ((start (event-start event)) + (end (event-end event))) + (gdb-if-arrow gud-overlay-arrow-position + (setq line (line-number-at-pos (posn-point end))) + (progn + (gud-call (concat "tbreak " (number-to-string line))) + (gud-call (concat "jump " (number-to-string line))))) + (gdb-if-arrow gdb-disassembly-position + (save-excursion + (goto-char (point-min)) + (forward-line (1- (line-number-at-pos (posn-point end)))) + (forward-char 2) + (progn + (gud-call (concat "tbreak *%a")) + (gud-call (concat "jump *%a"))))))) + +(defcustom gdb-show-changed-values t + "If non-nil change the face of out of scope variables and changed values. +Out of scope variables are suppressed with `shadow' face. +Changed values are highlighted with the face `font-lock-warning-face'." + :type 'boolean + :group 'gdb + :version "22.1") + +(defcustom gdb-max-children 40 + "Maximum number of children before expansion requires confirmation." + :type 'integer + :group 'gdb + :version "22.1") + +(defcustom gdb-delete-out-of-scope t + "If non-nil delete watch expressions automatically when they go out of scope." + :type 'boolean + :group 'gdb + :version "22.2") + +(defcustom gdb-speedbar-auto-raise nil + "If non-nil raise speedbar every time display of watch expressions is\ + updated." + :type 'boolean + :group 'gdb + :version "22.1") + +(defcustom gdb-use-colon-colon-notation nil + "If non-nil use FUN::VAR format to display variables in the speedbar." + :type 'boolean + :group 'gdb + :version "22.1") + +(defun gdb-speedbar-auto-raise (arg) + "Toggle automatic raising of the speedbar for watch expressions. +With prefix argument ARG, automatically raise speedbar if ARG is +positive, otherwise don't automatically raise it." + (interactive "P") + (setq gdb-speedbar-auto-raise + (if (null arg) + (not gdb-speedbar-auto-raise) + (> (prefix-numeric-value arg) 0))) + (message (format "Auto raising %sabled" + (if gdb-speedbar-auto-raise "en" "dis")))) + +(define-key gud-minor-mode-map "\C-c\C-w" 'gud-watch) +(define-key global-map (concat gud-key-prefix "\C-w") 'gud-watch) + +(declare-function tooltip-identifier-from-point "tooltip" (point)) + +(defun gud-watch (&optional arg event) + "Watch expression at point. +With arg, enter name of variable to be watched in the minibuffer." + (interactive (list current-prefix-arg last-input-event)) + (let ((minor-mode (buffer-local-value 'gud-minor-mode gud-comint-buffer))) + (if (eq minor-mode 'gdbmi) + (progn + (if event (posn-set-point (event-end event))) + (require 'tooltip) + (save-selected-window + (let ((expr + (if arg + (completing-read "Name of variable: " + 'gud-gdb-complete-command) + (if (and transient-mark-mode mark-active) + (buffer-substring (region-beginning) (region-end)) + (concat (if (eq major-mode 'gdb-registers-mode) "$") + (tooltip-identifier-from-point (point))))))) + (set-text-properties 0 (length expr) nil expr) + (gdb-input + (list (concat"-var-create - * " expr "") + `(lambda () (gdb-var-create-handler ,expr))))))) + (message "gud-watch is a no-op in this mode.")))) + +(defun gdb-var-create-handler (expr) + (let* ((result (gdb-json-partial-output))) + (if (not (bindat-get-field result 'msg)) + (let ((var + (list (bindat-get-field result 'name) + (if (and (string-equal gdb-current-language "c") + gdb-use-colon-colon-notation gdb-selected-frame) + (setq expr (concat gdb-selected-frame "::" expr)) + expr) + (bindat-get-field result 'numchild) + (bindat-get-field result 'type) + (bindat-get-field result 'value) + nil + (bindat-get-field result 'has_more) + gdb-frame-address))) + (push var gdb-var-list) + (speedbar 1) + (unless (string-equal + speedbar-initial-expansion-list-name "GUD") + (speedbar-change-initial-expansion-list "GUD"))) + (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))) + ;; Dummy command to update speedbar even when idle. + (gdb-input (list "-environment-pwd" 'gdb-speedbar-timer-fn)) + ;; Keep gdb-pending-triggers non-nil till end. + (gdb-add-pending 'gdb-speedbar-timer))) + +(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) + (goto-char (point-min)) + (re-search-forward ".*value=\\(\".*\"\\)" nil t) + (let ((var (assoc varnum gdb-var-list))) + (when var + (if changed (setcar (nthcdr 5 var) 'changed)) + (setcar (nthcdr 4 var) (read (match-string 1))))) + (gdb-speedbar-update)) + +; Uses "-var-list-children --all-values". Needs GDB 6.1 onwards. +(defun gdb-var-list-children (varnum) + (gdb-input + (list (concat "-var-update " varnum) 'ignore)) + (gdb-input + (list (concat "-var-list-children --all-values " + varnum) + `(lambda () (gdb-var-list-children-handler ,varnum))))) + +(defun gdb-var-list-children-handler (varnum) + (let* ((var-list nil) + (output (bindat-get-field (gdb-json-partial-output "child"))) + (children (bindat-get-field output 'children))) + (catch 'child-already-watched + (dolist (var gdb-var-list) + (if (string-equal varnum (car var)) + (progn + ;; With dynamic varobjs numchild may have increased. + (setcar (nthcdr 2 var) (bindat-get-field output 'numchild)) + (push var var-list) + (dolist (child children) + (let ((varchild (list (bindat-get-field child 'name) + (bindat-get-field child 'exp) + (bindat-get-field child 'numchild) + (bindat-get-field child 'type) + (bindat-get-field child 'value) + nil + (bindat-get-field child 'has_more)))) + (if (assoc (car varchild) gdb-var-list) + (throw 'child-already-watched nil)) + (push varchild var-list)))) + (push var var-list))) + (setq gdb-var-list (nreverse var-list)))) + (gdb-speedbar-update)) + +(defun gdb-var-set-format (format) + "Set the output format for a variable displayed in the speedbar." + (let* ((var (nth (- (count-lines (point-min) (point)) 2) gdb-var-list)) + (varnum (car var))) + (gdb-input + (list (concat "-var-set-format " varnum " " format) 'ignore)) + (gdb-var-update))) + +(defun gdb-var-delete-1 (var varnum) + (gdb-input + (list (concat "-var-delete " varnum) 'ignore)) + (setq gdb-var-list (delq var gdb-var-list)) + (dolist (varchild gdb-var-list) + (if (string-match (concat (car var) "\\.") (car varchild)) + (setq gdb-var-list (delq varchild gdb-var-list))))) + +(defun gdb-var-delete () + "Delete watch expression at point from the speedbar." + (interactive) + (let ((text (speedbar-line-text))) + (string-match "\\(\\S-+\\)" text) + (let* ((var (nth (- (count-lines (point-min) (point)) 2) gdb-var-list)) + (varnum (car var))) + (if (string-match "\\." (car var)) + (message-box "Can only delete a root expression") + (gdb-var-delete-1 var varnum))))) + +(defun gdb-var-delete-children (varnum) + "Delete children of variable object at point from the speedbar." + (gdb-input + (list (concat "-var-delete -c " varnum) 'ignore))) + +(defun gdb-edit-value (text token indent) + "Assign a value to a variable displayed in the speedbar." + (let* ((var (nth (- (count-lines (point-min) (point)) 2) gdb-var-list)) + (varnum (car var)) (value)) + (setq value (read-string "New value: ")) + (gdb-input + (list (concat "-var-assign " varnum " " value) + `(lambda () (gdb-edit-value-handler ,value)))))) + +(defconst gdb-error-regexp "\\^error,msg=\\(\".+\"\\)") + +(defun gdb-edit-value-handler (value) + (goto-char (point-min)) + (if (re-search-forward gdb-error-regexp nil t) + (message-box "Invalid number or expression (%s)" value))) + +; Uses "-var-update --all-values". Needs GDB 6.4 onwards. +(defun gdb-var-update () + (if (not (gdb-pending-p 'gdb-var-update)) + (gdb-input + (list "-var-update --all-values *" 'gdb-var-update-handler))) + (gdb-add-pending 'gdb-var-update)) + +(defun gdb-var-update-handler () + (let ((changelist (bindat-get-field (gdb-json-partial-output) 'changelist))) + (dolist (var gdb-var-list) + (setcar (nthcdr 5 var) nil)) + (let ((temp-var-list gdb-var-list)) + (dolist (change changelist) + (let* ((varnum (bindat-get-field change 'name)) + (var (assoc varnum gdb-var-list)) + (new-num (bindat-get-field change 'new_num_children))) + (when var + (let ((scope (bindat-get-field change 'in_scope)) + (has-more (bindat-get-field change 'has_more))) + (cond ((string-equal scope "false") + (if gdb-delete-out-of-scope + (gdb-var-delete-1 var varnum) + (setcar (nthcdr 5 var) 'out-of-scope))) + ((string-equal scope "true") + (setcar (nthcdr 6 var) has-more) + (when (and (or (not has-more) + (string-equal has-more "0")) + (not new-num) + (string-equal (nth 2 var) "0")) + (setcar (nthcdr 4 var) + (bindat-get-field change 'value)) + (setcar (nthcdr 5 var) 'changed))) + ((string-equal scope "invalid") + (gdb-var-delete-1 var varnum))))) + (let ((var-list nil) var1 + (children (bindat-get-field change 'new_children))) + (if new-num + (progn + (setq var1 (pop temp-var-list)) + (while var1 + (if (string-equal varnum (car var1)) + (let ((new (string-to-number new-num)) + (previous (string-to-number (nth 2 var1)))) + (setcar (nthcdr 2 var1) new-num) + (push var1 var-list) + (cond ((> new previous) + ;; Add new children to list. + (dotimes (dummy previous) + (push (pop temp-var-list) var-list)) + (dolist (child children) + (let ((varchild + (list (bindat-get-field child 'name) + (bindat-get-field child 'exp) + (bindat-get-field child 'numchild) + (bindat-get-field child 'type) + (bindat-get-field child 'value) + 'changed + (bindat-get-field child 'has_more)))) + (push varchild var-list)))) + ;; Remove deleted children from list. + ((< new previous) + (dotimes (dummy new) + (push (pop temp-var-list) var-list)) + (dotimes (dummy (- previous new)) + (pop temp-var-list))))) + (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) + "Expand the node the user clicked on. +TEXT is the text of the button we clicked on, a + or - item. +TOKEN is data related to this node. +INDENT is the current indentation depth." + (cond ((string-match "+" text) ;expand this node + (let* ((var (assoc token gdb-var-list)) + (expr (nth 1 var)) (children (nth 2 var))) + (if (or (<= (string-to-number children) gdb-max-children) + (y-or-n-p + (format "%s has %s children. Continue? " expr children))) + (gdb-var-list-children token)))) + ((string-match "-" text) ;contract this node + (dolist (var gdb-var-list) + (if (string-match (concat token "\\.") (car var)) + (setq gdb-var-list (delq var gdb-var-list)))) + (gdb-var-delete-children token) + (speedbar-change-expand-button-char ?+) + (speedbar-delete-subblock indent)) + (t (error "Ooops... not sure what to do"))) + (speedbar-center-buffer-smartly)) + +(defun gdb-get-target-string () + (with-current-buffer gud-comint-buffer + gud-target-name)) + + +;; +;; gdb buffers. +;; +;; Each buffer has a TYPE -- a symbol that identifies the function +;; of that particular buffer. +;; +;; The usual gdb interaction buffer is given the type `gdbmi' and +;; is constructed specially. +;; +;; Others are constructed by gdb-get-buffer-create and +;; named according to the rules set forth in the gdb-buffer-rules + +(defvar gdb-buffer-rules '()) + +(defun gdb-rules-name-maker (rules-entry) + (cadr rules-entry)) +(defun gdb-rules-buffer-mode (rules-entry) + (nth 2 rules-entry)) +(defun gdb-rules-update-trigger (rules-entry) + (nth 3 rules-entry)) + +(defun gdb-update-buffer-name () + "Rename current buffer according to name-maker associated with +it in `gdb-buffer-rules'." + (let ((f (gdb-rules-name-maker (assoc gdb-buffer-type + gdb-buffer-rules)))) + (when f (rename-buffer (funcall f))))) + +(defun gdb-current-buffer-rules () + "Get `gdb-buffer-rules' entry for current buffer type." + (assoc gdb-buffer-type gdb-buffer-rules)) + +(defun gdb-current-buffer-thread () + "Get thread object of current buffer from `gdb-threads-list'. + +When current buffer is not bound to any thread, return main +thread." + (cdr (assoc gdb-thread-number gdb-threads-list))) + +(defun gdb-current-buffer-frame () + "Get current stack frame object for thread of current buffer." + (bindat-get-field (gdb-current-buffer-thread) 'frame)) + +(defun gdb-buffer-type (buffer) + "Get value of `gdb-buffer-type' for BUFFER." + (with-current-buffer buffer + gdb-buffer-type)) + +(defun gdb-buffer-shows-main-thread-p () + "Return t if current GDB buffer shows main selected thread and +is not bound to it." + (current-buffer) + (not (local-variable-p 'gdb-thread-number))) + +(defun gdb-get-buffer (buffer-type &optional thread) + "Get a specific GDB buffer. + +In that buffer, `gdb-buffer-type' must be equal to BUFFER-TYPE +and `gdb-thread-number' (if provided) must be equal to THREAD." + (catch 'found + (dolist (buffer (buffer-list) nil) + (with-current-buffer buffer + (when (and (eq gdb-buffer-type buffer-type) + (or (not thread) + (equal gdb-thread-number thread))) + (throw 'found buffer)))))) + +(defun gdb-get-buffer-create (buffer-type &optional thread) + "Create a new GDB buffer of the type specified by BUFFER-TYPE. +The buffer-type should be one of the cars in `gdb-buffer-rules'. + +If THREAD is non-nil, it is assigned to `gdb-thread-number' +buffer-local variable of the new buffer. + +Buffer mode and name are selected according to buffer type. + +If buffer has trigger associated with it in `gdb-buffer-rules', +this trigger is subscribed to `gdb-buf-publisher' and called with +'update argument." + (or (gdb-get-buffer buffer-type thread) + (let ((rules (assoc buffer-type gdb-buffer-rules)) + (new (generate-new-buffer "limbo"))) + (with-current-buffer new + (let ((mode (gdb-rules-buffer-mode rules)) + (trigger (gdb-rules-update-trigger rules))) + (when mode (funcall mode)) + (setq gdb-buffer-type buffer-type) + (when thread + (set (make-local-variable 'gdb-thread-number) thread)) + (set (make-local-variable 'gud-minor-mode) + (buffer-local-value 'gud-minor-mode gud-comint-buffer)) + (set (make-local-variable 'tool-bar-map) gud-tool-bar-map) + (rename-buffer (funcall (gdb-rules-name-maker rules))) + (when trigger + (gdb-add-subscriber gdb-buf-publisher + (cons (current-buffer) + (gdb-bind-function-to-buffer trigger (current-buffer)))) + (funcall trigger 'start)) + (current-buffer)))))) + +(defun gdb-bind-function-to-buffer (expr buffer) + "Return a function which will evaluate EXPR in BUFFER." + `(lambda (&rest args) + (with-current-buffer ,buffer + (apply ',expr args)))) + +;; Used to define all gdb-frame-*-buffer functions except +;; `gdb-frame-io-buffer' +(defmacro def-gdb-frame-for-buffer (name buffer &optional doc) + "Define a function NAME which shows gdb BUFFER in a separate frame. + +DOC is an optional documentation string." + `(defun ,name (&optional thread) + ,(when doc doc) + (interactive) + (let ((special-display-regexps (append special-display-regexps '(".*"))) + (special-display-frame-alist gdb-frame-parameters)) + (display-buffer (gdb-get-buffer-create ,buffer thread))))) + +(defmacro def-gdb-display-buffer (name buffer &optional doc) + "Define a function NAME which shows gdb BUFFER. + +DOC is an optional documentation string." + `(defun ,name (&optional thread) + ,(when doc doc) + (interactive) + (gdb-display-buffer + (gdb-get-buffer-create ,buffer thread) t))) + +;; Used to display windows with thread-bound buffers +(defmacro def-gdb-preempt-display-buffer (name buffer &optional doc + split-horizontal) + `(defun ,name (&optional thread) + ,(when doc doc) + (message thread) + (gdb-preempt-existing-or-display-buffer + (gdb-get-buffer-create ,buffer thread) + ,split-horizontal))) + +;; This assoc maps buffer type symbols to rules. Each rule is a list of +;; at least one and possible more functions. The functions have these +;; roles in defining a buffer type: +;; +;; NAME - Return a name for this buffer type. +;; +;; The remaining function(s) are optional: +;; +;; MODE - called in a new buffer with no arguments, should establish +;; the proper mode for the buffer. +;; + +(defun gdb-set-buffer-rules (buffer-type &rest rules) + (let ((binding (assoc buffer-type gdb-buffer-rules))) + (if binding + (setcdr binding rules) + (push (cons buffer-type rules) + gdb-buffer-rules)))) + +(defun gdb-parent-mode () + "Generic mode to derive all other GDB buffer modes from." + (kill-all-local-variables) + (setq buffer-read-only t) + (buffer-disable-undo) + ;; Delete buffer from gdb-buf-publisher when it's killed + ;; (if it has an associated update trigger) + (add-hook + 'kill-buffer-hook + (function + (lambda () + (let ((trigger (gdb-rules-update-trigger + (gdb-current-buffer-rules)))) + (when trigger + (gdb-delete-subscriber + gdb-buf-publisher + ;; This should match gdb-add-subscriber done in + ;; gdb-get-buffer-create + (cons (current-buffer) + (gdb-bind-function-to-buffer trigger (current-buffer)))))))) + nil t)) + +;; Partial-output buffer : This accumulates output from a command executed on +;; behalf of emacs (rather than the user). +;; +(gdb-set-buffer-rules 'gdb-partial-output-buffer + 'gdb-partial-output-name) + +(defun gdb-partial-output-name () + (concat " *partial-output-" + (gdb-get-target-string) + "*")) + + +(gdb-set-buffer-rules 'gdb-inferior-io + 'gdb-inferior-io-name + 'gdb-inferior-io-mode) + +(defun gdb-inferior-io-name () + (concat "*input/output of " + (gdb-get-target-string) + "*")) + +(defun gdb-display-io-buffer () + "Display IO of debugged program in a separate window." + (interactive) + (gdb-display-buffer + (gdb-get-buffer-create 'gdb-inferior-io) t)) + +(defconst gdb-frame-parameters + '((height . 14) (width . 80) + (unsplittable . t) + (tool-bar-lines . nil) + (menu-bar-lines . nil) + (minibuffer . nil))) + +(defun gdb-frame-io-buffer () + "Display IO of debugged program in a new frame." + (interactive) + (let ((special-display-regexps (append special-display-regexps '(".*"))) + (special-display-frame-alist gdb-frame-parameters)) + (display-buffer (gdb-get-buffer-create 'gdb-inferior-io)))) + +(defvar gdb-inferior-io-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "\C-c\C-c" 'gdb-io-interrupt) + (define-key map "\C-c\C-z" 'gdb-io-stop) + (define-key map "\C-c\C-\\" 'gdb-io-quit) + (define-key map "\C-c\C-d" 'gdb-io-eof) + (define-key map "\C-d" 'gdb-io-eof) + map)) + +;; We want to use comint because it has various nifty and familiar features. +(define-derived-mode gdb-inferior-io-mode comint-mode "Inferior I/O" + "Major mode for gdb inferior-io. + +The following commands are available: +\\{gdb-inferior-io-mode-map}" + + :syntax-table nil :abbrev-table nil + +(make-comint-in-buffer "gdb-inferior" (current-buffer) nil)) + +(defun gdb-inferior-filter (proc string) + (unless (string-equal string "") + (gdb-display-buffer (gdb-get-buffer-create 'gdb-inferior-io) t)) + (with-current-buffer (gdb-get-buffer-create 'gdb-inferior-io) + (comint-output-filter proc string))) + +(defun gdb-io-interrupt () + "Interrupt the program being debugged." + (interactive) + (interrupt-process + (get-buffer-process gud-comint-buffer) comint-ptyp)) + +(defun gdb-io-quit () + "Send quit signal to the program being debugged." + (interactive) + (quit-process + (get-buffer-process gud-comint-buffer) comint-ptyp)) + +(defun gdb-io-stop () + "Stop the program being debugged." + (interactive) + (stop-process + (get-buffer-process gud-comint-buffer) comint-ptyp)) + +(defun gdb-io-eof () + "Send end-of-file to the program being debugged." + (interactive) + (process-send-eof + (get-buffer-process gud-comint-buffer))) + +(defun gdb-clear-inferior-io () + (with-current-buffer (gdb-get-buffer-create 'gdb-inferior-io) + (erase-buffer))) + + +(defconst breakpoint-xpm-data + "/* XPM */ +static char *magick[] = { +/* columns rows colors chars-per-pixel */ +\"10 10 2 1\", +\" c red\", +\"+ c None\", +/* pixels */ +\"+++ +++\", +\"++ ++\", +\"+ +\", +\" \", +\" \", +\" \", +\" \", +\"+ +\", +\"++ ++\", +\"+++ +++\", +};" + "XPM data used for breakpoint icon.") + +(defconst breakpoint-enabled-pbm-data + "P1 +10 10\", +0 0 0 0 1 1 1 1 0 0 0 0 +0 0 0 1 1 1 1 1 1 0 0 0 +0 0 1 1 1 1 1 1 1 1 0 0 +0 1 1 1 1 1 1 1 1 1 1 0 +0 1 1 1 1 1 1 1 1 1 1 0 +0 1 1 1 1 1 1 1 1 1 1 0 +0 1 1 1 1 1 1 1 1 1 1 0 +0 0 1 1 1 1 1 1 1 1 0 0 +0 0 0 1 1 1 1 1 1 0 0 0 +0 0 0 0 1 1 1 1 0 0 0 0" + "PBM data used for enabled breakpoint icon.") + +(defconst breakpoint-disabled-pbm-data + "P1 +10 10\", +0 0 1 0 1 0 1 0 0 0 +0 1 0 1 0 1 0 1 0 0 +1 0 1 0 1 0 1 0 1 0 +0 1 0 1 0 1 0 1 0 1 +1 0 1 0 1 0 1 0 1 0 +0 1 0 1 0 1 0 1 0 1 +1 0 1 0 1 0 1 0 1 0 +0 1 0 1 0 1 0 1 0 1 +0 0 1 0 1 0 1 0 1 0 +0 0 0 1 0 1 0 1 0 0" + "PBM data used for disabled breakpoint icon.") + +(defvar breakpoint-enabled-icon nil + "Icon for enabled breakpoint in display margin.") + +(defvar breakpoint-disabled-icon nil + "Icon for disabled breakpoint in display margin.") + +(declare-function define-fringe-bitmap "fringe.c" + (bitmap bits &optional height width align)) + +(and (display-images-p) + ;; Bitmap for breakpoint in fringe + (define-fringe-bitmap 'breakpoint + "\x3c\x7e\xff\xff\xff\xff\x7e\x3c") + ;; Bitmap for gud-overlay-arrow in fringe + (define-fringe-bitmap 'hollow-right-triangle + "\xe0\x90\x88\x84\x84\x88\x90\xe0")) + +(defface breakpoint-enabled + '((t + :foreground "red1" + :weight bold)) + "Face for enabled breakpoint icon in fringe." + :group 'gdb) + +(defface breakpoint-disabled + '((((class color) (min-colors 88)) :foreground "grey70") + ;; Ensure that on low-color displays that we end up something visible. + (((class color) (min-colors 8) (background light)) + :foreground "black") + (((class color) (min-colors 8) (background dark)) + :foreground "white") + (((type tty) (class mono)) + :inverse-video t) + (t :background "gray")) + "Face for disabled breakpoint icon in fringe." + :group 'gdb) + + +(defun gdb-send (proc string) + "A comint send filter for gdb." + (with-current-buffer gud-comint-buffer + (let ((inhibit-read-only t)) + (remove-text-properties (point-min) (point-max) '(face)))) + ;; mimic <RET> key to repeat previous command in GDB + (if (not (string= "" string)) + (setq gdb-last-command string) + (if gdb-last-command (setq string gdb-last-command))) + (if gdb-enable-debug + (push (cons 'mi-send (concat string "\n")) gdb-debug-log)) + (if (string-match "^-" string) + ;; MI command + (progn + (setq gdb-first-done-or-error t) + (process-send-string proc (concat string "\n"))) + ;; CLI command + (if (string-match "\\\\$" string) + (setq gdb-continuation (concat gdb-continuation string "\n")) + (setq gdb-first-done-or-error t) + (process-send-string proc (concat "-interpreter-exec console \"" + gdb-continuation string "\"\n")) + (setq gdb-continuation nil)))) + +(defun gdb-input (item) + (if gdb-enable-debug (push (cons 'send-item item) gdb-debug-log)) + (setq gdb-token-number (1+ gdb-token-number)) + (setcar item (concat (number-to-string gdb-token-number) (car item))) + (push (cons gdb-token-number (car (cdr item))) gdb-handler-alist) + (process-send-string (get-buffer-process gud-comint-buffer) + (concat (car item) "\n"))) + +;; NOFRAME is used for gud execution control commands +(defun gdb-current-context-command (command) + "Add --thread to gdb COMMAND when needed." + (if (and gdb-thread-number + (string-equal gdb-version "7.0+")) + (concat command " --thread " gdb-thread-number) + command)) + +(defun gdb-current-context-buffer-name (name) + "Add thread information and asterisks to string NAME. + +If `gdb-thread-number' is nil, just wrap NAME in asterisks." + (concat "*" name + (if (local-variable-p 'gdb-thread-number) + (format " (bound to thread %s)" gdb-thread-number) + "") + "*")) + +(defun gdb-current-context-mode-name (mode) + "Add thread information to MODE which is to be used as +`mode-name'." + (concat mode + (if gdb-thread-number + (format " [thread %s]" gdb-thread-number) + ""))) + + +(defcustom gud-gdb-command-name "gdb -i=mi" + "Default command to execute an executable under the GDB debugger." + :type 'string + :group 'gdb) + +(defun gdb-resync() + (setq gud-running nil) + (setq gdb-output-sink 'user) + (setq gdb-pending-triggers nil)) + +(defun gdb-update () + "Update buffers showing status of debug session." + (when gdb-first-prompt + (gdb-force-mode-line-update + (propertize "initializing..." 'face font-lock-variable-name-face)) + (gdb-init-1) + (setq gdb-first-prompt nil)) + + (gdb-get-main-selected-frame) + ;; We may need to update gdb-threads-list so we can use + (gdb-get-buffer-create 'gdb-threads-buffer) + ;; gdb-break-list is maintained in breakpoints handler + (gdb-get-buffer-create 'gdb-breakpoints-buffer) + + (gdb-emit-signal gdb-buf-publisher 'update) + + (gdb-get-changed-registers) + + (when (and (boundp 'speedbar-frame) (frame-live-p speedbar-frame)) + (dolist (var gdb-var-list) + (setcar (nthcdr 5 var) nil)) + (gdb-var-update))) + +;; gdb-setq-thread-number and gdb-update-gud-running are decoupled +;; because we may need to update current gud-running value without +;; changing current thread (see gdb-running) +(defun gdb-setq-thread-number (number) + "Only this function must be used to change `gdb-thread-number' +value to NUMBER, because `gud-running' and `gdb-frame-number' +need to be updated appropriately when current thread changes." + ;; GDB 6.8 and earlier always output thread-id="0" when stopping. + (unless (string-equal number "0") (setq gdb-thread-number number)) + (setq gdb-frame-number "0") + (gdb-update-gud-running)) + +(defun gdb-update-gud-running () + "Set `gud-running' according to the state of current thread. + +`gdb-frame-number' is set to 0 if current thread is now stopped. + +Note that when `gdb-gud-control-all-threads' is t, `gud-running' +cannot be reliably used to determine whether or not execution +control buttons should be shown in menu or toolbar. Use +`gdb-running-threads-count' and `gdb-stopped-threads-count' +instead. + +For all-stop mode, thread information is unavailable while target +is running." + (let ((old-value gud-running)) + (setq gud-running + (string= (bindat-get-field (gdb-current-buffer-thread) 'state) + "running")) + ;; Set frame number to "0" when _current_ threads stops + (when (and (gdb-current-buffer-thread) + (not (eq gud-running old-value))) + (setq gdb-frame-number "0")))) + +(defun gdb-show-run-p () + "Return t if \"Run/continue\" should be shown on the toolbar." + (or (not gdb-active-process) + (and (or + (not gdb-gud-control-all-threads) + (not gdb-non-stop)) + (not gud-running)) + (and gdb-gud-control-all-threads + (> gdb-stopped-threads-count 0)))) + +(defun gdb-show-stop-p () + "Return t if \"Stop\" should be shown on the toolbar." + (or (and (or + (not gdb-gud-control-all-threads) + (not gdb-non-stop)) + gud-running) + (and gdb-gud-control-all-threads + (> gdb-running-threads-count 0)))) + +;; GUD displays the selected GDB frame. This might might not be the current +;; GDB frame (after up, down etc). If no GDB frame is visible but the last +;; visited breakpoint is, use that window. +(defun gdb-display-source-buffer (buffer) + (let* ((last-window (if gud-last-last-frame + (get-buffer-window + (gud-find-file (car gud-last-last-frame))))) + (source-window (or last-window + (if (and gdb-source-window + (window-live-p gdb-source-window)) + gdb-source-window)))) + (when source-window + (setq gdb-source-window source-window) + (set-window-buffer source-window buffer)) + source-window)) + +(defun gdb-car< (a b) + (< (car a) (car b))) + +(defvar gdbmi-record-list + '((gdb-gdb . "(gdb) \n") + (gdb-done . "\\([0-9]*\\)\\^done,?\\(.*?\\)\n") + (gdb-starting . "\\([0-9]*\\)\\^running\n") + (gdb-error . "\\([0-9]*\\)\\^error,\\(.*?\\)\n") + (gdb-console . "~\\(\".*?\"\\)\n") + (gdb-internals . "&\\(\".*?\"\\)\n") + (gdb-stopped . "\\*stopped,?\\(.*?\\)\n") + (gdb-running . "\\*running,\\(.*?\n\\)") + (gdb-thread-created . "=thread-created,\\(.*?\n\\)") + (gdb-thread-selected . "=thread-selected,\\(.*?\\)\n") + (gdb-thread-exited . "=thread-exited,\\(.*?\n\\)") + (gdb-ignored-notification . "=[-[:alpha:]]+,?\\(.*?\\)\n") + (gdb-shell . "\\(\\(?:^.+\n\\)+\\)"))) + +(defun gud-gdbmi-marker-filter (string) + "Filter GDB/MI output." + + ;; Record transactions if logging is enabled. + (when gdb-enable-debug + (push (cons 'recv string) gdb-debug-log) + (if (and gdb-debug-log-max + (> (length gdb-debug-log) gdb-debug-log-max)) + (setcdr (nthcdr (1- gdb-debug-log-max) gdb-debug-log) nil))) + + ;; Recall the left over gud-marker-acc from last time + (setq gud-marker-acc (concat gud-marker-acc string)) + + ;; Start accumulating output for the GUD buffer + (setq gdb-filter-output "") + (let ((output-record) (output-record-list)) + + ;; Process all the complete markers in this chunk. + (dolist (gdbmi-record gdbmi-record-list) + (while (string-match (cdr gdbmi-record) gud-marker-acc) + (push (list (match-beginning 0) + (car gdbmi-record) + (match-string 1 gud-marker-acc) + (match-string 2 gud-marker-acc) + (match-end 0)) + output-record-list) + (setq gud-marker-acc + (concat (substring gud-marker-acc 0 (match-beginning 0)) + ;; Pad with spaces to preserve position. + (make-string (length (match-string 0 gud-marker-acc)) 32) + (substring gud-marker-acc (match-end 0)))))) + + (setq output-record-list (sort output-record-list 'gdb-car<)) + + (dolist (output-record output-record-list) + (let ((record-type (cadr output-record)) + (arg1 (nth 2 output-record)) + (arg2 (nth 3 output-record))) + (if (eq record-type 'gdb-error) + (gdb-done-or-error arg2 arg1 'error) + (if (eq record-type 'gdb-done) + (gdb-done-or-error arg2 arg1 'done) + ;; Suppress "No registers." since GDB 6.8 and earlier duplicates MI + ;; error message on internal stream. Don't print to GUD buffer. + (unless (and (eq record-type 'gdb-internals) + (string-equal (read arg1) "No registers.\n")) + (funcall record-type arg1)))))) + + (setq gdb-output-sink 'user) + ;; Remove padding. + (string-match "^ *" gud-marker-acc) + (setq gud-marker-acc (substring gud-marker-acc (match-end 0))) + + gdb-filter-output)) + +(defun gdb-gdb (output-field)) + +(defun gdb-shell (output-field) + (let ((gdb-output-sink gdb-output-sink)) + (setq gdb-filter-output + (concat output-field gdb-filter-output)))) + +(defun gdb-ignored-notification (output-field)) + +;; gdb-invalidate-threads is defined to accept 'update-threads signal +(defun gdb-thread-created (output-field)) +(defun gdb-thread-exited (output-field) + "Handle =thread-exited async record: unset `gdb-thread-number' + if current thread exited and update threads list." + (let* ((thread-id (bindat-get-field (gdb-json-string output-field) 'id))) + (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. + (gdb-wait-for-pending + (gdb-emit-signal gdb-buf-publisher 'update-threads)))) + +(defun gdb-thread-selected (output-field) + "Handler for =thread-selected MI output record. + +Sets `gdb-thread-number' to new id." + (let* ((result (gdb-json-string output-field)) + (thread-id (bindat-get-field result 'id))) + (gdb-setq-thread-number thread-id) + ;; Typing `thread N` in GUD buffer makes GDB emit `^done` followed + ;; 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. + (gdb-wait-for-pending + (gdb-update)))) + +(defun gdb-running (output-field) + (let* ((thread-id (bindat-get-field (gdb-json-string output-field) 'thread-id))) + ;; We reset gdb-frame-number to nil if current thread has gone + ;; running. This can't be done in gdb-thread-list-handler-custom + ;; because we need correct gdb-frame-number by the time + ;; -thread-info command is sent. + (when (or (string-equal thread-id "all") + (string-equal thread-id gdb-thread-number)) + (setq gdb-frame-number nil))) + (setq gdb-inferior-status "running") + (gdb-force-mode-line-update + (propertize gdb-inferior-status 'face font-lock-type-face)) + (when (not gdb-non-stop) + (setq gud-running t)) + (setq gdb-active-process t) + (gdb-emit-signal gdb-buf-publisher 'update-threads)) + +(defun gdb-starting (output-field) + ;; CLI commands don't emit ^running at the moment so use gdb-running too. + (setq gdb-inferior-status "running") + (gdb-force-mode-line-update + (propertize gdb-inferior-status 'face font-lock-type-face)) + (setq gdb-active-process t) + (setq gud-running t) + ;; GDB doesn't seem to respond to -thread-info before first stop or + ;; thread exit (even in non-stop mode), so this is useless. + ;; Behaviour may change in the future. + (gdb-emit-signal gdb-buf-publisher 'update-threads)) + +;; -break-insert -t didn't give a reason before gdb 6.9 + +(defun gdb-stopped (output-field) + "Given the contents of *stopped MI async record, select new +current thread and update GDB buffers." + ;; Reason is available with target-async only + (let* ((result (gdb-json-string output-field)) + (reason (bindat-get-field result 'reason)) + (thread-id (bindat-get-field result 'thread-id))) + + ;; -data-list-register-names needs to be issued for any stopped + ;; thread + (when (not gdb-register-names) + (gdb-input + (list (concat "-data-list-register-names" + (if (string-equal gdb-version "7.0+") + (concat" --thread " thread-id))) + 'gdb-register-names-handler))) + +;;; Don't set gud-last-frame here as it's currently done in gdb-frame-handler +;;; because synchronous GDB doesn't give these fields with CLI. +;;; (when file +;;; (setq +;;; ;; Extract the frame position from the marker. +;;; gud-last-frame (cons file +;;; (string-to-number +;;; (match-string 6 gud-marker-acc))))) + + (setq gdb-inferior-status (or reason "unknown")) + (gdb-force-mode-line-update + (propertize gdb-inferior-status 'face font-lock-warning-face)) + (if (string-equal reason "exited-normally") + (setq gdb-active-process nil)) + + ;; Select new current thread. + + ;; Don't switch if we have no reasons selected + (when gdb-switch-reasons + ;; Switch from another stopped thread only if we have + ;; gdb-switch-when-another-stopped: + (when (or gdb-switch-when-another-stopped + (not (string= "stopped" + (bindat-get-field (gdb-current-buffer-thread) 'state)))) + ;; Switch if current reason has been selected or we have no + ;; reasons + (if (or (eq gdb-switch-reasons t) + (member reason gdb-switch-reasons)) + (when (not (string-equal gdb-thread-number thread-id)) + (message (concat "Switched to thread " thread-id)) + (gdb-setq-thread-number thread-id)) + (message (format "Thread %s stopped" thread-id))))) + + ;; Print "(gdb)" to GUD console + (when gdb-first-done-or-error + (setq gdb-filter-output (concat gdb-filter-output gdb-prompt-name))) + + ;; In non-stop, we update information as soon as another thread gets + ;; stopped + (when (or gdb-first-done-or-error + gdb-non-stop) + ;; In all-stop this updates gud-running properly as well. + (gdb-update) + (setq gdb-first-done-or-error nil)) + (run-hook-with-args 'gdb-stopped-hooks result))) + +;; Remove the trimmings from log stream containing debugging messages +;; being produced by GDB's internals, use warning face and send to GUD +;; buffer. +(defun gdb-internals (output-field) + (setq gdb-filter-output + (gdb-concat-output + gdb-filter-output + (let ((error-message + (read output-field))) + (put-text-property + 0 (length error-message) + 'face font-lock-warning-face + error-message) + error-message)))) + +;; Remove the trimmings from the console stream and send to GUD buffer +;; (frontend MI commands should not print to this stream) +(defun gdb-console (output-field) + (setq gdb-filter-output + (gdb-concat-output + gdb-filter-output + (read output-field)))) + +(defun gdb-done-or-error (output-field token-number type) + (if (string-equal token-number "") + ;; Output from command entered by user + (progn + (setq gdb-output-sink 'user) + (setq token-number nil) + ;; MI error - send to minibuffer + (when (eq type 'error) + ;; Skip "msg=" from `output-field' + (message (read (substring output-field 4))) + ;; Don't send to the console twice. (If it is a console error + ;; it is also in the console stream.) + (setq output-field nil))) + ;; Output from command from frontend. + (setq gdb-output-sink 'emacs)) + + (gdb-clear-partial-output) + (when gdb-first-done-or-error + (unless (or token-number gud-running) + (setq gdb-filter-output (concat gdb-filter-output gdb-prompt-name))) + (gdb-update) + (setq gdb-first-done-or-error nil)) + + (setq gdb-filter-output + (gdb-concat-output gdb-filter-output output-field)) + + (if token-number + (progn + (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))))) + +(defun gdb-concat-output (so-far new) + (let ((sink gdb-output-sink)) + (cond + ((eq sink 'user) (concat so-far new)) + ((eq sink 'emacs) + (gdb-append-to-partial-output new) + so-far)))) + +(defun gdb-append-to-partial-output (string) + (with-current-buffer (gdb-get-buffer-create 'gdb-partial-output-buffer) + (goto-char (point-max)) + (insert string))) + +(defun gdb-clear-partial-output () + (with-current-buffer (gdb-get-buffer-create 'gdb-partial-output-buffer) + (erase-buffer))) + +(defun gdb-jsonify-buffer (&optional fix-key fix-list) + "Prepare GDB/MI output in current buffer for parsing with `json-read'. + +Field names are wrapped in double quotes and equal signs are +replaced with semicolons. + +If FIX-KEY is non-nil, strip all \"FIX-KEY=\" occurrences from +partial output. This is used to get rid of useless keys in lists +in MI messages, e.g.: [key=.., key=..]. -stack-list-frames and +-break-info are examples of MI commands which issue such +responses. + +If FIX-LIST is non-nil, \"FIX-LIST={..}\" is replaced with +\"FIX-LIST=[..]\" prior to parsing. This is used to fix broken +-break-info output when it contains breakpoint script field +incompatible with GDB/MI output syntax." + (save-excursion + (goto-char (point-min)) + (when fix-key + (save-excursion + (while (re-search-forward (concat "[\\[,]\\(" fix-key "=\\)") nil t) + (replace-match "" nil nil nil 1)))) + (when fix-list + (save-excursion + ;; Find positions of braces which enclose broken list + (while (re-search-forward (concat fix-list "={\"") nil t) + (let ((p1 (goto-char (- (point) 2))) + (p2 (progn (forward-sexp) + (1- (point))))) + ;; Replace braces with brackets + (save-excursion + (goto-char p1) + (delete-char 1) + (insert "[") + (goto-char p2) + (delete-char 1) + (insert "]")))))) + (goto-char (point-min)) + (insert "{") + (while (re-search-forward + "\\([[:alnum:]-_]+\\)=\\({\\|\\[\\|\"\"\\|\".*?[^\\]\"\\)" nil t) + (replace-match "\"\\1\":\\2" nil nil)) + (goto-char (point-max)) + (insert "}"))) + +(defun gdb-json-read-buffer (&optional fix-key fix-list) + "Prepare and parse GDB/MI output in current buffer with `json-read'. + +FIX-KEY and FIX-LIST work as in `gdb-jsonify-buffer'." + (gdb-jsonify-buffer fix-key fix-list) + (save-excursion + (goto-char (point-min)) + (let ((json-array-type 'list)) + (json-read)))) + +(defun gdb-json-string (string &optional fix-key fix-list) + "Prepare and parse STRING containing GDB/MI output with `json-read'. + +FIX-KEY and FIX-LIST work as in `gdb-jsonify-buffer'." + (with-temp-buffer + (insert string) + (gdb-json-read-buffer fix-key fix-list))) + +(defun gdb-json-partial-output (&optional fix-key fix-list) + "Prepare and parse gdb-partial-output-buffer with `json-read'. + +FIX-KEY and FIX-KEY work as in `gdb-jsonify-buffer'." + (with-current-buffer (gdb-get-buffer-create 'gdb-partial-output-buffer) + (gdb-json-read-buffer fix-key fix-list))) + +(defun gdb-line-posns (line) + "Return a pair of LINE beginning and end positions." + (let ((offset (1+ (- line (line-number-at-pos))))) + (cons + (line-beginning-position offset) + (line-end-position offset)))) + +(defmacro gdb-mark-line (line variable) + "Set VARIABLE marker to point at beginning of LINE. + +If current window has no fringes, inverse colors on LINE. + +Return position where LINE begins." + `(save-excursion + (let* ((posns (gdb-line-posns ,line)) + (start-posn (car posns)) + (end-posn (cdr posns))) + (set-marker ,variable (copy-marker start-posn)) + (when (not (> (car (window-fringes)) 0)) + (put-text-property start-posn end-posn + 'font-lock-face '(:inverse-video t))) + start-posn))) + +(defun gdb-pad-string (string padding) + (format (concat "%" (number-to-string padding) "s") string)) + +;; gdb-table struct is a way to programmatically construct simple +;; tables. It help to reliably align columns of data in GDB buffers +;; and provides +(defstruct + gdb-table + (column-sizes nil) + (rows nil) + (row-properties nil) + (right-align nil)) + +(defun gdb-mapcar* (function &rest seqs) + "Apply FUNCTION to each element of SEQS, and make a list of the results. +If there are several SEQS, FUNCTION is called with that many +arugments, and mapping stops as sson as the shortest list runs +out." + (let ((shortest (apply #'min (mapcar #'length seqs)))) + (mapcar (lambda (i) + (apply function + (mapcar + (lambda (seq) + (nth i seq)) + seqs))) + (number-sequence 0 (1- shortest))))) + +(defun gdb-table-add-row (table row &optional properties) + "Add ROW of string to TABLE and recalculate column sizes. + +When non-nil, PROPERTIES will be added to the whole row when +calling `gdb-table-string'." + (let ((rows (gdb-table-rows table)) + (row-properties (gdb-table-row-properties table)) + (column-sizes (gdb-table-column-sizes table)) + (right-align (gdb-table-right-align table))) + (when (not column-sizes) + (setf (gdb-table-column-sizes table) + (make-list (length row) 0))) + (setf (gdb-table-rows table) + (append rows (list row))) + (setf (gdb-table-row-properties table) + (append row-properties (list properties))) + (setf (gdb-table-column-sizes table) + (gdb-mapcar* (lambda (x s) + (let ((new-x + (max (abs x) (string-width (or s ""))))) + (if right-align new-x (- new-x)))) + (gdb-table-column-sizes table) + row)) + ;; Avoid trailing whitespace at eol + (if (not (gdb-table-right-align table)) + (setcar (last (gdb-table-column-sizes table)) 0)))) + +(defun gdb-table-string (table &optional sep) + "Return TABLE as a string with columns separated with SEP." + (let ((column-sizes (gdb-table-column-sizes table)) + (res "")) + (mapconcat + 'identity + (gdb-mapcar* + (lambda (row properties) + (apply 'propertize + (mapconcat 'identity + (gdb-mapcar* (lambda (s x) (gdb-pad-string s x)) + row column-sizes) + sep) + properties)) + (gdb-table-rows table) + (gdb-table-row-properties table)) + "\n"))) + +;; bindat-get-field goes deep, gdb-get-many-fields goes wide +(defun gdb-get-many-fields (struct &rest fields) + "Return a list of FIELDS values from STRUCT." + (let ((values)) + (dolist (field fields values) + (setq values (append values (list (bindat-get-field struct field))))))) + +(defmacro def-gdb-auto-update-trigger (trigger-name gdb-command + handler-name + &optional signal-list) + "Define a trigger TRIGGER-NAME which sends GDB-COMMAND and sets +HANDLER-NAME as its handler. HANDLER-NAME is bound to current +buffer with `gdb-bind-function-to-buffer'. + +If SIGNAL-LIST is non-nil, GDB-COMMAND is sent only when the +defined trigger is called with an argument from SIGNAL-LIST. It's +not recommended to define triggers with empty SIGNAL-LIST. +Normally triggers should respond at least to 'update signal. + +Normally the trigger defined by this command must be called from +the buffer where HANDLER-NAME must work. This should be done so +that buffer-local thread number may be used in GDB-COMMAND (by +calling `gdb-current-context-command'). +`gdb-bind-function-to-buffer' is used to achieve this, see +`gdb-get-buffer-create'. + +Triggers defined by this command are meant to be used as a +trigger argument when describing buffer types with +`gdb-set-buffer-rules'." + `(defun ,trigger-name (&optional signal) + (when + (or (not ,signal-list) + (memq signal ,signal-list)) + (when (not (gdb-pending-p + (cons (current-buffer) ',trigger-name))) + (gdb-input + (list ,gdb-command + (gdb-bind-function-to-buffer ',handler-name (current-buffer)))) + (gdb-add-pending (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 + &optional nopreserve) + "Define a handler HANDLER-NAME for TRIGGER-NAME with 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. + +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* ((buffer-read-only nil) + (window (get-buffer-window (current-buffer) 0)) + (start (window-start window)) + (p (window-point window))) + (erase-buffer) + (,custom-defun) + (gdb-update-buffer-name) + ,(when (not nopreserve) + '(set-window-start window start) + '(set-window-point window p))))) + +(defmacro def-gdb-trigger-and-handler (trigger-name gdb-command + handler-name custom-defun + &optional signal-list) + "Define trigger and handler. + +TRIGGER-NAME trigger is defined to send GDB-COMMAND. See +`def-gdb-auto-update-trigger'. + +HANDLER-NAME handler uses customization of CUSTOM-DEFUN. See +`def-gdb-auto-update-handler'." + `(progn + (def-gdb-auto-update-trigger ,trigger-name + ,gdb-command + ,handler-name ,signal-list) + (def-gdb-auto-update-handler ,handler-name + ,trigger-name ,custom-defun))) + + + +;; Breakpoint buffer : This displays the output of `-break-list'. +(def-gdb-trigger-and-handler + gdb-invalidate-breakpoints "-break-list" + gdb-breakpoints-list-handler gdb-breakpoints-list-handler-custom + '(start update)) + +(gdb-set-buffer-rules + 'gdb-breakpoints-buffer + 'gdb-breakpoints-buffer-name + 'gdb-breakpoints-mode + 'gdb-invalidate-breakpoints) + +(defun gdb-breakpoints-list-handler-custom () + (let ((breakpoints-list (bindat-get-field + (gdb-json-partial-output "bkpt" "script") + 'BreakpointTable 'body)) + (table (make-gdb-table))) + (setq gdb-breakpoints-list nil) + (gdb-table-add-row table '("Num" "Type" "Disp" "Enb" "Addr" "Hits" "What")) + (dolist (breakpoint breakpoints-list) + (add-to-list 'gdb-breakpoints-list + (cons (bindat-get-field breakpoint 'number) + breakpoint)) + (let ((at (bindat-get-field breakpoint 'at)) + (pending (bindat-get-field breakpoint 'pending)) + (func (bindat-get-field breakpoint 'func)) + (type (bindat-get-field breakpoint 'type))) + (gdb-table-add-row table + (list + (bindat-get-field breakpoint 'number) + type + (bindat-get-field breakpoint 'disp) + (let ((flag (bindat-get-field breakpoint 'enabled))) + (if (string-equal flag "y") + (propertize "y" 'font-lock-face font-lock-warning-face) + (propertize "n" 'font-lock-face font-lock-comment-face))) + (bindat-get-field breakpoint 'addr) + (bindat-get-field breakpoint 'times) + (if (string-match ".*watchpoint" type) + (bindat-get-field breakpoint 'what) + (or pending at + (concat "in " + (propertize func 'font-lock-face font-lock-function-name-face) + (gdb-frame-location breakpoint))))) + ;; Add clickable properties only for breakpoints with file:line + ;; information + (append (list 'gdb-breakpoint breakpoint) + (when func '(help-echo "mouse-2, RET: visit breakpoint" + mouse-face highlight)))))) + (insert (gdb-table-string table " ")) + (gdb-place-breakpoints))) + +;; Put breakpoint icons in relevant margins (even those set in the GUD buffer). +(defun gdb-place-breakpoints () + (let ((flag) (bptno)) + ;; Remove all breakpoint-icons in source buffers but not assembler buffer. + (dolist (buffer (buffer-list)) + (with-current-buffer buffer + (if (and (eq gud-minor-mode 'gdbmi) + (not (string-match "\\` ?\\*.+\\*\\'" (buffer-name)))) + (gdb-remove-breakpoint-icons (point-min) (point-max))))) + (dolist (breakpoint gdb-breakpoints-list) + (let* ((breakpoint (cdr breakpoint)) ; gdb-breakpoints-list is + ; an associative list + (line (bindat-get-field breakpoint 'line))) + (when line + (let ((file (bindat-get-field breakpoint 'fullname)) + (flag (bindat-get-field breakpoint 'enabled)) + (bptno (bindat-get-field breakpoint 'number))) + (unless (file-exists-p file) + (setq file (cdr (assoc bptno gdb-location-alist)))) + (if (and file + (not (string-equal file "File not found"))) + (with-current-buffer + (find-file-noselect file 'nowarn) + (gdb-init-buffer) + ;; Only want one breakpoint icon at each location. + (gdb-put-breakpoint-icon (string-equal flag "y") bptno + (string-to-number line))) + (gdb-input + (list (concat "list " file ":1") + 'ignore)) + (gdb-input + (list "-file-list-exec-source-file" + `(lambda () (gdb-get-location + ,bptno ,line ,flag))))))))))) + +(defvar gdb-source-file-regexp "fullname=\"\\(.*?\\)\"") + +(defun gdb-get-location (bptno line flag) + "Find the directory containing the relevant source file. +Put in buffer and place breakpoint icon." + (goto-char (point-min)) + (catch 'file-not-found + (if (re-search-forward gdb-source-file-regexp nil t) + (delete (cons bptno "File not found") gdb-location-alist) + (push (cons bptno (match-string 1)) gdb-location-alist) + (gdb-resync) + (unless (assoc bptno gdb-location-alist) + (push (cons bptno "File not found") gdb-location-alist) + (message-box "Cannot find source file for breakpoint location. +Add directory to search path for source files using the GDB command, dir.")) + (throw 'file-not-found nil)) + (with-current-buffer (find-file-noselect (match-string 1)) + (gdb-init-buffer) + ;; only want one breakpoint icon at each location + (gdb-put-breakpoint-icon (eq flag ?y) bptno (string-to-number line))))) + +(add-hook 'find-file-hook 'gdb-find-file-hook) + +(defun gdb-find-file-hook () + "Set up buffer for debugging if file is part of the source code +of the current session." + (if (and (buffer-name gud-comint-buffer) + ;; in case gud or gdb-ui is just loaded + gud-comint-buffer + (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) + 'gdbmi)) + (if (member buffer-file-name gdb-source-file-list) + (with-current-buffer (find-buffer-visiting buffer-file-name) + (gdb-init-buffer))))) + +(declare-function gud-remove "gdb-mi" t t) ; gud-def +(declare-function gud-break "gdb-mi" t t) ; gud-def +(declare-function fringe-bitmaps-at-pos "fringe.c" (&optional pos window)) + +(defun gdb-mouse-set-clear-breakpoint (event) + "Set/clear breakpoint in left fringe/margin at mouse click. +If not in a source or disassembly buffer just set point." + (interactive "e") + (mouse-minibuffer-check event) + (let ((posn (event-end event))) + (with-selected-window (posn-window posn) + (if (or (buffer-file-name) (eq major-mode 'gdb-disassembly-mode)) + (if (numberp (posn-point posn)) + (save-excursion + (goto-char (posn-point posn)) + (if (or (posn-object posn) + (eq (car (fringe-bitmaps-at-pos (posn-point posn))) + 'breakpoint)) + (gud-remove nil) + (gud-break nil))))) + (posn-set-point posn)))) + +(defun gdb-mouse-toggle-breakpoint-margin (event) + "Enable/disable breakpoint in left margin with mouse click." + (interactive "e") + (mouse-minibuffer-check event) + (let ((posn (event-end event))) + (if (numberp (posn-point posn)) + (with-selected-window (posn-window posn) + (save-excursion + (goto-char (posn-point posn)) + (if (posn-object posn) + (gud-basic-call + (let ((bptno (get-text-property + 0 'gdb-bptno (car (posn-string posn))))) + (concat + (if (get-text-property + 0 'gdb-enabled (car (posn-string posn))) + "-break-disable " + "-break-enable ") + bptno))))))))) + +(defun gdb-mouse-toggle-breakpoint-fringe (event) + "Enable/disable breakpoint in left fringe with mouse click." + (interactive "e") + (mouse-minibuffer-check event) + (let* ((posn (event-end event)) + (pos (posn-point posn)) + obj) + (when (numberp pos) + (with-selected-window (posn-window posn) + (with-current-buffer (window-buffer (selected-window)) + (goto-char pos) + (dolist (overlay (overlays-in pos pos)) + (when (overlay-get overlay 'put-break) + (setq obj (overlay-get overlay 'before-string)))) + (when (stringp obj) + (gud-basic-call + (concat + (if (get-text-property 0 'gdb-enabled obj) + "-break-disable " + "-break-enable ") + (get-text-property 0 'gdb-bptno obj))))))))) + +(defun gdb-breakpoints-buffer-name () + (concat "*breakpoints of " (gdb-get-target-string) "*")) + +(def-gdb-display-buffer + gdb-display-breakpoints-buffer + 'gdb-breakpoints-buffer + "Display status of user-settable breakpoints.") + +(def-gdb-frame-for-buffer + gdb-frame-breakpoints-buffer + 'gdb-breakpoints-buffer + "Display status of user-settable breakpoints in a new frame.") + +(defvar gdb-breakpoints-mode-map + (let ((map (make-sparse-keymap)) + (menu (make-sparse-keymap "Breakpoints"))) + (define-key menu [quit] '("Quit" . gdb-delete-frame-or-window)) + (define-key menu [goto] '("Goto" . gdb-goto-breakpoint)) + (define-key menu [delete] '("Delete" . gdb-delete-breakpoint)) + (define-key menu [toggle] '("Toggle" . gdb-toggle-breakpoint)) + (suppress-keymap map) + (define-key map [menu-bar breakpoints] (cons "Breakpoints" menu)) + (define-key map " " 'gdb-toggle-breakpoint) + (define-key map "D" 'gdb-delete-breakpoint) + ;; Don't bind "q" to kill-this-buffer as we need it for breakpoint icons. + (define-key map "q" 'gdb-delete-frame-or-window) + (define-key map "\r" 'gdb-goto-breakpoint) + (define-key map "\t" '(lambda () + (interactive) + (gdb-set-window-buffer + (gdb-get-buffer-create 'gdb-threads-buffer) t))) + (define-key map [mouse-2] 'gdb-goto-breakpoint) + (define-key map [follow-link] 'mouse-face) + map)) + +(defun gdb-delete-frame-or-window () + "Delete frame if there is only one window. Otherwise delete the window." + (interactive) + (if (one-window-p) (delete-frame) + (delete-window))) + +;;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)) + +(defmacro gdb-propertize-header (name buffer help-echo mouse-face face) + `(propertize ,name + 'help-echo ,help-echo + 'mouse-face ',mouse-face + 'face ',face + 'local-map + (gdb-make-header-line-mouse-map + 'mouse-1 + (lambda (event) (interactive "e") + (save-selected-window + (select-window (posn-window (event-start event))) + (gdb-set-window-buffer + (gdb-get-buffer-create ',buffer) t) ))))) + + +;; uses "-thread-info". Needs GDB 7.0 onwards. +;;; Threads view + +(defun gdb-threads-buffer-name () + (concat "*threads of " (gdb-get-target-string) "*")) + +(def-gdb-display-buffer + gdb-display-threads-buffer + 'gdb-threads-buffer + "Display GDB threads.") + +(def-gdb-frame-for-buffer + gdb-frame-threads-buffer + 'gdb-threads-buffer + "Display GDB threads in a new frame.") + +(def-gdb-trigger-and-handler + gdb-invalidate-threads (gdb-current-context-command "-thread-info") + gdb-thread-list-handler gdb-thread-list-handler-custom + '(start update update-threads)) + +(gdb-set-buffer-rules + 'gdb-threads-buffer + 'gdb-threads-buffer-name + 'gdb-threads-mode + 'gdb-invalidate-threads) + +(defvar gdb-threads-font-lock-keywords + '(("in \\([^ ]+\\)" (1 font-lock-function-name-face)) + (" \\(stopped\\)" (1 font-lock-warning-face)) + (" \\(running\\)" (1 font-lock-string-face)) + ("\\(\\(\\sw\\|[_.]\\)+\\)=" (1 font-lock-variable-name-face))) + "Font lock keywords used in `gdb-threads-mode'.") + +(defvar gdb-threads-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "\r" 'gdb-select-thread) + (define-key map "f" 'gdb-display-stack-for-thread) + (define-key map "F" 'gdb-frame-stack-for-thread) + (define-key map "l" 'gdb-display-locals-for-thread) + (define-key map "L" 'gdb-frame-locals-for-thread) + (define-key map "r" 'gdb-display-registers-for-thread) + (define-key map "R" 'gdb-frame-registers-for-thread) + (define-key map "d" 'gdb-display-disassembly-for-thread) + (define-key map "D" 'gdb-frame-disassembly-for-thread) + (define-key map "i" 'gdb-interrupt-thread) + (define-key map "c" 'gdb-continue-thread) + (define-key map "s" 'gdb-step-thread) + (define-key map "\t" '(lambda () + (interactive) + (gdb-set-window-buffer + (gdb-get-buffer-create 'gdb-breakpoints-buffer) t))) + (define-key map [mouse-2] 'gdb-select-thread) + (define-key map [follow-link] 'mouse-face) + map)) + +(defvar gdb-threads-header + (list + (gdb-propertize-header "Breakpoints" gdb-breakpoints-buffer + "mouse-1: select" mode-line-highlight mode-line-inactive) + " " + (gdb-propertize-header "Threads" gdb-threads-buffer + nil nil mode-line))) + +(define-derived-mode gdb-threads-mode gdb-parent-mode "Threads" + "Major mode for GDB threads. + +\\{gdb-threads-mode-map}" + (setq gdb-thread-position (make-marker)) + (add-to-list 'overlay-arrow-variable-list 'gdb-thread-position) + (setq header-line-format gdb-threads-header) + (set (make-local-variable 'font-lock-defaults) + '(gdb-threads-font-lock-keywords)) + (run-mode-hooks 'gdb-threads-mode-hook) + 'gdb-invalidate-threads) + +(defun gdb-thread-list-handler-custom () + (let ((threads-list (bindat-get-field (gdb-json-partial-output) 'threads)) + (table (make-gdb-table)) + (marked-line nil)) + (setq gdb-threads-list nil) + (setq gdb-running-threads-count 0) + (setq gdb-stopped-threads-count 0) + (set-marker gdb-thread-position nil) + + (dolist (thread (reverse threads-list)) + (let ((running (string-equal (bindat-get-field thread 'state) "running"))) + (add-to-list 'gdb-threads-list + (cons (bindat-get-field thread 'id) + thread)) + (if running + (incf gdb-running-threads-count) + (incf gdb-stopped-threads-count)) + + (gdb-table-add-row table + (list + (bindat-get-field thread 'id) + (concat + (if gdb-thread-buffer-verbose-names + (concat (bindat-get-field thread 'target-id) " ") "") + (bindat-get-field thread 'state) + ;; Include frame information for stopped threads + (if (not running) + (concat + " in " (bindat-get-field thread 'frame 'func) + (if gdb-thread-buffer-arguments + (concat + " (" + (let ((args (bindat-get-field thread 'frame 'args))) + (mapconcat + (lambda (arg) + (apply 'format `("%s=%s" ,@(gdb-get-many-fields arg 'name 'value)))) + args ",")) + ")") + "") + (if gdb-thread-buffer-locations + (gdb-frame-location (bindat-get-field thread 'frame)) "") + (if gdb-thread-buffer-addresses + (concat " at " (bindat-get-field thread 'frame 'addr)) "")) + ""))) + (list + 'gdb-thread thread + 'mouse-face 'highlight + 'help-echo "mouse-2, RET: select thread"))) + (when (string-equal gdb-thread-number + (bindat-get-field thread 'id)) + (setq marked-line (length gdb-threads-list)))) + (insert (gdb-table-string table " ")) + (when marked-line + (gdb-mark-line marked-line gdb-thread-position))) + ;; We update gud-running here because we need to make sure that + ;; gdb-threads-list is up-to-date + (gdb-update-gud-running) + (gdb-emit-signal gdb-buf-publisher 'update-disassembly)) + +(defmacro def-gdb-thread-buffer-command (name custom-defun &optional doc) + "Define a NAME command which will act upon thread on the current line. + +CUSTOM-DEFUN may use locally bound `thread' variable, which will +be the value of 'gdb-thread property of the current line. If +'gdb-thread is nil, error is signaled." + `(defun ,name (&optional event) + ,(when doc doc) + (interactive (list last-input-event)) + (if event (posn-set-point (event-end event))) + (save-excursion + (beginning-of-line) + (let ((thread (get-text-property (point) 'gdb-thread))) + (if thread + ,custom-defun + (error "Not recognized as thread line")))))) + +(defmacro def-gdb-thread-buffer-simple-command (name buffer-command &optional doc) + "Define a NAME which will call BUFFER-COMMAND with id of thread +on the current line." + `(def-gdb-thread-buffer-command ,name + (,buffer-command (bindat-get-field thread 'id)) + ,doc)) + +(def-gdb-thread-buffer-command gdb-select-thread + (let ((new-id (bindat-get-field thread 'id))) + (gdb-setq-thread-number new-id) + (gdb-input (list (concat "-thread-select " new-id) 'ignore)) + (gdb-update)) + "Select the thread at current line of threads buffer.") + +(def-gdb-thread-buffer-simple-command + gdb-display-stack-for-thread + gdb-preemptively-display-stack-buffer + "Display stack buffer for the thread at current line.") + +(def-gdb-thread-buffer-simple-command + gdb-display-locals-for-thread + gdb-preemptively-display-locals-buffer + "Display locals buffer for the thread at current line.") + +(def-gdb-thread-buffer-simple-command + gdb-display-registers-for-thread + gdb-preemptively-display-registers-buffer + "Display registers buffer for the thread at current line.") + +(def-gdb-thread-buffer-simple-command + gdb-display-disassembly-for-thread + gdb-preemptively-display-disassembly-buffer + "Display disassembly buffer for the thread at current line.") + +(def-gdb-thread-buffer-simple-command + gdb-frame-stack-for-thread + gdb-frame-stack-buffer + "Display a new frame with stack buffer for the thread at +current line.") + +(def-gdb-thread-buffer-simple-command + gdb-frame-locals-for-thread + gdb-frame-locals-buffer + "Display a new frame with locals buffer for the thread at +current line.") + +(def-gdb-thread-buffer-simple-command + gdb-frame-registers-for-thread + gdb-frame-registers-buffer + "Display a new frame with registers buffer for the thread at +current line.") + +(def-gdb-thread-buffer-simple-command + gdb-frame-disassembly-for-thread + gdb-frame-disassembly-buffer + "Display a new frame with disassembly buffer for the thread at +current line.") + +(defmacro def-gdb-thread-buffer-gud-command (name gud-command &optional doc) + "Define a NAME which will execute GUD-COMMAND with +`gdb-thread-number' locally bound to id of thread on the current +line." + `(def-gdb-thread-buffer-command ,name + (if gdb-non-stop + (let ((gdb-thread-number (bindat-get-field thread 'id)) + (gdb-gud-control-all-threads nil)) + (call-interactively #',gud-command)) + (error "Available in non-stop mode only, customize `gdb-non-stop-setting'")) + ,doc)) + +(def-gdb-thread-buffer-gud-command + gdb-interrupt-thread + gud-stop-subjob + "Interrupt thread at current line.") + +(def-gdb-thread-buffer-gud-command + gdb-continue-thread + gud-cont + "Continue thread at current line.") + +(def-gdb-thread-buffer-gud-command + gdb-step-thread + gud-step + "Step thread at current line.") + + +;;; Memory view + +(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") + +(def-gdb-trigger-and-handler + gdb-invalidate-memory + (format "-data-read-memory %s %s %d %d %d" + gdb-memory-address + gdb-memory-format + gdb-memory-unit + gdb-memory-rows + gdb-memory-columns) + gdb-read-memory-handler + gdb-read-memory-custom + '(start update)) + +(gdb-set-buffer-rules + 'gdb-memory-buffer + 'gdb-memory-buffer-name + 'gdb-memory-mode + 'gdb-invalidate-memory) + +(defun gdb-memory-column-width (size format) + "Return length of string with memory unit of SIZE in FORMAT. + +SIZE is in bytes, as in `gdb-memory-unit'. FORMAT is a string as +in `gdb-memory-format'." + (let ((format-base (cdr (assoc format + '(("x" . 16) + ("d" . 10) ("u" . 10) + ("o" . 8) + ("t" . 2)))))) + (if format-base + (let ((res (ceiling (log (expt 2.0 (* size 8)) format-base)))) + (cond ((string-equal format "x") + (+ 2 res)) ; hexadecimal numbers have 0x in front + ((or (string-equal format "d") + (string-equal format "o")) + (1+ res)) + (t res))) + (error "Unknown format")))) + +(defun gdb-read-memory-custom () + (let* ((res (gdb-json-partial-output)) + (err-msg (bindat-get-field res 'msg))) + (if (not err-msg) + (let ((memory (bindat-get-field res 'memory))) + (setq gdb-memory-address (bindat-get-field res 'addr)) + (setq gdb-memory-next-page (bindat-get-field res 'next-page)) + (setq gdb-memory-prev-page (bindat-get-field res 'prev-page)) + (setq gdb-memory-last-address gdb-memory-address) + (dolist (row memory) + (insert (concat (bindat-get-field row 'addr) ":")) + (dolist (column (bindat-get-field row 'data)) + (insert (gdb-pad-string column + (+ 2 (gdb-memory-column-width + gdb-memory-unit + gdb-memory-format))))) + (newline))) + ;; Show last page instead of empty buffer when out of bounds + (progn + (let ((gdb-memory-address gdb-memory-last-address)) + (gdb-invalidate-memory 'update) + (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))) + +;; 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 'update)) + +(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 'update)))))) + +(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 'update))) + +(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))))) + +(defmacro def-gdb-memory-unit (name unit-size doc) + "Define a function NAME to switch memory unit size to UNIT-SIZE. + +DOC is an optional documentation string." + `(defun ,name () ,(when doc doc) + (interactive) + (customize-set-variable 'gdb-memory-unit ,unit-size) + (gdb-invalidate-memory 'update))) + +(def-gdb-memory-unit gdb-memory-unit-giant 8 + "Set the unit size to giant words (eight bytes).") + +(def-gdb-memory-unit gdb-memory-unit-word 4 + "Set the unit size to words (four bytes).") + +(def-gdb-memory-unit gdb-memory-unit-halfword 2 + "Set the unit size to halfwords (two bytes).") + +(def-gdb-memory-unit gdb-memory-unit-byte 1 + "Set the unit size to bytes.") + +(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))))) + +(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'.") + +(define-derived-mode gdb-memory-mode gdb-parent-mode "Memory" + "Major mode for examining memory. + +\\{gdb-memory-mode-map}" + (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 () + (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) + (let* ((special-display-regexps (append special-display-regexps '(".*"))) + (special-display-frame-alist + `((left-fringe . 0) + (right-fringe . 0) + (width . 83) + ,@gdb-frame-parameters))) + (display-buffer (gdb-get-buffer-create 'gdb-memory-buffer)))) + + +;;; Disassembly view + +(defun gdb-disassembly-buffer-name () + (gdb-current-context-buffer-name + (concat "disassembly of " (gdb-get-target-string)))) + +(def-gdb-display-buffer + gdb-display-disassembly-buffer + 'gdb-disassembly-buffer + "Display disassembly for current stack frame.") + +(def-gdb-preempt-display-buffer + gdb-preemptively-display-disassembly-buffer + 'gdb-disassembly-buffer) + +(def-gdb-frame-for-buffer + gdb-frame-disassembly-buffer + 'gdb-disassembly-buffer + "Display disassembly in a new frame.") + +(def-gdb-auto-update-trigger gdb-invalidate-disassembly + (let* ((frame (gdb-current-buffer-frame)) + (file (bindat-get-field frame 'fullname)) + (line (bindat-get-field frame 'line))) + (when file + (format "-data-disassemble -f %s -l %s -n -1 -- 0" file line))) + gdb-disassembly-handler + ;; We update disassembly only after we have actual frame information + ;; about all threads, so no there's `update' signal in this list + '(start update-disassembly)) + +(def-gdb-auto-update-handler + gdb-disassembly-handler + gdb-invalidate-disassembly + gdb-disassembly-handler-custom + t) + +(gdb-set-buffer-rules + 'gdb-disassembly-buffer + 'gdb-disassembly-buffer-name + 'gdb-disassembly-mode + 'gdb-invalidate-disassembly) + +(defvar gdb-disassembly-font-lock-keywords + '(;; <__function.name+n> + ("<\\(\\(\\sw\\|[_.]\\)+\\)\\(\\+[0-9]+\\)?>" + (1 font-lock-function-name-face)) + ;; 0xNNNNNNNN <__function.name+n>: opcode + ("^0x[0-9a-f]+ \\(<\\(\\(\\sw\\|[_.]\\)+\\)\\+[0-9]+>\\)?:[ \t]+\\(\\sw+\\)" + (4 font-lock-keyword-face)) + ;; %register(at least i386) + ("%\\sw+" . font-lock-variable-name-face) + ("^\\(Dump of assembler code for function\\) \\(.+\\):" + (1 font-lock-comment-face) + (2 font-lock-function-name-face)) + ("^\\(End of assembler dump\\.\\)" . font-lock-comment-face)) + "Font lock keywords used in `gdb-disassembly-mode'.") + +(defvar gdb-disassembly-mode-map + ;; TODO + (let ((map (make-sparse-keymap))) + (suppress-keymap map) + (define-key map "q" 'kill-this-buffer) + map)) + +(define-derived-mode gdb-disassembly-mode gdb-parent-mode "Disassembly" + "Major mode for GDB disassembly information. + +\\{gdb-disassembly-mode-map}" + ;; TODO Rename overlay variable for disassembly mode + (add-to-list 'overlay-arrow-variable-list 'gdb-disassembly-position) + (setq fringes-outside-margins t) + (set (make-local-variable 'gdb-disassembly-position) (make-marker)) + (set (make-local-variable 'font-lock-defaults) + '(gdb-disassembly-font-lock-keywords)) + (run-mode-hooks 'gdb-disassembly-mode-hook) + 'gdb-invalidate-disassembly) + +(defun gdb-disassembly-handler-custom () + (let* ((instructions (bindat-get-field (gdb-json-partial-output) 'asm_insns)) + (address (bindat-get-field (gdb-current-buffer-frame) 'addr)) + (pos 1) + (table (make-gdb-table)) + (marked-line nil)) + (dolist (instr instructions) + (gdb-table-add-row table + (list + (bindat-get-field instr 'address) + (apply 'format `("<%s+%s>:" ,@(gdb-get-many-fields instr 'func-name 'offset))) + (bindat-get-field instr 'inst))) + (when (string-equal (bindat-get-field instr 'address) + address) + (progn + (setq marked-line (length (gdb-table-rows table))) + (setq fringe-indicator-alist + (if (string-equal gdb-frame-number "0") + nil + '((overlay-arrow . hollow-right-triangle))))))) + (insert (gdb-table-string table " ")) + (gdb-disassembly-place-breakpoints) + ;; Mark current position with overlay arrow and scroll window to + ;; that point + (when marked-line + (let ((window (get-buffer-window (current-buffer) 0))) + (set-window-point window (gdb-mark-line marked-line gdb-disassembly-position)))) + (setq mode-name + (gdb-current-context-mode-name + (concat "Disassembly: " + (bindat-get-field (gdb-current-buffer-frame) 'func)))))) + +(defun gdb-disassembly-place-breakpoints () + (gdb-remove-breakpoint-icons (point-min) (point-max)) + (dolist (breakpoint gdb-breakpoints-list) + (let* ((breakpoint (cdr breakpoint)) + (bptno (bindat-get-field breakpoint 'number)) + (flag (bindat-get-field breakpoint 'enabled)) + (address (bindat-get-field breakpoint 'addr))) + (save-excursion + (goto-char (point-min)) + (if (re-search-forward (concat "^" address) nil t) + (gdb-put-breakpoint-icon (string-equal flag "y") bptno)))))) + + +(defvar gdb-breakpoints-header + (list + (gdb-propertize-header "Breakpoints" gdb-breakpoints-buffer + nil nil mode-line) + " " + (gdb-propertize-header "Threads" gdb-threads-buffer + "mouse-1: select" mode-line-highlight mode-line-inactive))) + +;;; Breakpoints view +(define-derived-mode gdb-breakpoints-mode gdb-parent-mode "Breakpoints" + "Major mode for gdb breakpoints. + +\\{gdb-breakpoints-mode-map}" + (setq header-line-format gdb-breakpoints-header) + (run-mode-hooks 'gdb-breakpoints-mode-hook) + 'gdb-invalidate-breakpoints) + +(defun gdb-toggle-breakpoint () + "Enable/disable breakpoint at current line of breakpoints buffer." + (interactive) + (save-excursion + (beginning-of-line) + (let ((breakpoint (get-text-property (point) 'gdb-breakpoint))) + (if breakpoint + (gud-basic-call + (concat (if (string-equal "y" (bindat-get-field breakpoint 'enabled)) + "-break-disable " + "-break-enable ") + (bindat-get-field breakpoint 'number))) + (error "Not recognized as break/watchpoint line"))))) + +(defun gdb-delete-breakpoint () + "Delete the breakpoint at current line of breakpoints buffer." + (interactive) + (save-excursion + (beginning-of-line) + (let ((breakpoint (get-text-property (point) 'gdb-breakpoint))) + (if breakpoint + (gud-basic-call (concat "-break-delete " (bindat-get-field breakpoint 'number))) + (error "Not recognized as break/watchpoint line"))))) + +(defun gdb-goto-breakpoint (&optional event) + "Go to the location of breakpoint at current line of +breakpoints buffer." + (interactive (list last-input-event)) + (if event (posn-set-point (event-end event))) + ;; Hack to stop gdb-goto-breakpoint displaying in GUD buffer. + (let ((window (get-buffer-window gud-comint-buffer))) + (if window (save-selected-window (select-window window)))) + (save-excursion + (beginning-of-line) + (let ((breakpoint (get-text-property (point) 'gdb-breakpoint))) + (if breakpoint + (let ((bptno (bindat-get-field breakpoint 'number)) + (file (bindat-get-field breakpoint 'fullname)) + (line (bindat-get-field breakpoint 'line))) + (save-selected-window + (let* ((buffer (find-file-noselect + (if (file-exists-p file) file + (cdr (assoc bptno gdb-location-alist))))) + (window (or (gdb-display-source-buffer buffer) + (display-buffer buffer)))) + (setq gdb-source-window window) + (with-current-buffer buffer + (goto-char (point-min)) + (forward-line (1- (string-to-number line))) + (set-window-point window (point)))))) + (error "Not recognized as break/watchpoint line"))))) + + +;; Frames buffer. This displays a perpetually correct bactrack trace. +;; +(def-gdb-trigger-and-handler + gdb-invalidate-frames (gdb-current-context-command "-stack-list-frames") + gdb-stack-list-frames-handler gdb-stack-list-frames-custom + '(start update)) + +(gdb-set-buffer-rules + 'gdb-stack-buffer + 'gdb-stack-buffer-name + 'gdb-frames-mode + 'gdb-invalidate-frames) + +(defun gdb-frame-location (frame) + "Return \" of file:line\" or \" of library\" for structure FRAME. + +FRAME must have either \"file\" and \"line\" members or \"from\" +member." + (let ((file (bindat-get-field frame 'file)) + (line (bindat-get-field frame 'line)) + (from (bindat-get-field frame 'from))) + (let ((res (or (and file line (concat file ":" line)) + from))) + (if res (concat " of " res) "")))) + +(defun gdb-stack-list-frames-custom () + (let ((stack (bindat-get-field (gdb-json-partial-output "frame") 'stack)) + (table (make-gdb-table))) + (set-marker gdb-stack-position nil) + (dolist (frame stack) + (gdb-table-add-row table + (list + (bindat-get-field frame 'level) + "in" + (concat + (bindat-get-field frame 'func) + (if gdb-stack-buffer-locations + (gdb-frame-location frame) "") + (if gdb-stack-buffer-addresses + (concat " at " (bindat-get-field frame 'addr)) ""))) + `(mouse-face highlight + help-echo "mouse-2, RET: Select frame" + gdb-frame ,frame))) + (insert (gdb-table-string table " "))) + (when (and gdb-frame-number + (gdb-buffer-shows-main-thread-p)) + (gdb-mark-line (1+ (string-to-number gdb-frame-number)) + gdb-stack-position)) + (setq mode-name + (gdb-current-context-mode-name "Frames"))) + +(defun gdb-stack-buffer-name () + (gdb-current-context-buffer-name + (concat "stack frames of " (gdb-get-target-string)))) + +(def-gdb-display-buffer + gdb-display-stack-buffer + 'gdb-stack-buffer + "Display backtrace of current stack.") + +(def-gdb-preempt-display-buffer + gdb-preemptively-display-stack-buffer + 'gdb-stack-buffer nil t) + +(def-gdb-frame-for-buffer + gdb-frame-stack-buffer + 'gdb-stack-buffer + "Display backtrace of current stack in a new frame.") + +(defvar gdb-frames-mode-map + (let ((map (make-sparse-keymap))) + (suppress-keymap map) + (define-key map "q" 'kill-this-buffer) + (define-key map "\r" 'gdb-select-frame) + (define-key map [mouse-2] 'gdb-select-frame) + (define-key map [follow-link] 'mouse-face) + map)) + +(defvar gdb-frames-font-lock-keywords + '(("in \\([^ ]+\\)" (1 font-lock-function-name-face))) + "Font lock keywords used in `gdb-frames-mode'.") + +(define-derived-mode gdb-frames-mode gdb-parent-mode "Frames" + "Major mode for gdb call stack. + +\\{gdb-frames-mode-map}" + (setq gdb-stack-position (make-marker)) + (add-to-list 'overlay-arrow-variable-list 'gdb-stack-position) + (setq truncate-lines t) ;; Make it easier to see overlay arrow. + (set (make-local-variable 'font-lock-defaults) + '(gdb-frames-font-lock-keywords)) + (run-mode-hooks 'gdb-frames-mode-hook) + 'gdb-invalidate-frames) + +(defun gdb-select-frame (&optional event) + "Select the frame and display the relevant source." + (interactive (list last-input-event)) + (if event (posn-set-point (event-end event))) + (let ((frame (get-text-property (point) 'gdb-frame))) + (if frame + (if (gdb-buffer-shows-main-thread-p) + (let ((new-level (bindat-get-field frame 'level))) + (setq gdb-frame-number new-level) + (gdb-input (list (concat "-stack-select-frame " new-level) 'ignore)) + (gdb-update)) + (error "Could not select frame for non-current thread")) + (error "Not recognized as frame line")))) + + +;; Locals buffer. +;; uses "-stack-list-locals --simple-values". Needs GDB 6.1 onwards. +(def-gdb-trigger-and-handler + gdb-invalidate-locals + (concat (gdb-current-context-command "-stack-list-locals") " --simple-values") + gdb-locals-handler gdb-locals-handler-custom + '(start update)) + +(gdb-set-buffer-rules + 'gdb-locals-buffer + 'gdb-locals-buffer-name + 'gdb-locals-mode + 'gdb-invalidate-locals) + +(defvar gdb-locals-watch-map + (let ((map (make-sparse-keymap))) + (suppress-keymap map) + (define-key map "\r" 'gud-watch) + (define-key map [mouse-2] 'gud-watch) + map) + "Keymap to create watch expression of a complex data type local variable.") + +(defvar gdb-edit-locals-map-1 + (let ((map (make-sparse-keymap))) + (suppress-keymap map) + (define-key map "\r" 'gdb-edit-locals-value) + (define-key map [mouse-2] 'gdb-edit-locals-value) + map) + "Keymap to edit value of a simple data type local variable.") + +(defun gdb-edit-locals-value (&optional event) + "Assign a value to a variable displayed in the locals buffer." + (interactive (list last-input-event)) + (save-excursion + (if event (posn-set-point (event-end event))) + (beginning-of-line) + (let* ((var (bindat-get-field + (get-text-property (point) 'gdb-local-variable) 'name)) + (value (read-string (format "New value (%s): " var)))) + (gud-basic-call + (concat "-gdb-set variable " var " = " value))))) + +;; Dont display values of arrays or structures. +;; These can be expanded using gud-watch. +(defun gdb-locals-handler-custom () + (let ((locals-list (bindat-get-field (gdb-json-partial-output) 'locals)) + (table (make-gdb-table))) + (dolist (local locals-list) + (let ((name (bindat-get-field local 'name)) + (value (bindat-get-field local 'value)) + (type (bindat-get-field local 'type))) + (if (or (not value) + (string-match "\\0x" value)) + (add-text-properties 0 (length name) + `(mouse-face highlight + help-echo "mouse-2: create watch expression" + local-map ,gdb-locals-watch-map) + name) + (add-text-properties 0 (length value) + `(mouse-face highlight + help-echo "mouse-2: edit value" + local-map ,gdb-edit-locals-map-1) + value)) + (gdb-table-add-row + table + (list + (propertize type 'font-lock-face font-lock-type-face) + (propertize name 'font-lock-face font-lock-variable-name-face) + value) + `(gdb-local-variable ,local)))) + (insert (gdb-table-string table " ")) + (setq mode-name + (gdb-current-context-mode-name + (concat "Locals: " (bindat-get-field (gdb-current-buffer-frame) 'func)))))) + +(defvar gdb-locals-header + (list + (gdb-propertize-header "Locals" gdb-locals-buffer + nil nil mode-line) + " " + (gdb-propertize-header "Registers" gdb-registers-buffer + "mouse-1: select" mode-line-highlight mode-line-inactive))) + +(defvar gdb-locals-mode-map + (let ((map (make-sparse-keymap))) + (suppress-keymap map) + (define-key map "q" 'kill-this-buffer) + (define-key map "\t" '(lambda () + (interactive) + (gdb-set-window-buffer + (gdb-get-buffer-create + 'gdb-registers-buffer + gdb-thread-number) t))) + map)) + +(define-derived-mode gdb-locals-mode gdb-parent-mode "Locals" + "Major mode for gdb locals. + +\\{gdb-locals-mode-map}" + (setq header-line-format gdb-locals-header) + (run-mode-hooks 'gdb-locals-mode-hook) + 'gdb-invalidate-locals) + +(defun gdb-locals-buffer-name () + (gdb-current-context-buffer-name + (concat "locals of " (gdb-get-target-string)))) + +(def-gdb-display-buffer + gdb-display-locals-buffer + 'gdb-locals-buffer + "Display local variables of current stack and their values.") + +(def-gdb-preempt-display-buffer + gdb-preemptively-display-locals-buffer + 'gdb-locals-buffer nil t) + +(def-gdb-frame-for-buffer + gdb-frame-locals-buffer + 'gdb-locals-buffer + "Display local variables of current stack and their values in a new frame.") + + +;; Registers buffer. + +(def-gdb-trigger-and-handler + gdb-invalidate-registers + (concat (gdb-current-context-command "-data-list-register-values") " x") + gdb-registers-handler + gdb-registers-handler-custom + '(start update)) + +(gdb-set-buffer-rules + 'gdb-registers-buffer + 'gdb-registers-buffer-name + 'gdb-registers-mode + 'gdb-invalidate-registers) + +(defun gdb-registers-handler-custom () + (when gdb-register-names + (let ((register-values (bindat-get-field (gdb-json-partial-output) 'register-values)) + (table (make-gdb-table))) + (dolist (register register-values) + (let* ((register-number (bindat-get-field register 'number)) + (value (bindat-get-field register 'value)) + (register-name (nth (string-to-number register-number) + gdb-register-names))) + (gdb-table-add-row + table + (list + (propertize register-name 'font-lock-face font-lock-variable-name-face) + (if (member register-number gdb-changed-registers) + (propertize value 'font-lock-face font-lock-warning-face) + value)) + `(mouse-face highlight + help-echo "mouse-2: edit value" + gdb-register-name ,register-name)))) + (insert (gdb-table-string table " "))) + (setq mode-name + (gdb-current-context-mode-name "Registers")))) + +(defun gdb-edit-register-value (&optional event) + "Assign a value to a register displayed in the registers buffer." + (interactive (list last-input-event)) + (save-excursion + (if event (posn-set-point (event-end event))) + (beginning-of-line) + (let* ((var (bindat-get-field + (get-text-property (point) 'gdb-register-name))) + (value (read-string (format "New value (%s): " var)))) + (gud-basic-call + (concat "-gdb-set variable $" var " = " value))))) + +(defvar gdb-registers-mode-map + (let ((map (make-sparse-keymap))) + (suppress-keymap map) + (define-key map "\r" 'gdb-edit-register-value) + (define-key map [mouse-2] 'gdb-edit-register-value) + (define-key map "q" 'kill-this-buffer) + (define-key map "\t" '(lambda () + (interactive) + (gdb-set-window-buffer + (gdb-get-buffer-create + 'gdb-locals-buffer + gdb-thread-number) t))) + map)) + +(defvar gdb-registers-header + (list + (gdb-propertize-header "Locals" gdb-locals-buffer + "mouse-1: select" mode-line-highlight mode-line-inactive) + " " + (gdb-propertize-header "Registers" gdb-registers-buffer + nil nil mode-line))) + +(define-derived-mode gdb-registers-mode gdb-parent-mode "Registers" + "Major mode for gdb registers. + +\\{gdb-registers-mode-map}" + (setq header-line-format gdb-registers-header) + (run-mode-hooks 'gdb-registers-mode-hook) + 'gdb-invalidate-registers) + +(defun gdb-registers-buffer-name () + (gdb-current-context-buffer-name + (concat "registers of " (gdb-get-target-string)))) + +(def-gdb-display-buffer + gdb-display-registers-buffer + 'gdb-registers-buffer + "Display integer register contents.") + +(def-gdb-preempt-display-buffer + gdb-preemptively-display-registers-buffer + 'gdb-registers-buffer nil t) + +(def-gdb-frame-for-buffer + gdb-frame-registers-buffer + 'gdb-registers-buffer + "Display integer register contents in a new frame.") + +;; Needs GDB 6.4 onwards (used to fail with no stack). +(defun gdb-get-changed-registers () + (if (and (gdb-get-buffer 'gdb-registers-buffer) + (not (gdb-pending-p 'gdb-get-changed-registers))) + (progn + (gdb-input + (list + "-data-list-changed-registers" + 'gdb-changed-registers-handler)) + (gdb-add-pending '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 + ;; only once (in gdb-init-1) + (setq gdb-register-names nil) + (dolist (register-name (bindat-get-field (gdb-json-partial-output) 'register-names)) + (push register-name gdb-register-names)) + (setq gdb-register-names (reverse gdb-register-names))) + + +(defun gdb-get-source-file-list () + "Create list of source files for current GDB session. +If buffers already exist for any of these files, gud-minor-mode +is set in them." + (goto-char (point-min)) + (while (re-search-forward gdb-source-file-regexp nil t) + (push (match-string 1) gdb-source-file-list)) + (dolist (buffer (buffer-list)) + (with-current-buffer buffer + (when (member buffer-file-name gdb-source-file-list) + (gdb-init-buffer)))) + (gdb-force-mode-line-update + (propertize "ready" 'face font-lock-variable-name-face))) + +(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 + (list (gdb-current-context-command "-stack-info-frame") 'gdb-frame-handler)) + (gdb-add-pending 'gdb-get-main-selected-frame)))) + +(defun gdb-frame-handler () + "Sets `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)) + (setq gdb-selected-file (bindat-get-field frame 'fullname)) + (setq gdb-frame-number (bindat-get-field frame 'level)) + (setq gdb-frame-address (bindat-get-field frame 'addr)) + (let ((line (bindat-get-field frame 'line))) + (setq gdb-selected-line (and line (string-to-number line))) + (when (and gdb-selected-file gdb-selected-line) + (setq gud-last-frame (cons gdb-selected-file gdb-selected-line)) + (gud-display-frame))) + (if gud-overlay-arrow-position + (let ((buffer (marker-buffer gud-overlay-arrow-position)) + (position (marker-position gud-overlay-arrow-position))) + (when buffer + (with-current-buffer buffer + (setq fringe-indicator-alist + (if (string-equal gdb-frame-number "0") + nil + '((overlay-arrow . hollow-right-triangle)))) + (setq gud-overlay-arrow-position (make-marker)) + (set-marker gud-overlay-arrow-position position)))))))) + +(defvar gdb-prompt-name-regexp "value=\"\\(.*?\\)\"") + +(defun gdb-get-prompt () + "Find prompt for GDB session." + (goto-char (point-min)) + (setq gdb-prompt-name nil) + (re-search-forward gdb-prompt-name-regexp nil t) + (setq gdb-prompt-name (match-string 1)) + ;; Insert first prompt. + (setq gdb-filter-output (concat gdb-filter-output gdb-prompt-name))) + +;;;; Window management +(defun gdb-display-buffer (buf dedicated &optional frame) + "Show buffer BUF. + +If BUF is already displayed in some window, show it, deiconifying +the frame if necessary. Otherwise, find least recently used +window and show BUF there, if the window is not used for GDB +already, in which case that window is splitted first." + (let ((answer (get-buffer-window buf (or frame 0)))) + (if answer + (display-buffer buf nil (or frame 0)) ;Deiconify the frame if necessary. + (let ((window (get-lru-window))) + (if (eq (buffer-local-value 'gud-minor-mode (window-buffer window)) + 'gdbmi) + (let* ((largest (get-largest-window)) + (cur-size (window-height largest))) + (setq answer (split-window largest)) + (set-window-buffer answer buf) + (set-window-dedicated-p answer dedicated) + answer) + (set-window-buffer window buf) + window))))) + +(defun gdb-preempt-existing-or-display-buffer (buf &optional split-horizontal) + "Find window displaying a buffer with the same +`gdb-buffer-type' as BUF and show BUF there. If no such window +exists, just call `gdb-display-buffer' for BUF. If the window +found is already dedicated, split window according to +SPLIT-HORIZONTAL and show BUF in the new window." + (if buf + (when (not (get-buffer-window buf)) + (let* ((buf-type (gdb-buffer-type buf)) + (existing-window + (get-window-with-predicate + #'(lambda (w) + (and (eq buf-type + (gdb-buffer-type (window-buffer w))) + (not (window-dedicated-p w))))))) + (if existing-window + (set-window-buffer existing-window buf) + (let ((dedicated-window + (get-window-with-predicate + #'(lambda (w) + (eq buf-type + (gdb-buffer-type (window-buffer w))))))) + (if dedicated-window + (set-window-buffer + (split-window dedicated-window nil split-horizontal) buf) + (gdb-display-buffer buf t)))))) + (error "Null buffer"))) + +;;; Shared keymap initialization: + +(let ((menu (make-sparse-keymap "GDB-Windows"))) + (define-key gud-menu-map [displays] + `(menu-item "GDB-Windows" ,menu + :visible (eq gud-minor-mode 'gdbmi))) + (define-key menu [gdb] '("Gdb" . gdb-display-gdb-buffer)) + (define-key menu [threads] '("Threads" . gdb-display-threads-buffer)) + (define-key menu [memory] '("Memory" . gdb-display-memory-buffer)) + (define-key menu [disassembly] + '("Disassembly" . gdb-display-disassembly-buffer)) + (define-key menu [registers] '("Registers" . gdb-display-registers-buffer)) + (define-key menu [inferior] + '("IO" . gdb-display-io-buffer)) + (define-key menu [locals] '("Locals" . gdb-display-locals-buffer)) + (define-key menu [frames] '("Stack" . gdb-display-stack-buffer)) + (define-key menu [breakpoints] + '("Breakpoints" . gdb-display-breakpoints-buffer))) + +(let ((menu (make-sparse-keymap "GDB-Frames"))) + (define-key gud-menu-map [frames] + `(menu-item "GDB-Frames" ,menu + :visible (eq gud-minor-mode 'gdbmi))) + (define-key menu [gdb] '("Gdb" . gdb-frame-gdb-buffer)) + (define-key menu [threads] '("Threads" . gdb-frame-threads-buffer)) + (define-key menu [memory] '("Memory" . gdb-frame-memory-buffer)) + (define-key menu [disassembly] '("Disassembly" . gdb-frame-disassembly-buffer)) + (define-key menu [registers] '("Registers" . gdb-frame-registers-buffer)) + (define-key menu [inferior] + '("IO" . gdb-frame-io-buffer)) + (define-key menu [locals] '("Locals" . gdb-frame-locals-buffer)) + (define-key menu [frames] '("Stack" . gdb-frame-stack-buffer)) + (define-key menu [breakpoints] + '("Breakpoints" . gdb-frame-breakpoints-buffer))) + +(let ((menu (make-sparse-keymap "GDB-MI"))) + (define-key menu [gdb-customize] + '(menu-item "Customize" (lambda () (interactive) (customize-group 'gdb)) + :help "Customize Gdb Graphical Mode options.")) + (define-key menu [gdb-many-windows] + '(menu-item "Display Other Windows" gdb-many-windows + :help "Toggle display of locals, stack and breakpoint information" + :button (:toggle . gdb-many-windows))) + (define-key menu [gdb-restore-windows] + '(menu-item "Restore Window Layout" gdb-restore-windows + :help "Restore standard layout for debug session.")) + (define-key menu [sep1] + '(menu-item "--")) + (define-key menu [all-threads] + '(menu-item "GUD controls all threads" + (lambda () + (interactive) + (setq gdb-gud-control-all-threads t)) + :help "GUD start/stop commands apply to all threads" + :button (:radio . gdb-gud-control-all-threads))) + (define-key menu [current-thread] + '(menu-item "GUD controls current thread" + (lambda () + (interactive) + (setq gdb-gud-control-all-threads nil)) + :help "GUD start/stop commands apply to current thread only" + :button (:radio . (not gdb-gud-control-all-threads)))) + (define-key menu [sep2] + '(menu-item "--")) + (define-key menu [gdb-customize-reasons] + '(menu-item "Customize switching..." + (lambda () + (interactive) + (customize-option 'gdb-switch-reasons)))) + (define-key menu [gdb-switch-when-another-stopped] + (menu-bar-make-toggle gdb-toggle-switch-when-another-stopped gdb-switch-when-another-stopped + "Automatically switch to stopped thread" + "GDB thread switching %s" + "Switch to stopped thread")) + (define-key gud-menu-map [mi] + `(menu-item "GDB-MI" ,menu :visible (eq gud-minor-mode 'gdbmi)))) + +;; TODO Fit these into tool-bar-local-item-from-menu call in gud.el. +;; GDB-MI menu will need to be moved to gud.el. We can't use +;; tool-bar-local-item-from-menu here because it appends new buttons +;; to toolbar from right to left while we want our A/T throttle to +;; show up right before Run button. +(define-key-after gud-tool-bar-map [all-threads] + '(menu-item "Switch to non-stop/A mode" gdb-control-all-threads + :image (find-image '((:type xpm :file "gud/thread.xpm"))) + :visible (and (eq gud-minor-mode 'gdbmi) + gdb-non-stop + (not gdb-gud-control-all-threads))) + 'run) + +(define-key-after gud-tool-bar-map [current-thread] + '(menu-item "Switch to non-stop/T mode" gdb-control-current-thread + :image (find-image '((:type xpm :file "gud/all.xpm"))) + :visible (and (eq gud-minor-mode 'gdbmi) + gdb-non-stop + gdb-gud-control-all-threads)) + 'all-threads) + +(defun gdb-frame-gdb-buffer () + "Display GUD buffer in a new frame." + (interactive) + (let ((special-display-regexps (append special-display-regexps '(".*"))) + (special-display-frame-alist + (remove '(menu-bar-lines) (remove '(tool-bar-lines) + gdb-frame-parameters))) + (same-window-regexps nil)) + (display-buffer gud-comint-buffer))) + +(defun gdb-display-gdb-buffer () + "Display GUD buffer." + (interactive) + (let ((same-window-regexps nil)) + (select-window (display-buffer gud-comint-buffer nil 0)))) + +(defun gdb-set-window-buffer (name &optional ignore-dedicated) + "Set buffer of selected window to NAME and dedicate window. + +When IGNORE-DEDICATED is non-nil, buffer is set even if selected +window is dedicated." + (when ignore-dedicated + (set-window-dedicated-p (selected-window) nil)) + (set-window-buffer (selected-window) (get-buffer name)) + (set-window-dedicated-p (selected-window) t)) + +(defun gdb-setup-windows () + "Layout the window pattern for `gdb-many-windows'." + (gdb-display-locals-buffer) + (gdb-display-stack-buffer) + (delete-other-windows) + (gdb-display-breakpoints-buffer) + (delete-other-windows) + ; Don't dedicate. + (pop-to-buffer gud-comint-buffer) + (split-window nil ( / ( * (window-height) 3) 4)) + (split-window nil ( / (window-height) 3)) + (split-window-horizontally) + (other-window 1) + (gdb-set-window-buffer (gdb-locals-buffer-name)) + (other-window 1) + (switch-to-buffer + (if gud-last-last-frame + (gud-find-file (car gud-last-last-frame)) + (if gdb-main-file + (gud-find-file gdb-main-file) + ;; Put buffer list in window if we + ;; can't find a source file. + (list-buffers-noselect)))) + (setq gdb-source-window (selected-window)) + (split-window-horizontally) + (other-window 1) + (gdb-set-window-buffer + (gdb-get-buffer-create 'gdb-inferior-io)) + (other-window 1) + (gdb-set-window-buffer (gdb-stack-buffer-name)) + (split-window-horizontally) + (other-window 1) + (gdb-set-window-buffer (if gdb-show-threads-by-default + (gdb-threads-buffer-name) + (gdb-breakpoints-buffer-name))) + (other-window 1)) + +(defcustom gdb-many-windows nil + "If nil just pop up the GUD buffer unless `gdb-show-main' is t. +In this case it starts with two windows: one displaying the GUD +buffer and the other with the source file with the main routine +of the debugged program. Non-nil means display the layout shown for +`gdb'." + :type 'boolean + :group 'gdb + :version "22.1") + +(defun gdb-many-windows (arg) + "Toggle the number of windows in the basic arrangement. +With arg, display additional buffers iff arg is positive." + (interactive "P") + (setq gdb-many-windows + (if (null arg) + (not gdb-many-windows) + (> (prefix-numeric-value arg) 0))) + (message (format "Display of other windows %sabled" + (if gdb-many-windows "en" "dis"))) + (if (and gud-comint-buffer + (buffer-name gud-comint-buffer)) + (condition-case nil + (gdb-restore-windows) + (error nil)))) + +(defun gdb-restore-windows () + "Restore the basic arrangement of windows used by gdb. +This arrangement depends on the value of `gdb-many-windows'." + (interactive) + (pop-to-buffer gud-comint-buffer) ;Select the right window and frame. + (delete-other-windows) + (if gdb-many-windows + (gdb-setup-windows) + (when (or gud-last-last-frame gdb-show-main) + (split-window) + (other-window 1) + (switch-to-buffer + (if gud-last-last-frame + (gud-find-file (car gud-last-last-frame)) + (gud-find-file gdb-main-file))) + (setq gdb-source-window (selected-window)) + (other-window 1)))) + +(defun gdb-reset () + "Exit a debugging session cleanly. +Kills the gdb buffers, and resets variables and the source buffers." + (dolist (buffer (buffer-list)) + (unless (eq buffer gud-comint-buffer) + (with-current-buffer buffer + (if (eq gud-minor-mode 'gdbmi) + (if (string-match "\\` ?\\*.+\\*\\'" (buffer-name)) + (kill-buffer nil) + (gdb-remove-breakpoint-icons (point-min) (point-max) t) + (setq gud-minor-mode nil) + (kill-local-variable 'tool-bar-map) + (kill-local-variable 'gdb-define-alist)))))) + (setq gdb-disassembly-position nil) + (setq overlay-arrow-variable-list + (delq 'gdb-disassembly-position overlay-arrow-variable-list)) + (setq fringe-indicator-alist '((overlay-arrow . right-triangle))) + (setq gdb-stack-position nil) + (setq overlay-arrow-variable-list + (delq 'gdb-stack-position overlay-arrow-variable-list)) + (setq gdb-thread-position nil) + (setq overlay-arrow-variable-list + (delq 'gdb-thread-position overlay-arrow-variable-list)) + (if (boundp 'speedbar-frame) (speedbar-timer-fn)) + (setq gud-running nil) + (setq gdb-active-process nil) + (remove-hook 'after-save-hook 'gdb-create-define-alist t)) + +(defun gdb-get-source-file () + "Find the source file where the program starts and display it with related +buffers, if required." + (goto-char (point-min)) + (if (re-search-forward gdb-source-file-regexp nil t) + (setq gdb-main-file (match-string 1))) + (if gdb-many-windows + (gdb-setup-windows) + (gdb-get-buffer-create 'gdb-breakpoints-buffer) + (if gdb-show-main + (let ((pop-up-windows t)) + (display-buffer (gud-find-file gdb-main-file)))))) + +;;from put-image +(defun gdb-put-string (putstring pos &optional dprop &rest sprops) + "Put string PUTSTRING in front of POS in the current buffer. +PUTSTRING is displayed by putting an overlay into the current buffer with a +`before-string' string that has a `display' property whose value is +PUTSTRING." + (let ((string (make-string 1 ?x)) + (buffer (current-buffer))) + (setq putstring (copy-sequence putstring)) + (let ((overlay (make-overlay pos pos buffer)) + (prop (or dprop + (list (list 'margin 'left-margin) putstring)))) + (put-text-property 0 1 'display prop string) + (if sprops + (add-text-properties 0 1 sprops string)) + (overlay-put overlay 'put-break t) + (overlay-put overlay 'before-string string)))) + +;;from remove-images +(defun gdb-remove-strings (start end &optional buffer) + "Remove strings between START and END in BUFFER. +Remove only strings that were put in BUFFER with calls to `gdb-put-string'. +BUFFER nil or omitted means use the current buffer." + (unless buffer + (setq buffer (current-buffer))) + (dolist (overlay (overlays-in start end)) + (when (overlay-get overlay 'put-break) + (delete-overlay overlay)))) + +(defun gdb-put-breakpoint-icon (enabled bptno &optional line) + (let* ((posns (gdb-line-posns (or line (line-number-at-pos)))) + (start (- (car posns) 1)) + (end (+ (cdr posns) 1)) + (putstring (if enabled "B" "b")) + (source-window (get-buffer-window (current-buffer) 0))) + (add-text-properties + 0 1 '(help-echo "mouse-1: clear bkpt, mouse-3: enable/disable bkpt") + putstring) + (if enabled + (add-text-properties + 0 1 `(gdb-bptno ,bptno gdb-enabled t) putstring) + (add-text-properties + 0 1 `(gdb-bptno ,bptno gdb-enabled nil) putstring)) + (gdb-remove-breakpoint-icons start end) + (if (display-images-p) + (if (>= (or left-fringe-width + (if source-window (car (window-fringes source-window))) + gdb-buffer-fringe-width) 8) + (gdb-put-string + nil (1+ start) + `(left-fringe breakpoint + ,(if enabled + 'breakpoint-enabled + 'breakpoint-disabled)) + 'gdb-bptno bptno + 'gdb-enabled enabled) + (when (< left-margin-width 2) + (save-current-buffer + (setq left-margin-width 2) + (if source-window + (set-window-margins + source-window + left-margin-width right-margin-width)))) + (put-image + (if enabled + (or breakpoint-enabled-icon + (setq breakpoint-enabled-icon + (find-image `((:type xpm :data + ,breakpoint-xpm-data + :ascent 100 :pointer hand) + (:type pbm :data + ,breakpoint-enabled-pbm-data + :ascent 100 :pointer hand))))) + (or breakpoint-disabled-icon + (setq breakpoint-disabled-icon + (find-image `((:type xpm :data + ,breakpoint-xpm-data + :conversion disabled + :ascent 100 :pointer hand) + (:type pbm :data + ,breakpoint-disabled-pbm-data + :ascent 100 :pointer hand)))))) + (+ start 1) + putstring + 'left-margin)) + (when (< left-margin-width 2) + (save-current-buffer + (setq left-margin-width 2) + (let ((window (get-buffer-window (current-buffer) 0))) + (if window + (set-window-margins + window left-margin-width right-margin-width))))) + (gdb-put-string + (propertize putstring + 'face (if enabled 'breakpoint-enabled 'breakpoint-disabled)) + (1+ start))))) + +(defun gdb-remove-breakpoint-icons (start end &optional remove-margin) + (gdb-remove-strings start end) + (if (display-images-p) + (remove-images start end)) + (when remove-margin + (setq left-margin-width 0) + (let ((window (get-buffer-window (current-buffer) 0))) + (if window + (set-window-margins + window left-margin-width right-margin-width))))) + +(provide 'gdb-mi) + +;; arch-tag: 1b41ea2b-f364-4cec-8f35-e02e4fe01912 +;;; gdb-mi.el ends here diff --git a/lisp/progmodes/gdb-ui.el b/lisp/progmodes/gdb-ui.el deleted file mode 100644 index b2a354c5410..00000000000 --- a/lisp/progmodes/gdb-ui.el +++ /dev/null @@ -1,4158 +0,0 @@ -;;; gdb-ui.el --- User Interface for running GDB - -;; Author: Nick Roberts <nickrob@gnu.org> -;; Maintainer: FSF -;; Keywords: unix, tools - -;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; This mode acts as a graphical user interface to GDB. You can interact with -;; GDB through the GUD buffer in the usual way, but there are also further -;; buffers which control the execution and describe the state of your program. -;; It separates the input/output of your program from that of GDB, if -;; required, and watches expressions in the speedbar. It also uses features of -;; Emacs 21 such as the fringe/display margin for breakpoints, and the toolbar -;; (see the GDB Graphical Interface section in the Emacs info manual). - -;; By default, M-x gdb will start the debugger. - -;; This file has evolved from gdba.el that was included with GDB 5.0 and -;; written by Tom Lord and Jim Kingdon. It uses GDB's annotation interface. -;; You don't need to know about annotations to use this mode as a debugger, -;; but if you are interested developing the mode itself, see the Annotations -;; section in the GDB info manual. - -;; GDB developers plan to make the annotation interface obsolete. A new -;; interface called GDB/MI (machine interface) has been designed to replace it. -;; Some GDB/MI commands are used in this file through the CLI command -;; 'interpreter mi <mi-command>'. To help with the process of fully migrating -;; Emacs from annotations to GDB/MI, there is an experimental package called -;; gdb-mi in the Emacs Lisp Package Archive ("http://tromey.com/elpa/"). It -;; comprises of modified gud.el and a file called gdb-mi.el which replaces -;; gdb-ui.el. When installed, this overrides the current files and invoking -;; M-x gdb will use GDB/MI directly (starts with "gdb -i=mi"). When deleted -;; ('d' followed by 'x' in Package Menu mode), the files are deleted and old -;; functionality restored. This provides a convenient way to review the -;; current status/contribute to its improvement. For someone who just wants to -;; use GDB, however, the current mode in Emacs 22 is a much better option. -;; There is also a file, also called gdb-mi.el, a version of which is included -;; the GDB distribution. This will probably only work with versions -;; distributed with GDB 6.5 or later. Unlike the version in ELPA it works on -;; top of gdb-ui.el and you can only start it with M-x gdbmi. - -;; This mode SHOULD WORK WITH GDB 5.0 or later but you will NEED AT LEAST -;; GDB 6.0 to use watch expressions. It works best with GDB 6.4 or later -;; where watch expressions will update more quickly. - -;;; Windows Platforms: - -;; If you are using Emacs and GDB on Windows you will need to flush the buffer -;; explicitly in your program if you want timely display of I/O in Emacs. -;; Alternatively you can make the output stream unbuffered, for example, by -;; using a macro: - -;; #ifdef UNBUFFERED -;; setvbuf (stdout, (char *) NULL, _IONBF, 0); -;; #endif - -;; and compiling with -DUNBUFFERED while debugging. - -;; If you are using Cygwin GDB and find that the source is not being displayed -;; in Emacs when you step through it, possible solutions are to: - -;; 1) Use Cygwin X Windows and Cygwin Emacs. -;; (Since 22.1 Emacs builds under Cygwin.) -;; 2) Use MinGW GDB instead. -;; 3) Use cygwin-mount.el - -;;; Mac OSX: - -;; GDB in Emacs on Mac OSX works best with FSF GDB as Apple have made -;; some changes to the version that they include as part of Mac OSX. -;; This requires GDB version 7.0 or later (estimated release date June 2009) -;; as earlier versions don not compile on Mac OSX. - -;;; Known Bugs: - -;; 1) Cannot handle multiple debug sessions. -;; 2) If you wish to call procedures from your program in GDB -;; e.g "call myproc ()", "p mysquare (5)" then use level 2 annotations -;; "gdb --annotate=2 myprog" to keep source buffer/selected frame fixed. -;; 3) After detaching from a process, clicking on the "GO" icon on toolbar -;; (gud-go) sends "continue" to GDB (should be "run"). - -;;; TODO: - -;; 1) Use MI command -data-read-memory for memory window. -;; 2) Use tree-buffer.el (from ECB) instead of the speedbar for -;; watch-expressions? Handling of watch-expressions needs to be -;; overhauled to work for large arrays/structures by creating variable -;; objects for visible watch-expressions only. -;; 3) Mark breakpoint locations on scroll-bar of source buffer? - -;;; Code: - -(require 'gud) -(require 'json) -(require 'bindat) - -(defvar tool-bar-map) -(defvar speedbar-initial-expansion-list-name) -(defvar speedbar-frame) - -(defvar gdb-pc-address nil "Initialization for Assembler buffer. -Set to \"main\" at start if `gdb-show-main' is t.") -(defvar gdb-frame-address nil "Identity of frame for watch expression.") -(defvar gdb-previous-frame-pc-address nil) -(defvar gdb-memory-address "main") -(defvar gdb-previous-frame nil) -(defvar gdb-selected-frame nil) -(defvar gdb-frame-number nil) -(defvar gdb-current-language nil) -(defvar gdb-var-list nil - "List of variables in watch window. -Each element has the form (VARNUM EXPRESSION NUMCHILD TYPE VALUE STATUS HAS_MORE FP) -where STATUS is nil (`unchanged'), `changed' or `out-of-scope', FP the frame -address for root variables.") -(defvar gdb-main-file nil "Source file from which program execution begins.") -(defvar gud-old-arrow nil) -(defvar gdb-thread-indicator nil) -(defvar gdb-overlay-arrow-position nil) -(defvar gdb-stack-position nil) -(defvar gdb-server-prefix nil) -(defvar gdb-flush-pending-output nil) -(defvar gdb-location-alist nil - "Alist of breakpoint numbers and full filenames. -Only used for files that Emacs can't find.") -(defvar gdb-active-process nil - "GUD tooltips display variable values when t, and macro definitions otherwise.") -(defvar gdb-recording nil - "If t, then record session for playback and reverse execution") -(defvar gdb-error "Non-nil when GDB is reporting an error.") -(defvar gdb-macro-info nil - "Non-nil if GDB knows that the inferior includes preprocessor macro info.") -(defvar gdb-buffer-fringe-width nil) -(defvar gdb-signalled nil) -(defvar gdb-source-window nil) -(defvar gdb-inferior-status nil) -(defvar gdb-continuation nil) -(defvar gdb-look-up-stack nil) -(defvar gdb-frame-begin nil - "Non-nil when GDB generates frame-begin annotation.") -(defvar gdb-printing t) -(defvar gdb-parent-bptno-enabled nil) -(defvar gdb-ready nil) -(defvar gdb-stack-update nil) -(defvar gdb-early-user-input nil) - -(defvar gdb-buffer-type nil - "One of the symbols bound in `gdb-buffer-rules'.") -(make-variable-buffer-local 'gdb-buffer-type) - -(defvar gdb-input-queue () - "A list of gdb command objects.") - -(defvar gdb-prompting nil - "True when gdb is idle with no pending input.") - -(defvar gdb-output-sink nil - "The disposition of the output of the current gdb command. -Possible values are these symbols: - - `user' -- gdb output should be copied to the GUD buffer - for the user to see. - - `inferior' -- gdb output should be copied to the inferior-io buffer. - - `pre-emacs' -- output should be ignored util the post-prompt - annotation is received. Then the output-sink - becomes:... - `emacs' -- output should be collected in the partial-output-buffer - for subsequent processing by a command. This is the - disposition of output generated by commands that - gdb mode sends to gdb on its own behalf. - `post-emacs' -- ignore output until the prompt annotation is - received, then go to USER disposition. - -gdba (gdb-ui.el) uses all five values, gdbmi (gdb-mi.el) only two -\(`user' and `emacs').") - -(defvar gdb-current-item nil - "The most recent command item sent to gdb.") - -(defvar gdb-pending-triggers '() - "A list of trigger functions that have run later than their output handlers.") - -(defvar gdb-first-post-prompt nil) -(defvar gdb-version nil) -(defvar gdb-locals-font-lock-keywords nil) -(defvar gdb-source-file-list nil - "List of source files for the current executable.") -(defconst gdb-error-regexp "\\^error,msg=\"\\(.+\\)\"") - -(defvar gdb-locals-font-lock-keywords-1 - '(;; var = (struct struct_tag) value - ( "\\(^\\(\\sw\\|[_.]\\)+\\) += +(\\(struct\\) \\(\\(\\sw\\|[_.]\\)+\\)" - (1 font-lock-variable-name-face) - (3 font-lock-keyword-face) - (4 font-lock-type-face)) - ;; var = (type) value - ( "\\(^\\(\\sw\\|[_.]\\)+\\) += +(\\(\\(\\sw\\|[_.]\\)+\\)" - (1 font-lock-variable-name-face) - (3 font-lock-type-face)) - ;; var = val - ( "\\(^\\(\\sw\\|[_.]\\)+\\) += +[^(]" - (1 font-lock-variable-name-face))) - "Font lock keywords used in `gdb-local-mode'.") - -(defvar gdb-locals-font-lock-keywords-2 - '(;; var = type value - ( "\\(^\\(\\sw\\|[_.]\\)+\\)\t+\\(\\(\\sw\\|[_.]\\)+\\)" - (1 font-lock-variable-name-face) - (3 font-lock-type-face))) - "Font lock keywords used in `gdb-local-mode'.") - -;; Variables for GDB 6.4+ -(defvar gdb-register-names nil "List of register names.") -(defvar gdb-changed-registers nil - "List of changed register numbers (strings).") - -;;;###autoload -(defun gdb (command-line) - "Run gdb on program FILE in buffer *gud-FILE*. -The directory containing FILE becomes the initial working -directory and source-file directory for your debugger. - -If `gdb-many-windows' is nil (the default value) then gdb just -pops up the GUD buffer unless `gdb-show-main' is t. In this case -it starts with two windows: one displaying the GUD buffer and the -other with the source file with the main routine of the inferior. - -If `gdb-many-windows' is t, regardless of the value of -`gdb-show-main', the layout below will appear unless -`gdb-use-separate-io-buffer' is nil when the source buffer -occupies the full width of the frame. Keybindings are shown in -some of the buffers. - -Watch expressions appear in the speedbar/slowbar. - -The following commands help control operation : - -`gdb-many-windows' - Toggle the number of windows gdb uses. -`gdb-restore-windows' - To restore the window layout. - -See Info node `(emacs)GDB Graphical Interface' for a more -detailed description of this mode. - -+----------------------------------------------------------------------+ -| GDB Toolbar | -+-----------------------------------+----------------------------------+ -| GUD buffer (I/O of GDB) | Locals buffer | -|-----------------------------------+----------------------------------+ -| | | -| Source buffer | I/O buffer for debugged program | -| | | -|-----------------------------------+----------------------------------+ -| Stack buffer | Breakpoints/threads buffer | -+-----------------------------------+----------------------------------+ - -The option \"--annotate=3\" must be included in this value. To -run GDB in text command mode, use `gud-gdb'. You need to use -text command mode to debug multiple programs within one Emacs -session." - (interactive (list (gud-query-cmdline 'gdb))) - - (when (and gud-comint-buffer - (buffer-name gud-comint-buffer) - (get-buffer-process gud-comint-buffer) - (with-current-buffer gud-comint-buffer (eq gud-minor-mode 'gdba))) - (gdb-restore-windows) - (error - "Multiple debugging requires restarting in text command mode")) - - (gud-common-init command-line nil 'gud-gdba-marker-filter) - (set (make-local-variable 'gud-minor-mode) 'gdba) - (setq comint-input-sender 'gdb-send) - - (gud-def gud-break "break %f:%l" "\C-b" "Set breakpoint at current line.") - (gud-def gud-tbreak "tbreak %f:%l" "\C-t" - "Set temporary breakpoint at current line.") - (gud-def gud-remove "clear %f:%l" "\C-d" "Remove breakpoint at current line.") - (gud-def gud-step "step %p" "\C-s" "Step one source line with display.") - (gud-def gud-stepi "stepi %p" "\C-i" "Step one instruction with display.") - (gud-def gud-next "next %p" "\C-n" "Step one line (skip functions).") - (gud-def gud-nexti "nexti %p" nil "Step one instruction (skip functions).") - (gud-def gud-cont "continue" "\C-r" "Continue with display.") - (gud-def gud-finish "finish" "\C-f" "Finish executing current function.") - (gud-def gud-jump - (progn (gud-call "tbreak %f:%l") (gud-call "jump %f:%l")) - "\C-j" "Set execution address to current line.") - - (gud-def gud-rstep "reverse-step %p" nil "Reverse step one source line with display.") - (gud-def gud-rstepi "reverse-stepi %p" nil "Reverse step one instruction with display.") - (gud-def gud-rnext "reverse-next %p" nil "Reverse step one line (skip functions).") - (gud-def gud-rnexti "reverse-nexti %p" nil "Reverse step one instruction (skip functions).") - (gud-def gud-rcont "reverse-continue" nil "Reverse continue with display.") - (gud-def gud-rfinish "reverse-finish" nil "Reverse finish executing current function.") - - (gud-def gud-up "up %p" "<" "Up N stack frames (numeric arg).") - (gud-def gud-down "down %p" ">" "Down N stack frames (numeric arg).") - (gud-def gud-print "print %e" "\C-p" "Evaluate C expression at point.") - (gud-def gud-pstar "print* %e" nil - "Evaluate C dereferenced pointer expression at point.") - - ;; For debugging Emacs only. - (gud-def gud-pv "pv1 %e" "\C-v" "Print the value of the lisp variable.") - - (gud-def gud-until "until %l" "\C-u" "Continue to current line.") - (gud-def gud-run "run" nil "Run the program.") - - (local-set-key "\C-i" 'gud-gdb-complete-command) - (setq comint-prompt-regexp "^(.*gdb[+]?) *") - (setq paragraph-start comint-prompt-regexp) - (setq gdb-output-sink 'user) - (setq gdb-first-prompt t) - (setq gud-running nil) - (setq gdb-ready nil) - (setq gdb-stack-update nil) - (setq gdb-flush-pending-output nil) - (setq gdb-early-user-input nil) - (setq gud-filter-pending-text nil) - (gdb-thread-identification) - (run-hooks 'gdb-mode-hook)) - -;; Keep as an alias for compatibility with Emacs 22.1. -;;;###autoload -(defalias 'gdba 'gdb) - -(defgroup gdb nil - "Gdb Graphical Mode options specifically for running Gdb in Emacs." - :group 'processes - :group 'tools) - -(defcustom gdb-debug-log-max 128 - "Maximum size of `gdb-debug-log'. If nil, size is unlimited." - :group 'gdb - :type '(choice (integer :tag "Number of elements") - (const :tag "Unlimited" nil)) - :version "22.1") - -(defvar gdb-debug-log nil - "List of commands sent to and replies received from GDB. -Most recent commands are listed first. This list stores only the last -`gdb-debug-log-max' values. This variable is used to debug GDB-UI.") - -;;;###autoload -(defcustom gdb-enable-debug nil - "Non-nil means record the process input and output in `gdb-debug-log'." - :type 'boolean - :group 'gdb - :version "22.1") - -(defcustom gdb-cpp-define-alist-program "gcc -E -dM -" - "Shell command for generating a list of defined macros in a source file. -This list is used to display the #define directive associated -with an identifier as a tooltip. It works in a debug session with -GDB, when `gud-tooltip-mode' is t. - -Set `gdb-cpp-define-alist-flags' for any include paths or -predefined macros." - :type 'string - :group 'gdb - :version "22.1") - -(defcustom gdb-cpp-define-alist-flags "" - "Preprocessor flags for `gdb-cpp-define-alist-program'." - :type 'string - :group 'gdb - :version "22.1") - -(defcustom gdb-create-source-file-list t - "Non-nil means create a list of files from which the executable was built. -Set this to nil if the GUD buffer displays \"initializing...\" in the mode -line for a long time when starting, possibly because your executable was -built from a large number of files. This allows quicker initialization -but means that these files are not automatically enabled for debugging, -e.g., you won't be able to click in the fringe to set a breakpoint until -execution has already stopped there." - :type 'boolean - :group 'gdb - :version "23.1") - -(defcustom gdb-show-main nil - "Non-nil means display source file containing the main routine at startup. -Also display the main routine in the disassembly buffer if present." - :type 'boolean - :group 'gdb - :version "22.1") - -(defcustom gdb-many-windows nil - "If nil, just pop up the GUD buffer unless `gdb-show-main' is t. -In this case start with two windows: one displaying the GUD -buffer and the other with the source file with the main routine -of the debugged program. Non-nil means display the layout shown -for `gdba'." - :type 'boolean - :group 'gdb - :version "22.1") - -(defcustom gdb-use-separate-io-buffer nil - "Non-nil means display output from the debugged program in a separate buffer." - :type 'boolean - :group 'gdb - :version "22.1") - -(defun gdb-force-mode-line-update (status) - (let ((buffer gud-comint-buffer)) - (if (and buffer (buffer-name buffer)) - (with-current-buffer buffer - (setq mode-line-process - (format ":%s [%s]" - (process-status (get-buffer-process buffer)) status)) - ;; Force mode line redisplay soon. - (force-mode-line-update))))) - -(defun gdb-enable-debug (arg) - "Toggle logging of transaction between Emacs and Gdb. -The log is stored in `gdb-debug-log' as an alist with elements -whose cons is send, send-item or recv and whose cdr is the string -being transferred. This list may grow up to a size of -`gdb-debug-log-max' after which the oldest element (at the end of -the list) is deleted every time a new one is added (at the front)." - (interactive "P") - (setq gdb-enable-debug - (if (null arg) - (not gdb-enable-debug) - (> (prefix-numeric-value arg) 0))) - (message (format "Logging of transaction %sabled" - (if gdb-enable-debug "en" "dis")))) - -(defun gdb-many-windows (arg) - "Toggle the number of windows in the basic arrangement. -With prefix argument ARG, display additional buffers if ARG is positive, -otherwise use a single window." - (interactive "P") - (setq gdb-many-windows - (if (null arg) - (not gdb-many-windows) - (> (prefix-numeric-value arg) 0))) - (message (format "Display of other windows %sabled" - (if gdb-many-windows "en" "dis"))) - (if (and gud-comint-buffer - (buffer-name gud-comint-buffer)) - (condition-case nil - (gdb-restore-windows) - (error nil)))) - -(defun gdb-use-separate-io-buffer (arg) - "Toggle separate IO for debugged program. -With prefix argument ARG, use separate IO if ARG is positive, -otherwise do not." - (interactive "P") - (setq gdb-use-separate-io-buffer - (if (null arg) - (not gdb-use-separate-io-buffer) - (> (prefix-numeric-value arg) 0))) - (message (format "Separate IO %sabled" - (if gdb-use-separate-io-buffer "en" "dis"))) - (if (and gud-comint-buffer - (buffer-name gud-comint-buffer)) - (condition-case nil - (if gdb-use-separate-io-buffer - (if gdb-many-windows (gdb-restore-windows)) - (kill-buffer (gdb-inferior-io-name))) - (error nil)))) - -(defvar gdb-define-alist nil "Alist of #define directives for GUD tooltips.") - -(defun gdb-create-define-alist () - "Create an alist of #define directives for GUD tooltips." - (let* ((file (buffer-file-name)) - (output - (with-output-to-string - (with-current-buffer standard-output - (and file - (file-exists-p file) - ;; call-process doesn't work with remote file names. - (not (file-remote-p default-directory)) - (call-process shell-file-name file - (list t nil) nil "-c" - (concat gdb-cpp-define-alist-program " " - gdb-cpp-define-alist-flags)))))) - (define-list (split-string output "\n" t)) (name)) - (setq gdb-define-alist nil) - (dolist (define define-list) - (setq name (nth 1 (split-string define "[( ]"))) - (push (cons name define) gdb-define-alist)))) - -(declare-function tooltip-show "tooltip" (text &optional use-echo-area)) -(defvar tooltip-use-echo-area) - -(defun gdb-tooltip-print (expr) - (tooltip-show - (with-current-buffer (gdb-get-buffer 'gdb-partial-output-buffer) - (goto-char (point-min)) - (let ((string - (if (search-forward "=" nil t) - (concat expr (buffer-substring (- (point) 2) (point-max))) - (buffer-string)))) - ;; remove newline for gud-tooltip-echo-area - (substring string 0 (- (length string) 1)))) - (or gud-tooltip-echo-area tooltip-use-echo-area - (not (display-graphic-p))))) - -;; If expr is a macro for a function don't print because of possible dangerous -;; side-effects. Also printing a function within a tooltip generates an -;; unexpected starting annotation (phase error). -(defun gdb-tooltip-print-1 (expr) - (with-current-buffer (gdb-get-buffer 'gdb-partial-output-buffer) - (goto-char (point-min)) - (if (search-forward "expands to: " nil t) - (unless (looking-at "\\S-+.*(.*).*") - (gdb-enqueue-input - (list (concat gdb-server-prefix "print " expr "\n") - `(lambda () (gdb-tooltip-print ,expr)))))))) - -(defconst gdb-source-file-regexp "\\(.+?\\), \\|\\([^, \n].*$\\)") - -(defun gdb-init-buffer () - (set (make-local-variable 'gud-minor-mode) - (buffer-local-value 'gud-minor-mode gud-comint-buffer)) - (set (make-local-variable 'tool-bar-map) gud-tool-bar-map) - (when gud-tooltip-mode - (make-local-variable 'gdb-define-alist) - (gdb-create-define-alist) - (add-hook 'after-save-hook 'gdb-create-define-alist nil t))) - -(defun gdb-set-gud-minor-mode-existing-buffers () - "Create list of source files for current GDB session." - (goto-char (point-min)) - (when (search-forward "read in on demand:" nil t) - (while (re-search-forward gdb-source-file-regexp nil t) - (push (file-name-nondirectory (or (match-string 1) (match-string 2))) - gdb-source-file-list)) - (dolist (buffer (buffer-list)) - (with-current-buffer buffer - (when (and buffer-file-name - (member (file-name-nondirectory buffer-file-name) - gdb-source-file-list)) - (gdb-init-buffer))))) - (gdb-force-mode-line-update - (propertize "ready" 'face font-lock-variable-name-face))) - -(defun gdb-find-watch-expression () - (let* ((var (nth (- (line-number-at-pos (point)) 2) gdb-var-list)) - (varnum (car var)) expr array) - (string-match "\\(var[0-9]+\\)\\.\\(.*\\)" varnum) - (let ((var1 (assoc (match-string 1 varnum) gdb-var-list)) var2 varnumlet - (component-list (split-string (match-string 2 varnum) "\\." t))) - (setq expr (nth 1 var1)) - (setq varnumlet (car var1)) - (dolist (component component-list) - (setq var2 (assoc varnumlet gdb-var-list)) - (setq expr (concat expr - (if (string-match ".*\\[[0-9]+\\]$" (nth 3 var2)) - (concat "[" component "]") - (concat "." component)))) - (setq varnumlet (concat varnumlet "." component))) - expr))) - -(defun gdb-toggle-recording () -"Start/stop recording of debug session." - (interactive) - (if gud-running - (message-box "Recording cannot be started or stopped while your program is still running") - (gdb-enqueue-input - (list (concat gdb-server-prefix - (if gdb-recording "record stop\n" "target record\n")) - 'gdb-recording-handler)))) - -;; Convenience function for tool bar. -(defalias 'gdb-toggle-recording-1 'gdb-toggle-recording) - -(defun gdb-recording-handler () - (goto-char (point-min)) - (if (re-search-forward "current architecture doesn't support record function" nil t) - (message-box "Not enabled. The current architecture doesn't support the process record function.") - (goto-char (point-min)) - (if (re-search-forward "Undefined target command" nil t) - (message-box "Not enabled. Process record requires GDB 7.0 onwards.") - (goto-char (point-min)) - (if (re-search-forward "the program is not being run" nil t) - (message-box "Not enabled. Starting process recording requires an active target (running process).") - (setq gdb-recording (not gdb-recording)) - ;; Actually forcing the tool-bar to update. - (force-mode-line-update))))) - -(defun gdb-init-1 () - (gud-def gud-break (if (not (string-match "Machine" mode-name)) - (gud-call "break %f:%l" arg) - (save-excursion - (beginning-of-line) - (forward-char 2) - (gud-call "break *%a" arg))) - "\C-b" "Set breakpoint at current line or address.") - ;; - (gud-def gud-remove (if (not (string-match "Machine" mode-name)) - (gud-call "clear %f:%l" arg) - (save-excursion - (beginning-of-line) - (forward-char 2) - (gud-call "clear *%a" arg))) - "\C-d" "Remove breakpoint at current line or address.") - ;; - (gud-def gud-until (if (not (string-match "Machine" mode-name)) - (gud-call "until %f:%l" arg) - (save-excursion - (beginning-of-line) - (forward-char 2) - (gud-call "until *%a" arg))) - "\C-u" "Continue to current line or address.") - ;; - (gud-def gud-go (gud-call (if gdb-active-process "continue" "run") arg) - nil "Start or continue execution.") - - ;; For debugging Emacs only. - (gud-def gud-pp - (gud-call - (concat - "pp1 " (if (eq (buffer-local-value - 'major-mode (window-buffer)) 'speedbar-mode) - (gdb-find-watch-expression) "%e")) arg) - nil "Print the Emacs s-expression.") - - (define-key gud-minor-mode-map [left-margin mouse-1] - 'gdb-mouse-set-clear-breakpoint) - (define-key gud-minor-mode-map [left-fringe mouse-1] - 'gdb-mouse-set-clear-breakpoint) - (define-key gud-minor-mode-map [left-margin C-mouse-1] - 'gdb-mouse-toggle-breakpoint-margin) - (define-key gud-minor-mode-map [left-fringe C-mouse-1] - 'gdb-mouse-toggle-breakpoint-fringe) - - (define-key gud-minor-mode-map [left-margin drag-mouse-1] - 'gdb-mouse-until) - (define-key gud-minor-mode-map [left-fringe drag-mouse-1] - 'gdb-mouse-until) - (define-key gud-minor-mode-map [left-margin mouse-3] - 'gdb-mouse-until) - (define-key gud-minor-mode-map [left-fringe mouse-3] - 'gdb-mouse-until) - - (define-key gud-minor-mode-map [left-margin C-drag-mouse-1] - 'gdb-mouse-jump) - (define-key gud-minor-mode-map [left-fringe C-drag-mouse-1] - 'gdb-mouse-jump) - (define-key gud-minor-mode-map [left-fringe C-mouse-3] - 'gdb-mouse-jump) - (define-key gud-minor-mode-map [left-margin C-mouse-3] - 'gdb-mouse-jump) - - ;; (re-)initialize - (setq gdb-pc-address (if gdb-show-main "main" nil)) - (setq gdb-previous-frame-pc-address nil - gdb-memory-address "main" - gdb-previous-frame nil - gdb-selected-frame nil - gdb-current-language nil - gdb-frame-number nil - gdb-var-list nil - gdb-main-file nil - gdb-first-post-prompt t - gdb-prompting nil - gdb-input-queue nil - gdb-current-item nil - gdb-pending-triggers nil - gdb-output-sink 'user - gdb-server-prefix "server " - gdb-location-alist nil - gdb-source-file-list nil - gdb-error nil - gdb-macro-info nil - gdb-buffer-fringe-width (car (window-fringes)) - gdb-debug-log nil - gdb-signalled nil - gdb-source-window nil - gdb-inferior-status nil - gdb-continuation nil - gdb-look-up-stack nil - gdb-frame-begin nil - gdb-printing t - gud-old-arrow nil - gdb-thread-indicator nil - gdb-register-names nil - gdb-recording nil) - - (setq gdb-buffer-type 'gdba) - - (if gdb-use-separate-io-buffer (gdb-clear-inferior-io)) - - (if (eq system-type 'darwin) - (gdb-enqueue-input (list "server show version\n" 'gdb-apple-test))) - - ;; Hack to see test for GDB 6.4+ (-stack-info-frame was implemented in 6.4) - (gdb-enqueue-input (list "server interpreter mi -stack-info-frame\n" - 'gdb-get-version))) - -(defun gdb-init-2 () - (if (eq window-system 'w32) - (gdb-enqueue-input (list "set new-console off\n" 'ignore))) - (gdb-enqueue-input (list "set height 0\n" 'ignore)) - (gdb-enqueue-input (list "set width 0\n" 'ignore)) - - (if (string-equal gdb-version "pre-6.4") - (if gdb-create-source-file-list - (gdb-enqueue-input (list (concat gdb-server-prefix "info sources\n") - 'gdb-set-gud-minor-mode-existing-buffers)) - (setq gdb-locals-font-lock-keywords gdb-locals-font-lock-keywords-1)) - ; Needs GDB 6.2 onwards. - (if gdb-create-source-file-list - (gdb-enqueue-input - (list "server interpreter mi \"-file-list-exec-source-files\"\n" - 'gdb-set-gud-minor-mode-existing-buffers-1))) - (setq gdb-locals-font-lock-keywords gdb-locals-font-lock-keywords-2) - ; Needs GDB 7.0 onwards. - (gdb-enqueue-input - (list "server interpreter mi -enable-pretty-printing\n" 'ignore))) - - ;; Find source file and compilation directory here. - ;; Works for C, C++, Fortran and Ada but not Java (GDB 6.4) - (gdb-enqueue-input (list "server list\n" 'ignore)) - (gdb-enqueue-input (list "server list MAIN__\n" 'ignore)) - (gdb-enqueue-input (list "server info source\n" 'gdb-source-info))) - -;; Workaround for some Apple versions of GDB that add ^M at EOL -;; after the command "server interpreter mi -stack-info-frame". -(defun gdb-apple-test () - (goto-char (point-min)) - (if (re-search-forward "(Apple version " nil t) - (let* ((process (get-buffer-process gud-comint-buffer)) - (coding-systems (process-coding-system process))) - (set-process-coding-system process - (coding-system-change-eol-conversion - (car coding-systems) 'dos) - (cdr coding-systems))))) - -(defun gdb-get-version () - (goto-char (point-min)) - (if (re-search-forward "Undefined\\( mi\\)* command:" nil t) - (setq gdb-version "pre-6.4") - (setq gdb-version "6.4+")) - (gdb-init-2)) - -(defmacro gdb-if-arrow (arrow-position &rest body) - `(if ,arrow-position - (let ((buffer (marker-buffer ,arrow-position)) (line)) - (if (equal buffer (window-buffer (posn-window end))) - (with-current-buffer buffer - (when (or (equal start end) - (equal (posn-point start) - (marker-position ,arrow-position))) - ,@body)))))) - -(defun gdb-mouse-until (event) - "Continue running until a source line past the current line. -The destination source line can be selected either by clicking -with mouse-3 on the fringe/margin or dragging the arrow -with mouse-1 (default bindings)." - (interactive "e") - (let ((start (event-start event)) - (end (event-end event))) - (gdb-if-arrow gud-overlay-arrow-position - (setq line (line-number-at-pos (posn-point end))) - (gud-call (concat "until " (number-to-string line)))) - (gdb-if-arrow gdb-overlay-arrow-position - (save-excursion - (goto-char (point-min)) - (forward-line (1- (line-number-at-pos (posn-point end)))) - (forward-char 2) - (gud-call (concat "until *%a")))))) - -(defun gdb-mouse-jump (event) - "Set execution address/line. -The destination source line can be selected either by clicking with C-mouse-3 -on the fringe/margin or dragging the arrow with C-mouse-1 (default bindings). -Unlike `gdb-mouse-until' the destination address can be before the current -line, and no execution takes place." - (interactive "e") - (let ((start (event-start event)) - (end (event-end event))) - (gdb-if-arrow gud-overlay-arrow-position - (setq line (line-number-at-pos (posn-point end))) - (progn - (gud-call (concat "tbreak " (number-to-string line))) - (gud-call (concat "jump " (number-to-string line))))) - (gdb-if-arrow gdb-overlay-arrow-position - (save-excursion - (goto-char (point-min)) - (forward-line (1- (line-number-at-pos (posn-point end)))) - (forward-char 2) - (progn - (gud-call (concat "tbreak *%a")) - (gud-call (concat "jump *%a"))))))) - -(defcustom gdb-speedbar-auto-raise nil - "If non-nil raise speedbar every time display of watch expressions is\ - updated." - :type 'boolean - :group 'gdb - :version "22.1") - -(defun gdb-speedbar-auto-raise (arg) - "Toggle automatic raising of the speedbar for watch expressions. -With prefix argument ARG, automatically raise speedbar if ARG is -positive, otherwise don't automatically raise it." - (interactive "P") - (setq gdb-speedbar-auto-raise - (if (null arg) - (not gdb-speedbar-auto-raise) - (> (prefix-numeric-value arg) 0))) - (message (format "Auto raising %sabled" - (if gdb-speedbar-auto-raise "en" "dis")))) - -(defcustom gdb-use-colon-colon-notation nil - "If non-nil use FUN::VAR format to display variables in the speedbar." - :type 'boolean - :group 'gdb - :version "22.1") - -(define-key gud-minor-mode-map "\C-c\C-w" 'gud-watch) -(define-key global-map (concat gud-key-prefix "\C-w") 'gud-watch) - -(declare-function tooltip-identifier-from-point "tooltip" (point)) - -(defun gud-watch (&optional arg event) - "Watch expression at point. -With arg, enter name of variable to be watched in the minibuffer." - (interactive (list current-prefix-arg last-input-event)) - (let ((minor-mode (buffer-local-value 'gud-minor-mode gud-comint-buffer))) - (if (memq minor-mode '(gdbmi gdba)) - (progn - (if event (posn-set-point (event-end event))) - (require 'tooltip) - (save-selected-window - (let ((expr - (if arg - (completing-read "Name of variable: " - 'gud-gdb-complete-command) - (if (and transient-mark-mode mark-active) - (buffer-substring (region-beginning) (region-end)) - (concat (if (eq major-mode 'gdb-registers-mode) "$") - (tooltip-identifier-from-point (point))))))) - (set-text-properties 0 (length expr) nil expr) - (gdb-enqueue-input - (list - (if (eq minor-mode 'gdba) - (concat - "server interpreter mi \"-var-create - * " expr "\"\n") - (concat"-var-create - * " expr "\n")) - `(lambda () (gdb-var-create-handler ,expr))))))) - (message "gud-watch is a no-op in this mode.")))) - -(declare-function speedbar-change-initial-expansion-list "speedbar" (new-default)) - -(defun gdb-var-create-handler (expr) - (let* ((result (gdb-json-partial-output))) - (if (not (bindat-get-field result 'msg)) - (let ((var - (list (bindat-get-field result 'name) - (if (and (string-equal gdb-current-language "c") - gdb-use-colon-colon-notation gdb-selected-frame) - (setq expr (concat gdb-selected-frame "::" expr)) - expr) - (bindat-get-field result 'numchild) - (bindat-get-field result 'type) - (bindat-get-field result 'value) - nil - (bindat-get-field result 'has_more) - gdb-frame-address))) - (push var gdb-var-list) - (speedbar 1) - (unless (string-equal - speedbar-initial-expansion-list-name "GUD") - (speedbar-change-initial-expansion-list "GUD"))) - (message-box "No symbol \"%s\" in current context." expr)))) - -(declare-function speedbar-timer-fn "speedbar" ()) - -(defun gdb-speedbar-update () - (when (and (boundp 'speedbar-frame) (frame-live-p speedbar-frame) - (not (member 'gdb-speedbar-timer gdb-pending-triggers))) - ;; Dummy command to update speedbar even when idle. - (gdb-enqueue-input (list "server pwd\n" 'gdb-speedbar-timer-fn)) - ;; Keep gdb-pending-triggers non-nil till end. - (push 'gdb-speedbar-timer gdb-pending-triggers))) - -(defun gdb-speedbar-timer-fn () - (if gdb-speedbar-auto-raise - (raise-frame speedbar-frame)) - (setq gdb-pending-triggers - (delq 'gdb-speedbar-timer gdb-pending-triggers)) - (speedbar-timer-fn)) - -(defun gdb-var-evaluate-expression-handler (varnum changed) - (goto-char (point-min)) - (re-search-forward "\\(.+\\)\\^done,value=\\(\".*\"\\)" nil t) - (setq gdb-pending-triggers - (delq (string-to-number (match-string 1)) gdb-pending-triggers)) - (let ((var (assoc varnum gdb-var-list))) - (when var - (if changed (setcar (nthcdr 5 var) 'changed)) - (setcar (nthcdr 4 var) (read (match-string 2))))) - (gdb-speedbar-update)) - -(defun gdb-var-list-children (varnum) - (gdb-enqueue-input - (list (concat "server interpreter mi \"-var-list-children " varnum "\"\n") - `(lambda () (gdb-var-list-children-handler ,varnum))))) - -(defconst gdb-var-list-children-regexp - "child={.*?name=\"\\(.*?\\)\".*?,exp=\"\\(.*?\\)\".*?,\ -numchild=\"\\(.*?\\)\"\\(}\\|.*?,\\(type=\"\\(.*?\\)\"\\)?.*?}\\)") - -(defun gdb-var-list-children-handler (varnum) - (goto-char (point-min)) - (let ((var-list nil)) - (catch 'child-already-watched - (dolist (var gdb-var-list) - (if (string-equal varnum (car var)) - (progn - (push var var-list) - (while (re-search-forward gdb-var-list-children-regexp nil t) - (let ((varchild (list (match-string 1) - (match-string 2) - (match-string 3) - (match-string 6) - nil nil))) - (if (assoc (car varchild) gdb-var-list) - (throw 'child-already-watched nil)) - (push varchild var-list) - (gdb-enqueue-input - (list - (concat - "server interpreter mi \"0-var-evaluate-expression " - (car varchild) "\"\n") - `(lambda () (gdb-var-evaluate-expression-handler - ,(car varchild) nil))))))) - (push var var-list))) - (setq gdb-var-list (nreverse var-list))))) - -(defun gdb-var-update () - (when (not (member 'gdb-var-update gdb-pending-triggers)) - (gdb-enqueue-input - (list "server interpreter mi \"-var-update *\"\n" - 'gdb-var-update-handler)) - (push 'gdb-var-update gdb-pending-triggers))) - -(defconst gdb-var-update-regexp - "{.*?name=\"\\(.*?\\)\".*?,in_scope=\"\\(.*?\\)\".*?,\ -type_changed=\".*?\".*?}") - -(defun gdb-var-update-handler () - (dolist (var gdb-var-list) - (setcar (nthcdr 5 var) nil)) - (goto-char (point-min)) - (let ((n 0)) - (while (re-search-forward gdb-var-update-regexp nil t) - (let ((varnum (match-string 1))) - (if (string-equal (match-string 2) "false") - (let ((var (assoc varnum gdb-var-list))) - (if var (setcar (nthcdr 5 var) 'out-of-scope))) - (setq n (1+ n)) - (push n gdb-pending-triggers) - (gdb-enqueue-input - (list - (concat "server interpreter mi \"" (number-to-string n) - "-var-evaluate-expression " varnum "\"\n") - `(lambda () (gdb-var-evaluate-expression-handler ,varnum t)))))))) - (setq gdb-pending-triggers - (delq 'gdb-var-update gdb-pending-triggers))) - -(defun gdb-var-set-format (format) - "Set the output format for a variable displayed in the speedbar." - (let* ((var (nth (- (count-lines (point-min) (point)) 2) gdb-var-list)) - (varnum (car var))) - (gdb-enqueue-input - (list - (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) - (concat "server interpreter mi \"-var-set-format " - varnum " " format "\"\n") - (concat "-var-set-format " varnum " " format "\n")) - `(lambda () (gdb-var-set-format-handler ,varnum)))))) - -(defconst gdb-var-set-format-regexp - "format=\"\\(.*?\\)\",.*value=\"\\(.*?\\)\"") - -(defun gdb-var-set-format-handler (varnum) - (goto-char (point-min)) - (if (re-search-forward gdb-var-set-format-regexp nil t) - (let ((var (assoc varnum gdb-var-list))) - (setcar (nthcdr 4 var) (match-string 2)) - (gdb-var-update-1)))) - -(defun gdb-var-delete-1 (var varnum) - (gdb-enqueue-input - (list - (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) - (concat "server interpreter mi \"-var-delete " varnum "\"\n") - (concat "-var-delete " varnum "\n")) - 'ignore)) - (setq gdb-var-list (delq var gdb-var-list)) - (dolist (varchild gdb-var-list) - (if (string-match (concat (car var) "\\.") (car varchild)) - (setq gdb-var-list (delq varchild gdb-var-list))))) - -(defun gdb-var-delete () - "Delete watch expression at point from the speedbar." - (interactive) - (if (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer) - '(gdbmi gdba)) - (let* ((var (nth (- (count-lines (point-min) (point)) 2) gdb-var-list)) - (varnum (car var))) - (if (string-match "\\." (car var)) - (message-box "Can only delete a root expression") - (gdb-var-delete-1 var varnum))))) - -(defun gdb-var-delete-children (varnum) - "Delete children of variable object at point from the speedbar." - (gdb-enqueue-input - (list - (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) - (concat "server interpreter mi \"-var-delete -c " varnum "\"\n") - (concat "-var-delete -c " varnum "\n")) 'ignore))) - -(defun gdb-edit-value (text token indent) - "Assign a value to a variable displayed in the speedbar." - (let* ((var (nth (- (count-lines (point-min) (point)) 2) gdb-var-list)) - (varnum (car var)) (value)) - (setq value (read-string "New value: ")) - (gdb-enqueue-input - (list - (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) - (concat "server interpreter mi \"-var-assign " - varnum " " value "\"\n") - (concat "-var-assign " varnum " " value "\n")) - `(lambda () (gdb-edit-value-handler ,value)))))) - -(defun gdb-edit-value-handler (value) - (goto-char (point-min)) - (if (re-search-forward gdb-error-regexp nil t) - (message-box "Invalid number or expression (%s)" value))) - -(defcustom gdb-show-changed-values t - "If non-nil change the face of out of scope variables and changed values. -Out of scope variables are suppressed with `shadow' face. -Changed values are highlighted with the face `font-lock-warning-face'." - :type 'boolean - :group 'gdb - :version "22.1") - -(defcustom gdb-max-children 40 - "Maximum number of children before expansion requires confirmation." - :type 'integer - :group 'gdb - :version "22.1") - -(defcustom gdb-delete-out-of-scope t - "If non-nil delete watch expressions automatically when they go out of scope." - :type 'boolean - :group 'gdb - :version "22.2") - -(declare-function speedbar-change-expand-button-char "speedbar" (char)) -(declare-function speedbar-delete-subblock "speedbar" (indent)) -(declare-function speedbar-center-buffer-smartly "speedbar" ()) - -(defun gdb-speedbar-expand-node (text token indent) - "Expand the node the user clicked on. -TEXT is the text of the button we clicked on, a + or - item. -TOKEN is data related to this node. -INDENT is the current indentation depth." - (if (and gud-comint-buffer (buffer-name gud-comint-buffer)) - (progn - (cond ((string-match "+" text) ;expand this node - (let* ((var (assoc token gdb-var-list)) - (expr (nth 1 var)) (children (nth 2 var))) - (if (or (<= (string-to-number children) gdb-max-children) - (y-or-n-p - (format - "%s has %s children. Continue? " expr children))) - (if (and (eq (buffer-local-value - 'gud-minor-mode gud-comint-buffer) 'gdba) - (string-equal gdb-version "pre-6.4")) - (gdb-var-list-children token) - (gdb-var-list-children-1 token))))) - ((string-match "-" text) ;contract this node - (dolist (var gdb-var-list) - (if (string-match (concat token "\\.") (car var)) - (setq gdb-var-list (delq var gdb-var-list)))) - (gdb-var-delete-children token) - (speedbar-change-expand-button-char ?+) - (speedbar-delete-subblock indent)) - (t (error "Ooops... not sure what to do"))) - (speedbar-center-buffer-smartly)) - (message-box "GUD session has been killed"))) - -(defun gdb-get-target-string () - (with-current-buffer gud-comint-buffer - gud-target-name)) - - -;; -;; gdb buffers. -;; -;; Each buffer has a TYPE -- a symbol that identifies the function -;; of that particular buffer. -;; -;; The usual gdb interaction buffer is given the type `gdba' and -;; is constructed specially. -;; -;; Others are constructed by gdb-get-buffer-create and -;; named according to the rules set forth in the gdb-buffer-rules-assoc - -(defvar gdb-buffer-rules-assoc '()) - -(defun gdb-get-buffer (key) - "Return the gdb buffer tagged with type KEY. -The key should be one of the cars in `gdb-buffer-rules-assoc'." - (save-excursion - (gdb-look-for-tagged-buffer key (buffer-list)))) - -(defun gdb-get-buffer-create (key) - "Create a new gdb buffer of the type specified by KEY. -The key should be one of the cars in `gdb-buffer-rules-assoc'." - (or (gdb-get-buffer key) - (let* ((rules (assoc key gdb-buffer-rules-assoc)) - (name (funcall (gdb-rules-name-maker rules))) - (new (get-buffer-create name))) - (with-current-buffer new - (let ((trigger)) - (if (cdr (cdr rules)) - (setq trigger (funcall (car (cdr (cdr rules)))))) - (setq gdb-buffer-type key) - (set (make-local-variable 'gud-minor-mode) - (buffer-local-value 'gud-minor-mode gud-comint-buffer)) - (set (make-local-variable 'tool-bar-map) gud-tool-bar-map) - (if trigger (funcall trigger))) - new)))) - -(defun gdb-rules-name-maker (rules) (car (cdr rules))) - -(defun gdb-look-for-tagged-buffer (key bufs) - (let ((retval nil)) - (while (and (not retval) bufs) - (set-buffer (car bufs)) - (if (eq gdb-buffer-type key) - (setq retval (car bufs))) - (setq bufs (cdr bufs))) - retval)) - -;; -;; This assoc maps buffer type symbols to rules. Each rule is a list of -;; at least one and possible more functions. The functions have these -;; roles in defining a buffer type: -;; -;; NAME - Return a name for this buffer type. -;; -;; The remaining function(s) are optional: -;; -;; MODE - called in a new buffer with no arguments, should establish -;; the proper mode for the buffer. -;; - -(defun gdb-set-buffer-rules (buffer-type &rest rules) - (let ((binding (assoc buffer-type gdb-buffer-rules-assoc))) - (if binding - (setcdr binding rules) - (push (cons buffer-type rules) - gdb-buffer-rules-assoc)))) - -;; GUD buffers are an exception to the rules -(gdb-set-buffer-rules 'gdba 'error) - -;; Partial-output buffer : This accumulates output from a command executed on -;; behalf of emacs (rather than the user). -;; -(gdb-set-buffer-rules 'gdb-partial-output-buffer - 'gdb-partial-output-name) - -(defun gdb-partial-output-name () - (concat " *partial-output-" - (gdb-get-target-string) - "*")) - - -(gdb-set-buffer-rules 'gdb-inferior-io - 'gdb-inferior-io-name - 'gdb-inferior-io-mode) - -(defun gdb-inferior-io-name () - (concat "*input/output of " - (gdb-get-target-string) - "*")) - -(defun gdb-display-separate-io-buffer () - "Display IO of debugged program in a separate window." - (interactive) - (if gdb-use-separate-io-buffer - (gdb-display-buffer - (gdb-get-buffer-create 'gdb-inferior-io) t))) - -(defconst gdb-frame-parameters - '((height . 14) (width . 80) - (unsplittable . t) - (tool-bar-lines . nil) - (menu-bar-lines . nil) - (minibuffer . nil))) - -(defun gdb-frame-separate-io-buffer () - "Display IO of debugged program in a new frame." - (interactive) - (if gdb-use-separate-io-buffer - (let ((special-display-regexps (append special-display-regexps '(".*"))) - (special-display-frame-alist gdb-frame-parameters)) - (display-buffer (gdb-get-buffer-create 'gdb-inferior-io))))) - -(defvar gdb-inferior-io-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\C-c\C-c" 'gdb-separate-io-interrupt) - (define-key map "\C-c\C-z" 'gdb-separate-io-stop) - (define-key map "\C-c\C-\\" 'gdb-separate-io-quit) - (define-key map "\C-c\C-d" 'gdb-separate-io-eof) - (define-key map "\C-d" 'gdb-separate-io-eof) - map)) - -(define-derived-mode gdb-inferior-io-mode comint-mode "Inferior I/O" - "Major mode for gdb inferior-io." - :syntax-table nil :abbrev-table nil - ;; We want to use comint because it has various nifty and familiar - ;; features. We don't need a process, but comint wants one, so create - ;; a dummy one. - (make-comint-in-buffer - (substring (buffer-name) 1 (- (length (buffer-name)) 1)) - (current-buffer) "hexl") - (setq comint-input-sender 'gdb-inferior-io-sender)) - -(defun gdb-inferior-io-sender (proc string) - ;; PROC is the pseudo-process created to satisfy comint. - (with-current-buffer (process-buffer proc) - (setq proc (get-buffer-process gud-comint-buffer)) - (process-send-string proc string) - (process-send-string proc "\n"))) - -(defun gdb-separate-io-interrupt () - "Interrupt the program being debugged." - (interactive) - (interrupt-process - (get-buffer-process gud-comint-buffer) comint-ptyp)) - -(defun gdb-separate-io-quit () - "Send quit signal to the program being debugged." - (interactive) - (quit-process - (get-buffer-process gud-comint-buffer) comint-ptyp)) - -(defun gdb-separate-io-stop () - "Stop the program being debugged." - (interactive) - (stop-process - (get-buffer-process gud-comint-buffer) comint-ptyp)) - -(defun gdb-separate-io-eof () - "Send end-of-file to the program being debugged." - (interactive) - (process-send-eof - (get-buffer-process gud-comint-buffer))) - - -;; gdb communications -;; - -;; INPUT: things sent to gdb -;; -;; The queues are lists. Each element is either a string (indicating user or -;; user-like input) or a list of the form: -;; -;; (INPUT-STRING HANDLER-FN) -;; -;; The handler function will be called from the partial-output buffer when the -;; command completes. This is the way to write commands which invoke gdb -;; commands autonomously. -;; -;; These lists are consumed tail first. -;; - -(defun gdb-send (proc string) - "A comint send filter for gdb. -This filter may simply queue input for a later time." - (if gdb-ready - (progn - (with-current-buffer gud-comint-buffer - (let ((inhibit-read-only t)) - (remove-text-properties (point-min) (point-max) '(face)))) - (if gud-running - (progn - (let ((item (concat string "\n"))) - (if gdb-enable-debug (push (cons 'send item) gdb-debug-log)) - (process-send-string proc item))) - (if (string-match "\\\\\\'" string) - (setq gdb-continuation (concat gdb-continuation string "\n")) - (let ((item (concat - gdb-continuation string - (if (not comint-input-sender-no-newline) "\n")))) - (gdb-enqueue-input item) - (setq gdb-continuation nil))))) - (push (concat string "\n") gdb-early-user-input))) - -;; Note: Stuff enqueued here will be sent to the next prompt, even if it -;; is a query, or other non-top-level prompt. - -(defun gdb-enqueue-input (item) - (if (not gud-running) - (if gdb-prompting - (progn - (gdb-send-item item) - (setq gdb-prompting nil)) - (push item gdb-input-queue)))) - -(defun gdb-dequeue-input () - (let ((queue gdb-input-queue)) - (if queue - (let ((last (car (last queue)))) - (unless (nbutlast queue) (setq gdb-input-queue '())) - last) - ;; This should be nil here anyway but set it just to make sure. - (setq gdb-pending-triggers nil)))) - -(defun gdb-send-item (item) - (setq gdb-flush-pending-output nil) - (if gdb-enable-debug (push (cons 'send-item item) gdb-debug-log)) - (setq gdb-current-item item) - (let ((process (get-buffer-process gud-comint-buffer))) - (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) - (if (stringp item) - (progn - (setq gdb-output-sink 'user) - (process-send-string process item)) - (progn - (gdb-clear-partial-output) - (setq gdb-output-sink 'pre-emacs) - (process-send-string process - (car item)))) - ;; case: eq gud-minor-mode 'gdbmi - (gdb-clear-partial-output) - (setq gdb-output-sink 'emacs) - (process-send-string process (car item))))) - -;; -;; output -- things gdb prints to emacs -;; -;; GDB output is a stream interrupted by annotations. -;; Annotations can be recognized by their beginning -;; with \C-j\C-z\C-z<tag><opt>\C-j -;; -;; The tag is a string obeying symbol syntax. -;; -;; The optional part `<opt>' can be either the empty string -;; or a space followed by more data relating to the annotation. -;; For example, the SOURCE annotation is followed by a filename, -;; line number and various useless goo. This data must not include -;; any newlines. -;; - -(defcustom gud-gdb-command-name "gdb --annotate=3" - "Default command to execute an executable under the GDB debugger. -The option \"--annotate=3\" must be included in this value if you -want the GDB Graphical Interface." - :type 'string - :group 'gud - :version "22.1") - -(defvar gdb-annotation-rules - '(("pre-prompt" gdb-pre-prompt) - ("prompt" gdb-prompt) - ("commands" gdb-subprompt) - ("overload-choice" gdb-subprompt) - ("query" gdb-subprompt) - ;; Need this prompt for GDB 6.1 - ("nquery" gdb-subprompt) - ("prompt-for-continue" gdb-subprompt) - ("post-prompt" gdb-post-prompt) - ("source" gdb-source) - ("starting" gdb-starting) - ("exited" gdb-exited) - ("signalled" gdb-signalled) - ("signal" gdb-signal) - ("breakpoint" gdb-stopping) - ("watchpoint" gdb-stopping) - ("frame-begin" gdb-frame-begin) - ("stopped" gdb-stopped) - ("error-begin" gdb-error) - ("error" gdb-error) - ("new-thread" (lambda (ignored) - (gdb-get-buffer-create 'gdb-threads-buffer))) - ("thread-changed" gdb-thread-changed)) - "An assoc mapping annotation tags to functions which process them.") - -(defun gdb-resync() - (setq gdb-flush-pending-output t) - (setq gud-running nil) - (gdb-force-mode-line-update - (propertize "stopped" 'face font-lock-warning-face)) - (setq gdb-output-sink 'user) - (setq gdb-input-queue nil) - (setq gdb-pending-triggers nil) - (setq gdb-prompting t)) - -(defconst gdb-source-spec-regexp - "\\(.*\\):\\([0-9]*\\):[0-9]*:[a-z]*:0x0*\\([a-f0-9]*\\)") - -;; Do not use this except as an annotation handler. -(defun gdb-source (args) - (string-match gdb-source-spec-regexp args) - ;; Extract the frame position from the marker. - (setq gud-last-frame - (cons - (match-string 1 args) - (string-to-number (match-string 2 args)))) - (setq gdb-pc-address (match-string 3 args)) - ;; cover for auto-display output which comes *before* - ;; stopped annotation - (if (eq gdb-output-sink 'inferior) (setq gdb-output-sink 'user))) - -(defun gdb-pre-prompt (ignored) - "An annotation handler for `pre-prompt'. -This terminates the collection of output from a previous command if that -happens to be in effect." - (setq gdb-error nil) - (let ((sink gdb-output-sink)) - (cond - ((eq sink 'user) t) - ((eq sink 'emacs) - (setq gdb-output-sink 'post-emacs)) - (t - (gdb-resync) - (error "Phase error in gdb-pre-prompt (got %s)" sink))))) - -(defun gdb-prompt (ignored) - "An annotation handler for `prompt'. -This sends the next command (if any) to gdb." - (when gdb-first-prompt - (gdb-force-mode-line-update - (propertize "initializing..." 'face font-lock-variable-name-face)) - (gdb-init-1) - (setq gdb-first-prompt nil)) - (let ((sink gdb-output-sink)) - (cond - ((eq sink 'user) t) - ((eq sink 'post-emacs) - (setq gdb-output-sink 'user) - (let ((handler - (car (cdr gdb-current-item)))) - (with-current-buffer (gdb-get-buffer-create 'gdb-partial-output-buffer) - (funcall handler)))) - (t - (gdb-resync) - (error "Phase error in gdb-prompt (got %s)" sink)))) - (let ((input (gdb-dequeue-input))) - (if input - (gdb-send-item input) - (progn - (setq gdb-prompting t) - (gud-display-frame) - (setq gdb-early-user-input (nreverse gdb-early-user-input)) - (while gdb-early-user-input - (gdb-enqueue-input (car gdb-early-user-input)) - (setq gdb-early-user-input (cdr gdb-early-user-input))))))) - -(defun gdb-subprompt (ignored) - "An annotation handler for non-top-level prompts." - (setq gdb-prompting t)) - -(defun gdb-starting (ignored) - "An annotation handler for `starting'. -This says that I/O for the subprocess is now the program being debugged, -not GDB." - (setq gdb-active-process t) - (setq gdb-printing t) - (let ((sink gdb-output-sink)) - (cond - ((eq sink 'user) - (progn - (setq gud-running t) - (setq gdb-stack-update t) - ;; Temporarily set gud-running to nil to force "info stack" onto queue. - (let ((gud-running nil)) - (gdb-invalidate-frames) - (unless (or gdb-register-names - (string-equal gdb-version "pre-6.4")) - (gdb-enqueue-input - (list "server interpreter mi -data-list-register-names\n" - 'gdb-get-register-names)))) - (setq gdb-inferior-status "running") - (setq gdb-signalled nil) - (gdb-force-mode-line-update - (propertize gdb-inferior-status 'face font-lock-type-face)) - (gdb-remove-text-properties) - (setq gud-old-arrow gud-overlay-arrow-position) - (setq gud-overlay-arrow-position nil) - (setq gdb-overlay-arrow-position nil) - (setq gdb-stack-position nil) - (if gdb-use-separate-io-buffer - (setq gdb-output-sink 'inferior)))) - (t - (gdb-resync) - (error "Unexpected `starting' annotation"))))) - -(defun gdb-signal (ignored) - (setq gdb-inferior-status "signal") - (gdb-force-mode-line-update - (propertize gdb-inferior-status 'face font-lock-warning-face)) - (gdb-stopping ignored)) - -(defun gdb-stopping (ignored) - "An annotation handler for `breakpoint' and other annotations. -They say that I/O for the subprocess is now GDB, not the program -being debugged." - (if gdb-use-separate-io-buffer - (let ((sink gdb-output-sink)) - (cond - ((eq sink 'inferior) - (setq gdb-output-sink 'user)) - (t - (gdb-resync) - (error "Unexpected stopping annotation")))))) - -(defun gdb-exited (ignored) - "An annotation handler for `exited' and `signalled'. -They say that I/O for the subprocess is now GDB, not the program -being debugged and that the program is no longer running. This -function is used to change the focus of GUD tooltips to #define -directives." - (setq gdb-active-process nil) - (setq gud-overlay-arrow-position nil) - (setq gdb-overlay-arrow-position nil) - (setq gdb-stack-position nil) - (setq gud-old-arrow nil) - (setq gdb-inferior-status "exited") - (gdb-force-mode-line-update - (propertize gdb-inferior-status 'face font-lock-warning-face)) - (gdb-stopping ignored)) - -(defun gdb-signalled (ignored) - (setq gdb-signalled t)) - -(defun gdb-frame-begin (ignored) - (setq gdb-frame-begin t) - (setq gdb-printing nil) - (let ((sink gdb-output-sink)) - (cond - ((eq sink 'inferior) - (setq gdb-output-sink 'user)) - ((eq sink 'user) t) - ((eq sink 'emacs) t) - (t - (gdb-resync) - (error "Unexpected frame-begin annotation (%S)" sink))))) - -(defcustom gdb-same-frame (not focus-follows-mouse) - "Non-nil means pop up GUD buffer in same frame." - :group 'gdb - :type 'boolean - :version "22.1") - -(defcustom gdb-find-source-frame nil - "Non-nil means try to find a source frame further up stack e.g after signal." - :group 'gdb - :type 'boolean - :version "22.1") - -(defun gdb-find-source-frame (arg) - "Toggle looking for a source frame further up call stack. -The code associated with current (innermost) frame may not have -been compiled with debug information, e.g., C library routine. -With prefix argument ARG, look for a source frame further up -stack to display in the source buffer if ARG is positive, -otherwise don't look further up." - (interactive "P") - (setq gdb-find-source-frame - (if (null arg) - (not gdb-find-source-frame) - (> (prefix-numeric-value arg) 0))) - (message (format "Looking for source frame %sabled" - (if gdb-find-source-frame "en" "dis")))) - -(defun gdb-stopped (ignored) - "An annotation handler for `stopped'. -It is just like `gdb-stopping', except that if we already set the output -sink to `user' in `gdb-stopping', that is fine." - (setq gud-running nil) - (unless (or gud-overlay-arrow-position gud-last-frame) - (if (and gdb-frame-begin gdb-printing) - (setq gud-overlay-arrow-position gud-old-arrow) - ;;Pop up GUD buffer to display current frame when it doesn't have source - ;;information i.e if not compiled with -g as with libc routines generally. - (if gdb-same-frame - (gdb-display-gdb-buffer) - (gdb-frame-gdb-buffer)) - (if gdb-find-source-frame - ;;Try to find source further up stack e.g after signal. - (setq gdb-look-up-stack - (if (gdb-get-buffer 'gdb-stack-buffer) - 'keep - (progn - (gdb-get-buffer-create 'gdb-stack-buffer) - (gdb-invalidate-frames) - 'delete)))))) - (unless (member gdb-inferior-status '("exited" "signal")) - (setq gdb-active-process t) ;Just for attaching case. - (setq gdb-inferior-status "stopped") - (gdb-force-mode-line-update - (propertize gdb-inferior-status 'face font-lock-warning-face))) - (let ((sink gdb-output-sink)) - (cond - ((eq sink 'inferior) - (setq gdb-output-sink 'user)) - ((eq sink 'user) t) - (t - (gdb-resync) - (error "Unexpected stopped annotation")))) - (if gdb-signalled (gdb-exited ignored))) - -(defun gdb-error (ignored) - (setq gdb-error (not gdb-error))) - -(defun gdb-thread-changed (ignored) - (gdb-frames-force-update)) - -(defun gdb-post-prompt (ignored) - "An annotation handler for `post-prompt'. -This begins the collection of output from the current command if that -happens to be appropriate." - ;; Don't add to queue if there outstanding items or gdb-version is not known - ;; yet. - (unless (or gdb-pending-triggers gdb-first-post-prompt) - (gdb-get-selected-frame) - (gdb-invalidate-frames) - ;; Regenerate breakpoints buffer in case it has been inadvertantly deleted. - (gdb-get-buffer-create 'gdb-breakpoints-buffer) - (gdb-invalidate-breakpoints) - ;; Do this through gdb-get-selected-frame -> gdb-frame-handler - ;; so gdb-pc-address is updated. - ;; (gdb-invalidate-assembler) - - (if (string-equal gdb-version "pre-6.4") - (gdb-invalidate-registers) - (gdb-get-changed-registers) - (gdb-invalidate-registers-1)) - - (gdb-invalidate-memory) - (if (string-equal gdb-version "pre-6.4") - (gdb-invalidate-locals) - (gdb-invalidate-locals-1)) - - (gdb-invalidate-threads) - (unless (or (null gdb-var-list) - (eq system-type 'darwin)) ;Breaks on Darwin's GDB-5.3. - ;; FIXME: with GDB-6 on Darwin, this might very well work. - ;; Only needed/used with speedbar/watch expressions. - (when (and (boundp 'speedbar-frame) (frame-live-p speedbar-frame)) - (if (string-equal gdb-version "pre-6.4") - (gdb-var-update) - (gdb-var-update-1))))) - (setq gdb-first-post-prompt nil) - (let ((sink gdb-output-sink)) - (cond - ((eq sink 'user) t) - ((eq sink 'pre-emacs) - (setq gdb-output-sink 'emacs)) - (t - (gdb-resync) - (error "Phase error in gdb-post-prompt (got %s)" sink))))) - -(defconst gdb-buffer-list -'(gdb-stack-buffer gdb-locals-buffer gdb-registers-buffer gdb-threads-buffer)) - -(defun gdb-remove-text-properties () - (dolist (buffertype gdb-buffer-list) - (let ((buffer (gdb-get-buffer buffertype))) - (if buffer - (with-current-buffer buffer - (let ((inhibit-read-only t)) - (remove-text-properties - (point-min) (point-max) '(mouse-face nil help-echo nil)))))))) - -;; GUD displays the selected GDB frame. This might might not be the current -;; GDB frame (after up, down etc). If no GDB frame is visible but the last -;; visited breakpoint is, use that window. -(defun gdb-display-source-buffer (buffer) - (let* ((last-window (if gud-last-last-frame - (get-buffer-window - (gud-find-file (car gud-last-last-frame))))) - (source-window (or last-window - (if (and gdb-source-window - (window-live-p gdb-source-window)) - gdb-source-window)))) - (when source-window - (setq gdb-source-window source-window) - (set-window-buffer source-window buffer)) - source-window)) - -;; Derived from gud-gdb-marker-regexp -(defvar gdb-fullname-regexp - (concat "\\(.:?[^" ":" "\n]*\\)" ":" "\\([0-9]*\\)" ":" ".*")) - -(defun gud-gdba-marker-filter (string) - "A gud marker filter for gdb. Handle a burst of output from GDB." - (if gdb-flush-pending-output - nil - (when gdb-enable-debug - (push (cons 'recv string) gdb-debug-log) - (if (and gdb-debug-log-max - (> (length gdb-debug-log) gdb-debug-log-max)) - (setcdr (nthcdr (1- gdb-debug-log-max) gdb-debug-log) nil))) - ;; Recall the left over gud-marker-acc from last time. - (setq gud-marker-acc (concat gud-marker-acc string)) - ;; Start accumulating output for the GUD buffer. - (let ((output "")) - ;; - ;; Process all the complete markers in this chunk. - (while (string-match "\n\032\032\\(.*\\)\n" gud-marker-acc) - (let ((annotation (match-string 1 gud-marker-acc)) - (before (substring gud-marker-acc 0 (match-beginning 0))) - (after (substring gud-marker-acc (match-end 0)))) - ;; - ;; Parse the tag from the annotation, and maybe its arguments. - (string-match "\\(\\S-*\\) ?\\(.*\\)" annotation) - (let* ((annotation-type (match-string 1 annotation)) - (annotation-arguments (match-string 2 annotation)) - (annotation-rule (assoc annotation-type - gdb-annotation-rules))) - - ;; Stuff prior to the match is just ordinary output. - ;; It is either concatenated to OUTPUT or directed - ;; elsewhere. - (setq output (gdb-concat-output output before)) - - ;; Take that stuff off the gud-marker-acc. - (setq gud-marker-acc after) - - ;; Call the handler for this annotation. - (if annotation-rule - (funcall (car (cdr annotation-rule)) - annotation-arguments)) - - ;; Else the annotation is not recognized. Ignore it silently, - ;; so that GDB can add new annotations without causing - ;; us to blow up. - ))) - - ;; Does the remaining text end in a partial line? - ;; If it does, then keep part of the gud-marker-acc until we get more. - (if (string-match "\n\\'\\|\n\032\\'\\|\n\032\032.*\\'" - gud-marker-acc) - (progn - ;; Everything before the potential marker start can be output. - (setq output - (gdb-concat-output output - (substring gud-marker-acc 0 - (match-beginning 0)))) - ;; - ;; Everything after, we save, to combine with later input. - (setq gud-marker-acc (substring gud-marker-acc - (match-beginning 0)))) - ;; - ;; In case we know the gud-marker-acc contains no partial annotations: - (progn - (setq output (gdb-concat-output output gud-marker-acc)) - (setq gud-marker-acc ""))) - output))) - -(defun gdb-concat-output (so-far new) - (if gdb-error - (put-text-property 0 (length new) 'face font-lock-warning-face new)) - (let ((sink gdb-output-sink)) - (cond - ((eq sink 'user) (concat so-far new)) - ((or (eq sink 'pre-emacs) (eq sink 'post-emacs)) so-far) - ((eq sink 'emacs) - (gdb-append-to-partial-output new) - so-far) - ((eq sink 'inferior) - (gdb-append-to-inferior-io new) - so-far) - (t - (gdb-resync) - (error "Bogon output sink %S" sink))))) - -(defun gdb-append-to-partial-output (string) - (with-current-buffer (gdb-get-buffer-create 'gdb-partial-output-buffer) - (goto-char (point-max)) - (insert string))) - -(defun gdb-clear-partial-output () - (with-current-buffer (gdb-get-buffer-create 'gdb-partial-output-buffer) - (erase-buffer))) - -(defun gdb-append-to-inferior-io (string) - (with-current-buffer (gdb-get-buffer-create 'gdb-inferior-io) - (goto-char (point-max)) - (insert-before-markers string)) - (if (not (string-equal string "")) - (gdb-display-buffer (gdb-get-buffer-create 'gdb-inferior-io) t))) - -(defun gdb-clear-inferior-io () - (with-current-buffer (gdb-get-buffer-create 'gdb-inferior-io) - (erase-buffer))) - -(defun gdb-jsonify-buffer (&optional fix-key fix-list) - "Prepare GDB/MI output in current buffer for parsing with `json-read'. - -Field names are wrapped in double quotes and equal signs are -replaced with semicolons. - -If FIX-KEY is non-nil, strip all \"FIX-KEY=\" occurrences from -partial output. This is used to get rid of useless keys in lists -in MI messages, e.g.: [key=.., key=..]. -stack-list-frames and --break-info are examples of MI commands which issue such -responses. - -If FIX-LIST is non-nil, \"FIX-LIST={..}\" is replaced with -\"FIX-LIST=[..]\" prior to parsing. This is used to fix broken --break-info output when it contains breakpoint script field -incompatible with GDB/MI output syntax." - (save-excursion - (goto-char (point-min)) - ;; Sometimes missing symbol information precedes "^done" record. - (re-search-forward "[[:ascii:]]*?\\^done," nil t) - (replace-match "") - (re-search-forward "(gdb) \n" nil t) - (replace-match "") - (goto-char (point-min)) - (when fix-key - (save-excursion - (while (re-search-forward (concat "[\\[,]\\(" fix-key "=\\)") nil t) - (replace-match "" nil nil nil 1)))) - (when fix-list - (save-excursion - ;; Find positions of braces which enclose broken list - (while (re-search-forward (concat fix-list "={\"") nil t) - (let ((p1 (goto-char (- (point) 2))) - (p2 (progn (forward-sexp) - (1- (point))))) - ;; Replace braces with brackets - (save-excursion - (goto-char p1) - (delete-char 1) - (insert "[") - (goto-char p2) - (delete-char 1) - (insert "]")))))) - (goto-char (point-min)) - (insert "{") - (while (re-search-forward - "\\([[:alnum:]-_]+\\)=\\({\\|\\[\\|\"\"\\|\".*?[^\\]\"\\)" nil t) - (replace-match "\"\\1\":\\2" nil nil)) - (goto-char (point-max)) - (insert "}"))) - -(defun gdb-json-read-buffer (&optional fix-key fix-list) - "Prepare and parse GDB/MI output in current buffer with `json-read'. - -FIX-KEY and FIX-LIST work as in `gdb-jsonify-buffer'." - (gdb-jsonify-buffer fix-key fix-list) - (save-excursion - (goto-char (point-min)) - (let ((json-array-type 'list)) - (json-read)))) - -(defun gdb-json-partial-output (&optional fix-key fix-list) - "Prepare and parse gdb-partial-output-buffer with `json-read'. - -FIX-KEY and FIX-KEY work as in `gdb-jsonify-buffer'." - (with-current-buffer (gdb-get-buffer-create 'gdb-partial-output-buffer) - (gdb-json-read-buffer fix-key fix-list))) - - -;; One trick is to have a command who's output is always available in a buffer -;; of it's own, and is always up to date. We build several buffers of this -;; type. -;; -;; There are two aspects to this: gdb has to tell us when the output for that -;; command might have changed, and we have to be able to run the command -;; behind the user's back. -;; -;; The output phasing associated with the variable gdb-output-sink -;; help us to run commands behind the user's back. -;; -;; Below is the code for specificly managing buffers of output from one -;; command. -;; - -;; The trigger function is suitable for use in the assoc GDB-ANNOTATION-RULES -;; It adds an input for the command we are tracking. It should be the -;; annotation rule binding of whatever gdb sends to tell us this command -;; might have changed it's output. -;; -;; NAME is the function name. DEMAND-PREDICATE tests if output is really needed. -;; GDB-COMMAND is a string of such. OUTPUT-HANDLER is the function bound to the -;; input in the input queue (see comment about ``gdb communications'' above). - -(defmacro def-gdb-auto-update-trigger (name demand-predicate gdb-command - output-handler) - `(defun ,name (&optional ignored) - (if (and ,demand-predicate - (not (member ',name - gdb-pending-triggers))) - (progn - (gdb-enqueue-input - (list ,gdb-command ',output-handler)) - (push ',name gdb-pending-triggers))))) - -(defmacro def-gdb-auto-update-handler (name trigger buf-key custom-defun) - `(defun ,name () - (setq gdb-pending-triggers - (delq ',trigger - gdb-pending-triggers)) - (let ((buf (gdb-get-buffer ',buf-key))) - (and buf - (with-current-buffer buf - (let* ((window (get-buffer-window buf 0)) - (start (window-start window)) - (p (if window (window-point window) (point))) - (buffer-read-only nil)) - (erase-buffer) - (insert-buffer-substring (gdb-get-buffer-create - 'gdb-partial-output-buffer)) - (if window - (progn - (set-window-start window start) - (set-window-point window p)) - (goto-char p)))))) - ;; put customisation here - (,custom-defun))) - -(defmacro def-gdb-auto-updated-buffer (buffer-key - trigger-name gdb-command - output-handler-name custom-defun) - `(progn - (def-gdb-auto-update-trigger ,trigger-name - ;; The demand predicate: - (gdb-get-buffer ',buffer-key) - ,gdb-command - ,output-handler-name) - (def-gdb-auto-update-handler ,output-handler-name - ,trigger-name ,buffer-key ,custom-defun))) - - -;; -;; Breakpoint buffer : This displays the output of `info breakpoints'. -;; -(gdb-set-buffer-rules 'gdb-breakpoints-buffer - 'gdb-breakpoints-buffer-name - 'gdb-breakpoints-mode) - -(def-gdb-auto-updated-buffer gdb-breakpoints-buffer - ;; This defines the auto update rule for buffers of type - ;; `gdb-breakpoints-buffer'. - ;; - ;; It defines a function to serve as the annotation handler that - ;; handles the `foo-invalidated' message. That function is called: - gdb-invalidate-breakpoints - ;; - ;; To update the buffer, this command is sent to gdb. - "server info breakpoints\n" - ;; - ;; This also defines a function to be the handler for the output - ;; from the command above. That function will copy the output into - ;; the appropriately typed buffer. That function will be called: - gdb-info-breakpoints-handler - ;; buffer specific functions - gdb-info-breakpoints-custom) - -(defconst breakpoint-xpm-data - "/* XPM */ -static char *magick[] = { -/* columns rows colors chars-per-pixel */ -\"10 10 2 1\", -\" c red\", -\"+ c None\", -/* pixels */ -\"+++ +++\", -\"++ ++\", -\"+ +\", -\" \", -\" \", -\" \", -\" \", -\"+ +\", -\"++ ++\", -\"+++ +++\", -};" - "XPM data used for breakpoint icon.") - -(defconst breakpoint-enabled-pbm-data - "P1 -10 10\", -0 0 0 0 1 1 1 1 0 0 0 0 -0 0 0 1 1 1 1 1 1 0 0 0 -0 0 1 1 1 1 1 1 1 1 0 0 -0 1 1 1 1 1 1 1 1 1 1 0 -0 1 1 1 1 1 1 1 1 1 1 0 -0 1 1 1 1 1 1 1 1 1 1 0 -0 1 1 1 1 1 1 1 1 1 1 0 -0 0 1 1 1 1 1 1 1 1 0 0 -0 0 0 1 1 1 1 1 1 0 0 0 -0 0 0 0 1 1 1 1 0 0 0 0" - "PBM data used for enabled breakpoint icon.") - -(defconst breakpoint-disabled-pbm-data - "P1 -10 10\", -0 0 1 0 1 0 1 0 0 0 -0 1 0 1 0 1 0 1 0 0 -1 0 1 0 1 0 1 0 1 0 -0 1 0 1 0 1 0 1 0 1 -1 0 1 0 1 0 1 0 1 0 -0 1 0 1 0 1 0 1 0 1 -1 0 1 0 1 0 1 0 1 0 -0 1 0 1 0 1 0 1 0 1 -0 0 1 0 1 0 1 0 1 0 -0 0 0 1 0 1 0 1 0 0" - "PBM data used for disabled breakpoint icon.") - -(defvar breakpoint-enabled-icon nil - "Icon for enabled breakpoint in display margin.") - -(defvar breakpoint-disabled-icon nil - "Icon for disabled breakpoint in display margin.") - -(declare-function define-fringe-bitmap "fringe.c" - (bitmap bits &optional height width align)) - -(and (display-images-p) - ;; Bitmap for breakpoint in fringe - (define-fringe-bitmap 'breakpoint - "\x3c\x7e\xff\xff\xff\xff\x7e\x3c") - ;; Bitmap for gud-overlay-arrow in fringe - (define-fringe-bitmap 'hollow-right-triangle - "\xe0\x90\x88\x84\x84\x88\x90\xe0")) - -(defface breakpoint-enabled - '((t - :foreground "red1" - :weight bold)) - "Face for enabled breakpoint icon in fringe." - :group 'gdb) - -(defface breakpoint-disabled - '((((class color) (min-colors 88)) :foreground "grey70") - ;; Ensure that on low-color displays that we end up something visible. - (((class color) (min-colors 8) (background light)) - :foreground "black") - (((class color) (min-colors 8) (background dark)) - :foreground "white") - (((type tty) (class mono)) - :inverse-video t) - (t :background "gray")) - "Face for disabled breakpoint icon in fringe." - :group 'gdb) - -(defconst gdb-breakpoint-regexp - "\\(?:\\([0-9]+\\).*?\\(?:point\\|catch\\s-+\\S-+\\)\\s-+\\S-+\\|\\([0-9]+\\.[0-9]+\\)\\)\\s-+\\(.\\)\\s-+") - -;; Put breakpoint icons in relevant margins (even those set in the GUD buffer). -(defun gdb-info-breakpoints-custom () - (let ((flag) (bptno)) - ;; Remove all breakpoint-icons in source buffers but not assembler buffer. - (dolist (buffer (buffer-list)) - (with-current-buffer buffer - (if (and (memq gud-minor-mode '(gdba gdbmi)) - (not (string-match "\\` ?\\*.+\\*\\'" (buffer-name)))) - (gdb-remove-breakpoint-icons (point-min) (point-max))))) - (with-current-buffer (gdb-get-buffer 'gdb-breakpoints-buffer) - (save-excursion - (let ((buffer-read-only nil)) - (goto-char (point-min)) - (while (< (point) (- (point-max) 1)) - (forward-line 1) - (if (looking-at gdb-breakpoint-regexp) - (progn - (setq bptno (or (match-string 1) (match-string 2))) - (setq flag (char-after (match-beginning 3))) - (if (match-string 1) - (setq gdb-parent-bptno-enabled (eq flag ?y))) - (add-text-properties - (match-beginning 3) (match-end 3) - (if (eq flag ?y) - '(face font-lock-warning-face) - '(face font-lock-type-face))) - (let ((bl (point)) - (el (line-end-position))) - (when (re-search-forward " in \\(.*\\) at" el t) - (add-text-properties - (match-beginning 1) (match-end 1) - '(face font-lock-function-name-face))) - (if (re-search-forward - ".*\\s-+\\(\\S-+\\):\\([0-9]+\\)$" el t) - (let ((line (match-string 2)) - (file (match-string 1))) - (add-text-properties bl el - '(mouse-face highlight - help-echo "mouse-2, RET: visit breakpoint")) - (unless (file-exists-p file) - (setq file (cdr (assoc bptno gdb-location-alist)))) - (if (and file - (not (string-equal file "File not found"))) - (with-current-buffer - (find-file-noselect file 'nowarn) - (gdb-init-buffer) - ;; Only want one breakpoint icon at each - ;; location. - (save-excursion - (goto-char (point-min)) - (forward-line (1- (string-to-number line))) - (gdb-put-breakpoint-icon (eq flag ?y) bptno))) - (gdb-enqueue-input - (list - (concat gdb-server-prefix "list " - (match-string-no-properties 1) ":1\n") - 'ignore)) - (gdb-enqueue-input - (list (concat gdb-server-prefix "info source\n") - `(lambda () (gdb-get-location - ,bptno ,line ,flag)))))) - (if (re-search-forward - "<\\(\\(\\sw\\|[_.]\\)+\\)\\(\\+[0-9]+\\)?>" - el t) - (add-text-properties - (match-beginning 1) (match-end 1) - '(face font-lock-function-name-face)) - (end-of-line) - (re-search-backward "\\s-\\(\\S-*\\)" - bl t) - (add-text-properties - (match-beginning 1) (match-end 1) - '(face font-lock-variable-name-face))))))) - (end-of-line)))))) - (if (gdb-get-buffer 'gdb-assembler-buffer) (gdb-assembler-custom)) - - ;; Breakpoints buffer is always present. Hack to just update - ;; current frame if there's been no execution. - (if gdb-stack-update - (setq gdb-stack-update nil) - (if (gdb-get-buffer 'gdb-stack-buffer) (gdb-info-stack-custom)))) - -(declare-function gud-remove "gdb-ui" t t) ; gud-def -(declare-function gud-break "gdb-ui" t t) ; gud-def -(declare-function fringe-bitmaps-at-pos "fringe.c" (&optional pos window)) - -(defun gdb-mouse-set-clear-breakpoint (event) - "Set/clear breakpoint in left fringe/margin at mouse click. -If not in a source or disassembly buffer just set point." - (interactive "e") - (mouse-minibuffer-check event) - (let ((posn (event-end event))) - (with-selected-window (posn-window posn) - (if (or (buffer-file-name) (eq major-mode 'gdb-assembler-mode)) - (if (numberp (posn-point posn)) - (save-excursion - (goto-char (posn-point posn)) - (if (or (posn-object posn) - (eq (car (fringe-bitmaps-at-pos (posn-point posn))) - 'breakpoint)) - (gud-remove nil) - (gud-break nil))))) - (posn-set-point posn)))) - -(defun gdb-mouse-toggle-breakpoint-margin (event) - "Enable/disable breakpoint in left margin with mouse click." - (interactive "e") - (mouse-minibuffer-check event) - (let ((posn (event-end event))) - (if (numberp (posn-point posn)) - (with-selected-window (posn-window posn) - (save-excursion - (goto-char (posn-point posn)) - (if (posn-object posn) - (let* ((bptno (get-text-property - 0 'gdb-bptno (car (posn-string posn))))) - (string-match "\\([0-9]+\\)*" bptno) - (gdb-enqueue-input - (list - (concat gdb-server-prefix - (if (get-text-property - 0 'gdb-enabled (car (posn-string posn))) - "disable " - "enable ") - (match-string 1 bptno) "\n") - 'ignore))))))))) - -(defun gdb-mouse-toggle-breakpoint-fringe (event) - "Enable/disable breakpoint in left fringe with mouse click." - (interactive "e") - (mouse-minibuffer-check event) - (let* ((posn (event-end event)) - (pos (posn-point posn)) - obj) - (when (numberp pos) - (with-selected-window (posn-window posn) - (with-current-buffer (window-buffer (selected-window)) - (goto-char pos) - (dolist (overlay (overlays-in pos pos)) - (when (overlay-get overlay 'put-break) - (setq obj (overlay-get overlay 'before-string)))) - (when (stringp obj) - (let* ((bptno (get-text-property 0 'gdb-bptno obj))) - (string-match "\\([0-9]+\\)*" bptno) - (gdb-enqueue-input - (list - (concat gdb-server-prefix - (if (get-text-property 0 'gdb-enabled obj) - "disable " - "enable ") - (match-string 1 bptno) "\n") - 'ignore))))))))) - -(defun gdb-breakpoints-buffer-name () - (with-current-buffer gud-comint-buffer - (concat "*breakpoints of " (gdb-get-target-string) "*"))) - -(defun gdb-display-breakpoints-buffer () - "Display status of user-settable breakpoints." - (interactive) - (gdb-display-buffer - (gdb-get-buffer-create 'gdb-breakpoints-buffer) t)) - -(defun gdb-frame-breakpoints-buffer () - "Display status of user-settable breakpoints in a new frame." - (interactive) - (let ((special-display-regexps (append special-display-regexps '(".*"))) - (special-display-frame-alist gdb-frame-parameters)) - (display-buffer (gdb-get-buffer-create 'gdb-breakpoints-buffer)))) - -(defvar gdb-breakpoints-mode-map - (let ((map (make-sparse-keymap)) - (menu (make-sparse-keymap "Breakpoints"))) - (define-key menu [quit] '("Quit" . gdb-delete-frame-or-window)) - (define-key menu [goto] '("Goto" . gdb-goto-breakpoint)) - (define-key menu [delete] '("Delete" . gdb-delete-breakpoint)) - (define-key menu [toggle] '("Toggle" . gdb-toggle-breakpoint)) - (suppress-keymap map) - (define-key map [menu-bar breakpoints] (cons "Breakpoints" menu)) - (define-key map " " 'gdb-toggle-breakpoint) - (define-key map "D" 'gdb-delete-breakpoint) - ;; Don't bind "q" to kill-this-buffer as we need it for breakpoint icons. - (define-key map "q" 'gdb-delete-frame-or-window) - (define-key map "\r" 'gdb-goto-breakpoint) - (define-key map [mouse-2] 'gdb-goto-breakpoint) - (define-key map [follow-link] 'mouse-face) - map)) - -(defun gdb-delete-frame-or-window () - "Delete frame if there is only one window. Otherwise delete the window." - (interactive) - (if (one-window-p) (delete-frame) - (delete-window))) - -;;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)) - -(defmacro gdb-propertize-header (name buffer help-echo mouse-face face) - `(propertize ,name - 'help-echo ,help-echo - 'mouse-face ',mouse-face - 'face ',face - 'local-map - (gdb-make-header-line-mouse-map - 'mouse-1 - (lambda (event) (interactive "e") - (save-selected-window - (select-window (posn-window (event-start event))) - (set-window-dedicated-p (selected-window) nil) - (switch-to-buffer - (gdb-get-buffer-create ',buffer)) - (setq header-line-format(gdb-set-header ',buffer)) - (set-window-dedicated-p (selected-window) t)))))) - -(defun gdb-set-header (buffer) - (cond ((eq buffer 'gdb-locals-buffer) - (list - (gdb-propertize-header "Locals" gdb-locals-buffer - nil nil mode-line) - " " - (gdb-propertize-header "Registers" gdb-registers-buffer - "mouse-1: select" mode-line-highlight mode-line-inactive))) - ((eq buffer 'gdb-registers-buffer) - (list - (gdb-propertize-header "Locals" gdb-locals-buffer - "mouse-1: select" mode-line-highlight mode-line-inactive) - " " - (gdb-propertize-header "Registers" gdb-registers-buffer - nil nil mode-line))) - ((eq buffer 'gdb-breakpoints-buffer) - (list - (gdb-propertize-header "Breakpoints" gdb-breakpoints-buffer - nil nil mode-line) - " " - (gdb-propertize-header "Threads" gdb-threads-buffer - "mouse-1: select" mode-line-highlight mode-line-inactive))) - ((eq buffer 'gdb-threads-buffer) - (list - (gdb-propertize-header "Breakpoints" gdb-breakpoints-buffer - "mouse-1: select" mode-line-highlight mode-line-inactive) - " " - (gdb-propertize-header "Threads" gdb-threads-buffer - nil nil mode-line))))) - -(defvar gdb-breakpoints-header - (list - (gdb-propertize-header "Breakpoints" gdb-breakpoints-buffer - nil nil mode-line) - " " - (gdb-propertize-header "Threads" gdb-threads-buffer - "mouse-1: select" mode-line-highlight mode-line-inactive))) - -(defun gdb-breakpoints-mode () - "Major mode for gdb breakpoints. - -\\{gdb-breakpoints-mode-map}" - (kill-all-local-variables) - (setq major-mode 'gdb-breakpoints-mode) - (setq mode-name "Breakpoints") - (use-local-map gdb-breakpoints-mode-map) - (setq buffer-read-only t) - (buffer-disable-undo) - (setq header-line-format gdb-breakpoints-header) - (run-mode-hooks 'gdb-breakpoints-mode-hook) - (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) - 'gdb-invalidate-breakpoints - 'gdbmi-invalidate-breakpoints)) - -(defun gdb-toggle-breakpoint () - "Enable/disable breakpoint at current line." - (interactive) - (save-excursion - (beginning-of-line 1) - (if (looking-at gdb-breakpoint-regexp) - (gdb-enqueue-input - (list - (concat gdb-server-prefix - (if (eq ?y (char-after (match-beginning 3))) - "disable " - "enable ") - (or (match-string 1) (match-string 2)) "\n") 'ignore)) - (error "Not recognized as break/watchpoint line")))) - -(defun gdb-delete-breakpoint () - "Delete the breakpoint at current line." - (interactive) - (save-excursion - (beginning-of-line 1) - (if (looking-at gdb-breakpoint-regexp) - (if (match-string 1) - (gdb-enqueue-input - (list - (concat gdb-server-prefix "delete " (match-string 1) "\n") - 'ignore)) - (message-box "This breakpoint cannot be deleted on its own.")) - (error "Not recognized as break/watchpoint line")))) - -(defun gdb-goto-breakpoint (&optional event) - "Display the breakpoint location specified at current line." - (interactive (list last-input-event)) - (if event (posn-set-point (event-end event))) - (save-excursion - (beginning-of-line 1) - (if (looking-at "\\([0-9]+\\.?[0-9]*\\) .*\\s-+\\(\\S-+\\):\\([0-9]+\\)$") - (let ((bptno (match-string 1)) - (file (match-string 2)) - (line (match-string 3))) - (save-selected-window - (let* ((buffer (find-file-noselect - (if (file-exists-p file) file - (cdr (assoc bptno gdb-location-alist))))) - (window (or (gdb-display-source-buffer buffer) - (display-buffer buffer)))) - (setq gdb-source-window window) - (with-current-buffer buffer - (goto-char (point-min)) - (forward-line (1- (string-to-number line))) - (set-window-point window (point)))))) - (error "No location specified")))) - - -;; Frames buffer. This displays a perpetually correct backtrace -;; (from the command `where'). -;; -;; Alas, if your stack is deep, it is costly. -;; -(defcustom gdb-max-frames 40 - "Maximum number of frames displayed in call stack." - :type 'integer - :group 'gdb - :version "22.1") - -(gdb-set-buffer-rules 'gdb-stack-buffer - 'gdb-stack-buffer-name - 'gdb-frames-mode) - -(def-gdb-auto-updated-buffer gdb-stack-buffer - gdb-invalidate-frames - (concat "server info stack " (number-to-string gdb-max-frames) "\n") - gdb-info-stack-handler - gdb-info-stack-custom) - -;; This may be more important for embedded targets where unwinding the -;; stack may take a long time. -(defadvice gdb-invalidate-frames (around gdb-invalidate-frames-advice - (&optional ignored) activate compile) - "Only queue \"info stack\" if execution has occurred." - (if gdb-stack-update ad-do-it)) - -(defun gdb-info-stack-custom () - (with-current-buffer (gdb-get-buffer 'gdb-stack-buffer) - (let (move-to) - (save-excursion - (unless (eq gdb-look-up-stack 'delete) - (let ((buffer-read-only nil) - bl el) - (goto-char (point-min)) - (while (< (point) (point-max)) - (setq bl (line-beginning-position) - el (line-end-position)) - (when (looking-at "#") - (add-text-properties bl el - '(mouse-face highlight - help-echo "mouse-2, RET: Select frame"))) - (goto-char bl) - (when (looking-at "^#\\([0-9]+\\)") - (when (string-equal (match-string 1) gdb-frame-number) - (if (gud-tool-bar-item-visible-no-fringe) - (progn - (put-text-property bl (+ bl 4) - 'face '(:inverse-video t)) - (setq move-to bl)) - (or gdb-stack-position - (setq gdb-stack-position (make-marker))) - (set-marker gdb-stack-position (point)) - (setq move-to gdb-stack-position))) - (when (re-search-forward "\\([^ ]+\\) (" el t) - (put-text-property (match-beginning 1) (match-end 1) - 'face font-lock-function-name-face) - (setq bl (match-end 0)) - (while (re-search-forward "<\\([^>]+\\)>" el t) - (put-text-property (match-beginning 1) (match-end 1) - 'face font-lock-function-name-face)) - (goto-char bl) - (while (re-search-forward "\\(\\(\\sw\\|[_.]\\)+\\)=" el t) - (put-text-property (match-beginning 1) (match-end 1) - 'face font-lock-variable-name-face)))) - (forward-line 1)) - (forward-line -1) - (when (looking-at "(More stack frames follow...)") - (add-text-properties - (match-beginning 0) (match-end 0) - '(mouse-face highlight - gdb-max-frames t - help-echo - "mouse-2, RET: customize gdb-max-frames to see more frames" - ))))) - (when gdb-look-up-stack - (goto-char (point-min)) - (when (re-search-forward "\\(\\S-+?\\):\\([0-9]+\\)" nil t) - (let ((start (line-beginning-position)) - (file (match-string 1)) - (line (match-string 2))) - (re-search-backward "^#*\\([0-9]+\\)" start t) - (gdb-enqueue-input - (list (concat gdb-server-prefix "frame " - (match-string 1) "\n") 'gdb-set-hollow)) - (gdb-enqueue-input - (list (concat gdb-server-prefix "frame 0\n") 'ignore)))))) - (when move-to - (let ((window (get-buffer-window (current-buffer) 0))) - (when window - (with-selected-window window - (goto-char move-to) - (unless (pos-visible-in-window-p) - (recenter '(center))))))))) - (if (eq gdb-look-up-stack 'delete) - (kill-buffer (gdb-get-buffer 'gdb-stack-buffer))) - (setq gdb-look-up-stack nil)) - -(defun gdb-set-hollow () - (if gud-last-last-frame - (with-current-buffer (gud-find-file (car gud-last-last-frame)) - (setq fringe-indicator-alist - '((overlay-arrow . hollow-right-triangle)))))) - -(defun gdb-stack-buffer-name () - (with-current-buffer gud-comint-buffer - (concat "*stack frames of " (gdb-get-target-string) "*"))) - -(defun gdb-display-stack-buffer () - "Display backtrace of current stack." - (interactive) - (gdb-display-buffer - (gdb-get-buffer-create 'gdb-stack-buffer) t)) - -(defun gdb-frame-stack-buffer () - "Display backtrace of current stack in a new frame." - (interactive) - (let ((special-display-regexps (append special-display-regexps '(".*"))) - (special-display-frame-alist gdb-frame-parameters)) - (display-buffer (gdb-get-buffer-create 'gdb-stack-buffer)))) - -(defvar gdb-frames-mode-map - (let ((map (make-sparse-keymap))) - (suppress-keymap map) - (define-key map "q" 'kill-this-buffer) - (define-key map "\r" 'gdb-frames-select) - (define-key map "F" 'gdb-frames-force-update) - (define-key map [mouse-2] 'gdb-frames-select) - (define-key map [follow-link] 'mouse-face) - map)) - -(declare-function gdbmi-invalidate-frames "ext:gdb-mi" nil t) - -(defun gdb-frames-force-update () - "Force update of call stack. -Use when the displayed call stack gets out of sync with the -actual one, e.g after using the Gdb command \"return\" or setting -$pc directly from the GUD buffer. This command isn't normally needed." - (interactive) - (setq gdb-stack-update t) - (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) - (gdb-invalidate-frames) - (gdbmi-invalidate-frames))) - -(defun gdb-frames-mode () - "Major mode for gdb call stack. - -\\{gdb-frames-mode-map}" - (kill-all-local-variables) - (setq major-mode 'gdb-frames-mode) - (setq mode-name "Frames") - (setq gdb-stack-position nil) - (add-to-list 'overlay-arrow-variable-list 'gdb-stack-position) - (setq truncate-lines t) ;; Make it easier to see overlay arrow. - (setq buffer-read-only t) - (buffer-disable-undo) - (gdb-thread-identification) - (use-local-map gdb-frames-mode-map) - (run-mode-hooks 'gdb-frames-mode-hook) - (setq gdb-stack-update t) - (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) - 'gdb-invalidate-frames - 'gdbmi-invalidate-frames)) - -(defun gdb-get-frame-number () - (save-excursion - (end-of-line) - (let* ((start (line-beginning-position)) - (pos (re-search-backward "^#*\\([0-9]+\\)" start t)) - (n (or (and pos (match-string 1)) "0"))) - n))) - -(defun gdb-frames-select (&optional event) - "Select the frame and display the relevant source." - (interactive (list last-input-event)) - (if event (posn-set-point (event-end event))) - (if (get-text-property (point) 'gdb-max-frames) - (progn - (message-box "After setting gdb-max-frames, you need to enter\n\ -another GDB command e.g pwd, to see new frames") - (customize-variable-other-window 'gdb-max-frames)) - (gdb-enqueue-input - (list (concat gdb-server-prefix "frame " - (gdb-get-frame-number) "\n") 'ignore)))) - - -;; Threads buffer. This displays a selectable thread list. -;; -(gdb-set-buffer-rules 'gdb-threads-buffer - 'gdb-threads-buffer-name - 'gdb-threads-mode) - -(def-gdb-auto-updated-buffer gdb-threads-buffer - gdb-invalidate-threads - (concat gdb-server-prefix "info threads\n") - gdb-info-threads-handler - gdb-info-threads-custom) - -(defun gdb-info-threads-custom () - (with-current-buffer (gdb-get-buffer 'gdb-threads-buffer) - (let ((buffer-read-only nil)) - (save-excursion - (goto-char (point-min)) - (if (re-search-forward "\\* \\([0-9]+\\)" nil t) - (setq gdb-thread-indicator - (propertize (concat " [" (match-string 1) "]") - ; FIXME: this help-echo doesn't work - 'help-echo "thread id"))) - (goto-char (point-min)) - (while (< (point) (point-max)) - (unless (looking-at "No ") - (add-text-properties (line-beginning-position) (line-end-position) - '(mouse-face highlight - help-echo "mouse-2, RET: select thread"))) - (forward-line 1)))))) - -(defun gdb-threads-buffer-name () - (with-current-buffer gud-comint-buffer - (concat "*threads of " (gdb-get-target-string) "*"))) - -(defun gdb-display-threads-buffer () - "Display IDs of currently known threads." - (interactive) - (gdb-display-buffer - (gdb-get-buffer-create 'gdb-threads-buffer) t)) - -(defun gdb-frame-threads-buffer () - "Display IDs of currently known threads in a new frame." - (interactive) - (let ((special-display-regexps (append special-display-regexps '(".*"))) - (special-display-frame-alist gdb-frame-parameters)) - (display-buffer (gdb-get-buffer-create 'gdb-threads-buffer)))) - -(defvar gdb-threads-mode-map - (let ((map (make-sparse-keymap))) - (suppress-keymap map) - (define-key map "q" 'kill-this-buffer) - (define-key map "\r" 'gdb-threads-select) - (define-key map [mouse-2] 'gdb-threads-select) - (define-key map [follow-link] 'mouse-face) - map)) - -(defvar gdb-threads-font-lock-keywords - '((") +\\([^ ]+\\) (" (1 font-lock-function-name-face)) - ("in \\([^ ]+\\) (" (1 font-lock-function-name-face)) - ("\\(\\(\\sw\\|[_.]\\)+\\)=" (1 font-lock-variable-name-face))) - "Font lock keywords used in `gdb-threads-mode'.") - -(defun gdb-threads-mode () - "Major mode for gdb threads. - -\\{gdb-threads-mode-map}" - (kill-all-local-variables) - (setq major-mode 'gdb-threads-mode) - (setq mode-name "Threads") - (setq buffer-read-only t) - (buffer-disable-undo) - (setq header-line-format gdb-breakpoints-header) - (use-local-map gdb-threads-mode-map) - (set (make-local-variable 'font-lock-defaults) - '(gdb-threads-font-lock-keywords)) - (run-mode-hooks 'gdb-threads-mode-hook) - ;; Force "info threads" onto queue. - (lambda () (let ((gud-running nil)) (gdb-invalidate-threads)))) - -(defun gdb-get-thread-number () - (save-excursion - (re-search-backward "^\\s-*\\([0-9]*\\)" nil t) - (match-string-no-properties 1))) - -(defun gdb-threads-select (&optional event) - "Select the thread and display the relevant source." - (interactive (list last-input-event)) - (if event (posn-set-point (event-end event))) - (setq gdb-stack-update t) - (gdb-enqueue-input - (list (concat gdb-server-prefix "thread " - (gdb-get-thread-number) "\n") 'ignore)) - (gud-display-frame)) - -(defun gdb-thread-identification () - (setq mode-line-buffer-identification - (list (car mode-line-buffer-identification) - '(gdb-thread-indicator gdb-thread-indicator)))) - -;; Registers buffer. -;; -(defcustom gdb-all-registers nil - "Non-nil means include floating-point registers." - :type 'boolean - :group 'gdb - :version "22.1") - -(gdb-set-buffer-rules 'gdb-registers-buffer - 'gdb-registers-buffer-name - 'gdb-registers-mode) - -(def-gdb-auto-updated-buffer gdb-registers-buffer - gdb-invalidate-registers - (concat - gdb-server-prefix "info " (if gdb-all-registers "all-") "registers\n") - gdb-info-registers-handler - gdb-info-registers-custom) - -(defun gdb-info-registers-custom () - (with-current-buffer (gdb-get-buffer 'gdb-registers-buffer) - (save-excursion - (let ((buffer-read-only nil) - start end) - (goto-char (point-min)) - (while (< (point) (point-max)) - (setq start (line-beginning-position)) - (setq end (line-end-position)) - (when (looking-at "^[^ ]+") - (unless (string-equal (match-string 0) "The") - (put-text-property start (match-end 0) - 'face font-lock-variable-name-face) - (add-text-properties start end - '(help-echo "mouse-2: edit value" - mouse-face highlight)))) - (forward-line 1)))))) - -(defun gdb-edit-register-value (&optional event) - (interactive (list last-input-event)) - (save-excursion - (if event (posn-set-point (event-end event))) - (beginning-of-line) - (let* ((register (current-word)) - (value (read-string (format "New value (%s): " register)))) - (gdb-enqueue-input - (list (concat gdb-server-prefix "set $" register "=" value "\n") - 'ignore))))) - -(defvar gdb-registers-mode-map - (let ((map (make-sparse-keymap))) - (suppress-keymap map) - (define-key map "\r" 'gdb-edit-register-value) - (define-key map [mouse-2] 'gdb-edit-register-value) - (define-key map " " 'gdb-all-registers) - (define-key map "q" 'kill-this-buffer) - map)) - -(defvar gdb-locals-header - (list - (gdb-propertize-header "Locals" gdb-locals-buffer - nil nil mode-line) - " " - (gdb-propertize-header "Registers" gdb-registers-buffer - "mouse-1: select" mode-line-highlight mode-line-inactive))) - - -(defun gdb-registers-mode () - "Major mode for gdb registers. - -\\{gdb-registers-mode-map}" - (kill-all-local-variables) - (setq major-mode 'gdb-registers-mode) - (setq mode-name "Registers") - (setq header-line-format gdb-locals-header) - (setq buffer-read-only t) - (buffer-disable-undo) - (gdb-thread-identification) - (use-local-map gdb-registers-mode-map) - (run-mode-hooks 'gdb-registers-mode-hook) - (if (string-equal gdb-version "pre-6.4") - (progn - (if gdb-all-registers (setq mode-name "Registers:All")) - 'gdb-invalidate-registers) - 'gdb-invalidate-registers-1)) - -(defun gdb-registers-buffer-name () - (with-current-buffer gud-comint-buffer - (concat "*registers of " (gdb-get-target-string) "*"))) - -(defun gdb-display-registers-buffer () - "Display integer register contents." - (interactive) - (gdb-display-buffer - (gdb-get-buffer-create 'gdb-registers-buffer) t)) - -(defun gdb-frame-registers-buffer () - "Display integer register contents in a new frame." - (interactive) - (let ((special-display-regexps (append special-display-regexps '(".*"))) - (special-display-frame-alist gdb-frame-parameters)) - (display-buffer (gdb-get-buffer-create 'gdb-registers-buffer)))) - -(defun gdb-all-registers () - "Toggle the display of floating-point registers (pre GDB 6.4 only)." - (interactive) - (when (string-equal gdb-version "pre-6.4") - (if gdb-all-registers - (progn - (setq gdb-all-registers nil) - (with-current-buffer (gdb-get-buffer-create 'gdb-registers-buffer) - (setq mode-name "Registers"))) - (setq gdb-all-registers t) - (with-current-buffer (gdb-get-buffer-create 'gdb-registers-buffer) - (setq mode-name "Registers:All"))) - (message (format "Display of floating-point registers %sabled" - (if gdb-all-registers "en" "dis"))) - (gdb-invalidate-registers))) - - -;; Memory buffer. -;; -(defcustom gdb-memory-repeat-count 32 - "Number of data items in memory window." - :type 'integer - :group 'gdb - :version "22.1") - -(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 'gdb - :version "22.1") - -(defcustom gdb-memory-unit "w" - "Unit size of data items in memory window." - :type '(choice (const :tag "Byte" "b") - (const :tag "Halfword" "h") - (const :tag "Word" "w") - (const :tag "Giant word" "g")) - :group 'gdb - :version "22.1") - -(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 - (concat gdb-server-prefix "x/" (number-to-string gdb-memory-repeat-count) - gdb-memory-format gdb-memory-unit " " gdb-memory-address "\n") - gdb-read-memory-handler - gdb-read-memory-custom) - -(defun gdb-read-memory-custom () - (save-excursion - (goto-char (point-min)) - (if (looking-at "0x[[:xdigit:]]+") - (setq gdb-memory-address (match-string 0))))) - -(defvar gdb-memory-mode-map - (let ((map (make-sparse-keymap))) - (suppress-keymap map) - (define-key map "S" 'gdb-memory-set-address) - (define-key map "N" 'gdb-memory-set-repeat-count) - (define-key map "q" 'kill-this-buffer) - map)) - -(defun gdb-memory-set-address (&optional event) - "Set the start memory address." - (interactive) - (let ((arg (read-from-minibuffer "Start address: "))) - (setq gdb-memory-address arg)) - (gdb-invalidate-memory)) - -(defun gdb-memory-set-repeat-count (&optional event) - "Set the number of data items in memory window." - (interactive) - (let* ((arg (read-from-minibuffer "Repeat count: ")) - (count (string-to-number arg))) - (if (<= count 0) - (error "Positive numbers only") - (customize-set-variable 'gdb-memory-repeat-count count) - (gdb-invalidate-memory)))) - -(defun gdb-memory-format-binary () - "Set the display format to binary." - (interactive) - (customize-set-variable 'gdb-memory-format "t") - (gdb-invalidate-memory)) - -(defun gdb-memory-format-octal () - "Set the display format to octal." - (interactive) - (customize-set-variable 'gdb-memory-format "o") - (gdb-invalidate-memory)) - -(defun gdb-memory-format-unsigned () - "Set the display format to unsigned decimal." - (interactive) - (customize-set-variable 'gdb-memory-format "u") - (gdb-invalidate-memory)) - -(defun gdb-memory-format-signed () - "Set the display format to decimal." - (interactive) - (customize-set-variable 'gdb-memory-format "d") - (gdb-invalidate-memory)) - -(defun gdb-memory-format-hexadecimal () - "Set the display format to hexadecimal." - (interactive) - (customize-set-variable 'gdb-memory-format "x") - (gdb-invalidate-memory)) - -(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 "g") - (gdb-invalidate-memory)) - -(defun gdb-memory-unit-word () - "Set the unit size to words (four bytes)." - (interactive) - (customize-set-variable 'gdb-memory-unit "w") - (gdb-invalidate-memory)) - -(defun gdb-memory-unit-halfword () - "Set the unit size to halfwords (two bytes)." - (interactive) - (customize-set-variable 'gdb-memory-unit "h") - (gdb-invalidate-memory)) - -(defun gdb-memory-unit-byte () - "Set the unit size to bytes." - (interactive) - (customize-set-variable 'gdb-memory-unit "b") - (gdb-invalidate-memory)) - -(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 "g")))) -(define-key gdb-memory-unit-menu [words] - '(menu-item "Words" gdb-memory-unit-word - :button (:radio . (equal gdb-memory-unit "w")))) -(define-key gdb-memory-unit-menu [halfwords] - '(menu-item "Halfwords" gdb-memory-unit-halfword - :button (:radio . (equal gdb-memory-unit "h")))) -(define-key gdb-memory-unit-menu [bytes] - '(menu-item "Bytes" gdb-memory-unit-byte - :button (:radio . (equal gdb-memory-unit "b")))) - -(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))))) - -(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'.") - -(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") - (setq buffer-read-only t) - (buffer-disable-undo) - (use-local-map gdb-memory-mode-map) - (setq header-line-format - '(: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 - (lambda () (interactive) - (let ((gdb-memory-address - ;; Let GDB do the arithmetic. - (concat - gdb-memory-address " - " - (number-to-string - (* gdb-memory-repeat-count - (cond ((string= gdb-memory-unit "b") 1) - ((string= gdb-memory-unit "h") 2) - ((string= gdb-memory-unit "w") 4) - ((string= gdb-memory-unit "g") 8))))))) - (gdb-invalidate-memory))))) - "|" - (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 - (lambda () (interactive) - (let ((gdb-memory-address nil)) - (gdb-invalidate-memory))))) - "]: " - (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)) - " Repeat Count: " - (propertize (number-to-string gdb-memory-repeat-count) - 'face font-lock-warning-face - 'help-echo "mouse-1: set repeat count" - 'mouse-face 'mode-line-highlight - 'local-map (gdb-make-header-line-mouse-map - 'mouse-1 - #'gdb-memory-set-repeat-count)) - " 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 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)))) - (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) "*"))) - -(defun gdb-display-memory-buffer () - "Display memory contents." - (interactive) - (gdb-display-buffer - (gdb-get-buffer-create 'gdb-memory-buffer) t)) - -(defun gdb-frame-memory-buffer () - "Display memory contents in a new frame." - (interactive) - (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)))) - - -;; Locals buffer. -;; -(gdb-set-buffer-rules 'gdb-locals-buffer - 'gdb-locals-buffer-name - 'gdb-locals-mode) - -(def-gdb-auto-update-trigger gdb-invalidate-locals - (gdb-get-buffer 'gdb-locals-buffer) - "server info locals\n" - gdb-info-locals-handler) - -(defvar gdb-locals-watch-map - (let ((map (make-sparse-keymap))) - (suppress-keymap map) - (define-key map "\r" (lambda () (interactive) - (beginning-of-line) - (gud-watch))) - (define-key map [mouse-2] (lambda (event) (interactive "e") - (mouse-set-point event) - (beginning-of-line) - (gud-watch))) - map) - "Keymap to create watch expression of a complex data type local variable.") - -(defconst gdb-struct-string - (concat (propertize "[struct/union]" - 'mouse-face 'highlight - 'help-echo "mouse-2: create watch expression" - 'local-map gdb-locals-watch-map) "\n")) - -(defconst gdb-array-string - (concat " " (propertize "[array]" - 'mouse-face 'highlight - 'help-echo "mouse-2: create watch expression" - 'local-map gdb-locals-watch-map) "\n")) - -;; Abbreviate for arrays and structures. -;; These can be expanded using gud-display. -(defun gdb-info-locals-handler () - (setq gdb-pending-triggers (delq 'gdb-invalidate-locals - gdb-pending-triggers)) - (let ((buf (gdb-get-buffer 'gdb-partial-output-buffer))) - (with-current-buffer buf - (goto-char (point-min)) - ;; Need this in case "set print pretty" is on. - (while (re-search-forward "^[ }].*\n" nil t) - (replace-match "" nil nil)) - (goto-char (point-min)) - (while (re-search-forward "{\\(.*=.*\n\\|\n\\)" nil t) - (replace-match gdb-struct-string nil nil)) - (goto-char (point-min)) - (while (re-search-forward "\\s-*{[^.].*\n" nil t) - (replace-match gdb-array-string nil nil)))) - (let ((buf (gdb-get-buffer 'gdb-locals-buffer))) - (and buf - (with-current-buffer buf - (let* ((window (get-buffer-window buf 0)) - (start (window-start window)) - (p (window-point window)) - (buffer-read-only nil)) - (erase-buffer) - (insert-buffer-substring (gdb-get-buffer-create - 'gdb-partial-output-buffer)) - (set-window-start window start) - (set-window-point window p))))) - (run-hooks 'gdb-info-locals-hook)) - -(defvar gdb-locals-mode-map - (let ((map (make-sparse-keymap))) - (suppress-keymap map) - (define-key map "q" 'kill-this-buffer) - map)) - -(defun gdb-locals-mode () - "Major mode for gdb locals. - -\\{gdb-locals-mode-map}" - (kill-all-local-variables) - (setq major-mode 'gdb-locals-mode) - (setq mode-name (concat "Locals:" gdb-selected-frame)) - (use-local-map gdb-locals-mode-map) - (setq buffer-read-only t) - (buffer-disable-undo) - (setq header-line-format gdb-locals-header) - (gdb-thread-identification) - (set (make-local-variable 'font-lock-defaults) - '(gdb-locals-font-lock-keywords)) - (run-mode-hooks 'gdb-locals-mode-hook) - (if (and (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) - (string-equal gdb-version "pre-6.4")) - 'gdb-invalidate-locals - 'gdb-invalidate-locals-1)) - -(defun gdb-locals-buffer-name () - (with-current-buffer gud-comint-buffer - (concat "*locals of " (gdb-get-target-string) "*"))) - -(defun gdb-display-locals-buffer () - "Display local variables of current stack and their values." - (interactive) - (gdb-display-buffer - (gdb-get-buffer-create 'gdb-locals-buffer) t)) - -(defun gdb-frame-locals-buffer () - "Display local variables of current stack and their values in a new frame." - (interactive) - (let ((special-display-regexps (append special-display-regexps '(".*"))) - (special-display-frame-alist gdb-frame-parameters)) - (display-buffer (gdb-get-buffer-create 'gdb-locals-buffer)))) - - -;;;; Window management -(defun gdb-display-buffer (buf dedicated &optional frame) - (let ((answer (get-buffer-window buf (or frame 0)))) - (if answer - (display-buffer buf nil (or frame 0)) ;Deiconify the frame if necessary. - (let ((window (get-lru-window))) - (if (memq (buffer-local-value 'gud-minor-mode (window-buffer window)) - '(gdba gdbmi)) - (let* ((largest (get-largest-window)) - (cur-size (window-height largest))) - (setq answer (split-window largest)) - (set-window-buffer answer buf) - (set-window-dedicated-p answer dedicated) - answer) - (set-window-buffer window buf) - window))))) - - -;;; Shared keymap initialization: - -(let ((menu (make-sparse-keymap "GDB-Windows"))) - (define-key gud-menu-map [displays] - `(menu-item "GDB-Windows" ,menu - :help "Open a GDB-UI buffer in a new window." - :visible (memq gud-minor-mode '(gdbmi gdba)))) - (define-key menu [gdb] '("Gdb" . gdb-display-gdb-buffer)) - (define-key menu [threads] '("Threads" . gdb-display-threads-buffer)) - (define-key menu [inferior] - '(menu-item "Separate IO" gdb-display-separate-io-buffer - :enable gdb-use-separate-io-buffer)) - (define-key menu [memory] '("Memory" . gdb-display-memory-buffer)) - (define-key menu [registers] '("Registers" . gdb-display-registers-buffer)) - (define-key menu [disassembly] - '("Disassembly" . gdb-display-assembler-buffer)) - (define-key menu [breakpoints] - '("Breakpoints" . gdb-display-breakpoints-buffer)) - (define-key menu [locals] '("Locals" . gdb-display-locals-buffer)) - (define-key menu [frames] '("Stack" . gdb-display-stack-buffer))) - -(let ((menu (make-sparse-keymap "GDB-Frames"))) - (define-key gud-menu-map [frames] - `(menu-item "GDB-Frames" ,menu - :help "Open a GDB-UI buffer in a new frame." - :visible (memq gud-minor-mode '(gdbmi gdba)))) - (define-key menu [gdb] '("Gdb" . gdb-frame-gdb-buffer)) - (define-key menu [threads] '("Threads" . gdb-frame-threads-buffer)) - (define-key menu [memory] '("Memory" . gdb-frame-memory-buffer)) - (define-key menu [inferior] - '(menu-item "Separate IO" gdb-frame-separate-io-buffer - :enable gdb-use-separate-io-buffer)) - (define-key menu [registers] '("Registers" . gdb-frame-registers-buffer)) - (define-key menu [disassembly] '("Disassembly" . gdb-frame-assembler-buffer)) - (define-key menu [breakpoints] - '("Breakpoints" . gdb-frame-breakpoints-buffer)) - (define-key menu [locals] '("Locals" . gdb-frame-locals-buffer)) - (define-key menu [frames] '("Stack" . gdb-frame-stack-buffer))) - -(let ((menu (make-sparse-keymap "GDB-UI/MI"))) - (define-key gud-menu-map [ui] - `(menu-item (if (eq gud-minor-mode 'gdba) "GDB-UI" "GDB-MI") - ,menu :visible (memq gud-minor-mode '(gdbmi gdba)))) - (define-key menu [gdb-customize] - '(menu-item "Customize" (lambda () (interactive) (customize-group 'gdb)) - :help "Customize Gdb Graphical Mode options.")) - (define-key menu [gdb-find-source-frame] - '(menu-item "Look For Source Frame" gdb-find-source-frame - :visible (eq gud-minor-mode 'gdba) - :help "Toggle looking for source frame further up call stack." - :button (:toggle . gdb-find-source-frame))) - (define-key menu [gdb-use-separate-io] - '(menu-item "Separate IO" gdb-use-separate-io-buffer - :visible (eq gud-minor-mode 'gdba) - :help "Toggle separate IO for debugged program." - :button (:toggle . gdb-use-separate-io-buffer))) - (define-key menu [gdb-many-windows] - '(menu-item "Display Other Windows" gdb-many-windows - :help "Toggle display of locals, stack and breakpoint information." - :button (:toggle . gdb-many-windows))) - (define-key menu [gdb-restore-windows] - '(menu-item "Restore Window Layout" gdb-restore-windows - :help "Restore standard layout for debug session."))) - -(defun gdb-frame-gdb-buffer () - "Display GUD buffer in a new frame." - (interactive) - (let ((special-display-regexps (append special-display-regexps '(".*"))) - (special-display-frame-alist - (remove '(menu-bar-lines) (remove '(tool-bar-lines) - gdb-frame-parameters))) - (same-window-regexps nil)) - (display-buffer gud-comint-buffer))) - -(defun gdb-display-gdb-buffer () - "Display GUD buffer." - (interactive) - (let ((same-window-regexps nil)) - (select-window (display-buffer gud-comint-buffer nil 0)))) - -(defun gdb-set-window-buffer (name) - (set-window-buffer (selected-window) (get-buffer name)) - (set-window-dedicated-p (selected-window) t)) - -(defun gdb-setup-windows () - "Layout the window pattern for `gdb-many-windows'." - (gdb-display-locals-buffer) - (gdb-display-stack-buffer) - (delete-other-windows) - (gdb-display-breakpoints-buffer) - (delete-other-windows) - ; Don't dedicate. - (pop-to-buffer gud-comint-buffer) - (split-window nil ( / ( * (window-height) 3) 4)) - (split-window nil ( / (window-height) 3)) - (split-window-horizontally) - (other-window 1) - (gdb-set-window-buffer (gdb-locals-buffer-name)) - (other-window 1) - (switch-to-buffer - (if gud-last-last-frame - (gud-find-file (car gud-last-last-frame)) - (if gdb-main-file - (gud-find-file gdb-main-file) - ;; Put buffer list in window if we - ;; can't find a source file. - (list-buffers-noselect)))) - (setq gdb-source-window (selected-window)) - (when gdb-use-separate-io-buffer - (split-window-horizontally) - (other-window 1) - (gdb-set-window-buffer - (gdb-get-buffer-create 'gdb-inferior-io))) - (other-window 1) - (gdb-set-window-buffer (gdb-stack-buffer-name)) - (split-window-horizontally) - (other-window 1) - (gdb-set-window-buffer (gdb-breakpoints-buffer-name)) - (other-window 1)) - -(defun gdb-restore-windows () - "Restore the basic arrangement of windows used by gdba. -This arrangement depends on the value of `gdb-many-windows'." - (interactive) - (pop-to-buffer gud-comint-buffer) ;Select the right window and frame. - (delete-other-windows) - (if gdb-many-windows - (gdb-setup-windows) - (when (or gud-last-last-frame gdb-show-main) - (split-window) - (other-window 1) - (switch-to-buffer - (if gud-last-last-frame - (gud-find-file (car gud-last-last-frame)) - (gud-find-file gdb-main-file))) - (setq gdb-source-window (selected-window)) - (other-window 1)))) - -(defun gdb-reset () - "Exit a debugging session cleanly. -Kills the gdb buffers, and resets variables and the source buffers." - (dolist (buffer (buffer-list)) - (unless (eq buffer gud-comint-buffer) - (with-current-buffer buffer - (if (memq gud-minor-mode '(gdbmi gdba)) - (if (string-match "\\` ?\\*.+\\*\\'" (buffer-name)) - (kill-buffer nil) - (gdb-remove-breakpoint-icons (point-min) (point-max) t) - (setq gud-minor-mode nil) - (kill-local-variable 'tool-bar-map) - (kill-local-variable 'gdb-define-alist)))))) - (setq gdb-overlay-arrow-position nil) - (setq overlay-arrow-variable-list - (delq 'gdb-overlay-arrow-position overlay-arrow-variable-list)) - (setq fringe-indicator-alist '((overlay-arrow . right-triangle))) - (setq gdb-stack-position nil) - (setq overlay-arrow-variable-list - (delq 'gdb-stack-position overlay-arrow-variable-list)) - (if (boundp 'speedbar-frame) (speedbar-timer-fn)) - (setq gud-running nil) - (setq gdb-active-process nil) - (setq gdb-var-list nil) - (remove-hook 'after-save-hook 'gdb-create-define-alist t)) - -(defun gdb-source-info () - "Find the source file where the program starts and display it with related -buffers." - (goto-char (point-min)) - (if (and (search-forward "Located in " nil t) - (looking-at "\\S-+")) - (setq gdb-main-file (match-string 0))) - (goto-char (point-min)) - (if (search-forward "Includes preprocessor macro info." nil t) - (setq gdb-macro-info t)) - (if gdb-many-windows - (gdb-setup-windows) - (gdb-get-buffer-create 'gdb-breakpoints-buffer) - (if (and gdb-show-main gdb-main-file) - (let ((pop-up-windows t)) - (display-buffer (gud-find-file gdb-main-file))))) - (setq gdb-ready t)) - -(defun gdb-get-location (bptno line flag) - "Find the directory containing the relevant source file. -Put in buffer and place breakpoint icon." - (goto-char (point-min)) - (catch 'file-not-found - (if (search-forward "Located in " nil t) - (when (looking-at "\\S-+") - (delete (cons bptno "File not found") gdb-location-alist) - (push (cons bptno (match-string 0)) gdb-location-alist)) - (gdb-resync) - (unless (assoc bptno gdb-location-alist) - (push (cons bptno "File not found") gdb-location-alist) - (message-box "Cannot find source file for breakpoint location.\n\ -Add directory to search path for source files using the GDB command, dir.")) - (throw 'file-not-found nil)) - (with-current-buffer - (find-file-noselect (match-string 0)) - (gdb-init-buffer) - ;; only want one breakpoint icon at each location - (save-excursion - (goto-char (point-min)) - (forward-line (1- (string-to-number line))) - (gdb-put-breakpoint-icon (eq flag ?y) bptno))))) - -(add-hook 'find-file-hook 'gdb-find-file-hook) - -(defun gdb-find-file-hook () - "Set up buffer for debugging if file is part of the source code -of the current session." - (if (and (buffer-name gud-comint-buffer) - ;; in case gud or gdb-ui is just loaded - gud-comint-buffer - (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer) - '(gdba gdbmi))) - ;;Pre GDB 6.3 "info sources" doesn't give absolute file name. - (if (member (if (string-equal gdb-version "pre-6.4") - (file-name-nondirectory buffer-file-name) - buffer-file-name) - gdb-source-file-list) - (with-current-buffer (find-buffer-visiting buffer-file-name) - (gdb-init-buffer))))) - -;;from put-image -(defun gdb-put-string (putstring pos &optional dprop &rest sprops) - "Put string PUTSTRING in front of POS in the current buffer. -PUTSTRING is displayed by putting an overlay into the current buffer with a -`before-string' string that has a `display' property whose value is -PUTSTRING." - (let ((string (make-string 1 ?x)) - (buffer (current-buffer))) - (setq putstring (copy-sequence putstring)) - (let ((overlay (make-overlay pos pos buffer)) - (prop (or dprop - (list (list 'margin 'left-margin) putstring)))) - (put-text-property 0 1 'display prop string) - (if sprops - (add-text-properties 0 1 sprops string)) - (overlay-put overlay 'put-break t) - (overlay-put overlay 'before-string string)))) - -;;from remove-images -(defun gdb-remove-strings (start end &optional buffer) - "Remove strings between START and END in BUFFER. -Remove only strings that were put in BUFFER with calls to `gdb-put-string'. -BUFFER nil or omitted means use the current buffer." - (unless buffer - (setq buffer (current-buffer))) - (dolist (overlay (overlays-in start end)) - (when (overlay-get overlay 'put-break) - (delete-overlay overlay)))) - -(defun gdb-put-breakpoint-icon (enabled bptno) - (if (string-match "[0-9+]+\\." bptno) - (setq enabled gdb-parent-bptno-enabled)) - (let ((start (- (line-beginning-position) 1)) - (end (+ (line-end-position) 1)) - (putstring (if enabled "B" "b")) - (source-window (get-buffer-window (current-buffer) 0))) - (add-text-properties - 0 1 '(help-echo "mouse-1: clear bkpt, mouse-3: enable/disable bkpt") - putstring) - (if enabled - (add-text-properties - 0 1 `(gdb-bptno ,bptno gdb-enabled t) putstring) - (add-text-properties - 0 1 `(gdb-bptno ,bptno gdb-enabled nil) putstring)) - (gdb-remove-breakpoint-icons start end) - (if (display-images-p) - (if (>= (or left-fringe-width - (if source-window (car (window-fringes source-window))) - gdb-buffer-fringe-width) 8) - (gdb-put-string - nil (1+ start) - `(left-fringe breakpoint - ,(if enabled - 'breakpoint-enabled - 'breakpoint-disabled)) - 'gdb-bptno bptno - 'gdb-enabled enabled) - (when (< left-margin-width 2) - (save-current-buffer - (setq left-margin-width 2) - (if source-window - (set-window-margins - source-window - left-margin-width right-margin-width)))) - (put-image - (if enabled - (or breakpoint-enabled-icon - (setq breakpoint-enabled-icon - (find-image `((:type xpm :data - ,breakpoint-xpm-data - :ascent 100 :pointer hand) - (:type pbm :data - ,breakpoint-enabled-pbm-data - :ascent 100 :pointer hand))))) - (or breakpoint-disabled-icon - (setq breakpoint-disabled-icon - (find-image `((:type xpm :data - ,breakpoint-xpm-data - :conversion disabled - :ascent 100 :pointer hand) - (:type pbm :data - ,breakpoint-disabled-pbm-data - :ascent 100 :pointer hand)))))) - (+ start 1) - putstring - 'left-margin)) - (when (< left-margin-width 2) - (save-current-buffer - (setq left-margin-width 2) - (let ((window (get-buffer-window (current-buffer) 0))) - (if window - (set-window-margins - window left-margin-width right-margin-width))))) - (gdb-put-string - (propertize putstring - 'face (if enabled 'breakpoint-enabled 'breakpoint-disabled)) - (1+ start))))) - -(defun gdb-remove-breakpoint-icons (start end &optional remove-margin) - (gdb-remove-strings start end) - (if (display-images-p) - (remove-images start end)) - (when remove-margin - (setq left-margin-width 0) - (let ((window (get-buffer-window (current-buffer) 0))) - (if window - (set-window-margins - window left-margin-width right-margin-width))))) - - -;; -;; Assembler buffer. -;; -(gdb-set-buffer-rules 'gdb-assembler-buffer - 'gdb-assembler-buffer-name - 'gdb-assembler-mode) - -;; We can't use def-gdb-auto-update-handler because we don't want to use -;; window-start but keep the overlay arrow/current line visible. -(defun gdb-assembler-handler () - (setq gdb-pending-triggers - (delq 'gdb-invalidate-assembler - gdb-pending-triggers)) - (let ((buf (gdb-get-buffer 'gdb-partial-output-buffer))) - (with-current-buffer buf - (goto-char (point-min)) - ;; The disassemble command in GDB 7.1 onwards displays an overlay arrow. - (while (re-search-forward "\\(^ 0x\\|=> 0x\\)" nil t) - (replace-match "0x" nil nil)))) - (let ((buf (gdb-get-buffer 'gdb-assembler-buffer))) - (and buf - (with-current-buffer buf - (let* ((window (get-buffer-window buf 0)) - (p (window-point window)) - (buffer-read-only nil)) - (erase-buffer) - (insert-buffer-substring (gdb-get-buffer-create - 'gdb-partial-output-buffer)) - (set-window-point window p))))) - ;; put customisation here - (gdb-assembler-custom)) - -(defun gdb-assembler-custom () - (let ((buffer (gdb-get-buffer 'gdb-assembler-buffer)) - (pos 1) (address) (flag) (bptno)) - (with-current-buffer buffer - (save-excursion - (if (not (equal gdb-pc-address "main")) - (progn - (goto-char (point-min)) - (if (and gdb-pc-address - (search-forward gdb-pc-address nil t)) - (progn - (setq pos (point)) - (beginning-of-line) - (setq fringe-indicator-alist - (if (string-equal gdb-frame-number "0") - nil - '((overlay-arrow . hollow-right-triangle)))) - (or gdb-overlay-arrow-position - (setq gdb-overlay-arrow-position (make-marker))) - (set-marker gdb-overlay-arrow-position (point)))))) - ;; remove all breakpoint-icons in assembler buffer before updating. - (gdb-remove-breakpoint-icons (point-min) (point-max)))) - (with-current-buffer (gdb-get-buffer 'gdb-breakpoints-buffer) - (goto-char (point-min)) - (while (< (point) (- (point-max) 1)) - (forward-line 1) - (when (looking-at - "\\([0-9]+\\.?[0-9]*\\).*?\\s-+\\(.\\)\\s-+0x0*\\(\\S-+\\)") - (setq bptno (match-string 1)) - (setq flag (char-after (match-beginning 2))) - (setq address (match-string 3)) - (with-current-buffer buffer - (save-excursion - (goto-char (point-min)) - (if (re-search-forward (concat "^0x0*" address) nil t) - (gdb-put-breakpoint-icon (eq flag ?y) bptno))))))) - (if (not (equal gdb-pc-address "main")) - (with-current-buffer buffer - (set-window-point (get-buffer-window buffer 0) pos))))) - -(defvar gdb-assembler-mode-map - (let ((map (make-sparse-keymap))) - (suppress-keymap map) - (define-key map "q" 'kill-this-buffer) - map)) - -(defvar gdb-assembler-font-lock-keywords - '(;; <__function.name+n> - ("<\\(\\(\\sw\\|[_.]\\)+\\)\\(\\+[0-9]+\\)?>" - (1 font-lock-function-name-face)) - ;; 0xNNNNNNNN <__function.name+n>: opcode - ("^0x[0-9a-f]+ \\(<\\(\\(\\sw\\|[_.]\\)+\\)\\+[0-9]+>\\)?:[ \t]+\\(\\sw+\\)" - (4 font-lock-keyword-face)) - ;; %register(at least i386) - ("%\\sw+" . font-lock-variable-name-face) - ("^\\(Dump of assembler code for function\\) \\(.+\\):" - (1 font-lock-comment-face) - (2 font-lock-function-name-face)) - ("^\\(End of assembler dump\\.\\)" . font-lock-comment-face)) - "Font lock keywords used in `gdb-assembler-mode'.") - -(defun gdb-assembler-mode () - "Major mode for viewing code assembler. - -\\{gdb-assembler-mode-map}" - (kill-all-local-variables) - (setq major-mode 'gdb-assembler-mode) - (setq mode-name (concat "Machine:" gdb-selected-frame)) - (setq gdb-overlay-arrow-position nil) - (add-to-list 'overlay-arrow-variable-list 'gdb-overlay-arrow-position) - (setq fringes-outside-margins t) - (setq buffer-read-only t) - (buffer-disable-undo) - (gdb-thread-identification) - (use-local-map gdb-assembler-mode-map) - (gdb-invalidate-assembler) - (set (make-local-variable 'font-lock-defaults) - '(gdb-assembler-font-lock-keywords)) - (run-mode-hooks 'gdb-assembler-mode-hook) - 'gdb-invalidate-assembler) - -(defun gdb-assembler-buffer-name () - (with-current-buffer gud-comint-buffer - (concat "*disassembly of " (gdb-get-target-string) "*"))) - -(defun gdb-display-assembler-buffer () - "Display disassembly view." - (interactive) - (setq gdb-previous-frame nil) - (gdb-display-buffer - (gdb-get-buffer-create 'gdb-assembler-buffer) t)) - -(defun gdb-frame-assembler-buffer () - "Display disassembly view in a new frame." - (interactive) - (setq gdb-previous-frame nil) - (let ((special-display-regexps (append special-display-regexps '(".*"))) - (special-display-frame-alist gdb-frame-parameters)) - (display-buffer (gdb-get-buffer-create 'gdb-assembler-buffer)))) - -;; modified because if gdb-pc-address has changed value a new command -;; must be enqueued to update the buffer with the new output -(defun gdb-invalidate-assembler (&optional ignored) - (if (gdb-get-buffer 'gdb-assembler-buffer) - (progn - (unless (and gdb-selected-frame - (string-equal gdb-selected-frame gdb-previous-frame)) - (if (or (not (member 'gdb-invalidate-assembler - gdb-pending-triggers)) - (not (equal (string-to-number gdb-pc-address) - (string-to-number - gdb-previous-frame-pc-address)))) - (progn - ;; take previous disassemble command, if any, off the queue - (with-current-buffer gud-comint-buffer - (let ((queue gdb-input-queue)) - (dolist (item queue) - (if (equal (cdr item) '(gdb-assembler-handler)) - (setq gdb-input-queue - (delete item gdb-input-queue)))))) - (gdb-enqueue-input - (list - (concat gdb-server-prefix "disassemble " gdb-pc-address "\n") - 'gdb-assembler-handler)) - (push 'gdb-invalidate-assembler gdb-pending-triggers) - (setq gdb-previous-frame-pc-address gdb-pc-address) - (setq gdb-previous-frame gdb-selected-frame))))))) - -(defun gdb-get-selected-frame () - (if (not (member 'gdb-get-selected-frame gdb-pending-triggers)) - (progn - (if (string-equal gdb-version "pre-6.4") - (gdb-enqueue-input - (list (concat gdb-server-prefix "info frame\n") - 'gdb-frame-handler)) - (gdb-enqueue-input - (list "server interpreter mi -stack-info-frame\n" - 'gdb-frame-handler-1))) - (push 'gdb-get-selected-frame gdb-pending-triggers)))) - -(defun gdb-frame-handler () - (setq gdb-pending-triggers - (delq 'gdb-get-selected-frame gdb-pending-triggers)) - (goto-char (point-min)) - (when (re-search-forward - "Stack level \\([0-9]+\\), frame at \\(0x[[:xdigit:]]+\\)" nil t) - (setq gdb-frame-number (match-string 1)) - (setq gdb-frame-address (match-string 2))) - (goto-char (point-min)) - (when (re-search-forward ".*=\\s-+\\(\\S-*\\)\\s-+in\\s-+\\(.*?\\)\ -\\(?: (\\(\\S-+?\\):[0-9]+?)\\)*; " - nil t) - (setq gdb-selected-frame (match-string 2)) - (if (gdb-get-buffer 'gdb-locals-buffer) - (with-current-buffer (gdb-get-buffer 'gdb-locals-buffer) - (setq mode-name (concat "Locals:" gdb-selected-frame)))) - (if (gdb-get-buffer 'gdb-assembler-buffer) - (with-current-buffer (gdb-get-buffer 'gdb-assembler-buffer) - (setq mode-name (concat "Machine:" gdb-selected-frame)))) - (setq gdb-pc-address (match-string 1)) - (if (and (match-string 3) gud-overlay-arrow-position) - (let ((buffer (marker-buffer gud-overlay-arrow-position)) - (position (marker-position gud-overlay-arrow-position))) - (when (and buffer - (string-equal (file-name-nondirectory - (buffer-file-name buffer)) - (file-name-nondirectory (match-string 3)))) - (with-current-buffer buffer - (setq fringe-indicator-alist - (if (string-equal gdb-frame-number "0") - nil - '((overlay-arrow . hollow-right-triangle)))) - (set-marker gud-overlay-arrow-position position)))))) - (goto-char (point-min)) - (if (re-search-forward " source language \\(\\S-+\\)\." nil t) - (setq gdb-current-language (match-string 1))) - (gdb-invalidate-assembler)) - - -;; Code specific to GDB 6.4 -(defconst gdb-source-file-regexp-1 "fullname=\"\\(.*?\\)\"") - -(defun gdb-set-gud-minor-mode-existing-buffers-1 () - "Create list of source files for current GDB session. -If buffers already exist for any of these files, `gud-minor-mode' -is set in them." - (goto-char (point-min)) - (while (re-search-forward gdb-source-file-regexp-1 nil t) - (push (match-string 1) gdb-source-file-list)) - (dolist (buffer (buffer-list)) - (with-current-buffer buffer - (when (member buffer-file-name gdb-source-file-list) - (gdb-init-buffer)))) - (gdb-force-mode-line-update - (propertize "ready" 'face font-lock-variable-name-face))) - -;; Used for -stack-info-frame but could be used for -stack-list-frames too. -(defconst gdb-stack-list-frames-regexp -".*?level=\"\\(.*?\\)\".*?,addr=\"\\(.*?\\)\".*?,func=\"\\(.*?\\)\",\ -\\(?:.*?file=\".*?\".*?,fullname=\"\\(.*?\\)\".*?,line=\"\\(.*?\\)\".*?}\\|\ -from=\"\\(.*?\\)\"\\)") - -(defun gdb-frame-handler-1 () - (setq gdb-pending-triggers - (delq 'gdb-get-selected-frame gdb-pending-triggers)) - (goto-char (point-min)) - (when (re-search-forward gdb-stack-list-frames-regexp nil t) - (setq gdb-frame-number (match-string 1)) - (setq gdb-pc-address (match-string 2)) - (setq gdb-selected-frame (match-string 3)) - (if (gdb-get-buffer 'gdb-locals-buffer) - (with-current-buffer (gdb-get-buffer 'gdb-locals-buffer) - (setq mode-name (concat "Locals:" gdb-selected-frame)))) - (if (gdb-get-buffer 'gdb-assembler-buffer) - (with-current-buffer (gdb-get-buffer 'gdb-assembler-buffer) - (setq mode-name (concat "Machine:" gdb-selected-frame))))) - (if (and (match-string 4) (match-string 5) gud-overlay-arrow-position) - (let ((buffer (marker-buffer gud-overlay-arrow-position)) - (position (marker-position gud-overlay-arrow-position))) - (when (and buffer - (string-equal (file-name-nondirectory - (buffer-file-name buffer)) - (file-name-nondirectory (match-string 4)))) - (with-current-buffer buffer - (setq fringe-indicator-alist - (if (string-equal gdb-frame-number "0") - nil - '((overlay-arrow . hollow-right-triangle)))) - (set-marker gud-overlay-arrow-position position))))) - (gdb-invalidate-assembler)) - -; Uses "-var-list-children --all-values". Needs GDB 6.4 onwards. -(defun gdb-var-list-children-1 (varnum) - (gdb-enqueue-input - (list - (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) - (concat "server interpreter mi \"-var-list-children --all-values \\\"" - varnum "\\\"\"\n") - (concat "-var-list-children --all-values \"" varnum "\"\n")) - `(lambda () (gdb-var-list-children-handler-1 ,varnum))))) - -(defun gdb-var-list-children-handler-1 (varnum) - (let* ((var-list nil) - (output (bindat-get-field (gdb-json-partial-output "child"))) - (children (bindat-get-field output 'children))) - (catch 'child-already-watched - (dolist (var gdb-var-list) - (if (string-equal varnum (car var)) - (progn - ;; With dynamic varobjs numchild may have increased. - (setcar (nthcdr 2 var) (bindat-get-field output 'numchild)) - (push var var-list) - (dolist (child children) - (let ((varchild (list (bindat-get-field child 'name) - (bindat-get-field child 'exp) - (bindat-get-field child 'numchild) - (bindat-get-field child 'type) - (bindat-get-field child 'value) - nil - (bindat-get-field child 'has_more)))) - (if (assoc (car varchild) gdb-var-list) - (throw 'child-already-watched nil)) - (push varchild var-list)))) - (push var var-list))) - (setq gdb-var-list (nreverse var-list)))) - (gdb-speedbar-update)) - -; Uses "-var-update --all-values". Needs GDB 6.4 onwards. -(defun gdb-var-update-1 () - (if (not (member 'gdb-var-update gdb-pending-triggers)) - (progn - (gdb-enqueue-input - (list - (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) - "server interpreter mi \"-var-update --all-values *\"\n" - "-var-update --all-values *\n") - 'gdb-var-update-handler-1)) - (push 'gdb-var-update gdb-pending-triggers)))) - -(defun gdb-var-update-handler-1 () - (let ((changelist (bindat-get-field (gdb-json-partial-output) 'changelist))) - (dolist (var gdb-var-list) - (setcar (nthcdr 5 var) nil)) - (let ((temp-var-list gdb-var-list)) - (dolist (change changelist) - (let* ((varnum (bindat-get-field change 'name)) - (var (assoc varnum gdb-var-list)) - (new-num (bindat-get-field change 'new_num_children))) - (when var - (let ((scope (bindat-get-field change 'in_scope)) - (has-more (bindat-get-field change 'has_more))) - (cond ((string-equal scope "false") - (if gdb-delete-out-of-scope - (gdb-var-delete-1 var varnum) - (setcar (nthcdr 5 var) 'out-of-scope))) - ((string-equal scope "true") - (setcar (nthcdr 6 var) has-more) - (when (and (or (not has-more) - (string-equal has-more "0")) - (not new-num) - (string-equal (nth 2 var) "0")) - (setcar (nthcdr 4 var) - (bindat-get-field change 'value)) - (setcar (nthcdr 5 var) 'changed))) - ((string-equal scope "invalid") - (gdb-var-delete-1 var varnum))))) - (let ((var-list nil) var1 - (children (bindat-get-field change 'new_children))) - (if new-num - (progn - (setq var1 (pop temp-var-list)) - (while var1 - (if (string-equal varnum (car var1)) - (let ((new (string-to-number new-num)) - (previous (string-to-number (nth 2 var1)))) - (setcar (nthcdr 2 var1) new-num) - (push var1 var-list) - (cond ((> new previous) - ;; Add new children to list. - (dotimes (dummy previous) - (push (pop temp-var-list) var-list)) - (dolist (child children) - (let ((varchild - (list (bindat-get-field child 'name) - (bindat-get-field child 'exp) - (bindat-get-field child 'numchild) - (bindat-get-field child 'type) - (bindat-get-field child 'value) - 'changed - (bindat-get-field child 'has_more)))) - (push varchild var-list)))) - ;; Remove deleted children from list. - ((< new previous) - (dotimes (dummy new) - (push (pop temp-var-list) var-list)) - (dotimes (dummy (- previous new)) - (pop temp-var-list))))) - (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)) - -;; Registers buffer. -;; -(gdb-set-buffer-rules 'gdb-registers-buffer - 'gdb-registers-buffer-name - 'gdb-registers-mode) - -(def-gdb-auto-update-trigger gdb-invalidate-registers-1 - (gdb-get-buffer 'gdb-registers-buffer) - (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) - "server interpreter mi \"-data-list-register-values x\"\n" - "-data-list-register-values x\n") - gdb-data-list-register-values-handler) - -(defconst gdb-data-list-register-values-regexp - "{.*?number=\"\\(.*?\\)\".*?,value=\"\\(.*?\\)\".*?}") - -(defun gdb-data-list-register-values-handler () - (setq gdb-pending-triggers (delq 'gdb-invalidate-registers-1 - gdb-pending-triggers)) - (goto-char (point-min)) - (if (re-search-forward gdb-error-regexp nil t) - (let ((err (match-string 1))) - (with-current-buffer (gdb-get-buffer 'gdb-registers-buffer) - (let ((buffer-read-only nil)) - (erase-buffer) - (put-text-property 0 (length err) 'face font-lock-warning-face err) - (insert err) - (goto-char (point-min))))) - (let ((register-list (reverse gdb-register-names)) - (register nil) (register-string nil) (register-values nil)) - (goto-char (point-min)) - (while (re-search-forward gdb-data-list-register-values-regexp nil t) - (setq register (pop register-list)) - (setq register-string (concat register "\t" (match-string 2) "\n")) - (if (member (match-string 1) gdb-changed-registers) - (put-text-property 0 (length register-string) - 'face 'font-lock-warning-face - register-string)) - (setq register-values - (concat register-values register-string))) - (let ((buf (gdb-get-buffer 'gdb-registers-buffer))) - (with-current-buffer buf - (let* ((window (get-buffer-window buf 0)) - (start (window-start window)) - (p (if window (window-point window) (point))) - (buffer-read-only nil)) - (erase-buffer) - (insert register-values) - (if window - (progn - (set-window-start window start) - (set-window-point window p)) - (goto-char p))))))) - (gdb-data-list-register-values-custom)) - -(defun gdb-data-list-register-values-custom () - (with-current-buffer (gdb-get-buffer 'gdb-registers-buffer) - (save-excursion - (let ((buffer-read-only nil) - start end) - (goto-char (point-min)) - (while (< (point) (point-max)) - (setq start (line-beginning-position)) - (setq end (line-end-position)) - (when (looking-at "^[^\t]+") - (unless (string-equal (match-string 0) "No registers.") - (put-text-property start (match-end 0) - 'face font-lock-variable-name-face) - (add-text-properties start end - '(help-echo "mouse-2: edit value" - mouse-face highlight)))) - (forward-line 1)))))) - -;; Needs GDB 6.4 onwards (used to fail with no stack). -(defun gdb-get-changed-registers () - (if (and (gdb-get-buffer 'gdb-registers-buffer) - (not (member 'gdb-get-changed-registers gdb-pending-triggers))) - (progn - (gdb-enqueue-input - (list - (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) - "server interpreter mi -data-list-changed-registers\n" - "-data-list-changed-registers\n") - 'gdb-get-changed-registers-handler)) - (push 'gdb-get-changed-registers gdb-pending-triggers)))) - -(defconst gdb-data-list-register-names-regexp "\"\\(.*?\\)\"") - -(defun gdb-get-changed-registers-handler () - (setq gdb-pending-triggers - (delq 'gdb-get-changed-registers gdb-pending-triggers)) - (setq gdb-changed-registers nil) - (goto-char (point-min)) - (while (re-search-forward gdb-data-list-register-names-regexp nil t) - (push (match-string 1) gdb-changed-registers))) - - -;; Locals buffer. -;; -;; uses "-stack-list-locals --simple-values". Needs GDB 6.1 onwards. -(gdb-set-buffer-rules 'gdb-locals-buffer - 'gdb-locals-buffer-name - 'gdb-locals-mode) - -(def-gdb-auto-update-trigger gdb-invalidate-locals-1 - (gdb-get-buffer 'gdb-locals-buffer) - (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba) - "server interpreter mi -\"stack-list-locals --simple-values\"\n" - "-stack-list-locals --simple-values\n") - gdb-stack-list-locals-handler) - -(defconst gdb-stack-list-locals-regexp - "{.*?name=\"\\(.*?\\)\".*?,type=\"\\(.*?\\)\"") - -(defvar gdb-locals-watch-map-1 - (let ((map (make-sparse-keymap))) - (suppress-keymap map) - (define-key map "\r" 'gud-watch) - (define-key map [mouse-2] 'gud-watch) - map) - "Keymap to create watch expression of a complex data type local variable.") - -(defvar gdb-edit-locals-map-1 - (let ((map (make-sparse-keymap))) - (suppress-keymap map) - (define-key map "\r" 'gdb-edit-locals-value) - (define-key map [mouse-2] 'gdb-edit-locals-value) - map) - "Keymap to edit value of a simple data type local variable.") - -(defun gdb-edit-locals-value (&optional event) - "Assign a value to a variable displayed in the locals buffer." - (interactive (list last-input-event)) - (save-excursion - (if event (posn-set-point (event-end event))) - (beginning-of-line) - (let* ((var (current-word)) - (value (read-string (format "New value (%s): " var)))) - (gdb-enqueue-input - (list (concat gdb-server-prefix "set variable " var " = " value "\n") - 'ignore))))) - -;; Dont display values of arrays or structures. -;; These can be expanded using gud-watch. -(defun gdb-stack-list-locals-handler () - (setq gdb-pending-triggers (delq 'gdb-invalidate-locals-1 - gdb-pending-triggers)) - (goto-char (point-min)) - (if (re-search-forward gdb-error-regexp nil t) - (let ((err (match-string 1))) - (with-current-buffer (gdb-get-buffer 'gdb-locals-buffer) - (let ((buffer-read-only nil)) - (erase-buffer) - (insert err) - (goto-char (point-min))))) - (let (local locals-list) - (goto-char (point-min)) - (while (re-search-forward gdb-stack-list-locals-regexp nil t) - (let ((local (list (match-string 1) - (match-string 2) - nil))) - (if (looking-at ",value=\\(\".*\"\\).*?}") - (setcar (nthcdr 2 local) (read (match-string 1)))) - (push local locals-list))) - (let ((buf (gdb-get-buffer 'gdb-locals-buffer))) - (and buf (with-current-buffer buf - (let* ((window (get-buffer-window buf 0)) - (start (window-start window)) - (p (if window (window-point window) (point))) - (buffer-read-only nil) (name) (value)) - (erase-buffer) - (dolist (local locals-list) - (setq name (car local)) - (setq value (nth 2 local)) - (if (or (not value) - (string-match "^\\0x" value)) - (add-text-properties 0 (length name) - `(mouse-face highlight - help-echo "mouse-2: create watch expression" - local-map ,gdb-locals-watch-map-1) - name) - (add-text-properties 0 (length value) - `(mouse-face highlight - help-echo "mouse-2: edit value" - local-map ,gdb-edit-locals-map-1) - value)) - (insert - (concat name "\t" (nth 1 local) - "\t" value "\n"))) - (if window - (progn - (set-window-start window start) - (set-window-point window p)) - (goto-char p))))))))) - -(defun gdb-get-register-names () - "Create a list of register names." - (goto-char (point-min)) - (while (re-search-forward gdb-data-list-register-names-regexp nil t) - (push (match-string 1) gdb-register-names))) - -(provide 'gdb-ui) - -;; arch-tag: e9fb00c5-74ef-469f-a088-37384caae352 -;;; gdb-ui.el ends here diff --git a/lisp/progmodes/grep.el b/lisp/progmodes/grep.el index de94620c737..06ab8c389d4 100644 --- a/lisp/progmodes/grep.el +++ b/lisp/progmodes/grep.el @@ -348,7 +348,11 @@ Notice that using \\[next-error] or \\[compile-goto-error] modifies ;; produces them ;; ("^\\(.+?\\)\\(:[ \t]*\\)\\([0-9]+\\)\\2\\(?:\\([0-9]+\\)\\(?:-\\([0-9]+\\)\\)?\\2\\)?" ;; 1 3 (4 . 5)) - ("^\\(\\(.+?\\):\\([0-9]+\\):\\).*?\ + ;; Note that we want to use as tight a regexp as we can to try and + ;; handle weird file names (with colons in them) as well as possible. + ;; E.g. we use [1-9][0-9]* rather than [0-9]+ so as to accept ":034:" in + ;; file names. + ("^\\(\\(.+?\\):\\([1-9][0-9]*\\):\\).*?\ \\(\033\\[01;31m\\(?:\033\\[K\\)?\\)\\(.*?\\)\\(\033\\[[0-9]*m\\)" 2 3 ;; Calculate column positions (beg . end) of first grep match on a line @@ -357,7 +361,7 @@ Notice that using \\[next-error] or \\[compile-goto-error] modifies (- (match-beginning 4) (match-end 1))) . (lambda () (- (match-end 5) (match-end 1) - (- (match-end 4) (match-beginning 4))))) + (- (match-end 4) (match-beginning 4))))) nil 1) ("^Binary file \\(.+\\) matches$" 1 nil nil 0 1)) "Regexp used to match grep hits. See `compilation-error-regexp-alist'.") @@ -781,12 +785,17 @@ substitution string. Note dynamic scoping of variables.") (file-name-nondirectory bn))) (default-alias (and fn - (let ((aliases grep-files-aliases) + (let ((aliases (remove (assoc "all" grep-files-aliases) + grep-files-aliases)) alias) (while aliases (setq alias (car aliases) aliases (cdr aliases)) - (if (string-match (wildcard-to-regexp (cdr alias)) fn) + (if (string-match (mapconcat + 'wildcard-to-regexp + (split-string (cdr alias) nil t) + "\\|") + fn) (setq aliases nil) (setq alias nil))) (cdr alias)))) diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el index bee7a062f64..8c35a13ac53 100644 --- a/lisp/progmodes/gud.el +++ b/lisp/progmodes/gud.el @@ -43,10 +43,8 @@ (require 'comint) (defvar gdb-active-process) -(defvar gdb-recording) (defvar gdb-define-alist) (defvar gdb-macro-info) -(defvar gdb-server-prefix) (defvar gdb-show-changed-values) (defvar gdb-source-window) (defvar gdb-var-list) @@ -126,77 +124,52 @@ Used to grey out relevant toolbar icons.") (throw 'info-found nil)))) nil 0) (select-frame (make-frame))) - (if (memq gud-minor-mode '(gdbmi gdba)) + (if (eq gud-minor-mode 'gdbmi) (info "(emacs)GDB Graphical Interface") (info "(emacs)Debuggers")))) (defun gud-tool-bar-item-visible-no-fringe () (not (or (eq (buffer-local-value 'major-mode (window-buffer)) 'speedbar-mode) - (and (memq gud-minor-mode '(gdbmi gdba)) + (eq (buffer-local-value 'major-mode (window-buffer)) 'gdb-memory-mode) + (and (eq gud-minor-mode 'gdbmi) (> (car (window-fringes)) 0))))) +(declare-function gdb-gud-context-command "gdb-mi.el") + (defun gud-stop-subjob () (interactive) (with-current-buffer gud-comint-buffer - (if (string-equal gud-target-name "emacs") - (comint-stop-subjob) - (if (eq gud-minor-mode 'jdb) - (gud-call "suspend") - (comint-interrupt-subjob))))) + (cond ((string-equal gud-target-name "emacs") + (comint-stop-subjob)) + ((eq gud-minor-mode 'jdb) + (gud-call "suspend")) + ((eq gud-minor-mode 'gdbmi) + (gud-call (gdb-gud-context-command "-exec-interrupt"))) + (t + (comint-interrupt-subjob))))) (easy-mmode-defmap gud-menu-map '(([help] "Info (debugger)" . gud-goto-info) - ([rfinish] menu-item "Reverse Finish Function" gud-rfinish - :enable (not gud-running) - :visible (and gdb-recording - (eq gud-minor-mode 'gdba))) - ([rstepi] menu-item "Reverse Step Instruction" gud-rstepi - :enable (not gud-running) - :visible (and gdb-recording - (eq gud-minor-mode 'gdba))) - ([rnexti] menu-item "Reverse Next Instruction" gud-rnexti - :enable (not gud-running) - :visible (and gdb-recording - (eq gud-minor-mode 'gdba))) - ([rstep] menu-item "Reverse Step Line" gud-rstep - :enable (not gud-running) - :visible (and gdb-recording - (eq gud-minor-mode 'gdba))) - ([rnext] menu-item "Reverse Next Line" gud-rnext - :enable (not gud-running) - :visible (and gdb-recording - (eq gud-minor-mode 'gdba))) - ([rcont] menu-item "Reverse Continue" gud-rcont - :enable (not gud-running) - :visible (and gdb-recording - (eq gud-minor-mode 'gdba))) - ([recstart] menu-item "Start Recording" gdb-toggle-recording-1 - :visible (and (not gdb-recording) - (eq gud-minor-mode 'gdba))) - ([recstop] menu-item "Stop Recording" gdb-toggle-recording - :visible (and gdb-recording - (eq gud-minor-mode 'gdba))) ([tooltips] menu-item "Show GUD tooltips" gud-tooltip-mode :enable (and (not emacs-basic-display) (display-graphic-p) (fboundp 'x-show-tip)) :visible (memq gud-minor-mode - '(gdbmi gdba dbx sdb xdb pdb)) + '(gdbmi dbx sdb xdb pdb)) :button (:toggle . gud-tooltip-mode)) ([refresh] "Refresh" . gud-refresh) ([run] menu-item "Run" gud-run :enable (not gud-running) :visible (memq gud-minor-mode '(gdbmi gdb dbx jdb))) ([go] menu-item (if gdb-active-process "Continue" "Run") gud-go - :visible (and (not gud-running) - (eq gud-minor-mode 'gdba))) + :visible (and (eq gud-minor-mode 'gdbmi) + (gdb-show-run-p))) ([stop] menu-item "Stop" gud-stop-subjob - :visible (or (not (memq gud-minor-mode '(gdba pdb))) - (and gud-running - (eq gud-minor-mode 'gdba)))) + :visible (or (not (memq gud-minor-mode '(gdbmi pdb))) + (gdb-show-stop-p))) ([until] menu-item "Continue to selection" gud-until :enable (not gud-running) - :visible (and (memq gud-minor-mode '(gdbmi gdba gdb perldb)) + :visible (and (memq gud-minor-mode '(gdbmi gdb perldb)) (gud-tool-bar-item-visible-no-fringe))) ([remove] menu-item "Remove Breakpoint" gud-remove :enable (not gud-running) @@ -204,50 +177,52 @@ Used to grey out relevant toolbar icons.") ([tbreak] menu-item "Temporary Breakpoint" gud-tbreak :enable (not gud-running) :visible (memq gud-minor-mode - '(gdbmi gdba gdb sdb xdb))) + '(gdbmi gdb sdb xdb))) ([break] menu-item "Set Breakpoint" gud-break :enable (not gud-running) :visible (gud-tool-bar-item-visible-no-fringe)) ([up] menu-item "Up Stack" gud-up :enable (not gud-running) :visible (memq gud-minor-mode - '(gdbmi gdba gdb dbx xdb jdb pdb))) + '(gdbmi gdb dbx xdb jdb pdb))) ([down] menu-item "Down Stack" gud-down :enable (not gud-running) :visible (memq gud-minor-mode - '(gdbmi gdba gdb dbx xdb jdb pdb))) + '(gdbmi gdb dbx xdb jdb pdb))) ([pp] menu-item "Print S-expression" gud-pp :enable (and (not gud-running) gdb-active-process) :visible (and (string-equal (buffer-local-value 'gud-target-name gud-comint-buffer) "emacs") - (eq gud-minor-mode 'gdba))) - ([print*] menu-item "Print Dereference" gud-pstar + (eq gud-minor-mode 'gdbmi))) + ([print*] menu-item (if (eq gud-minor-mode 'jdb) + "Dump object" + "Print Dereference") gud-pstar :enable (not gud-running) - :visible (memq gud-minor-mode '(gdbmi gdba gdb))) + :visible (memq gud-minor-mode '(gdbmi gdb jdb))) ([print] menu-item "Print Expression" gud-print :enable (not gud-running)) ([watch] menu-item "Watch Expression" gud-watch :enable (not gud-running) - :visible (memq gud-minor-mode '(gdbmi gdba))) + :visible (eq gud-minor-mode 'gdbmi)) ([finish] menu-item "Finish Function" gud-finish :enable (not gud-running) :visible (memq gud-minor-mode - '(gdbmi gdba gdb xdb jdb pdb))) + '(gdbmi gdb xdb jdb pdb))) ([stepi] menu-item "Step Instruction" gud-stepi :enable (not gud-running) - :visible (memq gud-minor-mode '(gdbmi gdba gdb dbx))) + :visible (memq gud-minor-mode '(gdbmi gdb dbx))) ([nexti] menu-item "Next Instruction" gud-nexti :enable (not gud-running) - :visible (memq gud-minor-mode '(gdbmi gdba gdb dbx))) + :visible (memq gud-minor-mode '(gdbmi gdb dbx))) ([step] menu-item "Step Line" gud-step :enable (not gud-running)) ([next] menu-item "Next Line" gud-next :enable (not gud-running)) ([cont] menu-item "Continue" gud-cont :enable (not gud-running) - :visible (not (eq gud-minor-mode 'gdba)))) + :visible (not (eq gud-minor-mode 'gdbmi)))) "Menu for `gud-mode'." :name "Gud") @@ -269,21 +244,22 @@ Used to grey out relevant toolbar icons.") . (,(propertize "next" 'face 'font-lock-doc-face) . gud-next)) ([menu-bar until] menu-item ,(propertize "until" 'face 'font-lock-doc-face) gud-until - :visible (memq gud-minor-mode '(gdbmi gdba gdb perldb))) + :visible (memq gud-minor-mode '(gdbmi gdb perldb))) ([menu-bar cont] menu-item ,(propertize "cont" 'face 'font-lock-doc-face) gud-cont - :visible (not (eq gud-minor-mode 'gdba))) + :visible (not (eq gud-minor-mode 'gdbmi))) ([menu-bar run] menu-item ,(propertize "run" 'face 'font-lock-doc-face) gud-run :visible (memq gud-minor-mode '(gdbmi gdb dbx jdb))) ([menu-bar go] menu-item ,(propertize " go " 'face 'font-lock-doc-face) gud-go - :visible (and (not gud-running) - (eq gud-minor-mode 'gdba))) + :visible (and (eq gud-minor-mode 'gdbmi) + (gdb-show-run-p))) ([menu-bar stop] menu-item ,(propertize "stop" 'face 'font-lock-doc-face) gud-stop-subjob - :visible (and gud-running - (eq gud-minor-mode 'gdba))) + :visible (or (and (eq gud-minor-mode 'gdbmi) + (gdb-show-stop-p)) + (not (eq gud-minor-mode 'gdbmi)))) ([menu-bar print] . (,(propertize "print" 'face 'font-lock-doc-face) . gud-print)) ([menu-bar tools] . undefined) @@ -322,14 +298,6 @@ Used to grey out relevant toolbar icons.") (gud-stepi . "gud/stepi") (gud-up . "gud/up") (gud-down . "gud/down") - (gdb-toggle-recording-1 . "gud/recstart") - (gdb-toggle-recording . "gud/recstop") - (gud-rcont . "gud/rcont") - (gud-rnext . "gud/rnext") - (gud-rstep . "gud/rstep") - (gud-rfinish . "gud/rfinish") - (gud-rnexti . "gud/rnexti") - (gud-rstepi . "gud/rstepi") (gud-goto-info . "info")) map) (tool-bar-local-item-from-menu @@ -354,7 +322,7 @@ Uses `gud-<MINOR-MODE>-directories' to find the source files." (setq directories (cdr directories))) result))) -(declare-function gdb-create-define-alist "gdb-ui" ()) +(declare-function gdb-create-define-alist "gdb-mi" ()) (defun gud-find-file (file) ;; Don't get confused by double slashes in the name that comes from GDB. @@ -370,7 +338,7 @@ Uses `gud-<MINOR-MODE>-directories' to find the source files." (set (make-local-variable 'gud-minor-mode) minor-mode) (set (make-local-variable 'tool-bar-map) gud-tool-bar-map) (when (and gud-tooltip-mode - (memq gud-minor-mode '(gdbmi gdba))) + (eq gud-minor-mode 'gdbmi)) (make-local-variable 'gdb-define-alist) (unless gdb-define-alist (gdb-create-define-alist)) (add-hook 'after-save-hook 'gdb-create-define-alist nil t)) @@ -499,21 +467,21 @@ The value t means that there is no stack, and we are in display-file mode.") (defvar gud-speedbar-menu-items '(["Jump to stack frame" speedbar-edit-line - :visible (not (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer) - '(gdbmi gdba)))] + :visible (not (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) + 'gdbmi))] ["Edit value" speedbar-edit-line - :visible (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer) - '(gdbmi gdba))] + :visible (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) + 'gdbmi)] ["Delete expression" gdb-var-delete - :visible (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer) - '(gdbmi gdba))] + :visible (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) + 'gdbmi)] ["Auto raise frame" gdb-speedbar-auto-raise :style toggle :selected gdb-speedbar-auto-raise - :visible (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer) - '(gdbmi gdba))] + :visible (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) + 'gdbmi)] ("Output Format" - :visible (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer) - '(gdbmi gdba)) + :visible (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) + 'gdbmi) ["Binary" (gdb-var-set-format "binary") t] ["Natural" (gdb-var-set-format "natural") t] ["Hexadecimal" (gdb-var-set-format "hexadecimal") t])) @@ -542,7 +510,7 @@ required by the caller." (start (window-start window)) (p (window-point window))) (cond - ((memq minor-mode '(gdbmi gdba)) + ((eq minor-mode 'gdbmi) (erase-buffer) (insert "Watch Expressions:\n") (let ((var-list gdb-var-list) parent) @@ -632,7 +600,7 @@ required by the caller." (car frame) 'speedbar-file-face 'speedbar-highlight-face - (cond ((memq minor-mode '(gdbmi gdba gdb)) + (cond ((memq minor-mode '(gdbmi gdb)) 'gud-gdb-goto-stackframe) (t (error "Should never be here"))) frame t)))) @@ -689,8 +657,6 @@ The option \"--fullname\" must be included in this value." ;; Set the accumulator to the remaining text. gud-marker-acc (substring gud-marker-acc (match-end 0)))) - ;; Check for annotations and change gud-minor-mode to 'gdba if - ;; they are found. (while (string-match "\n\032\032\\(.*\\)\n" gud-marker-acc) (let ((match (match-string 1 gud-marker-acc))) @@ -754,10 +720,10 @@ The option \"--fullname\" must be included in this value." (defvar gud-filter-pending-text nil "Non-nil means this is text that has been saved for later in `gud-filter'.") -;; If in gdba mode, gdb-ui is loaded. -(declare-function gdb-restore-windows "gdb-ui" ()) +;; If in gdb mode, gdb-mi is loaded. +(declare-function gdb-restore-windows "gdb-mi" ()) -;; The old gdb command (text command mode). The new one is in gdb-ui.el. +;; The old gdb command (text command mode). The new one is in gdb-mi.el. ;;;###autoload (defun gud-gdb (command-line) "Run gdb on program FILE in buffer *gud-FILE*. @@ -768,10 +734,10 @@ directory and source-file directory for your debugger." (when (and gud-comint-buffer (buffer-name gud-comint-buffer) (get-buffer-process gud-comint-buffer) - (with-current-buffer gud-comint-buffer (eq gud-minor-mode 'gdba))) - (gdb-restore-windows) - (error - "Multiple debugging requires restarting in text command mode")) + (with-current-buffer gud-comint-buffer (eq gud-minor-mode 'gdbmi))) + (gdb-restore-windows) + (error + "Multiple debugging requires restarting in text command mode")) (gud-common-init command-line nil 'gud-gdb-marker-filter) (set (make-local-variable 'gud-minor-mode) 'gdb) @@ -2547,7 +2513,7 @@ comint mode, which see." (setq w (cdr w))) (if w (setcar w - (if (file-remote-p default-directory) + (if (file-remote-p file) ;; Tramp has already been loaded if we are here. (setq file (tramp-file-name-localname (tramp-dissect-file-name file))) @@ -2642,7 +2608,7 @@ It is saved for when this flag is not set.") (defvar gud-overlay-arrow-position nil) (add-to-list 'overlay-arrow-variable-list 'gud-overlay-arrow-position) -(declare-function gdb-reset "gdb-ui" ()) +(declare-function gdb-reset "gdb-mi" ()) (defun gud-sentinel (proc msg) (cond ((null (buffer-name (process-buffer proc))) @@ -2654,14 +2620,14 @@ It is saved for when this flag is not set.") (string-equal speedbar-initial-expansion-list-name "GUD")) (speedbar-change-initial-expansion-list speedbar-previously-used-expansion-list-name)) - (if (memq gud-minor-mode-type '(gdbmi gdba)) + (if (eq gud-minor-mode-type 'gdbmi) (gdb-reset) (gud-reset))) ((memq (process-status proc) '(signal exit)) ;; Stop displaying an arrow in a source file. (setq gud-overlay-arrow-position nil) - (if (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer) - '(gdba gdbmi)) + (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) + 'gdbmi) (gdb-reset) (gud-reset)) (let* ((obuf (current-buffer))) @@ -2692,7 +2658,9 @@ It is saved for when this flag is not set.") (defun gud-kill-buffer-hook () (setq gud-minor-mode-type gud-minor-mode) (condition-case nil - (kill-process (get-buffer-process (current-buffer))) + (progn + (kill-process (get-buffer-process (current-buffer))) + (delete-process (get-process "gdb-inferior"))) (error nil))) (defun gud-reset () @@ -2715,8 +2683,8 @@ Obeying it means displaying in another window the specified file and line." (declare-function global-hl-line-highlight "hl-line" ()) (declare-function hl-line-highlight "hl-line" ()) -(declare-function gdb-display-source-buffer "gdb-ui" (buffer)) -(declare-function gdb-display-buffer "gdb-ui" (buf dedicated &optional size)) +(declare-function gdb-display-source-buffer "gdb-mi" (buffer)) +(declare-function gdb-display-buffer "gdb-mi" (buf dedicated &optional size)) ;; Make sure the file named TRUE-FILE is in a buffer that appears on the screen ;; and that its line LINE is visible. @@ -2732,7 +2700,7 @@ Obeying it means displaying in another window the specified file and line." (gud-find-file true-file))) (window (and buffer (or (get-buffer-window buffer) - (if (memq gud-minor-mode '(gdbmi gdba)) + (if (eq gud-minor-mode 'gdbmi) (or (if (get-buffer-window buffer 'visible) (display-buffer buffer nil 'visible)) (unless (gdb-display-source-buffer buffer) @@ -2769,7 +2737,7 @@ Obeying it means displaying in another window the specified file and line." (goto-char pos)))) (when window (set-window-point window gud-overlay-arrow-position) - (if (memq gud-minor-mode '(gdbmi gdba)) + (if (eq gud-minor-mode 'gdbmi) (setq gdb-source-window window))))))) ;; The gud-call function must do the right thing whether its invoking @@ -2875,7 +2843,7 @@ Obeying it means displaying in another window the specified file and line." (forward-line 0)) (if (looking-at comint-prompt-regexp) (set-marker gud-delete-prompt-marker (point))) - (if (memq gud-minor-mode '(gdbmi gdba)) + (if (eq gud-minor-mode 'gdbmi) (apply comint-input-sender (list proc command)) (process-send-string proc (concat command "\n")))))))) @@ -3155,10 +3123,12 @@ class of the file (using s to separate nested class ids)." ("\\$\\(\\w+\\)" (1 font-lock-variable-name-face)) ("^\\s-*\\(\\w\\(\\w\\|\\s_\\)*\\)" (1 font-lock-keyword-face)))) -(defvar gdb-script-font-lock-syntactic-keywords - '(("^document\\s-.*\\(\n\\)" (1 "< b")) - ("^end\\>" - (0 (unless (eq (match-beginning 0) (point-min)) +(defconst gdb-script-syntax-propertize-function + (syntax-propertize-rules + ("^document\\s-.*\\(\n\\)" (1 "< b")) + ("^end\\(\\>\\)" + (1 (ignore + (unless (eq (match-beginning 0) (point-min)) ;; We change the \n in front, which is more difficult, but results ;; in better highlighting. If the doc is empty, the single \n is ;; both the beginning and the end of the docstring, which can't be @@ -3170,10 +3140,9 @@ class of the file (using s to separate nested class ids)." 'syntax-table (eval-when-compile (string-to-syntax "> b"))) ;; Make sure that rehighlighting the previous line won't erase our - ;; syntax-table property. + ;; syntax-table property and that modifying `end' will. (put-text-property (1- (match-beginning 0)) (match-end 0) - 'font-lock-multiline t) - nil))))) + 'syntax-multiline t))))))) (defun gdb-script-font-lock-syntactic-face (state) (cond @@ -3249,13 +3218,6 @@ Treats actions as defuns." (goto-char (point-max))) t) -;; Besides .gdbinit, gdb documents other names to be usable for init -;; files, cross-debuggers can use something like -;; .PROCESSORNAME-gdbinit so that the host and target gdbinit files -;; don't interfere with each other. -;;;###autoload -(add-to-list 'auto-mode-alist (cons (purecopy "/\\.[a-z0-9-]*gdbinit") 'gdb-script-mode)) - ;;;###autoload (define-derived-mode gdb-script-mode nil "GDB-Script" "Major mode for editing GDB scripts." @@ -3271,10 +3233,13 @@ Treats actions as defuns." #'gdb-script-end-of-defun) (set (make-local-variable 'font-lock-defaults) '(gdb-script-font-lock-keywords nil nil ((?_ . "w")) nil - (font-lock-syntactic-keywords - . gdb-script-font-lock-syntactic-keywords) (font-lock-syntactic-face-function - . gdb-script-font-lock-syntactic-face)))) + . gdb-script-font-lock-syntactic-face))) + ;; Recognize docstrings. + (set (make-local-variable 'syntax-propertize-function) + gdb-script-syntax-propertize-function) + (add-hook 'syntax-propertize-extend-region-functions + #'syntax-propertize-multiline 'append 'local)) ;;; tooltips for GUD @@ -3301,14 +3266,14 @@ Treats actions as defuns." (gud-tooltip-activate-mouse-motions-if-enabled) (if (and gud-comint-buffer (buffer-name gud-comint-buffer); gud-comint-buffer might be killed - (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer) - '(gdbmi gdba))) + (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) + 'gdbmi)) (if gud-tooltip-mode (progn (dolist (buffer (buffer-list)) (unless (eq buffer gud-comint-buffer) (with-current-buffer buffer - (when (and (memq gud-minor-mode '(gdbmi gdba)) + (when (and (eq gud-minor-mode 'gdbmi) (not (string-match "\\`\\*.+\\*\\'" (buffer-name)))) (make-local-variable 'gdb-define-alist) @@ -3433,8 +3398,8 @@ With arg, dereference expr if ARG is positive, otherwise do not derereference." ; Larger arrays (say 400 elements) are displayed in ; the tooltip incompletely and spill over into the gud buffer. ; Switching the process-filter creates timing problems and -; it may be difficult to do better. Using annotations as in -; gdb-ui.el gets round this problem. +; it may be difficult to do better. Using GDB/MI as in +; gdb-mi.el gets round this problem. (defun gud-tooltip-process-output (process output) "Process debugger output and show it in a tooltip window." (set-process-filter process gud-tooltip-original-filter) @@ -3444,12 +3409,12 @@ With arg, dereference expr if ARG is positive, otherwise do not derereference." (defun gud-tooltip-print-command (expr) "Return a suitable command to print the expression EXPR." (case gud-minor-mode - (gdba (concat "server print " expr)) - ((dbx gdbmi) (concat "print " expr)) + (gdbmi (concat "-data-evaluate-expression " expr)) + (dbx (concat "print " expr)) ((xdb pdb) (concat "p " expr)) (sdb (concat expr "/")))) -(declare-function gdb-enqueue-input "gdb-ui" (item)) +(declare-function gdb-input "gdb-mi" (item)) (declare-function tooltip-expr-to-print "tooltip" (event)) (declare-function tooltip-event-buffer "tooltip" (event)) @@ -3469,12 +3434,12 @@ This function must return nil if it doesn't handle EVENT." (buffer-name gud-comint-buffer); might be killed (setq process (get-buffer-process gud-comint-buffer)) (posn-point (event-end event)) - (or (and (eq gud-minor-mode 'gdba) (not gdb-active-process)) + (or (and (eq gud-minor-mode 'gdbmi) (not gdb-active-process)) (progn (setq gud-tooltip-event event) (eval (cons 'and gud-tooltip-display))))) (let ((expr (tooltip-expr-to-print event))) (when expr - (if (and (eq gud-minor-mode 'gdba) + (if (and (eq gud-minor-mode 'gdbmi) (not gdb-active-process)) (progn (with-current-buffer (tooltip-event-buffer event) @@ -3492,13 +3457,13 @@ This function must return nil if it doesn't handle EVENT." (message-box "Using GUD tooltips in this mode is unsafe\n\ so they have been disabled.")) (unless (null cmd) ; CMD can be nil if unknown debugger - (if (memq gud-minor-mode '(gdba gdbmi)) + (if (eq gud-minor-mode 'gdbmi) (if gdb-macro-info - (gdb-enqueue-input + (gdb-input (list (concat - gdb-server-prefix "macro expand " expr "\n") + "server macro expand " expr "\n") `(lambda () (gdb-tooltip-print-1 ,expr)))) - (gdb-enqueue-input + (gdb-input (list (concat cmd "\n") `(lambda () (gdb-tooltip-print ,expr))))) (setq gud-tooltip-original-filter (process-filter process)) diff --git a/lisp/progmodes/hideif.el b/lisp/progmodes/hideif.el index 04ec915f3d3..b21cd9c89ef 100644 --- a/lisp/progmodes/hideif.el +++ b/lisp/progmodes/hideif.el @@ -760,7 +760,7 @@ Point is left unchanged." (cond ((hif-looking-at-else) (setq else (point))) (t - (setq end (point)))) ; (save-excursion (end-of-line) (point)) + (setq end (point)))) ; (line-end-position) ;; If found #else, look for #endif. (when else (while (progn @@ -769,7 +769,7 @@ Point is left unchanged." (hif-ifdef-to-endif)) (if (hif-looking-at-else) (error "Found two elses in a row? Broken!")) - (setq end (point))) ; (save-excursion (end-of-line) (point)) + (setq end (point))) ; (line-end-position) (hif-make-range start end else)))) @@ -1025,5 +1025,4 @@ Return as (TOP . BOTTOM) the extent of ifdef block." (provide 'hideif) -;; arch-tag: c6381d17-a59a-483a-b945-658f22277981 ;;; hideif.el ends here diff --git a/lisp/progmodes/icon.el b/lisp/progmodes/icon.el index 9182b319b57..f0287c90188 100644 --- a/lisp/progmodes/icon.el +++ b/lisp/progmodes/icon.el @@ -1,7 +1,7 @@ ;;; icon.el --- mode for editing Icon code -;; Copyright (C) 1989, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. +;; Copyright (C) 1989, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, +;; 2009, 2010 Free Software Foundation, Inc. ;; Author: Chris Smith <csmith@convex.com> ;; Created: 15 Feb 89 @@ -601,7 +601,7 @@ Returns nil if line starts inside a string, t if in a comment." (indent-to this-indent))) ;; Indent any comment following the text. (or (looking-at comment-start-skip) - (if (re-search-forward comment-start-skip (save-excursion (end-of-line) (point)) t) + (if (re-search-forward comment-start-skip (line-end-position) t) (progn (indent-for-comment) (beginning-of-line)))))))))) (defconst icon-font-lock-keywords-1 @@ -687,5 +687,4 @@ Returns nil if line starts inside a string, t if in a comment." (provide 'icon) -;; arch-tag: 8abf8c99-e7df-44af-a58f-ef5ed2ee52cb ;;; icon.el ends here diff --git a/lisp/progmodes/idlw-complete-structtag.el b/lisp/progmodes/idlw-complete-structtag.el index 696853e0929..56b41541ee3 100644 --- a/lisp/progmodes/idlw-complete-structtag.el +++ b/lisp/progmodes/idlw-complete-structtag.el @@ -1,12 +1,13 @@ ;;; idlw-complete-structtag.el --- Completion of structure tags. -;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. +;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, +;; 2010 Free Software Foundation, Inc. ;; Author: Carsten Dominik <dominik@astro.uva.nl> ;; Maintainer: J.D. Smith <jdsmith@as.arizona.edu> ;; Version: 1.2 ;; Keywords: languages +;; Package: idlwave ;; This file is part of GNU Emacs. @@ -224,9 +225,8 @@ an up-to-date completion list." ;; Fake help in the source buffer for structure tags. -;; kwd and name are global-variables here. -(defvar name) -(defvar kwd) +;; idlw-help-kwd is a global-variable (from idlwave-do-mouse-completion-help). +(defvar idlw-help-kwd) (defvar idlwave-help-do-struct-tag) (defun idlwave-complete-structure-tag-help (mode word) (cond @@ -235,13 +235,10 @@ an up-to-date completion list." (not (equal idlwave-current-tags-buffer (get-buffer (idlwave-shell-buffer))))) ((eq mode 'set) - (setq kwd word + (setq idlw-help-kwd word idlwave-help-do-struct-tag idlwave-structtag-struct-location)) (t (error "This should not happen")))) (provide 'idlw-complete-structtag) ;;; idlw-complete-structtag.el ends here - - -;; arch-tag: d1f9e55c-e504-4187-9c31-3c3651fa4bfa diff --git a/lisp/progmodes/idlw-help.el b/lisp/progmodes/idlw-help.el index f6eff9c3cff..d7c14ccd4a8 100644 --- a/lisp/progmodes/idlw-help.el +++ b/lisp/progmodes/idlw-help.el @@ -1,12 +1,13 @@ ;;; idlw-help.el --- HTML Help code for IDLWAVE -;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. +;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, +;; 2009, 2010 Free Software Foundation, Inc. ;; ;; Authors: J.D. Smith <jdsmith@as.arizona.edu> ;; Carsten Dominik <dominik@science.uva.nl> ;; Maintainer: J.D. Smith <jdsmith@as.arizona.edu> -;; Version: 6.1_em22 +;; Version: 6.1.22 +;; Package: idlwave ;; This file is part of GNU Emacs. @@ -575,13 +576,13 @@ Needs additional info stored in global `idlwave-completion-help-info'." (let* ((cw (selected-window)) (info idlwave-completion-help-info) ; global passed in (what (nth 0 info)) - (name (nth 1 info)) + (idlw-help-name (nth 1 info)) (type (nth 2 info)) (class (nth 3 info)) (need-class class) - (kwd (nth 4 info)) + (idlw-help-kwd (nth 4 info)) (sclasses (nth 5 info)) - word link) + word idlw-help-link) (mouse-set-point ev) @@ -589,18 +590,18 @@ Needs additional info stored in global `idlwave-completion-help-info'." (setq word (idlwave-this-word)) (if (string= word "") (error "No help item selected")) - (setq link (get-text-property 0 'link word)) + (setq idlw-help-link (get-text-property 0 'link word)) (select-window cw) (cond ;; Routine name ((memq what '(procedure function routine)) - (setq name word) + (setq idlw-help-name word) (if (or (eq class t) (and (stringp class) sclasses)) (let* ((classes (idlwave-all-method-classes - (idlwave-sintern-method name) + (idlwave-sintern-method idlw-help-name) type))) - (setq link t) ; No specific link valid yet + (setq idlw-help-link t) ; No specific link valid yet (if sclasses (setq classes (idlwave-members-only classes (cons class sclasses)))) @@ -610,19 +611,19 @@ Needs additional info stored in global `idlwave-completion-help-info'." ;; XXX is this necessary, given all-method-classes? (if (stringp class) (setq class (idlwave-find-inherited-class - (idlwave-sintern-routine-or-method name class) + (idlwave-sintern-routine-or-method idlw-help-name class) type (idlwave-sintern-class class))))) ;; Keyword ((eq what 'keyword) - (setq kwd word) + (setq idlw-help-kwd word) (if (or (eq class t) (and (stringp class) sclasses)) (let ((classes (idlwave-all-method-keyword-classes - (idlwave-sintern-method name) - (idlwave-sintern-keyword kwd) + (idlwave-sintern-method idlw-help-name) + (idlwave-sintern-keyword idlw-help-kwd) type))) - (setq link t) ; Link can't be correct yet + (setq idlw-help-link t) ; Link can't be correct yet (if sclasses (setq classes (idlwave-members-only classes (cons class sclasses)))) @@ -631,11 +632,12 @@ Needs additional info stored in global `idlwave-completion-help-info'." ;; XXX is this necessary, given all-method-keyword-classes? (if (stringp class) (setq class (idlwave-find-inherited-class - (idlwave-sintern-routine-or-method name class) + (idlwave-sintern-routine-or-method + idlw-help-name class) type (idlwave-sintern-class class))))) - (if (string= (downcase name) "obj_new") + (if (string= (downcase idlw-help-name) "obj_new") (setq class idlwave-current-obj_new-class - name "Init")))) + idlw-help-name "Init")))) ;; Class name ((eq what 'class) @@ -648,9 +650,11 @@ Needs additional info stored in global `idlwave-completion-help-info'." (funcall what 'set word)) (t (error "Cannot help with this item"))) - (if (and need-class (not class) (not (and link (not (eq link t))))) + (if (and need-class (not class) + (not (and idlw-help-link (not (eq idlw-help-link t))))) (error "Cannot help with this item")) - (idlwave-online-help link (or name word) type class kwd))) + (idlwave-online-help idlw-help-link (or idlw-help-name word) + type class idlw-help-kwd))) (defvar idlwave-highlight-help-links-in-completion) (defvar idlwave-completion-help-links) @@ -1382,5 +1386,4 @@ IDL assistant.") (provide 'idlw-help) (provide 'idlwave-help) -;; arch-tag: d27b5505-59de-497f-ba3f-f199fd4fb911 ;;; idlw-help.el ends here diff --git a/lisp/progmodes/idlw-shell.el b/lisp/progmodes/idlw-shell.el index dbe6f179e5b..02eb0324cd8 100644 --- a/lisp/progmodes/idlw-shell.el +++ b/lisp/progmodes/idlw-shell.el @@ -7,8 +7,9 @@ ;; Carsten Dominik <dominik@astro.uva.nl> ;; Chris Chase <chase@att.com> ;; Maintainer: J.D. Smith <jdsmith@as.arizona.edu> -;; Version: 6.1_em22 +;; Version: 6.1.22 ;; Keywords: processes +;; Package: idlwave ;; This file is part of GNU Emacs. @@ -1457,7 +1458,7 @@ Otherwise just move the line. Move down unless UP is non-nil." (arg (if up arg (- arg)))) (if (eq t idlwave-shell-arrows-do-history) (goto-char proc-pos)) (if (and idlwave-shell-arrows-do-history - (>= (1+ (save-excursion (end-of-line) (point))) proc-pos)) + (>= (1+ (point-at-eol)) proc-pos)) (comint-previous-input arg) (forward-line (- arg))))) @@ -2179,8 +2180,8 @@ keywords." ;; Default completion of modules and keywords (idlwave-complete arg))))) -;; Get rid of opaque dynamic variable passing of link? -(defvar link) ;dynamic variable +;; Get rid of opaque dynamic variable passing of idlw-help-link? +(defvar idlw-help-link) ; dynamic variable from idlwave-do-mouse-completion-help (defun idlwave-shell-complete-execcomm-help (mode word) (let ((word (or (nth 1 idlwave-completion-help-info) word)) (entry (assoc-string word idlwave-executive-commands-alist t))) @@ -2188,7 +2189,7 @@ keywords." ((eq mode 'test) (and (stringp word) entry (cdr entry))) ((eq mode 'set) - (if entry (setq link (cdr entry)))) ;; setting dynamic variable!!! + (if entry (setq idlw-help-link (cdr entry)))) ; setting dynamic variable! (t (error "This should not happen"))))) (defun idlwave-shell-complete-filename (&optional arg) @@ -2210,7 +2211,7 @@ args of an executive .run, .rnew or .compile." (defun idlwave-shell-filename-string () "Return t if in a string and after what could be a file name." - (let ((limit (save-excursion (beginning-of-line) (point)))) + (let ((limit (point-at-bol))) (save-excursion ;; Skip backwards over file name chars (skip-chars-backward idlwave-shell-file-name-chars limit) @@ -2219,7 +2220,7 @@ args of an executive .run, .rnew or .compile." (defun idlwave-shell-batch-command () "Return t if we're in a batch command statement like @foo" - (let ((limit (save-excursion (beginning-of-line) (point)))) + (let ((limit (point-at-bol))) (save-excursion ;; Skip backwards over filename (skip-chars-backward idlwave-shell-file-name-chars limit) @@ -2397,7 +2398,7 @@ matter what the settings of that variable." idlwave-shell-electric-stop-line-face idlwave-shell-stop-line-face)) (move-overlay idlwave-shell-stop-line-overlay - (point) (save-excursion (end-of-line) (point)) + (point) (point-at-eol) (current-buffer))) ;; use the arrow instead, but only if marking is wanted. (if idlwave-shell-mark-stop-line @@ -2590,9 +2591,7 @@ If in the IDL shell buffer, returns `idlwave-shell-pc-frame'." (list (idlwave-shell-file-name (buffer-file-name)) (save-restriction (widen) - (save-excursion - (beginning-of-line) - (1+ (count-lines 1 (point)))))))) + (1+ (count-lines 1 (point-at-bol))))))) (defun idlwave-shell-current-module () "Return the name of the module for the current file. @@ -3644,7 +3643,7 @@ Existing overlays are recycled, in order to minimize consumption." (while (setq bp (pop bp-list)) (save-excursion (idlwave-shell-goto-frame (car bp)) - (let* ((end (progn (end-of-line 1) (point))) + (let* ((end (point-at-eol)) (beg (progn (beginning-of-line 1) (point))) (condition (idlwave-shell-bp-get bp 'condition)) (count (idlwave-shell-bp-get bp 'count)) @@ -3998,8 +3997,7 @@ of the form: (append ;; compiled procedures (progn - (beginning-of-line) - (narrow-to-region cpro (point)) + (narrow-to-region cpro (point-at-bol)) (goto-char (point-min)) (idlwave-shell-sources-grep)) ;; compiled functions @@ -4692,5 +4690,4 @@ static char * file[] = { (if idlwave-shell-use-toolbar (add-hook 'idlwave-shell-mode-hook 'idlwave-toolbar-add-everywhere)) -;; arch-tag: 20c2e8ce-0709-41d8-a5b6-bb039148440a ;;; idlw-shell.el ends here diff --git a/lisp/progmodes/idlw-toolbar.el b/lisp/progmodes/idlw-toolbar.el index 395cfd54045..474065451d7 100644 --- a/lisp/progmodes/idlw-toolbar.el +++ b/lisp/progmodes/idlw-toolbar.el @@ -5,8 +5,9 @@ ;; Author: Carsten Dominik <dominik@astro.uva.nl> ;; Maintainer: J.D. Smith <jdsmith@as.arizona.edu> -;; Version: 6.1_em22 +;; Version: 6.1.22 ;; Keywords: processes +;; Package: idlwave ;; This file is part of GNU Emacs. diff --git a/lisp/progmodes/idlwave.el b/lisp/progmodes/idlwave.el index b2858f1479d..e05ea855636 100644 --- a/lisp/progmodes/idlwave.el +++ b/lisp/progmodes/idlwave.el @@ -7,7 +7,7 @@ ;; Carsten Dominik <dominik@science.uva.nl> ;; Chris Chase <chase@att.com> ;; Maintainer: J.D. Smith <jdsmith@as.arizona.edu> -;; Version: 6.1_em22 +;; Version: 6.1.22 ;; Keywords: languages ;; This file is part of GNU Emacs. @@ -1370,6 +1370,7 @@ list order matters since matching an assignment statement exactly is not possible without parsing. Thus assignment statement become just the leftover unidentified statements containing an equal sign.") +;; FIXME: This var seems to only ever be set, but never actually used! (defvar idlwave-fill-function 'auto-fill-function "IDL mode auto fill function.") @@ -2096,7 +2097,7 @@ Returns non-nil if abbrev is left expanded." Moves to end of line if there is no comment delimiter. Ignores comment delimiters in strings. Returns point if comment found and nil otherwise." - (let ((eos (progn (end-of-line) (point))) + (let ((eos (point-at-eol)) (data (match-data)) found) ;; Look for first comment delimiter not in a string @@ -2151,7 +2152,7 @@ Also checks if the correct END statement has been used." ;;(backward-char 1) (let* ((pos (point-marker)) (last-abbrev-marker (copy-marker last-abbrev-location)) - (eol-pos (save-excursion (end-of-line) (point))) + (eol-pos (point-at-eol)) begin-pos end-pos end end1 ) (if idlwave-reindent-end (idlwave-indent-line)) (setq last-abbrev-location (marker-position last-abbrev-marker)) @@ -3300,10 +3301,8 @@ ignored." (setq here (point)) (beginning-of-line) (setq bcl (point)) - (re-search-forward - (concat "^[ \t]*" comment-start "+") - (save-excursion (end-of-line) (point)) - t) + (re-search-forward (concat "^[ \t]*" comment-start "+") + (point-at-eol) t) ;; Get the comment leader on the line and its length (setq pre (current-column)) ;; the comment leader is the indentation plus exactly the @@ -3311,10 +3310,7 @@ ignored." (setq fill-prefix-reg (concat (setq fill-prefix - (regexp-quote - (buffer-substring (save-excursion - (beginning-of-line) (point)) - (point)))) + (regexp-quote (buffer-substring (point-at-bol) (point)))) "[^;]")) ;; Mark the beginning and end of the paragraph @@ -3368,9 +3364,7 @@ ignored." (setq indent hang) (beginning-of-line) (while (> (point) start) - (re-search-forward comment-start-skip - (save-excursion (end-of-line) (point)) - t) + (re-search-forward comment-start-skip (point-at-eol) t) (if (> (setq diff (- indent (current-column))) 0) (progn (if (>= here (point)) @@ -3392,13 +3386,9 @@ ignored." (setq indent (min indent (progn - (re-search-forward - comment-start-skip - (save-excursion (end-of-line) (point)) - t) + (re-search-forward comment-start-skip (point-at-eol) t) (current-column)))) - (forward-line -1)) - ) + (forward-line -1))) (setq fill-prefix (concat fill-prefix (make-string (- indent pre) ?\ ))) @@ -3406,10 +3396,7 @@ ignored." (setq first-indent (max (progn - (re-search-forward - comment-start-skip - (save-excursion (end-of-line) (point)) - t) + (re-search-forward comment-start-skip (point-at-eol) t) (current-column)) indent)) @@ -3447,17 +3434,11 @@ If not found returns nil." (if idlwave-use-last-hang-indent (save-excursion (end-of-line) - (if (re-search-backward - idlwave-hang-indent-regexp - (save-excursion (beginning-of-line) (point)) - t) + (if (re-search-backward idlwave-hang-indent-regexp (point-at-bol) t) (+ (current-column) (length idlwave-hang-indent-regexp)))) (save-excursion (beginning-of-line) - (if (re-search-forward - idlwave-hang-indent-regexp - (save-excursion (end-of-line) (point)) - t) + (if (re-search-forward idlwave-hang-indent-regexp (point-at-eol) t) (current-column))))) (defun idlwave-auto-fill () @@ -3501,18 +3482,14 @@ if `idlwave-auto-fill-split-string' is non-nil." (save-excursion (forward-line -1) (idlwave-calc-hanging-indent)))) - (if indent - (progn - ;; Remove whitespace between comment delimiter and - ;; text, insert spaces for appropriate indentation. - (beginning-of-line) - (re-search-forward - comment-start-skip - (save-excursion (end-of-line) (point)) t) - (delete-horizontal-space) - (idlwave-indent-to indent) - (goto-char (- (point-max) here))) - ))) + (when indent + ;; Remove whitespace between comment delimiter and + ;; text, insert spaces for appropriate indentation. + (beginning-of-line) + (re-search-forward comment-start-skip (point-at-eol) t) + (delete-horizontal-space) + (idlwave-indent-to indent) + (goto-char (- (point-max) here))))) ;; Split code or comment? (if (save-excursion (end-of-line 0) @@ -3688,7 +3665,7 @@ constants - a double quote followed by an octal digit." ;; Because single and double quotes can quote each other we must ;; search for the string start from the beginning of line. (let* ((start (point)) - (eol (progn (end-of-line) (point))) + (eol (point-at-eol)) (bq (progn (beginning-of-line) (point))) (endq (point)) (data (match-data)) @@ -3766,7 +3743,7 @@ unless the optional second argument NOINDENT is non-nil." (setq s1 (downcase s1) s2 (downcase s2))) (idlwave-abbrev-change-case (setq s1 (upcase s1) s2 (upcase s2)))) - (let ((beg (save-excursion (beginning-of-line) (point))) + (let ((beg (point-at-bol)) end) (if (not (looking-at "\\s-*\n")) (open-line 1)) @@ -6910,9 +6887,10 @@ accumulate information on matching completions." ;;---------------------------------------------------------------------- ;;---------------------------------------------------------------------- ;;---------------------------------------------------------------------- -(defvar rtn) -(defun idlwave-pset (item) - (set 'rtn item)) +(when (featurep 'xemacs) + (defvar rtn) + (defun idlwave-pset (item) + (set 'rtn item))) (defun idlwave-popup-select (ev list title &optional sort) "Select an item in LIST with a popup menu. @@ -7681,8 +7659,7 @@ property indicating the link is added." t)) ; return t to skip other completions (t nil)))) -(defvar link) ;dynamic variables set by help callback -(defvar props) +(defvar idlw-help-link) ;dynamic variables set by help callback (defun idlwave-complete-sysvar-help (mode word) (let ((word (or (nth 1 idlwave-completion-help-info) word)) (entry (assoc word idlwave-system-variables-alist))) @@ -7690,7 +7667,8 @@ property indicating the link is added." ((eq mode 'test) (and (stringp word) entry (nth 1 (assq 'link entry)))) ((eq mode 'set) - (if entry (setq link (nth 1 (assq 'link entry))))) ;; setting dynamic!!! + ;; Setting dynamic!!! + (if entry (setq idlw-help-link (nth 1 (assq 'link entry))))) (t (error "This should not happen"))))) (defun idlwave-complete-sysvar-tag-help (mode word) @@ -7704,10 +7682,10 @@ property indicating the link is added." (and (stringp word) entry main)) ((eq mode 'set) (if entry - (setq link + (setq idlw-help-link (if (setq target (cdr (assoc-string word tags t))) - (idlwave-substitute-link-target main target) - main)))) ;; setting dynamic!!! + (idlwave-substitute-link-target main target) + main)))) ;; setting dynamic!!! (t (error "This should not happen"))))) (defun idlwave-split-link-target (link) @@ -7727,9 +7705,10 @@ property indicating the link is added." link))) ;; Fake help in the source buffer for class structure tags. -;; KWD AND NAME ARE GLOBAL-VARIABLES HERE. -(defvar name) -(defvar kwd) +;; IDLW-HELP-LINK AND IDLW-HELP-NAME ARE GLOBAL-VARIABLES HERE. +;; (from idlwave-do-mouse-completion-help) +(defvar idlw-help-name) +(defvar idlw-help-link) (defvar idlwave-help-do-class-struct-tag nil) (defun idlwave-complete-class-structure-tag-help (mode word) (cond @@ -7745,9 +7724,9 @@ property indicating the link is added." idlwave-system-class-info) (error "No help available for system class tags")) (if (setq found-in (idlwave-class-found-in class-with)) - (setq name (cons (concat found-in "__define") class-with)) - (setq name (concat class-with "__define"))))) - (setq kwd word + (setq idlw-help-name (cons (concat found-in "__define") class-with)) + (setq idlw-help-name (concat class-with "__define"))))) + (setq idlw-help-link word idlwave-help-do-class-struct-tag t)) (t (error "This should not happen")))) @@ -8825,9 +8804,9 @@ the `idlwave-system-routines' list, we omit the latter as non-dangerous because many IDL routines are implemented as library routines, and may have been scanned." (let* ((entry (car entries)) - (name (car entry)) ; + (idlwave-twin-name (car entry)) ; (type (nth 1 entry)) ; Must be bound for - (class (nth 2 entry)) ; idlwave-routine-twin-compare + (idlwave-twin-class (nth 2 entry)) ; idlwave-routine-twin-compare (cnt 0) source type type-cons file alist syslibp key) (while (setq entry (pop entries)) @@ -8869,7 +8848,6 @@ routines, and may have been scanned." ;; FIXME: Dynamically scoped vars need to use the `idlwave-' prefix. ;; (defvar type) -;; (defvar class) (defmacro idlwave-xor (a b) `(and (or ,a ,b) (not (and ,a ,b)))) @@ -8902,7 +8880,9 @@ names and path locations." (defun idlwave-routine-entry-compare-twins (a b) "Compare two routine entries, under the assumption that they are twins. This basically calls `idlwave-routine-twin-compare' with the correct args." - (let* ((name (car a)) (type (nth 1 a)) (class (nth 2 a)) ; needed outside + (let* ((idlwave-twin-name (car a)) + (type (nth 1 a)) + (idlwave-twin-class (nth 2 a)) ; used in idlwave-routine-twin-compare (asrc (nth 3 a)) (atype (car asrc)) (bsrc (nth 3 b)) @@ -8915,18 +8895,17 @@ This basically calls `idlwave-routine-twin-compare' with the correct args." (list atype afile (list atype))) (if (stringp bfile) (list (file-truename bfile) bfile (list btype)) - (list btype bfile (list btype)))) - )) + (list btype bfile (list btype)))))) ;; Bound in idlwave-study-twins,idlwave-routine-entry-compare-twins. -;; FIXME: Dynamically scoped vars need to use the `idlwave-' prefix. -(defvar class) +(defvar idlwave-twin-class) +(defvar idlwave-twin-name) (defun idlwave-routine-twin-compare (a b) "Compare two routine twin entries for sorting. In here, A and B are not normal routine info entries, but special lists (KEY FILENAME (TYPES...)). -This expects NAME TYPE CLASS to be bound to the right values." +This expects NAME TYPE IDLWAVE-TWIN-CLASS to be bound to the right values." (let* (;; Dis-assemble entries (akey (car a)) (bkey (car b)) (afile (nth 1 a)) (bfile (nth 1 b)) @@ -8958,16 +8937,19 @@ This expects NAME TYPE CLASS to be bound to the right values." ;; Look at file names (aname (if (stringp afile) (downcase (file-name-nondirectory afile)) "")) (bname (if (stringp bfile) (downcase (file-name-nondirectory bfile)) "")) - (fname-re (if class (format "\\`%s__\\(%s\\|define\\)\\.pro\\'" - (regexp-quote (downcase class)) - (regexp-quote (downcase name))) - (format "\\`%s\\.pro" (regexp-quote (downcase name))))) + (fname-re (if idlwave-twin-class + (format "\\`%s__\\(%s\\|define\\)\\.pro\\'" + (regexp-quote (downcase idlwave-twin-class)) + (regexp-quote (downcase idlwave-twin-name))) + (format "\\`%s\\.pro" (regexp-quote (downcase idlwave-twin-name))))) ;; Is file name derived from the routine name? ;; Method file or class definition file? (anamep (string-match fname-re aname)) - (adefp (and class anamep (string= "define" (match-string 1 aname)))) + (adefp (and idlwave-twin-class anamep + (string= "define" (match-string 1 aname)))) (bnamep (string-match fname-re bname)) - (bdefp (and class bnamep (string= "define" (match-string 1 bname))))) + (bdefp (and idlwave-twin-class bnamep + (string= "define" (match-string 1 bname))))) ;; Now: follow JD's ideas about sorting. Looks really simple now, ;; doesn't it? The difficult stuff is hidden above... @@ -8979,7 +8961,7 @@ This expects NAME TYPE CLASS to be bound to the right values." ((idlwave-xor acompp bcompp) acompp) ; Compiled entries ((idlwave-xor apathp bpathp) apathp) ; Library before non-library ((idlwave-xor anamep bnamep) anamep) ; Correct file names first - ((and class anamep bnamep ; both file names match -> + ((and idlwave-twin-class anamep bnamep ; both file names match -> (idlwave-xor adefp bdefp)) bdefp) ; __define after __method ((> anpath bnpath) t) ; Who is first on path? (t nil)))) ; Default @@ -9363,5 +9345,4 @@ This function was written since `list-abbrevs' looks terrible for IDLWAVE mode." (provide 'idlwave) -;; arch-tag: f77f3b0c-c37c-424f-a328-0886fd42b6fb ;;; idlwave.el ends here diff --git a/lisp/progmodes/inf-lisp.el b/lisp/progmodes/inf-lisp.el index ee5e2a49ead..41ce378e966 100644 --- a/lisp/progmodes/inf-lisp.el +++ b/lisp/progmodes/inf-lisp.el @@ -80,19 +80,17 @@ mode. Default is whitespace followed by 0 or 1 single-letter colon-keyword :type 'regexp :group 'inferior-lisp) -(defvar inferior-lisp-mode-map nil) -(unless inferior-lisp-mode-map - (setq inferior-lisp-mode-map (copy-keymap comint-mode-map)) - (set-keymap-parent inferior-lisp-mode-map lisp-mode-shared-map) - (define-key inferior-lisp-mode-map "\C-x\C-e" 'lisp-eval-last-sexp) - (define-key inferior-lisp-mode-map "\C-c\C-l" 'lisp-load-file) - (define-key inferior-lisp-mode-map "\C-c\C-k" 'lisp-compile-file) - (define-key inferior-lisp-mode-map "\C-c\C-a" 'lisp-show-arglist) - (define-key inferior-lisp-mode-map "\C-c\C-d" 'lisp-describe-sym) - (define-key inferior-lisp-mode-map "\C-c\C-f" - 'lisp-show-function-documentation) - (define-key inferior-lisp-mode-map "\C-c\C-v" - 'lisp-show-variable-documentation)) +(defvar inferior-lisp-mode-map + (let ((map (copy-keymap comint-mode-map))) + (set-keymap-parent map lisp-mode-shared-map) + (define-key map "\C-x\C-e" 'lisp-eval-last-sexp) + (define-key map "\C-c\C-l" 'lisp-load-file) + (define-key map "\C-c\C-k" 'lisp-compile-file) + (define-key map "\C-c\C-a" 'lisp-show-arglist) + (define-key map "\C-c\C-d" 'lisp-describe-sym) + (define-key map "\C-c\C-f" 'lisp-show-function-documentation) + (define-key map "\C-c\C-v" 'lisp-show-variable-documentation) + map)) ;;; These commands augment Lisp mode, so you can process Lisp code in ;;; the source files. diff --git a/lisp/progmodes/js.el b/lisp/progmodes/js.el index 60ed14afbac..6114a0e15b2 100644 --- a/lisp/progmodes/js.el +++ b/lisp/progmodes/js.el @@ -7,7 +7,7 @@ ;; Maintainer: Daniel Colascione <dan.colascione@gmail.com> ;; Version: 9 ;; Date: 2009-07-25 -;; Keywords: languages, oop, javascript +;; Keywords: languages, javascript ;; This file is part of GNU Emacs. @@ -45,16 +45,16 @@ ;;; Code: -(eval-and-compile - (require 'cc-mode) - (require 'font-lock) - (require 'newcomment) - (require 'imenu) - (require 'etags) - (require 'thingatpt) - (require 'easymenu) - (require 'moz nil t) - (require 'json nil t)) + +(require 'cc-mode) +(require 'font-lock) +(require 'newcomment) +(require 'imenu) +(require 'etags) +(require 'thingatpt) +(require 'easymenu) +(require 'moz nil t) +(require 'json nil t) (eval-when-compile (require 'cl) @@ -431,11 +431,32 @@ Match group 1 is the name of the macro.") :group 'js) (defcustom js-expr-indent-offset 0 - "Number of additional spaces used for indentation of continued expressions. + "Number of additional spaces for indenting continued expressions. The value must be no less than minus `js-indent-level'." :type 'integer :group 'js) +(defcustom js-paren-indent-offset 0 + "Number of additional spaces for indenting expressions in parentheses. +The value must be no less than minus `js-indent-level'." + :type 'integer + :group 'js + :version "24.1") + +(defcustom js-square-indent-offset 0 + "Number of additional spaces for indenting expressions in square braces. +The value must be no less than minus `js-indent-level'." + :type 'integer + :group 'js + :version "24.1") + +(defcustom js-curly-indent-offset 0 + "Number of additional spaces for indenting expressions in curly braces. +The value must be no less than minus `js-indent-level'." + :type 'integer + :group 'js + :version "24.1") + (defcustom js-auto-indent-flag t "Whether to automatically indent when typing punctuation characters. If non-nil, the characters {}();,: also indent the current line @@ -682,7 +703,7 @@ point at BOB." (setq str-terminator ?/)) (re-search-forward (concat "\\([^\\]\\|^\\)" (string str-terminator)) - (save-excursion (end-of-line) (point)) t)) + (point-at-eol) t)) ((nth 7 parse) (forward-line)) ((or (nth 4 parse) @@ -704,20 +725,19 @@ as if strings, cpp macros, and comments have been removed. If invoked while inside a macro, it treats the contents of the macro as normal text." + (unless count (setq count 1)) (let ((saved-point (point)) - (search-expr - (cond ((null count) - '(js--re-search-forward-inner regexp bound 1)) - ((< count 0) - '(js--re-search-backward-inner regexp bound (- count))) - ((> count 0) - '(js--re-search-forward-inner regexp bound count))))) + (search-fun + (cond ((< count 0) (setq count (- count)) + #'js--re-search-backward-inner) + ((> count 0) #'js--re-search-forward-inner) + (t #'ignore)))) (condition-case err - (eval search-expr) + (funcall search-fun regexp bound count) (search-failed (goto-char saved-point) (unless noerror - (error (error-message-string err))))))) + (signal (car err) (cdr err))))))) (defun js--re-search-backward-inner (regexp &optional bound count) @@ -739,7 +759,7 @@ macro as normal text." (setq str-terminator ?/)) (re-search-backward (concat "\\([^\\]\\|^\\)" (string str-terminator)) - (save-excursion (beginning-of-line) (point)) t)) + (point-at-bol) t)) ((nth 7 parse) (goto-char (nth 8 parse))) ((or (nth 4 parse) @@ -761,20 +781,7 @@ as if strings, preprocessor macros, and comments have been removed. If invoked while inside a macro, treat the macro as normal text." - (let ((saved-point (point)) - (search-expr - (cond ((null count) - '(js--re-search-backward-inner regexp bound 1)) - ((< count 0) - '(js--re-search-forward-inner regexp bound (- count))) - ((> count 0) - '(js--re-search-backward-inner regexp bound count))))) - (condition-case err - (eval search-expr) - (search-failed - (goto-char saved-point) - (unless noerror - (error (error-message-string err))))))) + (js--re-search-forward regexp bound noerror (if count (- count) -1))) (defun js--forward-expression () "Move forward over a whole JavaScript expression. @@ -1653,18 +1660,19 @@ This performs fontification according to `js--class-styles'." ;; XXX: Javascript can continue a regexp literal across lines so long ;; as the newline is escaped with \. Account for that in the regexp ;; below. -(defconst js--regexp-literal +(eval-and-compile + (defconst js--regexp-literal "[=(,:]\\(?:\\s-\\|\n\\)*\\(/\\)\\(?:\\\\/\\|[^/*]\\)\\(?:\\\\/\\|[^/]\\)*\\(/\\)" "Regexp matching a JavaScript regular expression literal. Match groups 1 and 2 are the characters forming the beginning and -end of the literal.") +end of the literal.")) -;; we want to match regular expressions only at the beginning of -;; expressions -(defconst js-font-lock-syntactic-keywords - `((,js--regexp-literal (1 "|") (2 "|"))) - "Syntactic font lock keywords matching regexps in JavaScript. -See `font-lock-keywords'.") + +(defconst js-syntax-propertize-function + (syntax-propertize-rules + ;; We want to match regular expressions only at the beginning of + ;; expressions. + (js--regexp-literal (1 "\"") (2 "\"")))) ;;; Indentation @@ -1769,14 +1777,17 @@ nil." ((eq (char-after) ?#) 0) ((save-excursion (js--beginning-of-macro)) 4) ((nth 1 parse-status) + ;; A single closing paren/bracket should be indented at the + ;; same level as the opening statement. Same goes for + ;; "case" and "default". (let ((same-indent-p (looking-at "[]})]\\|\\_<case\\_>\\|\\_<default\\_>")) (continued-expr-p (js--continued-expression-p))) - (goto-char (nth 1 parse-status)) + (goto-char (nth 1 parse-status)) ; go to the opening char (if (looking-at "[({[]\\s-*\\(/[/*]\\|$\\)") - (progn + (progn ; nothing following the opening paren/bracket (skip-syntax-backward " ") - (when (eq (char-before) ?\)) (backward-list)) + (when (eq (char-before) ?\)) (backward-list)) (back-to-indentation) (cond (same-indent-p (current-column)) @@ -1784,7 +1795,14 @@ nil." (+ (current-column) (* 2 js-indent-level) js-expr-indent-offset)) (t - (+ (current-column) js-indent-level)))) + (+ (current-column) js-indent-level + (case (char-after (nth 1 parse-status)) + (?\( js-paren-indent-offset) + (?\[ js-square-indent-offset) + (?\{ js-curly-indent-offset)))))) + ;; If there is something following the opening + ;; paren/bracket, everything else should be indented at + ;; the same level. (unless same-indent-p (forward-char) (skip-chars-forward " \t")) @@ -3268,7 +3286,7 @@ If one hasn't been set, or if it's stale, prompt for a new one." ;;; Main Function ;;;###autoload -(define-derived-mode js-mode nil "js" +(define-derived-mode js-mode prog-mode "js" "Major mode for editing JavaScript. Key bindings: @@ -3286,10 +3304,9 @@ Key bindings: (set (make-local-variable 'open-paren-in-column-0-is-defun-start) nil) (set (make-local-variable 'font-lock-defaults) - (list js--font-lock-keywords - nil nil nil nil - '(font-lock-syntactic-keywords - . js-font-lock-syntactic-keywords))) + (list js--font-lock-keywords)) + (set (make-local-variable 'syntax-propertize-function) + js-syntax-propertize-function) (set (make-local-variable 'parse-sexp-ignore-comments) t) (set (make-local-variable 'parse-sexp-lookup-properties) t) @@ -3360,5 +3377,4 @@ Key bindings: (provide 'js) -;; arch-tag: 1a0d0409-e87f-4fc7-a58c-3731c66ddaac ;; js.el ends here diff --git a/lisp/progmodes/ld-script.el b/lisp/progmodes/ld-script.el index 3d07ed226b2..318456e9534 100644 --- a/lisp/progmodes/ld-script.el +++ b/lisp/progmodes/ld-script.el @@ -1,7 +1,7 @@ ;;; ld-script.el --- GNU linker script editing mode for Emacs -;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. +;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, +;; 2010 Free Software Foundation, Inc. ;; Author: Masatake YAMATO<jet@gyve.org> ;; Keywords: languages, faces @@ -76,20 +76,20 @@ (defvar ld-script-keywords '( ;; 3.4.1 Setting the Entry Point - "ENTRY" + "ENTRY" ;; 3.4.2 Commands Dealing with Files "INCLUDE" "INPUT" "GROUP" "AS_NEEDED" "OUTPUT" "SEARCH_DIR" "STARTUP" ;; 3.4.3 Commands Dealing with Object File Formats "OUTPUT_FORMAT" "TARGET" ;; 3.4.3 Other Linker Script Commands - "ASSERT" "EXTERN" "FORCE_COMMON_ALLOCATION" + "ASSERT" "EXTERN" "FORCE_COMMON_ALLOCATION" "INHIBIT_COMMON_ALLOCATION" "NOCROSSREFS" "OUTPUT_ARCH" ;; 3.5.2 PROVIDE "PROVIDE" ;; 3.5.3 PROVIDE_HIDDEN "PROVIDE_HIDDEN" ;; 3.6 SECTIONS Command - "SECTIONS" + "SECTIONS" ;; 3.6.4.2 Input Section Wildcard Patterns "SORT" "SORT_BY_NAME" "SORT_BY_ALIGNMENT" ;; 3.6.4.3 Input Section for Common Symbols @@ -157,18 +157,6 @@ cpp-font-lock-keywords) "Default font-lock-keywords for `ld-script-mode'.") -;; Linux-2.6.9 uses some different suffix for linker scripts: -;; "ld", "lds", "lds.S", "lds.in", "ld.script", and "ld.script.balo". -;; eCos uses "ld" and "ldi". -;; Netbsd uses "ldscript.*". -;;;###autoload -(add-to-list 'auto-mode-alist (purecopy '("\\.ld[si]?\\>" . ld-script-mode))) -;;;###autoload -(add-to-list 'auto-mode-alist (purecopy '("ld\\.?script\\>" . ld-script-mode))) - -;;;###autoload -(add-to-list 'auto-mode-alist (purecopy '("\\.x[bdsru]?[cn]?\\'" . ld-script-mode))) - ;;;###autoload (define-derived-mode ld-script-mode nil "LD-Script" "A major mode to edit GNU ld script files" diff --git a/lisp/progmodes/make-mode.el b/lisp/progmodes/make-mode.el index d45ecd47907..187c838382b 100644 --- a/lisp/progmodes/make-mode.el +++ b/lisp/progmodes/make-mode.el @@ -281,8 +281,7 @@ not be enclosed in { } or ( )." "Regex used to highlight makepp rule action lines in font lock mode.") (defconst makefile-bsdmake-rule-action-regex - (progn (string-match "-@" makefile-rule-action-regex) - (replace-match "-+@" t t makefile-rule-action-regex)) + (replace-regexp-in-string "-@" "-+@" makefile-rule-action-regex) "Regex used to highlight BSD rule action lines in font lock mode.") ;; Note that the first and second subexpression is used by font lock. Note @@ -506,40 +505,41 @@ not be enclosed in { } or ( )." cpp-font-lock-keywords)) -(defconst makefile-font-lock-syntactic-keywords - ;; From sh-script.el. - ;; A `#' begins a comment in sh when it is unquoted and at the beginning - ;; of a word. In the shell, words are separated by metacharacters. - ;; The list of special chars is taken from the single-unix spec of the - ;; shell command language (under `quoting') but with `$' removed. - '(("[^|&;<>()`\\\"' \t\n]\\(#+\\)" 1 "_") - ;; Change the syntax of a quoted newline so that it does not end a comment. - ("\\\\\n" 0 "."))) +(defconst makefile-syntax-propertize-function + (syntax-propertize-rules + ;; From sh-script.el. + ;; A `#' begins a comment in sh when it is unquoted and at the beginning + ;; of a word. In the shell, words are separated by metacharacters. + ;; The list of special chars is taken from the single-unix spec of the + ;; shell command language (under `quoting') but with `$' removed. + ("[^|&;<>()`\\\"' \t\n]\\(#+\\)" (1 "_")) + ;; Change the syntax of a quoted newline so that it does not end a comment. + ("\\\\\n" (0 ".")))) (defvar makefile-imenu-generic-expression `(("Dependencies" makefile-previous-dependency 1) ("Macro Assignment" ,makefile-macroassign-regex 1)) "Imenu generic expression for Makefile mode. See `imenu-generic-expression'.") -;;; ------------------------------------------------------------ -;;; The following configurable variables are used in the -;;; up-to-date overview . -;;; The standard configuration assumes that your `make' program -;;; can be run in question/query mode using the `-q' option, this -;;; means that the command -;;; -;;; make -q foo -;;; -;;; should return an exit status of zero if the target `foo' is -;;; up to date and a nonzero exit status otherwise. -;;; Many makes can do this although the docs/manpages do not mention -;;; it. Try it with your favourite one. GNU make, System V make, and -;;; Dennis Vadura's DMake have no problems. -;;; Set the variable `makefile-brave-make' to the name of the -;;; make utility that does this on your system. -;;; To understand what this is all about see the function definition -;;; of `makefile-query-by-make-minus-q' . -;;; ------------------------------------------------------------ +;; ------------------------------------------------------------ +;; The following configurable variables are used in the +;; up-to-date overview . +;; The standard configuration assumes that your `make' program +;; can be run in question/query mode using the `-q' option, this +;; means that the command +;; +;; make -q foo +;; +;; should return an exit status of zero if the target `foo' is +;; up to date and a nonzero exit status otherwise. +;; Many makes can do this although the docs/manpages do not mention +;; it. Try it with your favourite one. GNU make, System V make, and +;; Dennis Vadura's DMake have no problems. +;; Set the variable `makefile-brave-make' to the name of the +;; make utility that does this on your system. +;; To understand what this is all about see the function definition +;; of `makefile-query-by-make-minus-q' . +;; ------------------------------------------------------------ (defcustom makefile-brave-make "make" "*How to invoke make, for `makefile-query-targets'. @@ -574,11 +574,8 @@ The function must satisfy this calling convention: ;;; --- end of up-to-date-overview configuration ------------------ -(defvar makefile-mode-abbrev-table nil +(define-abbrev-table 'makefile-mode-abbrev-table () "Abbrev table in use in Makefile buffers.") -(if makefile-mode-abbrev-table - () - (define-abbrev-table 'makefile-mode-abbrev-table ())) (defvar makefile-mode-map (let ((map (make-sparse-keymap)) @@ -706,15 +703,13 @@ The function must satisfy this calling convention: (modify-syntax-entry ?\n "> " st) st)) -(defvar makefile-imake-mode-syntax-table (copy-syntax-table - makefile-mode-syntax-table)) -(if makefile-imake-mode-syntax-table - () - (modify-syntax-entry ?/ ". 14" makefile-imake-mode-syntax-table) - (modify-syntax-entry ?* ". 23" makefile-imake-mode-syntax-table) - (modify-syntax-entry ?# "'" makefile-imake-mode-syntax-table) - (modify-syntax-entry ?\n ". b" makefile-imake-mode-syntax-table)) - +(defvar makefile-imake-mode-syntax-table + (let ((st (make-syntax-table makefile-mode-syntax-table))) + (modify-syntax-entry ?/ ". 14" st) + (modify-syntax-entry ?* ". 23" st) + (modify-syntax-entry ?# "'" st) + (modify-syntax-entry ?\n ". b" st) + st)) ;;; ------------------------------------------------------------ ;;; Internal variables. @@ -774,7 +769,7 @@ The function must satisfy this calling convention: ;;; ------------------------------------------------------------ ;;;###autoload -(defun makefile-mode () +(define-derived-mode makefile-mode prog-mode "Makefile" "Major mode for editing standard Makefiles. If you are editing a file for a different make, try one of the @@ -858,9 +853,6 @@ Makefile mode can be configured by modifying the following variables: List of special targets. You will be offered to complete on one of those in the minibuffer whenever you enter a `.'. at the beginning of a line in Makefile mode." - - (interactive) - (kill-all-local-variables) (add-hook 'write-file-functions 'makefile-warn-suspicious-lines nil t) (add-hook 'write-file-functions @@ -874,59 +866,44 @@ Makefile mode can be configured by modifying the following variables: (make-local-variable 'makefile-need-macro-pickup) ;; Font lock. - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults - ;; SYNTAX-BEGIN set to backward-paragraph to avoid slow-down - ;; near the end of a large buffer, due to parse-partial-sexp's - ;; trying to parse all the way till the beginning of buffer. - '(makefile-font-lock-keywords - nil nil - ((?$ . ".")) - backward-paragraph - (font-lock-syntactic-keywords - . makefile-font-lock-syntactic-keywords))) + (set (make-local-variable 'font-lock-defaults) + ;; SYNTAX-BEGIN set to backward-paragraph to avoid slow-down + ;; near the end of a large buffer, due to parse-partial-sexp's + ;; trying to parse all the way till the beginning of buffer. + '(makefile-font-lock-keywords + nil nil + ((?$ . ".")) + backward-paragraph)) + (set (make-local-variable 'syntax-propertize-function) + makefile-syntax-propertize-function) ;; Add-log. - (make-local-variable 'add-log-current-defun-function) - (setq add-log-current-defun-function 'makefile-add-log-defun) + (set (make-local-variable 'add-log-current-defun-function) + 'makefile-add-log-defun) ;; Imenu. - (make-local-variable 'imenu-generic-expression) - (setq imenu-generic-expression makefile-imenu-generic-expression) + (set (make-local-variable 'imenu-generic-expression) + makefile-imenu-generic-expression) ;; Dabbrev. - (make-local-variable 'dabbrev-abbrev-skip-leading-regexp) - (setq dabbrev-abbrev-skip-leading-regexp "\\$") + (set (make-local-variable 'dabbrev-abbrev-skip-leading-regexp) "\\$") ;; Other abbrevs. (setq local-abbrev-table makefile-mode-abbrev-table) ;; Filling. - (make-local-variable 'fill-paragraph-function) - (setq fill-paragraph-function 'makefile-fill-paragraph) + (set (make-local-variable 'fill-paragraph-function) 'makefile-fill-paragraph) ;; Comment stuff. - (make-local-variable 'comment-start) - (setq comment-start "#") - (make-local-variable 'comment-end) - (setq comment-end "") - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "#+[ \t]*") + (set (make-local-variable 'comment-start) "#") + (set (make-local-variable 'comment-end) "") + (set (make-local-variable 'comment-start-skip) "#+[ \t]*") ;; Make sure TAB really inserts \t. (set (make-local-variable 'indent-line-function) 'indent-to-left-margin) - ;; become the current major mode - (setq major-mode 'makefile-mode) - (setq mode-name "Makefile") - - ;; Activate keymap and syntax table. - (use-local-map makefile-mode-map) - (set-syntax-table makefile-mode-syntax-table) - ;; Real TABs are important in makefiles - (setq indent-tabs-mode t) - (run-mode-hooks 'makefile-mode-hook)) + (setq indent-tabs-mode t)) ;; These should do more than just differentiate font-lock. ;;;###autoload @@ -967,15 +944,9 @@ Makefile mode can be configured by modifying the following variables: (define-derived-mode makefile-imake-mode makefile-mode "Imakefile" "An adapted `makefile-mode' that knows about imake." :syntax-table makefile-imake-mode-syntax-table - (let ((base `(makefile-imake-font-lock-keywords ,@(cdr font-lock-defaults))) - new) - ;; Remove `font-lock-syntactic-keywords' entry from font-lock-defaults. - (mapc (lambda (elt) - (unless (and (consp elt) - (eq (car elt) 'font-lock-syntactic-keywords)) - (setq new (cons elt new)))) - base) - (setq font-lock-defaults (nreverse new)))) + (set (make-local-variable 'syntax-propertize-function) nil) + (setq font-lock-defaults + `(makefile-imake-font-lock-keywords ,@(cdr font-lock-defaults)))) diff --git a/lisp/progmodes/meta-mode.el b/lisp/progmodes/meta-mode.el index 70b38dc3999..294c75c9ccf 100644 --- a/lisp/progmodes/meta-mode.el +++ b/lisp/progmodes/meta-mode.el @@ -1,7 +1,7 @@ ;;; meta-mode.el --- major mode for editing Metafont or MetaPost sources -;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. +;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, +;; 2009, 2010 Free Software Foundation, Inc. ;; Author: Ulrik Vieth <vieth@thphy.uni-duesseldorf.de> ;; Version: 1.0 @@ -517,24 +517,24 @@ If the list was changed, sort the list and remove duplicates first." ;;; Indentation. (defcustom meta-indent-level 2 - "*Indentation of begin-end blocks in Metafont or MetaPost mode." + "Indentation of begin-end blocks in Metafont or MetaPost mode." :type 'integer :group 'meta-font) (defcustom meta-left-comment-regexp "%%+" - "*Regexp matching comments that should be placed on the left margin." + "Regexp matching comments that should be placed on the left margin." :type 'regexp :group 'meta-font) (defcustom meta-right-comment-regexp nil - "*Regexp matching comments that should be placed to the right margin." + "Regexp matching comments that should be placed to the right margin." :type '(choice regexp (const :tag "None" nil)) :group 'meta-font) (defcustom meta-ignore-comment-regexp "%[^%]" - "*Regexp matching comments that whose indentation should not be touched." + "Regexp matching comments that whose indentation should not be touched." :type 'regexp :group 'meta-font) @@ -543,21 +543,21 @@ If the list was changed, sort the list and remove duplicates first." (concat "\\(begin\\(char\\|fig\\|gr\\(aph\\|oup\\)\\|logochar\\)\\|" "def\\|for\\(\\|ever\\|suffixes\\)\\|if\\|mode_def\\|" "primarydef\\|secondarydef\\|tertiarydef\\|vardef\\)") - "*Regexp matching the beginning of environments to be indented." + "Regexp matching the beginning of environments to be indented." :type 'regexp :group 'meta-font) (defcustom meta-end-environment-regexp (concat "\\(end\\(char\\|def\\|f\\(ig\\|or\\)\\|gr\\(aph\\|oup\\)\\)" "\\|fi\\)") - "*Regexp matching the end of environments to be indented." + "Regexp matching the end of environments to be indented." :type 'regexp :group 'meta-font) (defcustom meta-within-environment-regexp ; (concat "\\(e\\(lse\\(\\|if\\)\\|xit\\(if\\|unless\\)\\)\\)") (concat "\\(else\\(\\|if\\)\\)") - "*Regexp matching keywords within environments not to be indented." + "Regexp matching keywords within environments not to be indented." :type 'regexp :group 'meta-font) @@ -575,12 +575,11 @@ If the list was changed, sort the list and remove duplicates first." "Indent the line containing point as Metafont or MetaPost source." (interactive) (let ((indent (meta-indent-calculate))) - (save-excursion - (if (/= (current-indentation) indent) - (let ((beg (progn (beginning-of-line) (point))) - (end (progn (back-to-indentation) (point)))) - (delete-region beg end) - (indent-to indent)))) + (if (/= (current-indentation) indent) + (save-excursion + (delete-region (line-beginning-position) + (progn (back-to-indentation) (point))) + (indent-to indent))) (if (< (current-column) indent) (back-to-indentation)))) @@ -744,13 +743,13 @@ If the list was changed, sort the list and remove duplicates first." (defcustom meta-begin-defun-regexp (concat "\\(begin\\(char\\|fig\\|logochar\\)\\|def\\|mode_def\\|" "primarydef\\|secondarydef\\|tertiarydef\\|vardef\\)") - "*Regexp matching beginning of defuns in Metafont or MetaPost mode." + "Regexp matching beginning of defuns in Metafont or MetaPost mode." :type 'regexp :group 'meta-font) (defcustom meta-end-defun-regexp (concat "\\(end\\(char\\|def\\|fig\\)\\)") - "*Regexp matching the end of defuns in Metafont or MetaPost mode." + "Regexp matching the end of defuns in Metafont or MetaPost mode." :type 'regexp :group 'meta-font) @@ -955,21 +954,21 @@ The environment marked is the one that contains point or follows point." ;;; Hook variables. (defcustom meta-mode-load-hook nil - "*Hook evaluated when first loading Metafont or MetaPost mode." + "Hook evaluated when first loading Metafont or MetaPost mode." :type 'hook :group 'meta-font) (defcustom meta-common-mode-hook nil - "*Hook evaluated by both `metafont-mode' and `metapost-mode'." + "Hook evaluated by both `metafont-mode' and `metapost-mode'." :type 'hook :group 'meta-font) (defcustom metafont-mode-hook nil - "*Hook evaluated by `metafont-mode' after `meta-common-mode-hook'." + "Hook evaluated by `metafont-mode' after `meta-common-mode-hook'." :type 'hook :group 'meta-font) (defcustom metapost-mode-hook nil - "*Hook evaluated by `metapost-mode' after `meta-common-mode-hook'." + "Hook evaluated by `metapost-mode' after `meta-common-mode-hook'." :type 'hook :group 'meta-font) @@ -1084,5 +1083,4 @@ Turning on MetaPost mode calls the value of the variable (provide 'meta-mode) (run-hooks 'meta-mode-load-hook) -;; arch-tag: ec2916b2-3a83-4cf7-962d-d8019370c006 ;;; meta-mode.el ends here diff --git a/lisp/progmodes/mixal-mode.el b/lisp/progmodes/mixal-mode.el index 5b1fc712477..f2a7aa045e4 100644 --- a/lisp/progmodes/mixal-mode.el +++ b/lisp/progmodes/mixal-mode.el @@ -7,7 +7,7 @@ ;; Maintainer: Pieter E.J. Pareit <pieter.pareit@gmail.com> ;; Created: 09 Nov 2002 ;; Version: 0.1 -;; Keywords: languages Knuth mix mixal asm mixvm "The Art Of Computer Programming" +;; Keywords: languages, Knuth, mix, mixal, asm, mixvm, The Art Of Computer Programming ;; This file is part of GNU Emacs. @@ -89,7 +89,7 @@ (defvar mixal-mode-syntax-table (let ((st (make-syntax-table))) ;; We need to do a bit more to make fontlocking for comments work. - ;; See mixal-font-lock-syntactic-keywords. + ;; See use of syntax-propertize-function. ;; (modify-syntax-entry ?* "<" st) (modify-syntax-entry ?\n ">" st) st) @@ -125,7 +125,7 @@ value.") (defvar mixal-operation-codes-alist ;; FIXME: the codes FADD, FSUB, FMUL, FDIV, JRAD, and FCMP were in ;; mixal-operation-codes but not here. They should probably be added here. - ;; + ;; ;; We used to define this with a backquote and subexps like ,(+ 8 3) for ;; better clarity, but the resulting code was too big and caused the ;; byte-compiler to eat up all the stack space. Even using @@ -1028,13 +1028,14 @@ EXECUTION-TIME holds info about the time it takes, number or string.") ;;; Font-locking: -(defvar mixal-font-lock-syntactic-keywords - ;; Normal comments start with a * in column 0 and end at end of line. - '(("^\\*" (0 '(11))) ;(string-to-syntax "<") == '(11) - ;; Every line can end with a comment which is placed after the operand. - ;; I assume here that mnemonics without operands can not have a comment. - ("^[[:alnum:]]*[ \t]+[[:alnum:]]+[ \t]+[^ \n\t]+[ \t]*\\([ \t]\\)[^\n \t]" - (1 '(11))))) +(defconst mixal-syntax-propertize-function + (syntax-propertize-rules + ;; Normal comments start with a * in column 0 and end at end of line. + ("^\\*" (0 "<")) + ;; Every line can end with a comment which is placed after the operand. + ;; I assume here that mnemonics without operands can not have a comment. + ("^[[:alnum:]]*[ \t]+[[:alnum:]]+[ \t]+[^ \n\t]+[ \t]*\\([ \t]\\)[^\n \t]" + (1 "<")))) (defvar mixal-font-lock-keywords `(("^\\([A-Z0-9a-z]+\\)" @@ -1110,9 +1111,9 @@ Assumes that file has been compiled with debugging support." (set (make-local-variable 'comment-start) "*") (set (make-local-variable 'comment-start-skip) "^\\*[ \t]*") (set (make-local-variable 'font-lock-defaults) - `(mixal-font-lock-keywords nil nil nil nil - (font-lock-syntactic-keywords . ,mixal-font-lock-syntactic-keywords) - (parse-sexp-lookup-properties . t))) + `(mixal-font-lock-keywords)) + (set (make-local-variable 'syntax-propertize-function) + mixal-syntax-propertize-function) ;; might add an indent function in the future ;; (set (make-local-variable 'indent-line-function) 'mixal-indent-line) (set (make-local-variable 'compile-command) (concat "mixasm " @@ -1122,9 +1123,6 @@ Assumes that file has been compiled with debugging support." (set (make-local-variable 'require-final-newline) mode-require-final-newline)) -;;;###autoload -(add-to-list 'auto-mode-alist '("\\.mixal\\'" . mixal-mode)) - (provide 'mixal-mode) ;; arch-tag: be7c128a-bf61-4951-a90e-9398267ce3f3 diff --git a/lisp/progmodes/modula2.el b/lisp/progmodes/modula2.el index 9d226cefbd4..c6ab5347065 100644 --- a/lisp/progmodes/modula2.el +++ b/lisp/progmodes/modula2.el @@ -22,6 +22,8 @@ ;;; Code: +(require 'smie) + (defgroup modula2 nil "Major mode for editing Modula-2 code." :link '(custom-group-link :tag "Font Lock Faces group" font-lock-faces) @@ -29,7 +31,22 @@ :group 'languages) ;;; Added by Tom Perrine (TEP) -(defvar m2-mode-syntax-table nil +(defvar m2-mode-syntax-table + (let ((table (make-syntax-table))) + (modify-syntax-entry ?\\ "\\" table) + (modify-syntax-entry ?/ ". 12" table) + (modify-syntax-entry ?\n ">" table) + (modify-syntax-entry ?\( "()1" table) + (modify-syntax-entry ?\) ")(4" table) + (modify-syntax-entry ?* ". 23nb" table) + (modify-syntax-entry ?+ "." table) + (modify-syntax-entry ?- "." table) + (modify-syntax-entry ?= "." table) + (modify-syntax-entry ?% "." table) + (modify-syntax-entry ?< "." table) + (modify-syntax-entry ?> "." table) + (modify-syntax-entry ?\' "\"" table) + table) "Syntax table in use in Modula-2 buffers.") (defcustom m2-compile-command "m2c" @@ -52,29 +69,10 @@ :type 'integer :group 'modula2) -(if m2-mode-syntax-table - () - (let ((table (make-syntax-table))) - (modify-syntax-entry ?\\ "\\" table) - (modify-syntax-entry ?\( ". 1" table) - (modify-syntax-entry ?\) ". 4" table) - (modify-syntax-entry ?* ". 23" table) - (modify-syntax-entry ?+ "." table) - (modify-syntax-entry ?- "." table) - (modify-syntax-entry ?= "." table) - (modify-syntax-entry ?% "." table) - (modify-syntax-entry ?< "." table) - (modify-syntax-entry ?> "." table) - (modify-syntax-entry ?\' "\"" table) - (setq m2-mode-syntax-table table))) - ;;; Added by TEP -(defvar m2-mode-map nil - "Keymap used in Modula-2 mode.") - -(if m2-mode-map () +(defvar m2-mode-map (let ((map (make-sparse-keymap))) - (define-key map "\^i" 'm2-tab) + ;; FIXME: Many of those bindings are contrary to coding conventions. (define-key map "\C-cb" 'm2-begin) (define-key map "\C-cc" 'm2-case) (define-key map "\C-cd" 'm2-definition) @@ -97,21 +95,197 @@ (define-key map "\C-cy" 'm2-import) (define-key map "\C-c{" 'm2-begin-comment) (define-key map "\C-c}" 'm2-end-comment) - (define-key map "\C-j" 'm2-newline) (define-key map "\C-c\C-z" 'suspend-emacs) (define-key map "\C-c\C-v" 'm2-visit) (define-key map "\C-c\C-t" 'm2-toggle) (define-key map "\C-c\C-l" 'm2-link) (define-key map "\C-c\C-c" 'm2-compile) - (setq m2-mode-map map))) + map) + "Keymap used in Modula-2 mode.") (defcustom m2-indent 5 "*This variable gives the indentation in Modula-2-Mode." :type 'integer :group 'modula2) +(put 'm2-indent 'safe-local-variable + (lambda (v) (or (null v) (integerp v)))) + +(defconst m2-smie-grammar + ;; An official definition can be found as "M2R10.pdf". This grammar does + ;; not really follow it, for lots of technical reasons, but it can still be + ;; useful to refer to it. + (smie-prec2->grammar + (smie-merge-prec2s + (smie-bnf->prec2 + '((range) (id) (epsilon) + (fields (fields ";" fields) (ids ":" type)) + (proctype (id ":" type)) + (type ("RECORD" fields "END") + ("POINTER" "TO" type) + ;; The PROCEDURE type is indistinguishable from the beginning + ;; of a PROCEDURE definition, so we need a "PROCEDURE-type" to + ;; prevent SMIE from trying to find the matching END. + ("PROCEDURE-type" proctype) + ;; OF's right hand side should bind tighter than ; for array + ;; types, but should bind less tight than | which itself binds + ;; less tight than ;. So we use two distinct OFs. + ("SET" "OF-type" id) + ("ARRAY" range "OF-type" type)) + (args ("(" fargs ")")) + ;; VAR has lower precedence than ";" in formal args, but not + ;; in declarations. So we use "VAR-arg" for the formal arg case. + (farg (ids ":" type) ("CONST-arg" farg) ("VAR-arg" farg)) + (fargs (fargs ";" fargs) (farg)) + ;; Handling of PROCEDURE in decls is problematic: we'd want + ;; TYPE/CONST/VAR/PROCEDURE's parent to be any previous + ;; CONST/TYPE/VAR/PROCEDURE, but we also want PROCEDURE to be an opener + ;; (so that its END has PROCEDURE as its parent). So instead, we treat + ;; the last ";" in those blocks as a separator (we call it ";-block"). + ;; FIXME: This means that "TYPE \n VAR" is not indented properly + ;; because there's no ";-block" between the two. + (decls (decls ";-block" decls) + ("TYPE" typedecls) ("CONST" constdecls) ("VAR" vardecls) + ;; END is usually a closer, but not quite for PROCEDURE...END. + ;; We could use "END-proc" for the procedure case, but + ;; I preferred to just pretend PROCEDURE's END is the closer. + ("PROCEDURE" decls "BEGIN" insts "END") ;END-proc id + ("PROCEDURE" decls "BEGIN" insts "FINALLY" insts "END") + ("PROCEDURE" decls "FORWARD") + ;; ("IMPLEMENTATION" epsilon "MODULE" decls + ;; "BEGIN" insts "FINALLY" insts "END") + ) + (typedecls (typedecls ";" typedecls) (id "=" type)) + (ids (ids "," ids)) + (vardecls (vardecls ";" vardecls) (ids ":" type)) + (constdecls (constdecls ";" constdecls) (id "=" exp)) + (exp (id "-anchor-" id) ("(" exp ")")) + (caselabel (caselabel ".." caselabel) (caselabel "," caselabel)) + ;; : for types binds tighter than ;, but the : for case labels binds + ;; less tight, so have to use two different :. + (cases (cases "|" cases) (caselabel ":-case" insts)) + (forspec (exp "TO" exp)) + (insts (insts ";" insts) + (id ":=" exp) + ("CASE" exp "OF" cases "END") + ("CASE" exp "OF" cases "ELSE" insts "END") + ("LOOP" insts "END") + ("WITH" exp "DO" insts "END") + ("REPEAT" insts "UNTIL" exp) + ("WHILE" exp "DO" insts "END") + ("FOR" forspec "DO" insts "END") + ("IF" exp "THEN" insts "END") + ("IF" exp "THEN" insts "ELSE" insts "END") + ("IF" exp "THEN" insts + "ELSIF" exp "THEN" insts "ELSE" insts "END") + ("IF" exp "THEN" insts + "ELSIF" exp "THEN" insts + "ELSIF" exp "THEN" insts "ELSE" insts "END")) + ;; This category is not used anywhere, but it adds some constraints that + ;; try to reduce the harm when an OF-type is not properly recognized. + (error-OF ("ARRAY" range "OF" type) ("SET" "OF" id))) + '((assoc ";")) '((assoc ";-block")) '((assoc "|")) + ;; For case labels. + '((assoc ",") (assoc "..")) + ;; '((assoc "TYPE" "CONST" "VAR" "PROCEDURE")) + ) + (smie-precs->prec2 + '((nonassoc "-anchor-" "=") + (nonassoc "<" "<=" ">=" ">" "<>" "#" "IN") + (assoc "OR" "+" "-") + (assoc "AND" "MOD" "DIV" "REM" "*" "/" "&") + (nonassoc "NOT" "~") + (left "." "^") + )) + ))) + +(defun m2-smie-refine-colon () + (let ((res nil)) + (while (not res) + (let ((tok (smie-default-backward-token))) + (cond + ((zerop (length tok)) + (let ((forward-sexp-function nil)) + (condition-case nil + (forward-sexp -1) + (scan-error (setq res ":"))))) + ((member tok '("|" "OF" "..")) (setq res ":-case")) + ((member tok '(":" "END" ";" "BEGIN" "VAR" "RECORD" "PROCEDURE")) + (setq res ":"))))) + res)) + +(defun m2-smie-refine-of () + (let ((tok (smie-default-backward-token))) + (when (zerop (length tok)) + (let ((forward-sexp-function nil)) + (condition-case nil + (backward-sexp 1) + (scan-error nil)) + (setq tok (smie-default-backward-token)))) + (if (member tok '("ARRAY" "SET")) + "OF-type" "OF"))) + +(defun m2-smie-refine-semi () + (forward-comment (point-max)) + (if (looking-at (regexp-opt '("PROCEDURE" "TYPE" "VAR" "CONST" "BEGIN"))) + ";-block" ";")) + +;; FIXME: "^." are two tokens, not one. +(defun m2-smie-forward-token () + (pcase (smie-default-forward-token) + (`"VAR" (if (zerop (car (syntax-ppss))) "VAR" "VAR-arg")) + (`"CONST" (if (zerop (car (syntax-ppss))) "CONST" "CONST-arg")) + (`";" (save-excursion (m2-smie-refine-semi))) + (`"OF" (save-excursion (forward-char -2) (m2-smie-refine-of))) + (`":" (save-excursion (forward-char -1) (m2-smie-refine-colon))) + ;; (`"END" (if (and (looking-at "[ \t\n]*\\(\\(?:\\sw\\|\\s_\\)+\\)") + ;; (not (assoc (match-string 1) m2-smie-grammar))) + ;; "END-proc" "END")) + (token token))) + +(defun m2-smie-backward-token () + (pcase (smie-default-backward-token) + (`"VAR" (if (zerop (car (syntax-ppss))) "VAR" "VAR-arg")) + (`"CONST" (if (zerop (car (syntax-ppss))) "CONST" "CONST-arg")) + (`";" (save-excursion (forward-char 1) (m2-smie-refine-semi))) + (`"OF" (save-excursion (m2-smie-refine-of))) + (`":" (save-excursion (m2-smie-refine-colon))) + ;; (`"END" (if (and (looking-at "\\sw+[ \t\n]+\\(\\(?:\\sw\\|\\s_\\)+\\)") + ;; (not (assoc (match-string 1) m2-smie-grammar))) + ;; "END-proc" "END")) + (token token))) + +(defun m2-smie-rules (kind token) + ;; FIXME: Apparently, the usual indentation convention is something like: + ;; + ;; TYPE t1 = bar; + ;; VAR x : INTEGER; + ;; PROCEDURE f (); + ;; TYPE t2 = foo; + ;; PROCEDURE g (); + ;; BEGIN blabla END; + ;; VAR y : type; + ;; BEGIN blibli END + ;; + ;; This is inconsistent with the actual structure of the code in 2 ways: + ;; - The inner VAR/TYPE are indented just like the outer VAR/TYPE. + ;; - The inner PROCEDURE is not aligned with its VAR/TYPE siblings. + (pcase (cons kind token) + (`(:elem . basic) m2-indent) + (`(:after . ":=") (or m2-indent smie-indent-basic)) + (`(:after . ,(or `"CONST" `"VAR" `"TYPE")) + (or m2-indent smie-indent-basic)) + ;; (`(:before . ,(or `"VAR" `"TYPE" `"CONST")) + ;; (if (smie-rule-parent-p "PROCEDURE") 0)) + (`(:after . ";-block") + (if (smie-rule-parent-p "PROCEDURE") + (smie-rule-parent (or m2-indent smie-indent-basic)))) + (`(:before . "|") (smie-rule-separator kind)) + )) ;;;###autoload -(defun modula-2-mode () +(defalias 'modula-2-mode 'm2-mode) +;;;###autoload +(define-derived-mode m2-mode prog-mode "Modula-2" "This is a mode intended to support program development in Modula-2. All control constructs of Modula-2 can be reached by typing C-c followed by the first character of the construct. @@ -134,46 +308,23 @@ followed by the first character of the construct. `m2-indent' controls the number of spaces for each indentation. `m2-compile-command' holds the command to compile a Modula-2 program. `m2-link-command' holds the command to link a Modula-2 program." - (interactive) - (kill-all-local-variables) - (use-local-map m2-mode-map) - (setq major-mode 'modula-2-mode) - (setq mode-name "Modula-2") - (make-local-variable 'comment-column) - (setq comment-column 41) (make-local-variable 'm2-end-comment-column) - (set-syntax-table m2-mode-syntax-table) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "$\\|" page-delimiter)) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate paragraph-start) - (make-local-variable 'paragraph-ignore-fill-prefix) - (setq paragraph-ignore-fill-prefix t) -; (make-local-variable 'indent-line-function) -; (setq indent-line-function 'c-indent-line) - (make-local-variable 'require-final-newline) - (setq require-final-newline mode-require-final-newline) - (make-local-variable 'comment-start) - (setq comment-start "(* ") - (make-local-variable 'comment-end) - (setq comment-end " *)") - (make-local-variable 'comment-column) - (setq comment-column 41) - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "/\\*+ *") - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'c-comment-indent) - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments t) - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults + + (set (make-local-variable 'paragraph-start) (concat "$\\|" page-delimiter)) + (set (make-local-variable 'paragraph-separate) paragraph-start) + (set (make-local-variable 'paragraph-ignore-fill-prefix) t) + (set (make-local-variable 'comment-start) "(* ") + (set (make-local-variable 'comment-end) " *)") + (set (make-local-variable 'comment-start-skip) "\\(?:(\\*+\\|//+\\) *") + (set (make-local-variable 'parse-sexp-ignore-comments) t) + (set (make-local-variable 'font-lock-defaults) '((m3-font-lock-keywords m3-font-lock-keywords-1 m3-font-lock-keywords-2) nil nil ((?_ . "w") (?. . "w") (?< . ". 1") (?> . ". 4")) nil - ;; Obsoleted by Emacs 19.35 parse-partial-sexp's COMMENTSTOP. - ;(font-lock-comment-start-regexp . "(\\*") )) - (run-mode-hooks 'm2-mode-hook)) + (smie-setup m2-smie-grammar #'m2-smie-rules + :forward-token #'m2-smie-forward-token + :backward-token #'m2-smie-backward-token)) ;; Regexps written with help from Ron Forrester <ron@orcad.com> ;; and Spencer Allain <sallain@teknowledge.com>. @@ -259,231 +410,131 @@ followed by the first character of the construct. (defvar m2-font-lock-keywords m2-font-lock-keywords-1 "Default expressions to highlight in Modula-2 modes.") -(defun m2-newline () - "Insert a newline and indent following line like previous line." - (interactive) - (let ((hpos (current-indentation))) - (newline) - (indent-to hpos))) - -(defun m2-tab () - "Indent to next tab stop." - (interactive) - (indent-to (* (1+ (/ (current-indentation) m2-indent)) m2-indent))) - -(defun m2-begin () +(define-skeleton m2-begin "Insert a BEGIN keyword and indent for the next line." - (interactive) - (insert "BEGIN") - (m2-newline) - (m2-tab)) + nil + \n "BEGIN" > \n) -(defun m2-case () +(define-skeleton m2-case "Build skeleton CASE statement, prompting for the <expression>." - (interactive) - (let ((name (read-string "Case-Expression: "))) - (insert "CASE " name " OF") - (m2-newline) - (m2-newline) - (insert "END (* case " name " *);")) - (end-of-line 0) - (m2-tab)) - -(defun m2-definition () + "Case-Expression: " + \n "CASE " str " OF" > \n _ \n "END (* " str " *);" > \n) + +(define-skeleton m2-definition "Build skeleton DEFINITION MODULE, prompting for the <module name>." - (interactive) - (insert "DEFINITION MODULE ") - (let ((name (read-string "Name: "))) - (insert name ";\n\n\n\nEND " name ".\n")) - (forward-line -3)) + "Name: " + \n "DEFINITION MODULE " str ";" > \n \n _ \n \n "END " str "." > \n) -(defun m2-else () +(define-skeleton m2-else "Insert ELSE keyword and indent for next line." - (interactive) - (m2-newline) - (backward-delete-char-untabify m2-indent ()) - (insert "ELSE") - (m2-newline) - (m2-tab)) + nil + \n "ELSE" > \n) -(defun m2-for () +(define-skeleton m2-for "Build skeleton FOR loop statement, prompting for the loop parameters." - (interactive) - (insert "FOR ") - (let ((name (read-string "Loop Initializer: ")) limit by) - (insert name " TO ") - (setq limit (read-string "Limit: ")) - (insert limit) - (setq by (read-string "Step: ")) + "Loop Initializer: " + ;; FIXME: this seems to be lacking a "<var> :=". + \n "FOR " str " TO " + (setq v1 (read-string "Limit: ")) + (let ((by (read-string "Step: "))) (if (not (string-equal by "")) - (insert " BY " by)) - (insert " DO") - (m2-newline) - (m2-newline) - (insert "END (* for " name " to " limit " *);")) - (end-of-line 0) - (m2-tab)) - -(defun m2-header () - "Insert a comment block containing the module title, author, etc." - (interactive) - (insert "(*\n Title: \t") - (insert (read-string "Title: ")) - (insert "\n Created:\t") - (insert (current-time-string)) - (insert "\n Author: \t") - (insert (user-full-name)) - (insert (concat "\n\t\t<" (user-login-name) "@" (system-name) ">\n")) - (insert "*)\n\n")) - -(defun m2-if () - "Insert skeleton IF statement, prompting for <boolean-expression>." - (interactive) - (insert "IF ") - (let ((thecondition (read-string "<boolean-expression>: "))) - (insert thecondition " THEN") - (m2-newline) - (m2-newline) - (insert "END (* if " thecondition " *);")) - (end-of-line 0) - (m2-tab)) - -(defun m2-loop () - "Build skeleton LOOP (with END)." - (interactive) - (insert "LOOP") - (m2-newline) - (m2-newline) - (insert "END (* loop *);") - (end-of-line 0) - (m2-tab)) - -(defun m2-module () - "Build skeleton IMPLEMENTATION MODULE, prompting for <module-name>." - (interactive) - (insert "IMPLEMENTATION MODULE ") - (let ((name (read-string "Name: "))) - (insert name ";\n\n\n\nEND " name ".\n") - (forward-line -3) - (m2-header) - (m2-type) - (newline) - (m2-var) - (newline) - (m2-begin) - (m2-begin-comment) - (insert " Module " name " Initialisation Code ")) - (m2-end-comment) - (newline) - (m2-tab)) - -(defun m2-or () - (interactive) - (m2-newline) - (backward-delete-char-untabify m2-indent) - (insert "|") - (m2-newline) - (m2-tab)) - -(defun m2-procedure () - (interactive) - (insert "PROCEDURE ") - (let ((name (read-string "Name: " )) - args) - (insert name " (") - (insert (read-string "Arguments: ") ")") - (setq args (read-string "Result Type: ")) - (if (not (string-equal args "")) - (insert " : " args)) - (insert ";") - (m2-newline) - (insert "BEGIN") - (m2-newline) - (m2-newline) - (insert "END ") - (insert name) - (insert ";") - (end-of-line 0) - (m2-tab))) - -(defun m2-with () - (interactive) - (insert "WITH ") - (let ((name (read-string "Record-Type: "))) - (insert name) - (insert " DO") - (m2-newline) - (m2-newline) - (insert "END (* with " name " *);")) - (end-of-line 0) - (m2-tab)) - -(defun m2-record () - (interactive) - (insert "RECORD") - (m2-newline) - (m2-newline) - (insert "END (* record *);") - (end-of-line 0) - (m2-tab)) - -(defun m2-stdio () - (interactive) - (insert " -FROM TextIO IMPORT - WriteCHAR, ReadCHAR, WriteINTEGER, ReadINTEGER, - WriteCARDINAL, ReadCARDINAL, WriteBOOLEAN, ReadBOOLEAN, - WriteREAL, ReadREAL, WriteBITSET, ReadBITSET, - WriteBasedCARDINAL, ReadBasedCARDINAL, WriteChars, ReadChars, - WriteString, ReadString, WhiteSpace, EndOfLine; - -FROM SysStreams IMPORT sysIn, sysOut, sysErr; + (concat " BY " by))) + " DO" > \n _ \n "END (* for " str " to " v1 " *);" > \n) -")) - -(defun m2-type () - (interactive) - (insert "TYPE") - (m2-newline) - (m2-tab)) +(define-skeleton m2-header + "Insert a comment block containing the module title, author, etc." + "Title: " + "(*\n Title: \t" str + "\n Created: \t" (current-time-string) + "\n Author: \t" (user-full-name) " <" user-mail-address ">\n" + "*)" > \n) -(defun m2-until () - (interactive) - (insert "REPEAT") - (m2-newline) - (m2-newline) - (insert "UNTIL ") - (insert (read-string "<boolean-expression>: ") ";") - (end-of-line 0) - (m2-tab)) - -(defun m2-var () - (interactive) - (m2-newline) - (insert "VAR") - (m2-newline) - (m2-tab)) +(define-skeleton m2-if + "Insert skeleton IF statement, prompting for <boolean-expression>." + "<boolean-expression>: " + \n "IF " str " THEN" > \n _ \n "END (* if " str " *);" > \n) -(defun m2-while () - (interactive) - (insert "WHILE ") - (let ((name (read-string "<boolean-expression>: "))) - (insert name " DO" ) - (m2-newline) - (m2-newline) - (insert "END (* while " name " *);")) - (end-of-line 0) - (m2-tab)) - -(defun m2-export () - (interactive) - (insert "EXPORT QUALIFIED ")) +(define-skeleton m2-loop + "Build skeleton LOOP (with END)." + nil + \n "LOOP" > \n _ \n "END (* loop *);" > \n) -(defun m2-import () - (interactive) - (insert "FROM ") - (insert (read-string "Module: ")) - (insert " IMPORT ")) +(define-skeleton m2-module + "Build skeleton IMPLEMENTATION MODULE, prompting for <module-name>." + "Name: " + \n "IMPLEMENTATION MODULE " str ";" > \n \n + '(m2-header) + '(m2-type) \n + '(m2-var) \n _ \n \n + '(m2-begin) + '(m2-begin-comment) + " Module " str " Initialisation Code " + '(m2-end-comment) + \n \n "END " str "." > \n) + +(define-skeleton m2-or + "No doc." + nil + \n "|" > \n) + +(define-skeleton m2-procedure + "No doc." + "Name: " + \n "PROCEDURE " str " (" (read-string "Arguments: ") ")" + (let ((args (read-string "Result Type: "))) + (if (not (equal args "")) (concat " : " args))) + ";" > \n "BEGIN" > \n _ \n "END " str ";" > \n) + +(define-skeleton m2-with + "No doc." + "Record-Type: " + \n "WITH " str " DO" > \n _ \n "END (* with " str " *);" > \n) + +(define-skeleton m2-record + "No doc." + nil + \n "RECORD" > \n _ \n "END (* record *);" > \n) + +(define-skeleton m2-stdio + "No doc." + nil + \n "FROM TextIO IMPORT" + > \n "WriteCHAR, ReadCHAR, WriteINTEGER, ReadINTEGER," + > \n "WriteCARDINAL, ReadCARDINAL, WriteBOOLEAN, ReadBOOLEAN," + > \n "WriteREAL, ReadREAL, WriteBITSET, ReadBITSET," + > \n "WriteBasedCARDINAL, ReadBasedCARDINAL, WriteChars, ReadChars," + > \n "WriteString, ReadString, WhiteSpace, EndOfLine;" + > \n \n "FROM SysStreams IMPORT sysIn, sysOut, sysErr;" > \n \n) + +(define-skeleton m2-type + "No doc." + nil + \n "TYPE" > \n ";" > \n) + +(define-skeleton m2-until + "No doc." + "<boolean-expression>: " + \n "REPEAT" > \n _ \n "UNTIL " str ";" > \n) + +(define-skeleton m2-var + "No doc." + nil + \n "VAR" > \n ";" > \n) + +(define-skeleton m2-while + "No doc." + "<boolean-expression>: " + \n "WHILE " str " DO" > \n _ \n "END (* while " str " *);" > \n) + +(define-skeleton m2-export + "No doc." + nil + \n "EXPORT QUALIFIED " > _ \n) + +(define-skeleton m2-import + "No doc." + "Module: " + \n "FROM " str " IMPORT " > _ \n) (defun m2-begin-comment () (interactive) @@ -503,15 +554,15 @@ FROM SysStreams IMPORT sysIn, sysOut, sysErr; (defun m2-link () (interactive) - (if m2-link-name - (compile (concat m2-link-command " " m2-link-name)) - (compile (concat m2-link-command " " - (setq m2-link-name (read-string "Name of executable: " - (buffer-name))))))) + (compile (concat m2-link-command " " + (or m2-link-name + (setq m2-link-name (read-string "Name of executable: " + (buffer-name))))))) (defun m2-execute-monitor-command (command) (let* ((shell shell-file-name) - (csh (equal (file-name-nondirectory shell) "csh"))) + ;; (csh (equal (file-name-nondirectory shell) "csh")) + ) (call-process shell nil t t "-cf" (concat "exec " command)))) (defun m2-visit () diff --git a/lisp/progmodes/octave-inf.el b/lisp/progmodes/octave-inf.el index 8e64d5689d1..c526a634d86 100644 --- a/lisp/progmodes/octave-inf.el +++ b/lisp/progmodes/octave-inf.el @@ -7,6 +7,7 @@ ;; Author: John Eaton <jwe@bevo.che.wisc.edu> ;; Maintainer: Kurt Hornik <Kurt.Hornik@wu-wien.ac.at> ;; Keywords: languages +;; Package: octave-mod ;; This file is part of GNU Emacs. diff --git a/lisp/progmodes/octave-mod.el b/lisp/progmodes/octave-mod.el index eb84be601de..cd2957f6180 100644 --- a/lisp/progmodes/octave-mod.el +++ b/lisp/progmodes/octave-mod.el @@ -1,10 +1,10 @@ ;;; octave-mod.el --- editing Octave source files under Emacs -;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. +;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, +;; 2009, 2010 Free Software Foundation, Inc. ;; Author: Kurt Hornik <Kurt.Hornik@wu-wien.ac.at> -;; Author: John Eaton <jwe@bevo.che.wisc.edu> +;; Author: John Eaton <jwe@octave.org> ;; Maintainer: Kurt Hornik <Kurt.Hornik@wu-wien.ac.at> ;; Keywords: languages @@ -92,7 +92,7 @@ All Octave abbrevs start with a grave accent (`)." (defvar octave-comment-char ?# "Character to start an Octave comment.") (defvar octave-comment-start - (string octave-comment-char ?\ ) + (string octave-comment-char ?\s) "String to insert to start a new Octave in-line comment.") (defvar octave-comment-start-skip "\\s<+\\s-*" "Regexp to match the start of an Octave comment up to its body.") @@ -161,8 +161,8 @@ parenthetical grouping.") (list ;; Fontify all builtin keywords. (cons (concat "\\<\\(" - (mapconcat 'identity octave-reserved-words "\\|") - (mapconcat 'identity octave-text-functions "\\|") + (regexp-opt (append octave-reserved-words + octave-text-functions)) "\\)\\>") 'font-lock-keyword-face) ;; Fontify all builtin operators. @@ -171,9 +171,7 @@ parenthetical grouping.") 'font-lock-builtin-face 'font-lock-preprocessor-face)) ;; Fontify all builtin variables. - (cons (concat "\\<\\(" - (mapconcat 'identity octave-variables "\\|") - "\\)\\>") + (cons (concat "\\<" (regexp-opt octave-variables) "\\>") 'font-lock-variable-name-face) ;; Fontify all function declarations. (list octave-function-header-regexp @@ -181,6 +179,29 @@ parenthetical grouping.") '(3 font-lock-function-name-face nil t))) "Additional Octave expressions to highlight.") +(defun octave-syntax-propertize-function (start end) + (goto-char start) + (octave-syntax-propertize-sqs end) + (funcall (syntax-propertize-rules + ;; Try to distinguish the string-quotes from the transpose-quotes. + ("[[({,; ]\\('\\)" + (1 (prog1 "\"'" (octave-syntax-propertize-sqs end))))) + (point) end)) + +(defun octave-syntax-propertize-sqs (end) + "Propertize the content/end of single-quote strings." + (when (eq (nth 3 (syntax-ppss)) ?\') + ;; A '..' string. + (when (re-search-forward + "\\(?:\\=\\|[^']\\)\\(?:''\\)*\\('\\)\\($\\|[^']\\)" end 'move) + (goto-char (match-beginning 2)) + (when (eq (char-before (match-beginning 1)) ?\\) + ;; Backslash cannot escape a single quote. + (put-text-property (1- (match-beginning 1)) (match-beginning 1) + 'syntax-table (string-to-syntax "."))) + (put-text-property (match-beginning 1) (match-end 1) + 'syntax-table (string-to-syntax "\"'"))))) + (defcustom inferior-octave-buffer "*Inferior Octave*" "Name of buffer for running an inferior Octave process." :type 'string @@ -191,29 +212,17 @@ parenthetical grouping.") (defvar octave-mode-map (let ((map (make-sparse-keymap))) (define-key map "`" 'octave-abbrev-start) - (define-key map ";" 'octave-electric-semi) - (define-key map " " 'octave-electric-space) - (define-key map "\n" 'octave-reindent-then-newline-and-indent) - (define-key map "\e;" 'octave-indent-for-comment) (define-key map "\e\n" 'octave-indent-new-comment-line) - (define-key map "\e\t" 'octave-complete-symbol) - (define-key map "\M-\C-a" 'octave-beginning-of-defun) - (define-key map "\M-\C-e" 'octave-end-of-defun) - (define-key map "\M-\C-h" 'octave-mark-defun) (define-key map "\M-\C-q" 'octave-indent-defun) - (define-key map "\C-c;" 'octave-comment-region) - (define-key map "\C-c:" 'octave-uncomment-region) (define-key map "\C-c\C-b" 'octave-submit-bug-report) (define-key map "\C-c\C-p" 'octave-previous-code-line) (define-key map "\C-c\C-n" 'octave-next-code-line) (define-key map "\C-c\C-a" 'octave-beginning-of-line) (define-key map "\C-c\C-e" 'octave-end-of-line) - (define-key map "\C-c\M-\C-n" 'octave-forward-block) - (define-key map "\C-c\M-\C-p" 'octave-backward-block) - (define-key map "\C-c\M-\C-u" 'octave-backward-up-block) - (define-key map "\C-c\M-\C-d" 'octave-down-block) + (define-key map [remap down-list] 'smie-down-list) (define-key map "\C-c\M-\C-h" 'octave-mark-block) - (define-key map "\C-c]" 'octave-close-block) + (define-key map "\C-c]" 'smie-close-block) + (define-key map "\C-c/" 'smie-close-block) (define-key map "\C-c\C-f" 'octave-insert-defun) (define-key map "\C-c\C-h" 'octave-help) (define-key map "\C-c\C-il" 'octave-send-line) @@ -234,7 +243,9 @@ parenthetical grouping.") "Keymap used in Octave mode.") -(defvar octave-mode-menu + +(easy-menu-define octave-mode-menu octave-mode-map + "Menu for Octave mode." '("Octave" ("Lines" ["Previous Code Line" octave-previous-code-line t] @@ -243,16 +254,9 @@ parenthetical grouping.") ["End of Continuation" octave-end-of-line t] ["Split Line at Point" octave-indent-new-comment-line t]) ("Blocks" - ["Next Block" octave-forward-block t] - ["Previous Block" octave-backward-block t] - ["Down Block" octave-down-block t] - ["Up Block" octave-backward-up-block t] ["Mark Block" octave-mark-block t] - ["Close Block" octave-close-block t]) + ["Close Block" smie-close-block t]) ("Functions" - ["Begin of Function" octave-beginning-of-defun t] - ["End of Function" octave-end-of-defun t] - ["Mark Function" octave-mark-defun t] ["Indent Function" octave-indent-defun t] ["Insert Function" octave-insert-defun t]) "-" @@ -266,16 +270,17 @@ parenthetical grouping.") ["Kill Process" octave-kill-process t]) "-" ["Indent Line" indent-according-to-mode t] - ["Complete Symbol" octave-complete-symbol t] + ["Complete Symbol" completion-at-point t] "-" - ["Toggle Abbrev Mode" abbrev-mode t] - ["Toggle Auto-Fill Mode" auto-fill-mode t] + ["Toggle Abbrev Mode" abbrev-mode + :style toggle :selected abbrev-mode] + ["Toggle Auto-Fill Mode" auto-fill-mode + :style toggle :selected auto-fill-function] "-" ["Submit Bug Report" octave-submit-bug-report t] "-" - ["Describe Octave Mode" octave-describe-major-mode t] - ["Lookup Octave Index" octave-help t]) - "Menu for Octave mode.") + ["Describe Octave Mode" describe-mode t] + ["Lookup Octave Index" info-lookup-symbol t])) (defvar octave-mode-syntax-table (let ((table (make-syntax-table))) @@ -297,62 +302,32 @@ parenthetical grouping.") (modify-syntax-entry ?\" "\"" table) (modify-syntax-entry ?. "w" table) (modify-syntax-entry ?_ "w" table) - (modify-syntax-entry ?\% "<" table) - (modify-syntax-entry ?\# "<" table) + ;; The "b" flag only applies to the second letter of the comstart + ;; and the first letter of the comend, i.e. the "4b" below is ineffective. + ;; If we try to put `b' on the single-line comments, we get a similar + ;; problem where the % and # chars appear as first chars of the 2-char + ;; comend, so the multi-line ender is also turned into style-b. + ;; So we need the new "c" comment style. + (modify-syntax-entry ?\% "< 13" table) + (modify-syntax-entry ?\# "< 13" table) + (modify-syntax-entry ?\{ "(} 2c" table) + (modify-syntax-entry ?\} "){ 4c" table) (modify-syntax-entry ?\n ">" table) table) "Syntax table in use in `octave-mode' buffers.") -(defcustom octave-auto-indent nil - "Non-nil means indent line after a semicolon or space in Octave mode." - :type 'boolean - :group 'octave) - -(defcustom octave-auto-newline nil - "Non-nil means automatically newline after a semicolon in Octave mode." - :type 'boolean - :group 'octave) - (defcustom octave-blink-matching-block t "Control the blinking of matching Octave block keywords. Non-nil means show matching begin of block when inserting a space, newline or semicolon after an else or end keyword." :type 'boolean :group 'octave) + (defcustom octave-block-offset 2 "Extra indentation applied to statements in Octave block structures." :type 'integer :group 'octave) -(defvar octave-block-begin-regexp - (concat "\\<\\(" - (mapconcat 'identity octave-begin-keywords "\\|") - "\\)\\>")) -(defvar octave-block-else-regexp - (concat "\\<\\(" - (mapconcat 'identity octave-else-keywords "\\|") - "\\)\\>")) -(defvar octave-block-end-regexp - (concat "\\<\\(" - (mapconcat 'identity octave-end-keywords "\\|") - "\\)\\>")) -(defvar octave-block-begin-or-end-regexp - (concat octave-block-begin-regexp "\\|" octave-block-end-regexp)) -(defvar octave-block-else-or-end-regexp - (concat octave-block-else-regexp "\\|" octave-block-end-regexp)) -(defvar octave-block-match-alist - '(("do" . ("until")) - ("for" . ("endfor" "end")) - ("function" . ("endfunction")) - ("if" . ("else" "elseif" "endif" "end")) - ("switch" . ("case" "otherwise" "endswitch" "end")) - ("try" . ("catch" "end_try_catch")) - ("unwind_protect" . ("unwind_protect_cleanup" "end_unwind_protect")) - ("while" . ("endwhile" "end"))) - "Alist with Octave's matching block keywords. -Has Octave's begin keywords as keys and a list of the matching else or -end keywords as associated values.") - (defvar octave-block-comment-start (concat (make-string 2 octave-comment-char) " ") "String to insert to start a new Octave comment on an empty line.") @@ -361,8 +336,11 @@ end keywords as associated values.") "Extra indentation applied to Octave continuation lines." :type 'integer :group 'octave) +(eval-and-compile + (defconst octave-continuation-marker-regexp "\\\\\\|\\.\\.\\.")) (defvar octave-continuation-regexp - "[^#%\n]*\\(\\\\\\|\\.\\.\\.\\)\\s-*\\(\\s<.*\\)?$") + (concat "[^#%\n]*\\(" octave-continuation-marker-regexp + "\\)\\s-*\\(\\s<.*\\)?$")) (defcustom octave-continuation-string "\\" "Character string used for Octave continuation lines. Normally \\." :type 'string @@ -400,8 +378,155 @@ Non-nil means always go to the next Octave code line after sending." :group 'octave) +;;; SMIE indentation + +(require 'smie) + +(defconst octave-operator-table + '((assoc ";" "\n") (assoc ",") ; The doc claims they have equal precedence!? + (right "=" "+=" "-=" "*=" "/=") + (assoc "&&") (assoc "||") ; The doc claims they have equal precedence!? + (assoc "&") (assoc "|") ; The doc claims they have equal precedence!? + (nonassoc "<" "<=" "==" ">=" ">" "!=" "~=") + (nonassoc ":") ;No idea what this is. + (assoc "+" "-") + (assoc "*" "/" "\\" ".\\" ".*" "./") + (nonassoc "'" ".'") + (nonassoc "++" "--" "!" "~") ;And unary "+" and "-". + (right "^" "**" ".^" ".**") + ;; It's not really an operator, but for indentation purposes it + ;; could be convenient to treat it as one. + (assoc "..."))) + +(defconst octave-smie-bnf-table + '((atom) + ;; We can't distinguish the first element in a sequence with + ;; precedence grammars, so we can't distinguish the condition + ;; if the `if' from the subsequent body, for example. + ;; This has to be done later in the indentation rules. + (exp (exp "\n" exp) + ;; We need to mention at least one of the operators in this part + ;; of the grammar: if the BNF and the operator table have + ;; no overlap, SMIE can't know how they relate. + (exp ";" exp) + ("try" exp "catch" exp "end_try_catch") + ("try" exp "catch" exp "end") + ("unwind_protect" exp + "unwind_protect_cleanup" exp "end_unwind_protect") + ("unwind_protect" exp "unwind_protect_cleanup" exp "end") + ("for" exp "endfor") + ("for" exp "end") + ("do" exp "until" atom) + ("while" exp "endwhile") + ("while" exp "end") + ("if" exp "endif") + ("if" exp "else" exp "endif") + ("if" exp "elseif" exp "else" exp "endif") + ("if" exp "elseif" exp "elseif" exp "else" exp "endif") + ("if" exp "elseif" exp "elseif" exp "else" exp "end") + ("switch" exp "case" exp "endswitch") + ("switch" exp "case" exp "otherwise" exp "endswitch") + ("switch" exp "case" exp "case" exp "otherwise" exp "endswitch") + ("switch" exp "case" exp "case" exp "otherwise" exp "end") + ("function" exp "endfunction") + ("function" exp "end")) + ;; (fundesc (atom "=" atom)) + )) + +(defconst octave-smie-grammar + (smie-prec2->grammar + (smie-merge-prec2s + (smie-bnf->prec2 octave-smie-bnf-table + '((assoc "\n" ";"))) + + (smie-precs->prec2 octave-operator-table)))) + +;; Tokenizing needs to be refined so that ";;" is treated as two +;; tokens and also so as to recognize the \n separator (and +;; corresponding continuation lines). + +(defconst octave-operator-regexp + (regexp-opt (apply 'append (mapcar 'cdr octave-operator-table)))) + +(defun octave-smie-backward-token () + (let ((pos (point))) + (forward-comment (- (point))) + (cond + ((and (not (eq (char-before) ?\;)) ;Coalesce ";" and "\n". + (> pos (line-end-position)) + (if (looking-back octave-continuation-marker-regexp (- (point) 3)) + (progn + (goto-char (match-beginning 0)) + (forward-comment (- (point))) + nil) + t) + ;; Ignore it if it's within parentheses. + (let ((ppss (syntax-ppss))) + (not (and (nth 1 ppss) + (eq ?\( (char-after (nth 1 ppss))))))) + (skip-chars-forward " \t") + ;; Why bother distinguishing \n and ;? + ";") ;;"\n" + ((and (looking-back octave-operator-regexp (- (point) 3) 'greedy) + ;; Don't mistake a string quote for a transpose. + (not (looking-back "\\s\"" (1- (point))))) + (goto-char (match-beginning 0)) + (match-string-no-properties 0)) + (t + (smie-default-backward-token))))) + +(defun octave-smie-forward-token () + (skip-chars-forward " \t") + (when (looking-at (eval-when-compile + (concat "\\(" octave-continuation-marker-regexp + "\\)[ \t]*\\($\\|[%#]\\)"))) + (goto-char (match-end 1)) + (forward-comment 1)) + (cond + ((and (looking-at "$\\|[%#]") + ;; Ignore it if it's within parentheses. + (prog1 (let ((ppss (syntax-ppss))) + (not (and (nth 1 ppss) + (eq ?\( (char-after (nth 1 ppss)))))) + (forward-comment (point-max)))) + ;; Why bother distinguishing \n and ;? + ";") ;;"\n" + ((looking-at ";[ \t]*\\($\\|[%#]\\)") + ;; Combine the ; with the subsequent \n. + (goto-char (match-beginning 1)) + (forward-comment 1) + ";") + ((and (looking-at octave-operator-regexp) + ;; Don't mistake a string quote for a transpose. + (not (looking-at "\\s\""))) + (goto-char (match-end 0)) + (match-string-no-properties 0)) + (t + (smie-default-forward-token)))) + +(defun octave-smie-rules (kind token) + (pcase (cons kind token) + ;; We could set smie-indent-basic instead, but that would have two + ;; disadvantages: + ;; - changes to octave-block-offset wouldn't take effect immediately. + ;; - edebug wouldn't show the use of this variable. + (`(:elem . basic) octave-block-offset) + ;; Since "case" is in the same BNF rules as switch..end, SMIE by default + ;; aligns it with "switch". + (`(:before . "case") (if (not (smie-rule-sibling-p)) octave-block-offset)) + (`(:after . ";") + (if (smie-rule-parent-p "function" "if" "while" "else" "elseif" "for" + "otherwise" "case" "try" "catch" "unwind_protect" + "unwind_protect_cleanup") + (smie-rule-parent octave-block-offset) + ;; For (invalid) code between switch and case. + ;; (if (smie-parent-p "switch") 4) + 0)))) + +(defvar electric-layout-rules) + ;;;###autoload -(defun octave-mode () +(define-derived-mode octave-mode prog-mode "Octave" "Major mode for editing Octave code. This mode makes it easier to write Octave code by helping with @@ -429,14 +554,6 @@ Keybindings Variables you can use to customize Octave mode ============================================== -`octave-auto-indent' - Non-nil means indent current line after a semicolon or space. - Default is nil. - -`octave-auto-newline' - Non-nil means auto-insert a newline and indent after a semicolon. - Default is nil. - `octave-blink-matching-block' Non-nil means show matching begin of block when inserting a space, newline or semicolon after an else or end keyword. Default is t. @@ -484,57 +601,65 @@ an Octave mode buffer. This automatically sets up a mail buffer with version information already added. You just need to add a description of the problem, including a reproducible test case and send the message." - (interactive) - (kill-all-local-variables) - - (use-local-map octave-mode-map) - (setq major-mode 'octave-mode) - (setq mode-name "Octave") (setq local-abbrev-table octave-abbrev-table) - (set-syntax-table octave-mode-syntax-table) - - (make-local-variable 'indent-line-function) - (setq indent-line-function 'octave-indent-line) - - (make-local-variable 'comment-start) - (setq comment-start octave-comment-start) - (make-local-variable 'comment-end) - (setq comment-end "") - (make-local-variable 'comment-column) - (setq comment-column 32) - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "\\s<+\\s-*") - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'octave-comment-indent) - - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments t) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "\\s-*$\\|" page-delimiter)) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate paragraph-start) - (make-local-variable 'paragraph-ignore-fill-prefix) - (setq paragraph-ignore-fill-prefix t) - (make-local-variable 'fill-paragraph-function) - (setq fill-paragraph-function 'octave-fill-paragraph) - (make-local-variable 'adaptive-fill-regexp) - (setq adaptive-fill-regexp nil) - (make-local-variable 'fill-column) - (setq fill-column 72) - (make-local-variable 'normal-auto-fill-function) - (setq normal-auto-fill-function 'octave-auto-fill) - - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults '(octave-font-lock-keywords nil nil)) - - (make-local-variable 'imenu-generic-expression) - (setq imenu-generic-expression octave-mode-imenu-generic-expression - imenu-case-fold-search nil) - - (octave-add-octave-menu) + + (smie-setup octave-smie-grammar #'octave-smie-rules + :forward-token #'octave-smie-forward-token + :backward-token #'octave-smie-backward-token) + (set (make-local-variable 'smie-indent-basic) 'octave-block-offset) + + (set (make-local-variable 'smie-blink-matching-triggers) + (cons ?\; smie-blink-matching-triggers)) + (unless octave-blink-matching-block + (remove-hook 'post-self-insert-hook #'smie-blink-matching-open 'local)) + + (set (make-local-variable 'electric-indent-chars) + (cons ?\; electric-indent-chars)) + ;; IIUC matlab-mode takes the opposite approach: it makes RET insert + ;; a ";" at those places where it's correct (i.e. outside of parens). + (set (make-local-variable 'electric-layout-rules) '((?\; . after))) + + (set (make-local-variable 'comment-start) octave-comment-start) + (set (make-local-variable 'comment-end) "") + ;; Don't set it here: it's not really a property of the language, + ;; just a personal preference of the author. + ;; (set (make-local-variable 'comment-column) 32) + (set (make-local-variable 'comment-start-skip) "\\s<+\\s-*") + (set (make-local-variable 'comment-add) 1) + + (set (make-local-variable 'parse-sexp-ignore-comments) t) + (set (make-local-variable 'paragraph-start) + (concat "\\s-*$\\|" page-delimiter)) + (set (make-local-variable 'paragraph-separate) paragraph-start) + (set (make-local-variable 'paragraph-ignore-fill-prefix) t) + (set (make-local-variable 'fill-paragraph-function) 'octave-fill-paragraph) + ;; FIXME: Why disable it? + ;; (set (make-local-variable 'adaptive-fill-regexp) nil) + ;; Again, this is not a property of the language, don't set it here. + ;; (set (make-local-variable 'fill-column) 72) + (set (make-local-variable 'normal-auto-fill-function) 'octave-auto-fill) + + (set (make-local-variable 'font-lock-defaults) + '(octave-font-lock-keywords)) + + (set (make-local-variable 'syntax-propertize-function) + #'octave-syntax-propertize-function) + + (set (make-local-variable 'imenu-generic-expression) + octave-mode-imenu-generic-expression) + (set (make-local-variable 'imenu-case-fold-search) nil) + + (add-hook 'completion-at-point-functions + 'octave-completion-at-point-function nil t) + (set (make-local-variable 'beginning-of-defun-function) + 'octave-beginning-of-defun) + + (easy-menu-add octave-mode-menu) (octave-initialize-completions) (run-mode-hooks 'octave-mode-hook)) +(defvar info-lookup-mode) + (defun octave-help () "Get help on Octave symbols from the Octave info files. Look up symbol in the function, operator and variable indices of the info files." @@ -542,74 +667,31 @@ Look up symbol in the function, operator and variable indices of the info files. (call-interactively 'info-lookup-symbol))) ;;; Miscellaneous useful functions -(defun octave-describe-major-mode () - "Describe the current major mode." - (interactive) - (describe-function major-mode)) (defsubst octave-in-comment-p () "Return t if point is inside an Octave comment." - (interactive) (save-excursion + ;; FIXME: use syntax-ppss? (nth 4 (parse-partial-sexp (line-beginning-position) (point))))) (defsubst octave-in-string-p () "Return t if point is inside an Octave string." - (interactive) (save-excursion + ;; FIXME: use syntax-ppss? (nth 3 (parse-partial-sexp (line-beginning-position) (point))))) (defsubst octave-not-in-string-or-comment-p () "Return t if point is not inside an Octave string or comment." + ;; FIXME: Use syntax-ppss? (let ((pps (parse-partial-sexp (line-beginning-position) (point)))) (not (or (nth 3 pps) (nth 4 pps))))) -(defun octave-in-block-p () - "Return t if point is inside an Octave block. -The block is taken to start at the first letter of the begin keyword and -to end after the end keyword." - (let ((pos (point))) - (save-excursion - (condition-case nil - (progn - (skip-syntax-forward "w") - (octave-up-block -1) - (octave-forward-block) - t) - (error nil)) - (< pos (point))))) (defun octave-looking-at-kw (regexp) "Like `looking-at', but sets `case-fold-search' nil." (let ((case-fold-search nil)) (looking-at regexp))) -(defun octave-re-search-forward-kw (regexp count) - "Like `re-search-forward', but sets `case-fold-search' nil, and moves point." - (let ((case-fold-search nil)) - (re-search-forward regexp nil 'move count))) - -(defun octave-re-search-backward-kw (regexp count) - "Like `re-search-backward', but sets `case-fold-search' nil, and moves point." - (let ((case-fold-search nil)) - (re-search-backward regexp nil 'move count))) - -(defun octave-in-defun-p () - "Return t if point is inside an Octave function declaration. -The function is taken to start at the `f' of `function' and to end after -the end keyword." - (let ((pos (point))) - (save-excursion - (or (and (octave-looking-at-kw "\\<function\\>") - (octave-not-in-string-or-comment-p)) - (and (octave-beginning-of-defun) - (condition-case nil - (progn - (octave-forward-block) - t) - (error nil)) - (< pos (point))))))) - (defun octave-maybe-insert-continuation-string () (if (or (octave-in-comment-p) (save-excursion @@ -619,147 +701,8 @@ the end keyword." (delete-horizontal-space) (insert (concat " " octave-continuation-string)))) -;;; Comments -(defun octave-comment-region (beg end &optional arg) - "Comment or uncomment each line in the region as Octave code. -See `comment-region'." - (interactive "r\nP") - (let ((comment-start (char-to-string octave-comment-char))) - (comment-region beg end arg))) - -(defun octave-uncomment-region (beg end &optional arg) - "Uncomment each line in the region as Octave code." - (interactive "r\nP") - (or arg (setq arg 1)) - (octave-comment-region beg end (- arg))) - ;;; Indentation -(defun calculate-octave-indent () - "Return appropriate indentation for current line as Octave code. -Returns an integer (the column to indent to) unless the line is a -comment line with fixed goal golumn. In that case, returns a list whose -car is the column to indent to, and whose cdr is the current indentation -level." - (let ((is-continuation-line - (save-excursion - (if (zerop (octave-previous-code-line)) - (looking-at octave-continuation-regexp)))) - (icol 0)) - (save-excursion - (beginning-of-line) - ;; If we can move backward out one level of parentheses, take 1 - ;; plus the indentation of that parenthesis. Otherwise, go back - ;; to the beginning of the previous code line, and compute the - ;; offset this line gives. - (if (condition-case nil - (progn - (up-list -1) - t) - (error nil)) - (setq icol (+ 1 (current-column))) - (if (zerop (octave-previous-code-line)) - (progn - (octave-beginning-of-line) - (back-to-indentation) - (setq icol (current-column)) - (let ((bot (point)) - (eol (line-end-position))) - (while (< (point) eol) - (if (octave-not-in-string-or-comment-p) - (cond - ((octave-looking-at-kw "\\<switch\\>") - (setq icol (+ icol (* 2 octave-block-offset)))) - ((octave-looking-at-kw octave-block-begin-regexp) - (setq icol (+ icol octave-block-offset))) - ((octave-looking-at-kw octave-block-else-regexp) - (if (= bot (point)) - (setq icol (+ icol octave-block-offset)))) - ((octave-looking-at-kw octave-block-end-regexp) - (if (and (not (= bot (point))) - ;; special case for `end' keyword, - ;; applied to all keywords - (not (octave-end-as-array-index-p))) - (setq icol (- icol - (octave-block-end-offset))))))) - (forward-char))) - (if is-continuation-line - (setq icol (+ icol octave-continuation-offset))))))) - (save-excursion - (back-to-indentation) - (cond - ((and (octave-looking-at-kw octave-block-else-regexp) - (octave-not-in-string-or-comment-p)) - (setq icol (- icol octave-block-offset))) - ((and (octave-looking-at-kw octave-block-end-regexp) - (octave-not-in-string-or-comment-p)) - (setq icol (- icol (octave-block-end-offset)))) - ((or (looking-at "\\s<\\s<\\s<\\S<") - (octave-before-magic-comment-p)) - (setq icol (list 0 icol))) - ((looking-at "\\s<\\S<") - (setq icol (list comment-column icol))))) - icol)) - -;; FIXME: this should probably also make sure we are actually looking -;; at the "end" keyword. -(defun octave-end-as-array-index-p () - (save-excursion - (condition-case nil - ;; Check if point is between parens - (progn (up-list 1) t) - (error nil)))) - -(defun octave-block-end-offset () - (save-excursion - (octave-backward-up-block 1) - (* octave-block-offset - (if (string-match (match-string 0) "switch") 2 1)))) - -(defun octave-before-magic-comment-p () - (save-excursion - (beginning-of-line) - (and (bobp) (looking-at "\\s-*#!")))) - -(defun octave-comment-indent () - (if (or (looking-at "\\s<\\s<\\s<") - (octave-before-magic-comment-p)) - 0 - (if (looking-at "\\s<\\s<") - (calculate-octave-indent) - (skip-syntax-backward " ") - (max (if (bolp) 0 (+ 1 (current-column))) - comment-column)))) - -(defun octave-indent-for-comment () - "Maybe insert and indent an Octave comment. -If there is no comment already on this line, create a code-level comment -\(started by two comment characters) if the line is empty, or an in-line -comment (started by one comment character) otherwise. -Point is left after the start of the comment which is properly aligned." - (interactive) - (beginning-of-line) - (if (looking-at "^\\s-*$") - (insert octave-block-comment-start) - (indent-for-comment)) - (indent-according-to-mode)) - -(defun octave-indent-line (&optional arg) - "Indent current line as Octave code. -With optional ARG, use this as offset unless this line is a comment with -fixed goal column." - (interactive) - (or arg (setq arg 0)) - (let ((icol (calculate-octave-indent)) - (relpos (- (current-column) (current-indentation)))) - (if (listp icol) - (setq icol (car icol)) - (setq icol (+ icol arg))) - (if (< icol 0) - (error "Unmatched end keyword") - (indent-line-to icol) - (if (> relpos 0) - (move-to-column (+ icol relpos)))))) (defun octave-indent-new-comment-line () "Break Octave line at point, continuing comment if within one. @@ -775,13 +718,13 @@ The new line is properly indented." (error "Cannot split a code line inside a string")) (t (insert (concat " " octave-continuation-string)) - (octave-reindent-then-newline-and-indent)))) + (reindent-then-newline-and-indent)))) (defun octave-indent-defun () "Properly indent the Octave function which contains point." (interactive) (save-excursion - (octave-mark-defun) + (mark-defun) (message "Indenting function...") (indent-region (point) (mark) nil)) (message "Indenting function...done.")) @@ -861,193 +804,33 @@ does not end in `...' or `\\' or is inside an open parenthesis list." (zerop (forward-line 1))))) (end-of-line))) -(defun octave-scan-blocks (count depth) - "Scan from point by COUNT Octave begin-end blocks. -Returns the character number of the position thus found. - -If DEPTH is nonzero, block depth begins counting from that value. -Only places where the depth in blocks becomes zero are candidates for -stopping; COUNT such places are counted. - -If the beginning or end of the buffer is reached and the depth is wrong, -an error is signaled." - (let ((min-depth (if (> depth 0) 0 depth)) - (inc (if (> count 0) 1 -1))) - (save-excursion - (while (/= count 0) - (catch 'foo - (while (or (octave-re-search-forward-kw - octave-block-begin-or-end-regexp inc) - (if (/= depth 0) - (error "Unbalanced block"))) - (if (octave-not-in-string-or-comment-p) - (progn - (cond - ((match-end 1) - (setq depth (+ depth inc))) - ((match-end 2) - (setq depth (- depth inc)))) - (if (< depth min-depth) - (error "Containing expression ends prematurely")) - (if (= depth 0) - (throw 'foo nil)))))) - (setq count (- count inc))) - (point)))) - -(defun octave-forward-block (&optional arg) - "Move forward across one balanced Octave begin-end block. -With argument, do it that many times. -Negative arg -N means move backward across N blocks." - (interactive "p") - (or arg (setq arg 1)) - (goto-char (or (octave-scan-blocks arg 0) (buffer-end arg)))) - -(defun octave-backward-block (&optional arg) - "Move backward across one balanced Octave begin-end block. -With argument, do it that many times. -Negative arg -N means move forward across N blocks." - (interactive "p") - (or arg (setq arg 1)) - (octave-forward-block (- arg))) - -(defun octave-down-block (arg) - "Move forward down one begin-end block level of Octave code. -With argument, do this that many times. -A negative argument means move backward but still go down a level. -In Lisp programs, an argument is required." - (interactive "p") - (let ((inc (if (> arg 0) 1 -1))) - (while (/= arg 0) - (goto-char (or (octave-scan-blocks inc -1) - (buffer-end arg))) - (setq arg (- arg inc))))) - -(defun octave-backward-up-block (arg) - "Move backward out of one begin-end block level of Octave code. -With argument, do this that many times. -A negative argument means move forward but still to a less deep spot. -In Lisp programs, an argument is required." - (interactive "p") - (octave-up-block (- arg))) - -(defun octave-up-block (arg) - "Move forward out of one begin-end block level of Octave code. -With argument, do this that many times. -A negative argument means move backward but still to a less deep spot. -In Lisp programs, an argument is required." - (interactive "p") - (let ((inc (if (> arg 0) 1 -1))) - (while (/= arg 0) - (goto-char (or (octave-scan-blocks inc 1) - (buffer-end arg))) - (setq arg (- arg inc))))) - (defun octave-mark-block () "Put point at the beginning of this Octave block, mark at the end. The block marked is the one that contains point or follows point." (interactive) - (let ((pos (point))) - (if (or (and (octave-in-block-p) - (skip-syntax-forward "w")) - (condition-case nil - (progn - (octave-down-block 1) - (octave-in-block-p)) - (error nil))) - (progn - (octave-up-block -1) - (push-mark (point)) - (octave-forward-block) - (exchange-point-and-mark)) - (goto-char pos) - (message "No block to mark found")))) - -(defun octave-close-block () - "Close the current Octave block on a separate line. -An error is signaled if no block to close is found." - (interactive) - (let (bb-keyword) - (condition-case nil - (progn - (save-excursion - (octave-backward-up-block 1) - (setq bb-keyword (buffer-substring-no-properties - (match-beginning 1) (match-end 1)))) - (if (save-excursion - (beginning-of-line) - (looking-at "^\\s-*$")) - (indent-according-to-mode) - (octave-reindent-then-newline-and-indent)) - (insert (car (reverse - (assoc bb-keyword - octave-block-match-alist)))) - (octave-reindent-then-newline-and-indent) - t) - (error (message "No block to close found"))))) - -(defun octave-blink-matching-block-open () - "Blink the matching Octave begin block keyword. -If point is right after an Octave else or end type block keyword, move -cursor momentarily to the corresponding begin keyword. -Signal an error if the keywords are incompatible." - (interactive) - (let (bb-keyword bb-arg eb-keyword pos eol) - (if (and (octave-not-in-string-or-comment-p) - (looking-at "\\>") - (save-excursion - (skip-syntax-backward "w") - (octave-looking-at-kw octave-block-else-or-end-regexp))) - (save-excursion - (cond - ((match-end 1) - (setq eb-keyword - (buffer-substring-no-properties - (match-beginning 1) (match-end 1))) - (octave-backward-up-block 1)) - ((match-end 2) - (setq eb-keyword - (buffer-substring-no-properties - (match-beginning 2) (match-end 2))) - (octave-backward-block))) - (setq pos (match-end 0) - bb-keyword - (buffer-substring-no-properties - (match-beginning 0) pos) - pos (+ pos 1) - eol (line-end-position) - bb-arg - (save-excursion - (save-restriction - (goto-char pos) - (while (and (skip-syntax-forward "^<" eol) - (octave-in-string-p) - (not (forward-char 1)))) - (skip-syntax-backward " ") - (buffer-substring-no-properties pos (point))))) - (if (member eb-keyword - (cdr (assoc bb-keyword octave-block-match-alist))) - (progn - (message "Matches `%s %s'" bb-keyword bb-arg) - (if (pos-visible-in-window-p) - (sit-for blink-matching-delay))) - (error "Block keywords `%s' and `%s' do not match" - bb-keyword eb-keyword)))))) + (unless (or (looking-at "\\s(") + (save-excursion + (let* ((token (funcall smie-forward-token-function)) + (level (assoc token smie-grammar))) + (and level (null (cadr level)))))) + (backward-up-list 1)) + (mark-sexp)) (defun octave-beginning-of-defun (&optional arg) "Move backward to the beginning of an Octave function. With positive ARG, do it that many times. Negative argument -N means move forward to Nth following beginning of a function. Returns t unless search stops at the beginning or end of the buffer." - (interactive "p") (let* ((arg (or arg 1)) (inc (if (> arg 0) 1 -1)) - (found)) + (found nil) + (case-fold-search nil)) (and (not (eobp)) - (not (and (> arg 0) (octave-looking-at-kw "\\<function\\>"))) + (not (and (> arg 0) (looking-at "\\<function\\>"))) (skip-syntax-forward "w")) (while (and (/= arg 0) (setq found - (octave-re-search-backward-kw "\\<function\\>" inc))) + (re-search-backward "\\<function\\>" inc))) (if (octave-not-in-string-or-comment-p) (setq arg (- arg inc)))) (if found @@ -1055,40 +838,6 @@ Returns t unless search stops at the beginning or end of the buffer." (and (< inc 0) (goto-char (match-beginning 0))) t)))) -(defun octave-end-of-defun (&optional arg) - "Move forward to the end of an Octave function. -With positive ARG, do it that many times. Negative argument -N means -move back to Nth preceding end of a function. - -An end of a function occurs right after the end keyword matching the -`function' keyword that starts the function." - (interactive "p") - (or arg (setq arg 1)) - (and (< arg 0) (skip-syntax-backward "w")) - (and (> arg 0) (skip-syntax-forward "w")) - (if (octave-in-defun-p) - (setq arg (- arg 1))) - (if (= arg 0) (setq arg -1)) - (if (octave-beginning-of-defun (- arg)) - (octave-forward-block))) - -(defun octave-mark-defun () - "Put point at the beginning of this Octave function, mark at its end. -The function marked is the one containing point or following point." - (interactive) - (let ((pos (point))) - (if (or (octave-in-defun-p) - (and (octave-beginning-of-defun -1) - (octave-in-defun-p))) - (progn - (skip-syntax-forward "w") - (octave-beginning-of-defun) - (push-mark (point)) - (octave-end-of-defun) - (exchange-point-and-mark)) - (goto-char pos) - (message "No function to mark found")))) - ;;; Filling (defun octave-auto-fill () @@ -1153,81 +902,73 @@ otherwise." (not give-up)))) (defun octave-fill-paragraph (&optional arg) - "Fill paragraph of Octave code, handling Octave comments." - ;; FIXME: now that the default fill-paragraph takes care of similar issues, - ;; this seems obsolete. --Stef - (interactive "P") - (save-excursion - (let ((end (progn (forward-paragraph) (point))) - (beg (progn - (forward-paragraph -1) - (skip-chars-forward " \t\n") - (beginning-of-line) - (point))) - (cfc (current-fill-column)) - (ind (calculate-octave-indent)) - comment-prefix) - (save-restriction - (goto-char beg) - (narrow-to-region beg end) - (if (listp ind) (setq ind (nth 1 ind))) - (while (not (eobp)) - (condition-case nil - (octave-indent-line ind) - (error nil)) - (if (and (> ind 0) - (not - (save-excursion - (beginning-of-line) - (looking-at "^\\s-*\\($\\|\\s<+\\)")))) - (setq ind 0)) - (move-to-column cfc) - ;; First check whether we need to combine non-empty comment lines - (if (and (< (current-column) cfc) - (octave-in-comment-p) - (not (save-excursion - (beginning-of-line) - (looking-at "^\\s-*\\s<+\\s-*$")))) - ;; This is a nonempty comment line which does not extend - ;; past the fill column. If it is followed by a nonempty - ;; comment line with the same comment prefix, try to - ;; combine them, and repeat this until either we reach the - ;; fill-column or there is nothing more to combine. - (progn - ;; Get the comment prefix - (save-excursion - (beginning-of-line) - (while (and (re-search-forward "\\s<+") - (not (octave-in-comment-p)))) - (setq comment-prefix (match-string 0))) - ;; And keep combining ... - (while (and (< (current-column) cfc) - (save-excursion - (forward-line 1) - (and (looking-at - (concat "^\\s-*" - comment-prefix - "\\S<")) - (not (looking-at - (concat "^\\s-*" - comment-prefix - "\\s-*$")))))) - (delete-char 1) - (re-search-forward comment-prefix) - (delete-region (match-beginning 0) (match-end 0)) - (fixup-whitespace) - (move-to-column cfc)))) - ;; We might also try to combine continued code lines> Perhaps - ;; some other time ... - (skip-chars-forward "^ \t\n") - (delete-horizontal-space) - (if (or (< (current-column) cfc) - (and (= (current-column) cfc) (eolp))) - (forward-line 1) - (if (not (eolp)) (insert " ")) - (or (octave-auto-fill) - (forward-line 1))))) - t))) + "Fill paragraph of Octave code, handling Octave comments." + ;; FIXME: difference with generic fill-paragraph: + ;; - code lines are only split, never joined. + ;; - \n that end comments are never removed. + ;; - insert continuation marker when splitting code lines. + (interactive "P") + (save-excursion + (let ((end (progn (forward-paragraph) (copy-marker (point) t))) + (beg (progn + (forward-paragraph -1) + (skip-chars-forward " \t\n") + (beginning-of-line) + (point))) + (cfc (current-fill-column)) + comment-prefix) + (goto-char beg) + (while (< (point) end) + (condition-case nil + (indent-according-to-mode) + (error nil)) + (move-to-column cfc) + ;; First check whether we need to combine non-empty comment lines + (if (and (< (current-column) cfc) + (octave-in-comment-p) + (not (save-excursion + (beginning-of-line) + (looking-at "^\\s-*\\s<+\\s-*$")))) + ;; This is a nonempty comment line which does not extend + ;; past the fill column. If it is followed by a nonempty + ;; comment line with the same comment prefix, try to + ;; combine them, and repeat this until either we reach the + ;; fill-column or there is nothing more to combine. + (progn + ;; Get the comment prefix + (save-excursion + (beginning-of-line) + (while (and (re-search-forward "\\s<+") + (not (octave-in-comment-p)))) + (setq comment-prefix (match-string 0))) + ;; And keep combining ... + (while (and (< (current-column) cfc) + (save-excursion + (forward-line 1) + (and (looking-at + (concat "^\\s-*" + comment-prefix + "\\S<")) + (not (looking-at + (concat "^\\s-*" + comment-prefix + "\\s-*$")))))) + (delete-char 1) + (re-search-forward comment-prefix) + (delete-region (match-beginning 0) (match-end 0)) + (fixup-whitespace) + (move-to-column cfc)))) + ;; We might also try to combine continued code lines> Perhaps + ;; some other time ... + (skip-chars-forward "^ \t\n") + (delete-horizontal-space) + (if (or (< (current-column) cfc) + (and (= (current-column) cfc) (eolp))) + (forward-line 1) + (if (not (eolp)) (insert " ")) + (or (octave-auto-fill) + (forward-line 1)))) + t))) ;;; Completions @@ -1236,72 +977,28 @@ otherwise." (if octave-completion-alist () (setq octave-completion-alist - (mapcar '(lambda (var) (cons var var)) - (append octave-reserved-words - octave-text-functions - octave-variables))))) + (append octave-reserved-words + octave-text-functions + octave-variables)))) + +(defun octave-completion-at-point-function () + "Find the text to complete and the corresponding table." + (let* ((beg (save-excursion (backward-sexp 1) (point))) + (end (point))) + (if (< beg (point)) + ;; Extend region past point, if applicable. + (save-excursion (goto-char beg) (forward-sexp 1) + (setq end (max end (point))))) + (list beg end octave-completion-alist))) (defun octave-complete-symbol () "Perform completion on Octave symbol preceding point. Compare that symbol against Octave's reserved words and builtin variables." (interactive) - (let* ((end (point)) - (beg (save-excursion (backward-sexp 1) (point)))) - (completion-in-region beg end octave-completion-alist))) - + (apply 'completion-in-region (octave-completion-at-point-function))) ;;; Electric characters && friends -(defun octave-reindent-then-newline-and-indent () - "Reindent current Octave line, insert newline, and indent the new line. -If Abbrev mode is on, expand abbrevs first." - (interactive) - (if abbrev-mode (expand-abbrev)) - (if octave-blink-matching-block - (octave-blink-matching-block-open)) - (save-excursion - (delete-region (point) (progn (skip-chars-backward " \t") (point))) - (indent-according-to-mode)) - (insert "\n") - (indent-according-to-mode)) - -(defun octave-electric-semi () - "Insert a semicolon in Octave mode. -Maybe expand abbrevs and blink matching block open keywords. -Reindent the line if `octave-auto-indent' is non-nil. -Insert a newline if `octave-auto-newline' is non-nil." - (interactive) - (if (not (octave-not-in-string-or-comment-p)) - (insert ";") - (if abbrev-mode (expand-abbrev)) - (if octave-blink-matching-block - (octave-blink-matching-block-open)) - (if octave-auto-indent - (indent-according-to-mode)) - (insert ";") - (if octave-auto-newline - (newline-and-indent)))) - -(defun octave-electric-space () - "Insert a space in Octave mode. -Maybe expand abbrevs and blink matching block open keywords. -Reindent the line if `octave-auto-indent' is non-nil." - (interactive) - (setq last-command-event ? ) - (if (and octave-auto-indent - (not (octave-not-in-string-or-comment-p))) - (progn - (indent-according-to-mode) - (self-insert-command 1)) - (if abbrev-mode (expand-abbrev)) - (if octave-blink-matching-block - (octave-blink-matching-block-open)) - (if (and octave-auto-indent - (save-excursion - (skip-syntax-backward " ") - (not (bolp)))) - (indent-according-to-mode)) - (self-insert-command 1))) (defun octave-abbrev-start () "Start entering an Octave abbreviation. @@ -1323,51 +1020,27 @@ Note that all Octave mode abbrevs start with a grave accent." (list-abbrevs)) (setq unread-command-events (list c)))))) -(defun octave-insert-defun (name args vals) +(define-skeleton octave-insert-defun "Insert an Octave function skeleton. Prompt for the function's name, arguments and return values (to be entered without parens)." - (interactive - (list - (read-from-minibuffer "Function name: " - (substring (buffer-name) 0 -2)) - (read-from-minibuffer "Arguments: ") - (read-from-minibuffer "Return values: "))) - (let ((string (format "%s %s (%s)" - (cond - ((string-equal vals "") - vals) - ((string-match "[ ,]" vals) - (concat " [" vals "] =")) - (t - (concat " " vals " ="))) - name - args)) - (prefix octave-block-comment-start)) - (if (not (bobp)) (newline)) - (insert "function" string) - (indent-according-to-mode) - (newline 2) - (insert prefix "usage: " string) - (reindent-then-newline-and-indent) - (insert prefix) - (reindent-then-newline-and-indent) - (insert prefix) - (indent-according-to-mode) - (save-excursion - (newline 2) - (insert "endfunction") - (indent-according-to-mode)))) - - -;;; Menu -(defun octave-add-octave-menu () - "Add the `Octave' menu to the menu bar in Octave mode." - (require 'easymenu) - (easy-menu-define octave-mode-menu-map octave-mode-map - "Menu keymap for Octave mode." octave-mode-menu) - (easy-menu-add octave-mode-menu-map octave-mode-map)) - + (let* ((defname (substring (buffer-name) 0 -2)) + (name (read-string (format "Function name (default %s): " defname) + nil nil defname)) + (args (read-string "Arguments: ")) + (vals (read-string "Return values: "))) + (format "%s%s (%s)" + (cond + ((string-equal vals "") vals) + ((string-match "[ ,]" vals) (concat "[" vals "] = ")) + (t (concat vals " = "))) + name + args)) + \n "function " > str \n \n + octave-block-comment-start "usage: " str \n + octave-block-comment-start \n octave-block-comment-start + \n _ \n + "endfunction" > \n) ;;; Communication with the inferior Octave process (defun octave-kill-process () @@ -1434,7 +1107,7 @@ entered without parens)." "Send current Octave function to the inferior Octave process." (interactive) (save-excursion - (octave-mark-defun) + (mark-defun) (octave-send-region (point) (mark)))) (defun octave-send-line (&optional arg) @@ -1483,8 +1156,6 @@ code line." octave-maintainer-address (concat "Emacs version " emacs-version) (list - 'octave-auto-indent - 'octave-auto-newline 'octave-blink-matching-block 'octave-block-offset 'octave-comment-char @@ -1498,5 +1169,4 @@ code line." (provide 'octave-mod) -;; arch-tag: 05f1ce09-be87-4c00-803e-4919ffa26c23 ;;; octave-mod.el ends here diff --git a/lisp/progmodes/pascal.el b/lisp/progmodes/pascal.el index d19fa08bf6c..a93e97efed9 100644 --- a/lisp/progmodes/pascal.el +++ b/lisp/progmodes/pascal.el @@ -1,8 +1,8 @@ ;;; pascal.el --- major mode for editing pascal source in Emacs -;; Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002 -;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. +;; Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, +;; 2002 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; Free Software Foundation, Inc. ;; Author: Espen Skoglund <esk@gnu.org> ;; Keywords: languages @@ -223,7 +223,7 @@ The name of the function or case is included between the braces." "*List of contexts where auto lineup of :'s or ='s should be done. Elements can be of type: 'paramlist', 'declaration' or 'case', which will do auto lineup in parameterlist, declarations or case-statements -respectively. The word 'all' will do all lineups. '(case paramlist) for +respectively. The word 'all' will do all lineups. '(case paramlist) for instance will do lineup in case-statements and parameterlist, while '(all) will do all lineups." :type '(set :extra-offset 8 @@ -274,22 +274,12 @@ are handled in another way, and should not be added to this list." ;;; Macros ;;; -(defsubst pascal-get-beg-of-line (&optional arg) - (save-excursion - (beginning-of-line arg) - (point))) - -(defsubst pascal-get-end-of-line (&optional arg) - (save-excursion - (end-of-line arg) - (point))) - (defun pascal-declaration-end () (let ((nest 1)) (while (and (> nest 0) (re-search-forward "[:=]\\|\\(\\<record\\>\\)\\|\\(\\<end\\>\\)" - (save-excursion (end-of-line 2) (point)) t)) + (point-at-eol 2) t)) (cond ((match-beginning 1) (setq nest (1+ nest))) ((match-beginning 2) (setq nest (1- nest))) ((looking-at "[^(\n]+)") (setq nest 0)))))) @@ -298,7 +288,7 @@ are handled in another way, and should not be added to this list." (defun pascal-declaration-beg () (let ((nest 1)) (while (and (> nest 0) - (re-search-backward "[:=]\\|\\<\\(type\\|var\\|label\\|const\\)\\>\\|\\(\\<record\\>\\)\\|\\(\\<end\\>\\)" (pascal-get-beg-of-line 0) t)) + (re-search-backward "[:=]\\|\\<\\(type\\|var\\|label\\|const\\)\\>\\|\\(\\<record\\>\\)\\|\\(\\<end\\>\\)" (point-at-bol 0) t)) (cond ((match-beginning 1) (setq nest 0)) ((match-beginning 2) (setq nest (1- nest))) ((match-beginning 3) (setq nest (1+ nest))))) @@ -306,12 +296,11 @@ are handled in another way, and should not be added to this list." (defsubst pascal-within-string () - (save-excursion - (nth 3 (parse-partial-sexp (pascal-get-beg-of-line) (point))))) + (nth 3 (parse-partial-sexp (point-at-bol) (point)))) ;;;###autoload -(defun pascal-mode () +(define-derived-mode pascal-mode prog-mode "Pascal" "Major mode for editing Pascal code. \\<pascal-mode-map> TAB indents for Pascal code. Delete converts tabs to spaces as it moves back. @@ -334,60 +323,47 @@ Other useful functions are: Variables controlling indentation/edit style: - pascal-indent-level (default 3) + `pascal-indent-level' (default 3) Indentation of Pascal statements with respect to containing block. - pascal-case-indent (default 2) + `pascal-case-indent' (default 2) Indentation for case statements. - pascal-auto-newline (default nil) + `pascal-auto-newline' (default nil) Non-nil means automatically newline after semicolons and the punctuation mark after an end. - pascal-indent-nested-functions (default t) + `pascal-indent-nested-functions' (default t) Non-nil means nested functions are indented. - pascal-tab-always-indent (default t) + `pascal-tab-always-indent' (default t) Non-nil means TAB in Pascal mode should always reindent the current line, regardless of where in the line point is when the TAB command is used. - pascal-auto-endcomments (default t) + `pascal-auto-endcomments' (default t) Non-nil means a comment { ... } is set after the ends which ends cases and functions. The name of the function or case will be set between the braces. - pascal-auto-lineup (default t) + `pascal-auto-lineup' (default t) List of contexts where auto lineup of :'s or ='s should be done. -See also the user variables pascal-type-keywords, pascal-start-keywords and -pascal-separator-keywords. +See also the user variables `pascal-type-keywords', `pascal-start-keywords' and +`pascal-separator-keywords'. Turning on Pascal mode calls the value of the variable pascal-mode-hook with no args, if that value is non-nil." - (interactive) - (kill-all-local-variables) - (use-local-map pascal-mode-map) - (setq major-mode 'pascal-mode) - (setq mode-name "Pascal") - (setq local-abbrev-table pascal-mode-abbrev-table) - (set-syntax-table pascal-mode-syntax-table) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'pascal-indent-line) - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'pascal-indent-comment) - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments nil) - (make-local-variable 'blink-matching-paren-dont-ignore-comments) - (setq blink-matching-paren-dont-ignore-comments t) - (make-local-variable 'case-fold-search) - (setq case-fold-search t) - (make-local-variable 'comment-start) - (setq comment-start "{") - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "(\\*+ *\\|{ *") - (make-local-variable 'comment-end) - (setq comment-end "}") + (set (make-local-variable 'local-abbrev-table) pascal-mode-abbrev-table) + (set (make-local-variable 'indent-line-function) 'pascal-indent-line) + (set (make-local-variable 'comment-indent-function) 'pascal-indent-comment) + (set (make-local-variable 'parse-sexp-ignore-comments) nil) + (set (make-local-variable 'blink-matching-paren-dont-ignore-comments) t) + (set (make-local-variable 'case-fold-search) t) + (set (make-local-variable 'comment-start) "{") + (set (make-local-variable 'comment-start-skip) "(\\*+ *\\|{ *") + (set (make-local-variable 'comment-end) "}") ;; Font lock support - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults '(pascal-font-lock-keywords nil t)) + (set (make-local-variable 'font-lock-defaults) + '(pascal-font-lock-keywords nil t)) ;; Imenu support - (make-local-variable 'imenu-generic-expression) - (setq imenu-generic-expression pascal-imenu-generic-expression) - (setq imenu-case-fold-search t) - (run-mode-hooks 'pascal-mode-hook)) + (set (make-local-variable 'imenu-generic-expression) + pascal-imenu-generic-expression) + (set (make-local-variable 'imenu-case-fold-search) t) + ;; Pascal-mode's own hide/show support. + (add-to-invisibility-spec '(pascal . t))) @@ -420,8 +396,7 @@ no args, if that value is non-nil." (forward-char 1) (delete-horizontal-space)) ((and (looking-at "(\\*\\|\\*[^)]") - (not (save-excursion - (search-forward "*)" (pascal-get-end-of-line) t)))) + (not (save-excursion (search-forward "*)" (point-at-eol) t)))) (setq setstar t)))) ;; If last line was a star comment line then this one shall be too. (if (null setstar) @@ -740,7 +715,7 @@ on the line which ends a function or procedure named NAME." (if (and (looking-at "\\<end;") (not (save-excursion (end-of-line) - (search-backward "{" (pascal-get-beg-of-line) t)))) + (search-backward "{" (point-at-bol) t)))) (let ((type (car (pascal-calculate-indent)))) (if (eq type 'declaration) () @@ -1012,7 +987,7 @@ indent of the current line in parameterlist." (stpos (progn (goto-char (scan-lists (point) -1 1)) (point))) (stcol (1+ (current-column))) (edpos (progn (pascal-declaration-end) - (search-backward ")" (pascal-get-beg-of-line) t) + (search-backward ")" (point-at-bol) t) (point))) (usevar (re-search-backward "\\<var\\>" stpos t))) (if arg (progn @@ -1059,7 +1034,7 @@ indent of the current line in parameterlist." (setq ind (pascal-get-lineup-indent stpos edpos lineup)) (goto-char stpos) (while (and (<= (point) edpos) (not (eobp))) - (if (search-forward lineup (pascal-get-end-of-line) 'move) + (if (search-forward lineup (point-at-eol) 'move) (forward-char -1)) (delete-horizontal-space) (indent-to ind) @@ -1086,7 +1061,7 @@ indent of the current line in parameterlist." (goto-char b) ;; Get rightmost position (while (< (point) e) - (and (re-search-forward reg (min e (pascal-get-end-of-line 2)) 'move) + (and (re-search-forward reg (min e (point-at-eol 2)) 'move) (cond ((match-beginning 1) ;; Skip record blocks (pascal-declaration-end)) @@ -1150,7 +1125,7 @@ indent of the current line in parameterlist." ;; Search through all reachable functions (while (pascal-beg-of-defun) - (if (re-search-forward pascal-str (pascal-get-end-of-line) t) + (if (re-search-forward pascal-str (point-at-eol) t) (progn (setq match (buffer-substring (match-beginning 2) (match-end 2))) (push match pascal-all))) @@ -1167,17 +1142,17 @@ indent of the current line in parameterlist." match) ;; Traverse lines (while (< (point) end) - (if (re-search-forward "[:=]" (pascal-get-end-of-line) t) + (if (re-search-forward "[:=]" (point-at-eol) t) ;; Traverse current line (while (and (re-search-backward (concat "\\((\\|\\<\\(var\\|type\\|const\\)\\>\\)\\|" pascal-symbol-re) - (pascal-get-beg-of-line) t) + (point-at-bol) t) (not (match-end 1))) (setq match (buffer-substring (match-beginning 0) (match-end 0))) (if (string-match (concat "\\<" pascal-str) match) (push match pascal-all)))) - (if (re-search-forward "\\<record\\>" (pascal-get-end-of-line) t) + (if (re-search-forward "\\<record\\>" (point-at-eol) t) (pascal-declaration-end) (forward-line 1))) @@ -1219,7 +1194,7 @@ indent of the current line in parameterlist." (if (> start (prog1 (save-excursion (pascal-end-of-defun) (point)))) () ; Declarations not reachable - (if (search-forward "(" (pascal-get-end-of-line) t) + (if (search-forward "(" (point-at-eol) t) ;; Check parameterlist ;; FIXME: pascal-get-completion-decl doesn't understand ;; the var declarations in parameter lists :-( @@ -1277,8 +1252,7 @@ indent of the current line in parameterlist." (or (eq state 'declaration) (eq state 'paramlist) (and (eq state 'defun) (save-excursion - (re-search-backward ")[ \t]*:" - (pascal-get-beg-of-line) t)))) + (re-search-backward ")[ \t]*:" (point-at-bol) t)))) (if (or (eq state 'paramlist) (eq state 'defun)) (pascal-beg-of-defun)) (nconc @@ -1478,18 +1452,12 @@ Pascal Outline mode provides some additional commands. (unless pascal-outline-mode (pascal-show-all))) -(defun pascal-outline-change (b e pascal-flag) - (save-excursion - ;; This used to use selective display so the boundaries used by the - ;; callers didn't have to be precise, since it just looked for \n or \^M - ;; and switched them. - (goto-char b) (setq b (line-end-position)) - (goto-char e) (setq e (line-end-position))) +(defun pascal-outline-change (b e hide) (when (> e b) ;; We could try and optimize this in the case where the region is ;; already hidden. But I'm not sure it's worth the trouble. (remove-overlays b e 'invisible 'pascal) - (when (eq pascal-flag ?\^M) + (when hide (let ((ol (make-overlay b e nil t nil))) (overlay-put ol 'invisible 'pascal) (overlay-put ol 'evaporate t))))) @@ -1497,7 +1465,7 @@ Pascal Outline mode provides some additional commands. (defun pascal-show-all () "Show all of the text in the buffer." (interactive) - (pascal-outline-change (point-min) (point-max) ?\n)) + (pascal-outline-change (point-min) (point-max) nil)) (defun pascal-hide-other-defuns () "Show only the current defun." @@ -1505,42 +1473,45 @@ Pascal Outline mode provides some additional commands. (save-excursion (let ((beg (progn (if (not (looking-at "\\(function\\|procedure\\)\\>")) (pascal-beg-of-defun)) - (point))) + (line-beginning-position))) (end (progn (pascal-end-of-defun) (backward-sexp 1) - (search-forward "\n\\|\^M" nil t) - (point))) + (line-beginning-position 2))) (opoint (point-min))) + ;; BEG at BOL. + ;; OPOINT at EOL. + ;; END at BOL. (goto-char (point-min)) ;; Hide all functions before current function - (while (re-search-forward "^\\(function\\|procedure\\)\\>" beg 'move) - (pascal-outline-change opoint (1- (match-beginning 0)) ?\^M) - (setq opoint (point)) + (while (re-search-forward "^[ \t]*\\(function\\|procedure\\)\\>" + beg 'move) + (pascal-outline-change opoint (line-end-position 0) t) + (setq opoint (line-end-position)) ;; Functions may be nested (if (> (progn (pascal-end-of-defun) (point)) beg) (goto-char opoint))) (if (> beg opoint) - (pascal-outline-change opoint (1- beg) ?\^M)) + (pascal-outline-change opoint (1- beg) t)) ;; Show current function - (pascal-outline-change beg end ?\n) + (pascal-outline-change (1- beg) end nil) ;; Hide nested functions (forward-char 1) (while (re-search-forward "^\\(function\\|procedure\\)\\>" end 'move) - (setq opoint (point)) + (setq opoint (line-end-position)) (pascal-end-of-defun) - (pascal-outline-change opoint (point) ?\^M)) + (pascal-outline-change opoint (line-end-position) t)) (goto-char end) (setq opoint end) ;; Hide all function after current function (while (re-search-forward "^\\(function\\|procedure\\)\\>" nil 'move) - (pascal-outline-change opoint (1- (match-beginning 0)) ?\^M) - (setq opoint (point)) + (pascal-outline-change opoint (line-end-position 0) t) + (setq opoint (line-end-position)) (pascal-end-of-defun)) - (pascal-outline-change opoint (point-max) ?\^M) + (pascal-outline-change opoint (point-max) t) ;; Hide main program (if (< (progn (forward-line -1) (point)) end) @@ -1548,7 +1519,7 @@ Pascal Outline mode provides some additional commands. (goto-char beg) (pascal-end-of-defun) (backward-sexp 1) - (pascal-outline-change (point) (point-max) ?\^M)))))) + (pascal-outline-change (line-end-position) (point-max) t)))))) (defun pascal-outline-next-defun () "Move to next function/procedure, hiding all others." @@ -1570,5 +1541,4 @@ Pascal Outline mode provides some additional commands. (provide 'pascal) -;; arch-tag: 04535136-fd93-40b4-a505-c9bebdc051f5 ;;; pascal.el ends here diff --git a/lisp/progmodes/perl-mode.el b/lisp/progmodes/perl-mode.el index f8eba5accdb..97de1b35621 100644 --- a/lisp/progmodes/perl-mode.el +++ b/lisp/progmodes/perl-mode.el @@ -250,59 +250,81 @@ The expansion is entirely correct because it uses the C preprocessor." ;; y /.../.../ ;; ;; <file*glob> -(defvar perl-font-lock-syntactic-keywords - ;; TODO: here-documents ("<<\\(\\sw\\|['\"]\\)") - `(;; Turn POD into b-style comments - ("^\\(=\\)\\sw" (1 "< b")) - ("^=cut[ \t]*\\(\n\\)" (1 "> b")) - ;; Catch ${ so that ${var} doesn't screw up indentation. - ;; This also catches $' to handle 'foo$', although it should really - ;; check that it occurs inside a '..' string. - ("\\(\\$\\)[{']" (1 ". p")) - ;; Handle funny names like $DB'stop. - ("\\$ ?{?^?[_a-zA-Z][_a-zA-Z0-9]*\\('\\)[_a-zA-Z]" (1 "_")) - ;; format statements - ("^[ \t]*format.*=[ \t]*\\(\n\\)" (1 '(7))) - ;; Funny things in `sub' arg-specs like `sub myfun ($)' or `sub ($)'. - ;; Be careful not to match "sub { (...) ... }". - ("\\<sub\\(?:[[:space:]]+[^{}[:punct:][:space:]]+\\)?[[:space:]]*(\\([^)]+\\))" - 1 '(1)) - ;; Regexp and funny quotes. Distinguishing a / that starts a regexp - ;; match from the division operator is ...interesting. - ;; Basically, / is a regexp match if it's preceded by an infix operator - ;; (or some similar separator), or by one of the special keywords - ;; corresponding to builtin functions that can take their first arg - ;; without parentheses. Of course, that presume we're looking at the - ;; *opening* slash. We can afford to mis-match the closing ones - ;; here, because they will be re-treated separately later in - ;; perl-font-lock-special-syntactic-constructs. - (,(concat "\\(?:\\(?:\\(?:^\\|[^$@&%[:word:]]\\)" - (regexp-opt '("split" "if" "unless" "until" "while" "split" - "grep" "map" "not" "or" "and")) - "\\)\\|[?:.,;=!~({[]\\|\\(^\\)\\)[ \t\n]*\\(/\\)") - (2 (if (and (match-end 1) - (save-excursion - (goto-char (match-end 1)) - ;; Not 100% correct since we haven't finished setting up - ;; the syntax-table before point, but better than nothing. - (forward-comment (- (point-max))) - (put-text-property (point) (match-end 2) - 'jit-lock-defer-multiline t) - (not (memq (char-before) - '(?? ?: ?. ?, ?\; ?= ?! ?~ ?\( ?\[))))) - nil ;; A division sign instead of a regexp-match. - '(7)))) - ("\\(^\\|[?:.,;=!~({[ \t]\\)\\([msy]\\|q[qxrw]?\\|tr\\)\\>\\s-*\\([^])}> \n\t]\\)" - ;; Nasty cases: - ;; /foo/m $a->m $#m $m @m %m - ;; \s (appears often in regexps). - ;; -s file - (3 (if (assoc (char-after (match-beginning 3)) - perl-quote-like-pairs) - '(15) '(7)))) - ;; Find and mark the end of funny quotes and format statements. - (perl-font-lock-special-syntactic-constructs) - )) +(defun perl-syntax-propertize-function (start end) + (let ((case-fold-search nil)) + (goto-char start) + (perl-syntax-propertize-special-constructs end) + ;; TODO: here-documents ("<<\\(\\sw\\|['\"]\\)") + (funcall + (syntax-propertize-rules + ;; Turn POD into b-style comments. Place the cut rule first since it's + ;; more specific. + ("^=cut\\>.*\\(\n\\)" (1 "> b")) + ("^\\(=\\)\\sw" (1 "< b")) + ;; Catch ${ so that ${var} doesn't screw up indentation. + ;; This also catches $' to handle 'foo$', although it should really + ;; check that it occurs inside a '..' string. + ("\\(\\$\\)[{']" (1 ". p")) + ;; Handle funny names like $DB'stop. + ("\\$ ?{?^?[_a-zA-Z][_a-zA-Z0-9]*\\('\\)[_a-zA-Z]" (1 "_")) + ;; format statements + ("^[ \t]*format.*=[ \t]*\\(\n\\)" + (1 (prog1 "\"" (perl-syntax-propertize-special-constructs end)))) + ;; Funny things in `sub' arg-specs like `sub myfun ($)' or `sub ($)'. + ;; Be careful not to match "sub { (...) ... }". + ("\\<sub\\(?:[[:space:]]+[^{}[:punct:][:space:]]+\\)?[[:space:]]*(\\([^)]+\\))" + (1 ".")) + ;; Turn __DATA__ trailer into a comment. + ("^\\(_\\)_\\(?:DATA\\|END\\)__[ \t]*\\(?:\\(\n\\)#.-\\*-.*perl.*-\\*-\\|\n.*\\)" + (1 "< c") (2 "> c") + (0 (ignore (put-text-property (match-beginning 0) (match-end 0) + 'syntax-multiline t)))) + ;; Regexp and funny quotes. Distinguishing a / that starts a regexp + ;; match from the division operator is ...interesting. + ;; Basically, / is a regexp match if it's preceded by an infix operator + ;; (or some similar separator), or by one of the special keywords + ;; corresponding to builtin functions that can take their first arg + ;; without parentheses. Of course, that presume we're looking at the + ;; *opening* slash. We can afford to mis-match the closing ones + ;; here, because they will be re-treated separately later in + ;; perl-font-lock-special-syntactic-constructs. + ((concat "\\(?:\\(?:^\\|[^$@&%[:word:]]\\)" + (regexp-opt '("split" "if" "unless" "until" "while" "split" + "grep" "map" "not" "or" "and")) + "\\|[?:.,;=!~({[]\\|\\(^\\)\\)[ \t\n]*\\(/\\)") + (2 (ignore + (if (and (match-end 1) ; / at BOL. + (save-excursion + (goto-char (match-end 1)) + (forward-comment (- (point-max))) + (put-text-property (point) (match-end 2) + 'syntax-multiline t) + (not (memq (char-before) + '(?? ?: ?. ?, ?\; ?= ?! ?~ ?\( ?\[))))) + nil ;; A division sign instead of a regexp-match. + (put-text-property (match-beginning 2) (match-end 2) + 'syntax-table (string-to-syntax "\"")) + (perl-syntax-propertize-special-constructs end))))) + ("\\(^\\|[?:.,;=!~({[ \t]\\)\\([msy]\\|q[qxrw]?\\|tr\\)\\>\\s-*\\([^])}> \n\t]\\)" + ;; Nasty cases: + ;; /foo/m $a->m $#m $m @m %m + ;; \s (appears often in regexps). + ;; -s file + ;; sub tr {...} + (3 (ignore + (if (save-excursion (goto-char (match-beginning 0)) + (forward-word -1) + (looking-at-p "sub[ \t\n]")) + ;; This is defining a function. + nil + (put-text-property (match-beginning 3) (match-end 3) + 'syntax-table + (if (assoc (char-after (match-beginning 3)) + perl-quote-like-pairs) + (string-to-syntax "|") + (string-to-syntax "\""))) + (perl-syntax-propertize-special-constructs end)))))) + (point) end))) (defvar perl-empty-syntax-table (let ((st (copy-syntax-table))) @@ -321,95 +343,123 @@ The expansion is entirely correct because it uses the C preprocessor." (modify-syntax-entry close ")" st)) st)) -(defun perl-font-lock-special-syntactic-constructs (limit) - ;; We used to do all this in a font-lock-syntactic-face-function, which - ;; did not work correctly because sometimes some parts of the buffer are - ;; treated with font-lock-syntactic-keywords but not with - ;; font-lock-syntactic-face-function (mostly because of - ;; font-lock-syntactically-fontified). That meant that some syntax-table - ;; properties were missing. So now we do the parse-partial-sexp loop - ;; ourselves directly from font-lock-syntactic-keywords, so we're sure - ;; it's done when necessary. +(defun perl-syntax-propertize-special-constructs (limit) + "Propertize special constructs like regexps and formats." (let ((state (syntax-ppss)) char) - (while (< (point) limit) - (cond - ((or (null (setq char (nth 3 state))) - (and (characterp char) (eq (char-syntax (nth 3 state)) ?\"))) - ;; Normal text, or comment, or docstring, or normal string. - nil) - ((eq (nth 3 state) ?\n) - ;; A `format' command. - (save-excursion - (when (and (re-search-forward "^\\s *\\.\\s *$" nil t) - (not (eobp))) - (put-text-property (point) (1+ (point)) 'syntax-table '(7))))) - (t - ;; This is regexp like quote thingy. - (setq char (char-after (nth 8 state))) - (save-excursion - (let ((twoargs (save-excursion - (goto-char (nth 8 state)) - (skip-syntax-backward " ") - (skip-syntax-backward "w") - (member (buffer-substring - (point) (progn (forward-word 1) (point))) - '("tr" "s" "y")))) - (close (cdr (assq char perl-quote-like-pairs))) - (pos (point)) - (st (perl-quote-syntax-table char))) - (if (not close) - ;; The closing char is the same as the opening char. - (with-syntax-table st - (parse-partial-sexp (point) (point-max) - nil nil state 'syntax-table) - (when twoargs - (parse-partial-sexp (point) (point-max) - nil nil state 'syntax-table))) - ;; The open/close chars are matched like () [] {} and <>. - (let ((parse-sexp-lookup-properties nil)) - (condition-case err - (progn - (with-syntax-table st - (goto-char (nth 8 state)) (forward-sexp 1)) - (when twoargs - (save-excursion - ;; Skip whitespace and make sure that font-lock will - ;; refontify the second part in the proper context. - (put-text-property - (point) (progn (forward-comment (point-max)) (point)) - 'font-lock-multiline t) - ;; - (unless - (or (eobp) - (save-excursion - (with-syntax-table - (perl-quote-syntax-table (char-after)) - (forward-sexp 1)) - (put-text-property pos (line-end-position) - 'jit-lock-defer-multiline t) - (looking-at "\\s-*\\sw*e"))) - (put-text-property (point) (1+ (point)) - 'syntax-table - (if (assoc (char-after) - perl-quote-like-pairs) - '(15) '(7))))))) - ;; The arg(s) is not terminated, so it extends until EOB. - (scan-error (goto-char (point-max)))))) - ;; Point is now right after the arg(s). - ;; Erase any syntactic marks within the quoted text. - (put-text-property pos (1- (point)) 'syntax-table nil) - (when (eq (char-before (1- (point))) ?$) - (put-text-property (- (point) 2) (1- (point)) - 'syntax-table '(1))) - (put-text-property (1- (point)) (point) - 'syntax-table (if close '(15) '(7))))))) - - (setq state (parse-partial-sexp (point) limit nil nil state - 'syntax-table)))) - ;; Tell font-lock that this needs not further processing. - nil) - + (cond + ((or (null (setq char (nth 3 state))) + (and (characterp char) (eq (char-syntax (nth 3 state)) ?\"))) + ;; Normal text, or comment, or docstring, or normal string. + nil) + ((eq (nth 3 state) ?\n) + ;; A `format' command. + (when (re-search-forward "^\\s *\\.\\s *\n" limit 'move) + (put-text-property (1- (point)) (point) + 'syntax-table (string-to-syntax "\"")))) + (t + ;; This is regexp like quote thingy. + (setq char (char-after (nth 8 state))) + (let ((twoargs (save-excursion + (goto-char (nth 8 state)) + (skip-syntax-backward " ") + (skip-syntax-backward "w") + (member (buffer-substring + (point) (progn (forward-word 1) (point))) + '("tr" "s" "y")))) + (close (cdr (assq char perl-quote-like-pairs))) + (st (perl-quote-syntax-table char))) + (when (with-syntax-table st + (if close + ;; For paired delimiters, Perl allows nesting them, but + ;; since we treat them as strings, Emacs does not count + ;; those delimiters in `state', so we don't know how deep + ;; we are: we have to go back to the beginning of this + ;; "string" and count from there. + (condition-case nil + (progn + ;; Start after the first char since it doesn't have + ;; paren-syntax (an alternative would be to let-bind + ;; parse-sexp-lookup-properties). + (goto-char (1+ (nth 8 state))) + (up-list 1) + t) + (scan-error nil)) + (not (or (nth 8 (parse-partial-sexp + (point) limit nil nil state 'syntax-table)) + ;; If we have a self-paired opener and a twoargs + ;; command, the form is s/../../ so we have to skip + ;; a second time. + ;; In the case of s{...}{...}, we only handle the + ;; first part here and the next below. + (when (and twoargs (not close)) + (nth 8 (parse-partial-sexp + (point) limit + nil nil state 'syntax-table))))))) + ;; Point is now right after the arg(s). + (when (eq (char-before (1- (point))) ?$) + (put-text-property (- (point) 2) (1- (point)) + 'syntax-table '(1))) + (put-text-property (1- (point)) (point) + 'syntax-table + (if close + (string-to-syntax "|") + (string-to-syntax "\""))) + ;; If we have two args with a non-self-paired starter (e.g. + ;; s{...}{...}) we're right after the first arg, so we still have to + ;; handle the second part. + (when (and twoargs close) + ;; Skip whitespace and make sure that font-lock will + ;; refontify the second part in the proper context. + (put-text-property + (point) (progn (forward-comment (point-max)) (point)) + 'syntax-multiline t) + ;; + (when (< (point) limit) + (put-text-property (point) (1+ (point)) + 'syntax-table + (if (assoc (char-after) + perl-quote-like-pairs) + ;; Put an `e' in the cdr to mark this + ;; char as "second arg starter". + (string-to-syntax "|e") + (string-to-syntax "\"e"))) + (forward-char 1) + ;; Re-use perl-syntax-propertize-special-constructs to handle the + ;; second part (the first delimiter of second part can't be + ;; preceded by "s" or "tr" or "y", so it will not be considered + ;; as twoarg). + (perl-syntax-propertize-special-constructs limit))))))))) + +(defun perl-font-lock-syntactic-face-function (state) + (cond + ((and (nth 3 state) + (eq ?e (cdr-safe (get-text-property (nth 8 state) 'syntax-table))) + ;; This is a second-arg of s{..}{...} form; let's check if this second + ;; arg is executable code rather than a string. For that, we need to + ;; look for an "e" after this second arg, so we have to hunt for the + ;; end of the arg. Depending on whether the whole arg has already + ;; been syntax-propertized or not, the end-char will have different + ;; syntaxes, so let's ignore syntax-properties temporarily so we can + ;; pretend it has not been syntax-propertized yet. + (let* ((parse-sexp-lookup-properties nil) + (char (char-after (nth 8 state))) + (paired (assq char perl-quote-like-pairs))) + (with-syntax-table (perl-quote-syntax-table char) + (save-excursion + (if (not paired) + (parse-partial-sexp (point) (point-max) + nil nil state 'syntax-table) + (condition-case nil + (progn + (goto-char (1+ (nth 8 state))) + (up-list 1)) + (scan-error (goto-char (point-max))))) + (put-text-property (nth 8 state) (point) + 'jit-lock-defer-multiline t) + (looking-at "[ \t]*\\sw*e"))))) + nil) + (t (funcall (default-value 'font-lock-syntactic-face-function) state)))) (defcustom perl-indent-level 4 "*Indentation of Perl statements with respect to containing block." @@ -574,9 +624,12 @@ Turning on Perl mode runs the normal hook `perl-mode-hook'." perl-font-lock-keywords-1 perl-font-lock-keywords-2) nil nil ((?\_ . "w")) nil - (font-lock-syntactic-keywords - . perl-font-lock-syntactic-keywords) - (parse-sexp-lookup-properties . t))) + (font-lock-syntactic-face-function + . perl-font-lock-syntactic-face-function))) + (set (make-local-variable 'syntax-propertize-function) + #'perl-syntax-propertize-function) + (add-hook 'syntax-propertize-extend-region-functions + #'syntax-propertize-multiline 'append 'local) ;; Tell imenu how to handle Perl. (set (make-local-variable 'imenu-generic-expression) perl-imenu-generic-expression) @@ -867,9 +920,7 @@ Optional argument PARSE-START should be the position of `beginning-of-defun'." (cond ((looking-at ";?#") (forward-line 1) t) ((looking-at "\\(\\w\\|\\s_\\)+:[^:]") - (save-excursion - (end-of-line) - (setq colon-line-end (point))) + (setq colon-line-end (line-end-position)) (search-forward ":"))))) ;; The first following code counts ;; if it is before the line we want to indent. @@ -929,7 +980,7 @@ Optional argument PARSE-START should be the position of `beginning-of-defun'." (if (= (char-after (marker-position bof-mark)) ?=) (message "Can't indent a format statement") (message "Indenting Perl expression...") - (save-excursion (end-of-line) (setq eol (point))) + (setq eol (line-end-position)) (save-excursion ; locate matching close paren (while (and (not (eobp)) (<= (point) eol)) (parse-partial-sexp (point) (point-max) 0)) @@ -1027,5 +1078,4 @@ With argument, repeat that many times; negative args move backward." (provide 'perl-mode) -;; arch-tag: 8c7ff68d-15f3-46a2-ade2-b7c41f176826 ;;; perl-mode.el ends here diff --git a/lisp/progmodes/prolog.el b/lisp/progmodes/prolog.el index 197b41506bd..f2f80d0d81d 100644 --- a/lisp/progmodes/prolog.el +++ b/lisp/progmodes/prolog.el @@ -31,6 +31,7 @@ (defvar comint-prompt-regexp) (defvar comint-process-echoes) +(require 'smie) (defgroup prolog nil "Major mode for editing and running Prolog under Emacs." @@ -98,6 +99,86 @@ When nil, send actual operating system end of file." (defvar prolog-mode-abbrev-table nil) (define-abbrev-table 'prolog-mode-abbrev-table ()) +(defun prolog-smie-forward-token () + (forward-comment (point-max)) + (buffer-substring-no-properties + (point) + (progn (cond + ((looking-at "[!;]") (forward-char 1)) + ((not (zerop (skip-chars-forward "#&*+-./:<=>?@\\^`~")))) + ((not (zerop (skip-syntax-forward "w_'")))) + ;; In case of non-ASCII punctuation. + ((not (zerop (skip-syntax-forward "."))))) + (point)))) + +(defun prolog-smie-backward-token () + (forward-comment (- (point-max))) + (buffer-substring-no-properties + (point) + (progn (cond + ((memq (char-before) '(?! ?\;)) (forward-char -1)) + ((not (zerop (skip-chars-backward "#&*+-./:<=>?@\\^`~")))) + ((not (zerop (skip-syntax-backward "w_'")))) + ;; In case of non-ASCII punctuation. + ((not (zerop (skip-syntax-backward "."))))) + (point)))) + +(defconst prolog-smie-grammar + ;; Rather than construct the operator levels table from the BNF, + ;; we directly provide the operator precedences from GNU Prolog's + ;; manual (7.14.10 op/3). The only problem is that GNU Prolog's + ;; manual uses precedence levels in the opposite sense (higher + ;; numbers bind less tightly) than SMIE, so we use negative numbers. + '(("." -10000 -10000) + (":-" -1200 -1200) + ("-->" -1200 -1200) + (";" -1100 -1100) + ("->" -1050 -1050) + ("," -1000 -1000) + ("\\+" -900 -900) + ("=" -700 -700) + ("\\=" -700 -700) + ("=.." -700 -700) + ("==" -700 -700) + ("\\==" -700 -700) + ("@<" -700 -700) + ("@=<" -700 -700) + ("@>" -700 -700) + ("@>=" -700 -700) + ("is" -700 -700) + ("=:=" -700 -700) + ("=\\=" -700 -700) + ("<" -700 -700) + ("=<" -700 -700) + (">" -700 -700) + (">=" -700 -700) + (":" -600 -600) + ("+" -500 -500) + ("-" -500 -500) + ("/\\" -500 -500) + ("\\/" -500 -500) + ("*" -400 -400) + ("/" -400 -400) + ("//" -400 -400) + ("rem" -400 -400) + ("mod" -400 -400) + ("<<" -400 -400) + (">>" -400 -400) + ("**" -200 -200) + ("^" -200 -200) + ;; Prefix + ;; ("+" 200 200) + ;; ("-" 200 200) + ;; ("\\" 200 200) + ) + "Precedence levels of infix operators.") + +(defun prolog-smie-rules (kind token) + (pcase (cons kind token) + (`(:elem . basic) prolog-indent-width) + (`(:after . ".") 0) ;; To work around smie-closer-alist. + (`(:after . ,(or `":-" `"->")) prolog-indent-width))) + (defun prolog-mode-variables () (make-local-variable 'paragraph-separate) (setq paragraph-separate (concat "%%\\|$\\|" page-delimiter)) ;'%%..' @@ -105,8 +186,17 @@ When nil, send actual operating system end of file." (setq paragraph-ignore-fill-prefix t) (make-local-variable 'imenu-generic-expression) (setq imenu-generic-expression '((nil "^\\sw+" 0))) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'prolog-indent-line) + + ;; Setup SMIE. + (smie-setup prolog-smie-grammar #'prolog-smie-rules + :forward-token #'prolog-smie-forward-token + :backward-token #'prolog-smie-backward-token) + (set (make-local-variable 'smie-blink-matching-triggers) '(?.)) + (set (make-local-variable 'smie-closer-alist) '((t . "."))) + (add-hook 'post-self-insert-hook #'smie-blink-matching-open 'append 'local) + ;; There's no real closer in Prolog anyway. + (set (make-local-variable 'smie-blink-matching-inners) t) + (make-local-variable 'comment-start) (setq comment-start "%") (make-local-variable 'comment-start-skip) @@ -122,7 +212,7 @@ When nil, send actual operating system end of file." (define-key map "\C-c\C-l" 'inferior-prolog-load-file) (define-key map "\C-c\C-z" 'switch-to-prolog) map)) - + (easy-menu-define prolog-mode-menu prolog-mode-map "Menu for Prolog mode." ;; Mostly copied from scheme-mode's menu. ;; Not tremendously useful, but it's a start. @@ -136,90 +226,23 @@ When nil, send actual operating system end of file." )) ;;;###autoload -(defun prolog-mode () +(define-derived-mode prolog-mode prog-mode "Prolog" "Major mode for editing Prolog code for Prologs. Blank lines and `%%...' separate paragraphs. `%'s start comments. Commands: \\{prolog-mode-map} Entry to this mode calls the value of `prolog-mode-hook' if that value is non-nil." - (interactive) - (kill-all-local-variables) - (use-local-map prolog-mode-map) - (set-syntax-table prolog-mode-syntax-table) - (setq major-mode 'prolog-mode) - (setq mode-name "Prolog") (prolog-mode-variables) (set (make-local-variable 'comment-add) 1) - ;; font lock (setq font-lock-defaults '(prolog-font-lock-keywords nil nil nil - beginning-of-line)) - (run-mode-hooks 'prolog-mode-hook)) - -(defun prolog-indent-line () - "Indent current line as Prolog code. -With argument, indent any additional lines of the same clause -rigidly along with this one (not yet)." - (interactive "p") - (let ((indent (prolog-indent-level)) - (pos (- (point-max) (point)))) - (beginning-of-line) - (indent-line-to indent) - (if (> (- (point-max) pos) (point)) - (goto-char (- (point-max) pos))))) - -(defun prolog-indent-level () - "Compute Prolog indentation level." - (save-excursion - (beginning-of-line) - (skip-chars-forward " \t") - (cond - ((looking-at "%%%") 0) ;Large comment starts - ((looking-at "%[^%]") comment-column) ;Small comment starts - ((bobp) 0) ;Beginning of buffer - (t - (let ((empty t) ind more less) - (if (looking-at ")") - (setq less t) ;Find close - (setq less nil)) - ;; See previous indentation - (while empty - (forward-line -1) - (beginning-of-line) - (if (bobp) - (setq empty nil) - (skip-chars-forward " \t") - (if (not (or (looking-at "%[^%]") (looking-at "\n"))) - (setq empty nil)))) - (if (bobp) - (setq ind 0) ;Beginning of buffer - (setq ind (current-column))) ;Beginning of clause - ;; See its beginning - (if (looking-at "%%[^%]") - ind - ;; Real prolog code - (if (looking-at "(") - (setq more t) ;Find open - (setq more nil)) - ;; See its tail - (end-of-prolog-clause) - (or (bobp) (forward-char -1)) - (cond ((looking-at "[,(;>]") - (if (and more (looking-at "[^,]")) - (+ ind prolog-indent-width) ;More indentation - (max tab-width ind))) ;Same indentation - ((looking-at "-") tab-width) ;TAB - ((or less (looking-at "[^.]")) - (max (- ind prolog-indent-width) 0)) ;Less indentation - (t 0)) ;No indentation - ))) - ))) + beginning-of-line))) (defun end-of-prolog-clause () "Go to end of clause in this line." (beginning-of-line 1) - (let* ((eolpos (save-excursion (end-of-line) (point)))) + (let* ((eolpos (line-end-position))) (if (re-search-forward comment-start-skip eolpos 'move) (goto-char (match-beginning 0))) (skip-chars-backward " \t"))) @@ -411,5 +434,4 @@ If COMPILE (prefix arg) is not nil, use compile mode rather than consult mode." (provide 'prolog) -;; arch-tag: f3ec6748-1272-4ab6-8826-c50cb1607636 ;;; prolog.el ends here diff --git a/lisp/progmodes/ps-mode.el b/lisp/progmodes/ps-mode.el index 93a559258fa..9b83f77d3b8 100644 --- a/lisp/progmodes/ps-mode.el +++ b/lisp/progmodes/ps-mode.el @@ -6,7 +6,7 @@ ;; Author: Peter Kleiweg <p.c.j.kleiweg@rug.nl> ;; Maintainer: Peter Kleiweg <p.c.j.kleiweg@rug.nl> ;; Created: 20 Aug 1997 -;; Version: 1.1h, 16 Jun 2005 +;; Version: 1.1h ;; Keywords: PostScript, languages ;; Yoni Rabkin <yoni@rabkins.net> contacted the maintainer of this @@ -39,6 +39,7 @@ (defconst ps-mode-version "1.1h, 16 Jun 2005") (defconst ps-mode-maintainer-address "Peter Kleiweg <p.c.j.kleiweg@rug.nl>") +(require 'comint) (require 'easymenu) ;; Define core `PostScript' group. @@ -431,12 +432,11 @@ If nil, use `temporary-file-directory'." (unless ps-run-mode-map (setq ps-run-mode-map (make-sparse-keymap)) + (set-keymap-parent ps-run-mode-map comint-mode-map) (define-key ps-run-mode-map "\C-c\C-q" 'ps-run-quit) (define-key ps-run-mode-map "\C-c\C-k" 'ps-run-kill) (define-key ps-run-mode-map "\C-c\C-e" 'ps-run-goto-error) - (define-key ps-run-mode-map [mouse-2] 'ps-run-mouse-goto-error) - (define-key ps-run-mode-map "\r" 'ps-run-newline) - (define-key ps-run-mode-map [return] 'ps-run-newline)) + (define-key ps-run-mode-map [mouse-2] 'ps-run-mouse-goto-error)) ;; Syntax table. @@ -681,7 +681,7 @@ defines the beginning of a group. These tokens are: { [ <<" (if (or (not ps-mode-auto-indent) (< ps-mode-tab 1) (not (re-search-backward "^[ \t]+\\=" nil t))) - (delete-backward-char 1) + (call-interactively 'delete-backward-char) (setq target (ps-mode-target-column)) (while (> column target) (setq target (+ target ps-mode-tab))) @@ -718,12 +718,9 @@ defines the beginning of a group. These tokens are: { [ <<" (blink-matching-open)) (defun ps-mode-other-newline () - "Perform newline in `*ps run*' buffer." + "Perform newline in `*ps-run*' buffer." (interactive) - (let ((buf (current-buffer))) - (set-buffer "*ps run*") - (ps-run-newline) - (set-buffer buf))) + (ps-run-send-string "")) ;; Print PostScript. @@ -980,7 +977,7 @@ plus the usually uncoded characters inserted on positions 1 through 28." ;; Interactive PostScript interpreter. -(define-derived-mode ps-run-mode fundamental-mode "Interactive PS" +(define-derived-mode ps-run-mode comint-mode "Interactive PS" "Major mode in interactive PostScript window. This mode is invoked from `ps-mode' and should not be called directly. @@ -1014,20 +1011,23 @@ This mode is invoked from `ps-mode' and should not be called directly. (setq init-file (ps-run-make-tmp-filename)) (write-region (concat ps-run-init "\n") 0 init-file) (setq init-file (list init-file))) - (pop-to-buffer "*ps run*") + (pop-to-buffer "*ps-run*") (ps-run-mode) (when (process-status "ps-run") (delete-process "ps-run")) (erase-buffer) (setq command (append command init-file)) (insert (mapconcat 'identity command " ") "\n") - (apply 'start-process "ps-run" "*ps run*" command) + (apply 'make-comint "ps-run" (car command) nil (cdr command)) + (with-current-buffer "*ps-run*" + (use-local-map ps-run-mode-map) + (setq comint-prompt-regexp ps-run-prompt)) (select-window oldwin))) (defun ps-run-quit () "Quit interactive PostScript." (interactive) - (ps-run-send-string "quit" t) + (ps-run-send-string "quit") (ps-run-cleanup)) (defun ps-run-kill () @@ -1039,9 +1039,9 @@ This mode is invoked from `ps-mode' and should not be called directly. (defun ps-run-clear () "Clear/reset PostScript graphics." (interactive) - (ps-run-send-string "showpage" t) + (ps-run-send-string "showpage") (sit-for 1) - (ps-run-send-string "" t)) + (ps-run-send-string "")) (defun ps-run-buffer () "Send buffer to PostScript interpreter." @@ -1056,7 +1056,7 @@ This mode is invoked from `ps-mode' and should not be called directly. (let ((f (ps-run-make-tmp-filename))) (set-marker ps-run-mark begin) (write-region begin end f) - (ps-run-send-string (format "(%s) run" f) t))) + (ps-run-send-string (format "(%s) run" f)))) (defun ps-run-boundingbox () "View BoundingBox." @@ -1104,17 +1104,15 @@ grestore " x1 y1 x2 y1 x2 y2 x1 y2) 0 f) - (ps-run-send-string (format "(%s) run" f) t) + (ps-run-send-string (format "(%s) run" f)) (set-buffer buf))) -(defun ps-run-send-string (string &optional echo) +(defun ps-run-send-string (string) (let ((oldwin (selected-window))) - (pop-to-buffer "*ps run*") - (goto-char (point-max)) - (when echo - (insert string "\n")) - (set-marker (process-mark (get-process "ps-run")) (point)) - (process-send-string "ps-run" (concat string "\n")) + (pop-to-buffer "*ps-run*") + (comint-goto-process-mark) + (insert string) + (comint-send-input) (select-window oldwin))) (defun ps-run-make-tmp-filename () @@ -1140,18 +1138,6 @@ grestore (mouse-set-point event) (ps-run-goto-error)) -(defun ps-run-newline () - "Process newline in PostScript interpreter window." - (interactive) - (end-of-line) - (insert "\n") - (forward-line -1) - (when (looking-at ps-run-prompt) - (goto-char (match-end 0))) - (looking-at ".*") - (goto-char (1+ (match-end 0))) - (ps-run-send-string (buffer-substring (match-beginning 0) (match-end 0)))) - (defun ps-run-goto-error () "Jump to buffer position read as integer at point. Use line numbers if `ps-run-error-line-numbers' is not nil" diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index 6fdaa126b5b..0a641d0945f 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -110,7 +110,8 @@ (,(rx symbol-start (group "def") (1+ space) (group (1+ (or word ?_)))) (1 font-lock-keyword-face) (2 font-lock-function-name-face)) ;; Top-level assignments are worth highlighting. - (,(rx line-start (group (1+ (or word ?_))) (0+ space) "=") + (,(rx line-start (group (1+ (or word ?_))) (0+ space) + (opt (or "+" "-" "*" "**" "/" "//" "&" "%" "|" "^" "<<" ">>")) "=") (1 font-lock-variable-name-face)) ;; Decorators. (,(rx line-start (* (any " \t")) (group "@" (1+ (or word ?_)) @@ -166,20 +167,20 @@ symbol-end) . font-lock-builtin-face))) -(defconst python-font-lock-syntactic-keywords +(defconst python-syntax-propertize-function ;; Make outer chars of matching triple-quote sequences into generic ;; string delimiters. Fixme: Is there a better way? ;; First avoid a sequence preceded by an odd number of backslashes. - `((,(concat "\\(?:\\([RUru]\\)[Rr]?\\|^\\|[^\\]\\(?:\\\\.\\)*\\)" ;Prefix. + (syntax-propertize-rules + (;; ¡Backrefs don't work in syntax-propertize-rules! + (concat "\\(?:\\([RUru]\\)[Rr]?\\|^\\|[^\\]\\(?:\\\\.\\)*\\)" ;Prefix. "\\(?:\\('\\)'\\('\\)\\|\\(?2:\"\\)\"\\(?3:\"\\)\\)") - (1 (python-quote-syntax 1) nil lax) - (2 (python-quote-syntax 2)) - (3 (python-quote-syntax 3))) - ;; This doesn't really help. -;;; (,(rx (and ?\\ (group ?\n))) (1 " ")) - )) - -(defun python-quote-syntax (n) + (3 (ignore (python-quote-syntax)))) + ;; This doesn't really help. + ;;((rx (and ?\\ (group ?\n))) (1 " ")) + )) + +(defun python-quote-syntax () "Put `syntax-table' property correctly on triple quote. Used for syntactic keywords. N is the match number (1, 2 or 3)." ;; Given a triple quote, we have to check the context to know @@ -197,28 +198,25 @@ Used for syntactic keywords. N is the match number (1, 2 or 3)." ;; x '"""' x """ \"""" x (save-excursion (goto-char (match-beginning 0)) - (cond - ;; Consider property for the last char if in a fenced string. - ((= n 3) - (let* ((font-lock-syntactic-keywords nil) - (syntax (syntax-ppss))) - (when (eq t (nth 3 syntax)) ; after unclosed fence - (goto-char (nth 8 syntax)) ; fence position - (skip-chars-forward "uUrR") ; skip any prefix - ;; Is it a matching sequence? - (if (eq (char-after) (char-after (match-beginning 2))) - (eval-when-compile (string-to-syntax "|")))))) - ;; Consider property for initial char, accounting for prefixes. - ((or (and (= n 2) ; leading quote (not prefix) - (not (match-end 1))) ; prefix is null - (and (= n 1) ; prefix - (match-end 1))) ; non-empty - (let ((font-lock-syntactic-keywords nil)) - (unless (eq 'string (syntax-ppss-context (syntax-ppss))) - (eval-when-compile (string-to-syntax "|"))))) - ;; Otherwise (we're in a non-matching string) the property is - ;; nil, which is OK. - ))) + (let ((syntax (save-match-data (syntax-ppss)))) + (cond + ((eq t (nth 3 syntax)) ; after unclosed fence + ;; Consider property for the last char if in a fenced string. + (goto-char (nth 8 syntax)) ; fence position + (skip-chars-forward "uUrR") ; skip any prefix + ;; Is it a matching sequence? + (if (eq (char-after) (char-after (match-beginning 2))) + (put-text-property (match-beginning 3) (match-end 3) + 'syntax-table (string-to-syntax "|")))) + ((match-end 1) + ;; Consider property for initial char, accounting for prefixes. + (put-text-property (match-beginning 1) (match-end 1) + 'syntax-table (string-to-syntax "|"))) + (t + ;; Consider property for initial char, accounting for prefixes. + (put-text-property (match-beginning 2) (match-end 2) + 'syntax-table (string-to-syntax "|")))) + ))) ;; This isn't currently in `font-lock-defaults' as probably not worth ;; it -- we basically only mess with a few normally-symbol characters. @@ -2291,6 +2289,7 @@ the if condition." (eval-when-compile ;; Define a user-level skeleton and add it to the abbrev table. (defmacro def-python-skeleton (name &rest elements) + (declare (indent 2)) (let* ((name (symbol-name name)) (function (intern (concat "python-insert-" name)))) `(progn @@ -2303,7 +2302,6 @@ the if condition." (define-skeleton ,function ,(format "Insert Python \"%s\" template." name) ,@elements))))) -(put 'def-python-skeleton 'lisp-indent-function 2) ;; From `skeleton-further-elements' set below: ;; `<': outdent a level; @@ -2501,12 +2499,12 @@ with skeleton expansions for compound statement templates. :group 'python (set (make-local-variable 'font-lock-defaults) '(python-font-lock-keywords nil nil nil nil - (font-lock-syntactic-keywords - . python-font-lock-syntactic-keywords) - ;; This probably isn't worth it. - ;; (font-lock-syntactic-face-function - ;; . python-font-lock-syntactic-face-function) - )) + ;; This probably isn't worth it. + ;; (font-lock-syntactic-face-function + ;; . python-font-lock-syntactic-face-function) + )) + (set (make-local-variable 'syntax-propertize-function) + python-syntax-propertize-function) (set (make-local-variable 'parse-sexp-lookup-properties) t) (set (make-local-variable 'parse-sexp-ignore-comments) t) (set (make-local-variable 'comment-start) "# ") @@ -2611,7 +2609,7 @@ This function is appropriate for `comint-output-filter-functions'." overlay-arrow-string "=>" python-pdbtrack-is-tracking-p t) (set-marker overlay-arrow-position - (save-excursion (beginning-of-line) (point)) + (line-beginning-position) (current-buffer))) (setq overlay-arrow-position nil python-pdbtrack-is-tracking-p nil))) diff --git a/lisp/progmodes/ruby-mode.el b/lisp/progmodes/ruby-mode.el index 59d85e60eef..b6158a0e581 100644 --- a/lisp/progmodes/ruby-mode.el +++ b/lisp/progmodes/ruby-mode.el @@ -1,7 +1,7 @@ ;;; ruby-mode.el --- Major mode for editing Ruby files -;; Copyright (C) 1994, 1995, 1996 1997, 1998, 1999, 2000, 2001, -;; 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; Copyright (C) 1994, 1995, 1996 1997, 1998, 1999, 2000, 2001, 2002, +;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 ;; Free Software Foundation, Inc. ;; Authors: Yukihiro Matsumoto @@ -43,6 +43,11 @@ (eval-when-compile (require 'cl)) +(defgroup ruby nil + "Major mode for editing Ruby code." + :prefix "ruby-" + :group 'languages) + (defconst ruby-keyword-end-re (if (string-match "\\_>" "ruby") "\\_>" @@ -95,17 +100,10 @@ (defconst ruby-block-end-re "\\<end\\>") -(defconst ruby-here-doc-beg-re +(eval-and-compile + (defconst ruby-here-doc-beg-re "\\(<\\)<\\(-\\)?\\(\\([a-zA-Z0-9_]+\\)\\|[\"]\\([^\"]+\\)[\"]\\|[']\\([^']+\\)[']\\)" - "Regexp to match the beginning of a heredoc.") - -(defconst ruby-here-doc-end-re - "^\\([ \t]+\\)?\\(.*\\)\\(.\\)$" - "Regexp to match the end of heredocs. - -This will actually match any line with one or more characters. -It's useful in that it divides up the match string so that -`ruby-here-doc-beg-match' can search for the beginning of the heredoc.") + "Regexp to match the beginning of a heredoc.")) (defun ruby-here-doc-end-match () "Return a regexp to find the end of a heredoc. @@ -118,18 +116,6 @@ This should only be called after matching against `ruby-here-doc-beg-re'." (match-string 5) (match-string 6))))) -(defun ruby-here-doc-beg-match () - "Return a regexp to find the beginning of a heredoc. - -This should only be called after matching against `ruby-here-doc-end-re'." - (let ((contents (regexp-quote (concat (match-string 2) (match-string 3))))) - (concat "<<" - (let ((match (match-string 1))) - (if (and match (> (length match) 0)) - (concat "\\(?:-\\([\"']?\\)\\|\\([\"']\\)" (match-string 1) "\\)" - contents "\\b\\(\\1\\|\\2\\)") - (concat "-?\\([\"']\\|\\)" contents "\\b\\1")))))) - (defconst ruby-delimiter (concat "[?$/%(){}#\"'`.:]\\|<<\\|\\[\\|\\]\\|\\<\\(" ruby-block-beg-re @@ -149,11 +135,9 @@ This should only be called after matching against `ruby-here-doc-end-re'." (defconst ruby-symbol-re (concat "[" ruby-symbol-chars "]") "Regexp to match symbols.") -(defvar ruby-mode-abbrev-table nil +(define-abbrev-table 'ruby-mode-abbrev-table () "Abbrev table in use in Ruby mode buffers.") -(define-abbrev-table 'ruby-mode-abbrev-table ()) - (defvar ruby-mode-map (let ((map (make-sparse-keymap))) (define-key map "{" 'ruby-electric-brace) @@ -166,7 +150,6 @@ This should only be called after matching against `ruby-here-doc-end-re'." (define-key map (kbd "M-C-n") 'ruby-end-of-block) (define-key map (kbd "M-C-h") 'ruby-mark-defun) (define-key map (kbd "M-C-q") 'ruby-indent-exp) - (define-key map (kbd "TAB") 'ruby-indent-line) (define-key map (kbd "C-M-h") 'backward-kill-word) (define-key map (kbd "C-j") 'reindent-then-newline-and-indent) (define-key map (kbd "C-m") 'newline) @@ -358,7 +341,7 @@ Also ignores spaces after parenthesis when 'space." (back-to-indentation) (current-column))) -(defun ruby-indent-line (&optional flag) +(defun ruby-indent-line (&optional ignored) "Correct the indentation of the current Ruby line." (interactive) (ruby-indent-to (ruby-calculate-indent))) @@ -401,8 +384,7 @@ and `\\' when preceded by `?'." "TODO: document." (save-excursion (store-match-data nil) - (let ((space (skip-chars-backward " \t")) - (start (point))) + (let ((space (skip-chars-backward " \t"))) (cond ((bolp) t) ((progn @@ -634,7 +616,7 @@ and `\\' when preceded by `?'." (setq re (regexp-quote (or (match-string 4) (match-string 2)))) (if (match-beginning 1) (setq re (concat "\\s *" re))) (let* ((id-end (goto-char (match-end 0))) - (line-end-position (save-excursion (end-of-line) (point))) + (line-end-position (point-at-eol)) (state (list in-string nest depth pcol indent))) ;; parse the rest of the line (while (and (> line-end-position (point)) @@ -696,7 +678,7 @@ and `\\' when preceded by `?'." (beginning-of-line) (let ((ruby-indent-point (point)) (case-fold-search nil) - state bol eol begin op-end + state eol begin op-end (paren (progn (skip-syntax-forward " ") (and (char-after) (matching-paren (char-after))))) (indent 0)) @@ -776,7 +758,6 @@ and `\\' when preceded by `?'." (if (re-search-forward "^\\s *#" end t) (beginning-of-line) (setq done t)))) - (setq bol (point)) (end-of-line) ;; skip the comment at the end (skip-chars-backward " \t") @@ -1033,10 +1014,8 @@ With ARG, do it many times. Negative ARG means move forward." (ruby-beginning-of-defun) (re-search-backward "^\n" (- (point) 1) t)) -(defun ruby-indent-exp (&optional shutup-p) - "Indent each line in the balanced expression following the point. -If a prefix arg is given or SHUTUP-P is non-nil, no errors -are signalled if a balanced expression isn't found." +(defun ruby-indent-exp (&optional ignored) + "Indent each line in the balanced expression following the point." (interactive "*P") (let ((here (point-marker)) start top column (nest t)) (set-marker-insertion-type here t) @@ -1129,58 +1108,210 @@ See `add-log-current-defun-function'." (if mlist (concat mlist mname) mname) mlist))))) -(defconst ruby-font-lock-syntactic-keywords - `(;; #{ }, #$hoge, #@foo are not comments - ("\\(#\\)[{$@]" 1 (1 . nil)) - ;; the last $', $", $` in the respective string is not variable - ;; the last ?', ?", ?` in the respective string is not ascii code - ("\\(^\\|[\[ \t\n<+\(,=]\\)\\(['\"`]\\)\\(\\\\.\\|\\2\\|[^'\"`\n\\\\]\\)*?\\\\?[?$]\\(\\2\\)" - (2 (7 . nil)) - (4 (7 . nil))) - ;; $' $" $` .... are variables - ;; ?' ?" ?` are ascii codes - ("\\(^\\|[^\\\\]\\)\\(\\\\\\\\\\)*[?$]\\([#\"'`]\\)" 3 (1 . nil)) - ;; regexps - ("\\(^\\|[=(,~?:;<>]\\|\\(^\\|\\s \\)\\(if\\|elsif\\|unless\\|while\\|until\\|when\\|and\\|or\\|&&\\|||\\)\\|g?sub!?\\|scan\\|split!?\\)\\s *\\(/\\)[^/\n\\\\]*\\(\\\\.[^/\n\\\\]*\\)*\\(/\\)" - (4 (7 . ?/)) - (6 (7 . ?/))) - ("^=en\\(d\\)\\_>" 1 "!") - ("^\\(=\\)begin\\_>" 1 (ruby-comment-beg-syntax)) - ;; Currently, the following case is highlighted incorrectly: - ;; - ;; <<FOO - ;; FOO - ;; <<BAR - ;; <<BAZ - ;; BAZ - ;; BAR - ;; - ;; This is because all here-doc beginnings are highlighted before any endings, - ;; so although <<BAR is properly marked as a beginning, when we get to <<BAZ - ;; it thinks <<BAR is part of a string so it's marked as well. - ;; - ;; This may be fixable by modifying ruby-in-here-doc-p to use - ;; ruby-in-non-here-doc-string-p rather than syntax-ppss-context, - ;; but I don't want to try that until we've got unit tests set up - ;; to make sure I don't break anything else. - (,(concat ruby-here-doc-beg-re ".*\\(\n\\)") - ,(+ 1 (regexp-opt-depth ruby-here-doc-beg-re)) - (ruby-here-doc-beg-syntax)) - (,ruby-here-doc-end-re 3 (ruby-here-doc-end-syntax))) - "Syntactic keywords for Ruby mode. See `font-lock-syntactic-keywords'.") - -(defun ruby-comment-beg-syntax () - "Return the syntax cell for a the first character of a =begin. +(declare-function ruby-syntax-propertize-heredoc "ruby-mode" (limit)) + +(if (eval-when-compile (fboundp #'syntax-propertize-rules)) + ;; New code that works independently from font-lock. + (progn + (defun ruby-syntax-propertize-function (start end) + "Syntactic keywords for Ruby mode. See `syntax-propertize-function'." + (goto-char start) + (ruby-syntax-propertize-heredoc end) + (funcall + (syntax-propertize-rules + ;; #{ }, #$hoge, #@foo are not comments + ("\\(#\\)[{$@]" (1 ".")) + ;; the last $', $", $` in the respective string is not variable + ;; the last ?', ?", ?` in the respective string is not ascii code + ("\\(^\\|[\[ \t\n<+\(,=]\\)\\(['\"`]\\)\\(\\\\.\\|\\2\\|[^'\"`\n\\\\]\\)*?\\\\?[?$]\\(\\2\\)" + (2 "\"") + (4 "\"")) + ;; $' $" $` .... are variables + ;; ?' ?" ?` are ascii codes + ("\\(^\\|[^\\\\]\\)\\(\\\\\\\\\\)*[?$]\\([#\"'`]\\)" (3 ".")) + ;; regexps + ("\\(^\\|[=(,~?:;<>]\\|\\(^\\|\\s \\)\\(if\\|elsif\\|unless\\|while\\|until\\|when\\|and\\|or\\|&&\\|||\\)\\|g?sub!?\\|scan\\|split!?\\)\\s *\\(/\\)[^/\n\\\\]*\\(\\\\.[^/\n\\\\]*\\)*\\(/\\)" + (4 "\"/") + (6 "\"/")) + ("^=en\\(d\\)\\_>" (1 "!")) + ("^\\(=\\)begin\\_>" (1 "!")) + ;; Handle here documents. + ((concat ruby-here-doc-beg-re ".*\\(\n\\)") + (7 (prog1 "\"" (ruby-syntax-propertize-heredoc end))))) + (point) end)) + + (defun ruby-syntax-propertize-heredoc (limit) + (let ((ppss (syntax-ppss)) + (res '())) + (when (eq ?\n (nth 3 ppss)) + (save-excursion + (goto-char (nth 8 ppss)) + (beginning-of-line) + (while (re-search-forward ruby-here-doc-beg-re + (line-end-position) t) + (push (concat (ruby-here-doc-end-match) "\n") res))) + (let ((start (point))) + ;; With multiple openers on the same line, we don't know in which + ;; part `start' is, so we have to go back to the beginning. + (when (cdr res) + (goto-char (nth 8 ppss)) + (setq res (nreverse res))) + (while (and res (re-search-forward (pop res) limit 'move)) + (if (null res) + (put-text-property (1- (point)) (point) + 'syntax-table (string-to-syntax "\"")))) + ;; Make extra sure we don't move back, lest we could fall into an + ;; inf-loop. + (if (< (point) start) (goto-char start)))))) + ) + + ;; For Emacsen where syntax-propertize-rules is not (yet) available, + ;; fallback on the old font-lock-syntactic-keywords stuff. + + (defconst ruby-here-doc-end-re + "^\\([ \t]+\\)?\\(.*\\)\\(\n\\)" + "Regexp to match the end of heredocs. + +This will actually match any line with one or more characters. +It's useful in that it divides up the match string so that +`ruby-here-doc-beg-match' can search for the beginning of the heredoc.") + + (defun ruby-here-doc-beg-match () + "Return a regexp to find the beginning of a heredoc. + +This should only be called after matching against `ruby-here-doc-end-re'." + (let ((contents (regexp-quote (match-string 2)))) + (concat "<<" + (let ((match (match-string 1))) + (if (and match (> (length match) 0)) + (concat "\\(?:-\\([\"']?\\)\\|\\([\"']\\)" match "\\)" + contents "\\b\\(\\1\\|\\2\\)") + (concat "-?\\([\"']\\|\\)" contents "\\b\\1")))))) + + (defconst ruby-font-lock-syntactic-keywords + `( ;; #{ }, #$hoge, #@foo are not comments + ("\\(#\\)[{$@]" 1 (1 . nil)) + ;; the last $', $", $` in the respective string is not variable + ;; the last ?', ?", ?` in the respective string is not ascii code + ("\\(^\\|[\[ \t\n<+\(,=]\\)\\(['\"`]\\)\\(\\\\.\\|\\2\\|[^'\"`\n\\\\]\\)*?\\\\?[?$]\\(\\2\\)" + (2 (7 . nil)) + (4 (7 . nil))) + ;; $' $" $` .... are variables + ;; ?' ?" ?` are ascii codes + ("\\(^\\|[^\\\\]\\)\\(\\\\\\\\\\)*[?$]\\([#\"'`]\\)" 3 (1 . nil)) + ;; regexps + ("\\(^\\|[=(,~?:;<>]\\|\\(^\\|\\s \\)\\(if\\|elsif\\|unless\\|while\\|until\\|when\\|and\\|or\\|&&\\|||\\)\\|g?sub!?\\|scan\\|split!?\\)\\s *\\(/\\)[^/\n\\\\]*\\(\\\\.[^/\n\\\\]*\\)*\\(/\\)" + (4 (7 . ?/)) + (6 (7 . ?/))) + ("^=en\\(d\\)\\_>" 1 "!") + ("^\\(=\\)begin\\_>" 1 (ruby-comment-beg-syntax)) + ;; Currently, the following case is highlighted incorrectly: + ;; + ;; <<FOO + ;; FOO + ;; <<BAR + ;; <<BAZ + ;; BAZ + ;; BAR + ;; + ;; This is because all here-doc beginnings are highlighted before any endings, + ;; so although <<BAR is properly marked as a beginning, when we get to <<BAZ + ;; it thinks <<BAR is part of a string so it's marked as well. + ;; + ;; This may be fixable by modifying ruby-in-here-doc-p to use + ;; ruby-in-non-here-doc-string-p rather than syntax-ppss-context, + ;; but I don't want to try that until we've got unit tests set up + ;; to make sure I don't break anything else. + (,(concat ruby-here-doc-beg-re ".*\\(\n\\)") + ,(+ 1 (regexp-opt-depth ruby-here-doc-beg-re)) + (ruby-here-doc-beg-syntax)) + (,ruby-here-doc-end-re 3 (ruby-here-doc-end-syntax))) + "Syntactic keywords for Ruby mode. See `font-lock-syntactic-keywords'.") + + (defun ruby-comment-beg-syntax () + "Return the syntax cell for a the first character of a =begin. See the definition of `ruby-font-lock-syntactic-keywords'. This returns a comment-delimiter cell as long as the =begin isn't in a string or another comment." - (when (not (nth 3 (syntax-ppss))) - (string-to-syntax "!"))) + (when (not (nth 3 (syntax-ppss))) + (string-to-syntax "!"))) + + (defun ruby-in-here-doc-p () + "Return whether or not the point is in a heredoc." + (save-excursion + (let ((old-point (point)) (case-fold-search nil)) + (beginning-of-line) + (catch 'found-beg + (while (re-search-backward ruby-here-doc-beg-re nil t) + (if (not (or (ruby-in-ppss-context-p 'anything) + (ruby-here-doc-find-end old-point))) + (throw 'found-beg t))))))) + + (defun ruby-here-doc-find-end (&optional limit) + "Expects the point to be on a line with one or more heredoc openers. +Returns the buffer position at which all heredocs on the line +are terminated, or nil if they aren't terminated before the +buffer position `limit' or the end of the buffer." + (save-excursion + (beginning-of-line) + (catch 'done + (let ((eol (point-at-eol)) + (case-fold-search nil) + ;; Fake match data such that (match-end 0) is at eol + (end-match-data (progn (looking-at ".*$") (match-data))) + beg-match-data end-re) + (while (re-search-forward ruby-here-doc-beg-re eol t) + (setq beg-match-data (match-data)) + (setq end-re (ruby-here-doc-end-match)) + + (set-match-data end-match-data) + (goto-char (match-end 0)) + (unless (re-search-forward end-re limit t) (throw 'done nil)) + (setq end-match-data (match-data)) + + (set-match-data beg-match-data) + (goto-char (match-end 0))) + (set-match-data end-match-data) + (goto-char (match-end 0)) + (point))))) -(unless (functionp 'syntax-ppss) - (defun syntax-ppss (&optional pos) - (parse-partial-sexp (point-min) (or pos (point))))) + (defun ruby-here-doc-beg-syntax () + "Return the syntax cell for a line that may begin a heredoc. +See the definition of `ruby-font-lock-syntactic-keywords'. + +This sets the syntax cell for the newline ending the line +containing the heredoc beginning so that cases where multiple +heredocs are started on one line are handled correctly." + (save-excursion + (goto-char (match-beginning 0)) + (unless (or (ruby-in-ppss-context-p 'non-heredoc) + (ruby-in-here-doc-p)) + (string-to-syntax "\"")))) + + (defun ruby-here-doc-end-syntax () + "Return the syntax cell for a line that may end a heredoc. +See the definition of `ruby-font-lock-syntactic-keywords'." + (let ((pss (syntax-ppss)) (case-fold-search nil)) + ;; If we aren't in a string, we definitely aren't ending a heredoc, + ;; so we can just give up. + ;; This means we aren't doing a full-document search + ;; every time we enter a character. + (when (ruby-in-ppss-context-p 'heredoc pss) + (save-excursion + (goto-char (nth 8 pss)) ; Go to the beginning of heredoc. + (let ((eol (point))) + (beginning-of-line) + (if (and (re-search-forward (ruby-here-doc-beg-match) eol t) ; If there is a heredoc that matches this line... + (not (ruby-in-ppss-context-p 'anything)) ; And that's not inside a heredoc/string/comment... + (progn (goto-char (match-end 0)) ; And it's the last heredoc on its line... + (not (re-search-forward ruby-here-doc-beg-re eol t)))) + (string-to-syntax "\""))))))) + + (unless (functionp 'syntax-ppss) + (defun syntax-ppss (&optional pos) + (parse-partial-sexp (point-min) (or pos (point))))) + ) (defun ruby-in-ppss-context-p (context &optional ppss) (let ((ppss (or ppss (syntax-ppss (point))))) @@ -1191,10 +1322,7 @@ isn't in a string or another comment." ((eq context 'string) (nth 3 ppss)) ((eq context 'heredoc) - (and (nth 3 ppss) - ;; If it's generic string, it's a heredoc and we don't care - ;; See `parse-partial-sexp' - (not (numberp (nth 3 ppss))))) + (eq ?\n (nth 3 ppss))) ((eq context 'non-heredoc) (and (ruby-in-ppss-context-p 'anything) (not (ruby-in-ppss-context-p 'heredoc)))) @@ -1206,77 +1334,6 @@ isn't in a string or another comment." "context name `" (symbol-name context) "' is unknown")))) t))) -(defun ruby-in-here-doc-p () - "Return whether or not the point is in a heredoc." - (save-excursion - (let ((old-point (point)) (case-fold-search nil)) - (beginning-of-line) - (catch 'found-beg - (while (re-search-backward ruby-here-doc-beg-re nil t) - (if (not (or (ruby-in-ppss-context-p 'anything) - (ruby-here-doc-find-end old-point))) - (throw 'found-beg t))))))) - -(defun ruby-here-doc-find-end (&optional limit) - "Expects the point to be on a line with one or more heredoc openers. -Returns the buffer position at which all heredocs on the line -are terminated, or nil if they aren't terminated before the -buffer position `limit' or the end of the buffer." - (save-excursion - (beginning-of-line) - (catch 'done - (let ((eol (save-excursion (end-of-line) (point))) - (case-fold-search nil) - ;; Fake match data such that (match-end 0) is at eol - (end-match-data (progn (looking-at ".*$") (match-data))) - beg-match-data end-re) - (while (re-search-forward ruby-here-doc-beg-re eol t) - (setq beg-match-data (match-data)) - (setq end-re (ruby-here-doc-end-match)) - - (set-match-data end-match-data) - (goto-char (match-end 0)) - (unless (re-search-forward end-re limit t) (throw 'done nil)) - (setq end-match-data (match-data)) - - (set-match-data beg-match-data) - (goto-char (match-end 0))) - (set-match-data end-match-data) - (goto-char (match-end 0)) - (point))))) - -(defun ruby-here-doc-beg-syntax () - "Return the syntax cell for a line that may begin a heredoc. -See the definition of `ruby-font-lock-syntactic-keywords'. - -This sets the syntax cell for the newline ending the line -containing the heredoc beginning so that cases where multiple -heredocs are started on one line are handled correctly." - (save-excursion - (goto-char (match-beginning 0)) - (unless (or (ruby-in-ppss-context-p 'non-heredoc) - (ruby-in-here-doc-p)) - (string-to-syntax "|")))) - -(defun ruby-here-doc-end-syntax () - "Return the syntax cell for a line that may end a heredoc. -See the definition of `ruby-font-lock-syntactic-keywords'." - (let ((pss (syntax-ppss)) (case-fold-search nil)) - ;; If we aren't in a string, we definitely aren't ending a heredoc, - ;; so we can just give up. - ;; This means we aren't doing a full-document search - ;; every time we enter a character. - (when (ruby-in-ppss-context-p 'heredoc pss) - (save-excursion - (goto-char (nth 8 pss)) ; Go to the beginning of heredoc. - (let ((eol (point))) - (beginning-of-line) - (if (and (re-search-forward (ruby-here-doc-beg-match) eol t) ; If there is a heredoc that matches this line... - (not (ruby-in-ppss-context-p 'anything)) ; And that's not inside a heredoc/string/comment... - (progn (goto-char (match-end 0)) ; And it's the last heredoc on its line... - (not (re-search-forward ruby-here-doc-beg-re eol t)))) - (string-to-syntax "|"))))))) - (if (featurep 'xemacs) (put 'ruby-mode 'font-lock-defaults '((ruby-font-lock-keywords) @@ -1374,7 +1431,7 @@ See `font-lock-syntax-table'.") "Additional expressions to highlight in Ruby mode.") ;;;###autoload -(defun ruby-mode () +(define-derived-mode ruby-mode prog-mode "Ruby" "Major mode for editing Ruby scripts. \\[ruby-indent-line] properly indents subexpressions of multi-line class, module, def, if, while, for, do, and case statements, taking @@ -1383,11 +1440,6 @@ nesting into account. The variable `ruby-indent-level' controls the amount of indentation. \\{ruby-mode-map}" - (interactive) - (kill-all-local-variables) - (use-local-map ruby-mode-map) - (setq mode-name "Ruby") - (setq major-mode 'ruby-mode) (ruby-mode-variables) (set (make-local-variable 'imenu-create-index-function) @@ -1396,12 +1448,13 @@ The variable `ruby-indent-level' controls the amount of indentation. 'ruby-add-log-current-method) (add-hook - (cond ((boundp 'before-save-hook) - (make-local-variable 'before-save-hook) - 'before-save-hook) + (cond ((boundp 'before-save-hook) 'before-save-hook) ((boundp 'write-contents-functions) 'write-contents-functions) ((boundp 'write-contents-hooks) 'write-contents-hooks)) - 'ruby-mode-set-encoding) + 'ruby-mode-set-encoding nil 'local) + + (set (make-local-variable 'electric-indent-chars) + (append '(?\{ ?\}) electric-indent-chars)) (set (make-local-variable 'font-lock-defaults) '((ruby-font-lock-keywords) nil nil)) @@ -1409,12 +1462,12 @@ The variable `ruby-indent-level' controls the amount of indentation. ruby-font-lock-keywords) (set (make-local-variable 'font-lock-syntax-table) ruby-font-lock-syntax-table) - (set (make-local-variable 'font-lock-syntactic-keywords) - ruby-font-lock-syntactic-keywords) - (if (fboundp 'run-mode-hooks) - (run-mode-hooks 'ruby-mode-hook) - (run-hooks 'ruby-mode-hook))) + (if (eval-when-compile (fboundp 'syntax-propertize-rules)) + (set (make-local-variable 'syntax-propertize-function) + #'ruby-syntax-propertize-function) + (set (make-local-variable 'font-lock-syntactic-keywords) + ruby-font-lock-syntactic-keywords))) ;;; Invoke ruby-mode when appropriate @@ -1427,5 +1480,4 @@ The variable `ruby-indent-level' controls the amount of indentation. (provide 'ruby-mode) -;; arch-tag: e6ecc893-8005-420c-b7f9-34ab99a1fff9 ;;; ruby-mode.el ends here diff --git a/lisp/progmodes/scheme.el b/lisp/progmodes/scheme.el index ce8a34220e4..da143db5ffb 100644 --- a/lisp/progmodes/scheme.el +++ b/lisp/progmodes/scheme.el @@ -107,7 +107,7 @@ ;; Special characters (modify-syntax-entry ?, "' " st) (modify-syntax-entry ?@ "' " st) - (modify-syntax-entry ?# "' 14b" st) + (modify-syntax-entry ?# "' 14" st) (modify-syntax-entry ?\\ "\\ " st) st)) diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el index 610fa14489a..1f085045192 100644 --- a/lisp/progmodes/sh-script.el +++ b/lisp/progmodes/sh-script.el @@ -1,7 +1,8 @@ ;;; sh-script.el --- shell-script editing commands for Emacs ;; Copyright (C) 1993, 1994, 1995, 1996, 1997, 1999, 2001, 2002, 2003, -;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. +;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; Free Software Foundation, Inc. ;; Author: Daniel Pfeiffer <occitan@esperanto.org> ;; Version: 2.0f @@ -411,11 +412,7 @@ the car and cdr are the same symbol.") (modify-syntax-entry (pop list) (pop list) table)) table) -(defvar sh-mode-syntax-table nil - "The syntax table to use for Shell-Script mode. -This is buffer-local in every such buffer.") - -(defvar sh-mode-default-syntax-table +(defvar sh-mode-syntax-table (sh-mode-syntax-table () ?\# "<" ?\n ">#" @@ -436,7 +433,8 @@ This is buffer-local in every such buffer.") ?= "." ?< "." ?> ".") - "Default syntax table for shell mode.") + "The syntax table to use for Shell-Script mode. +This is buffer-local in every such buffer.") (defvar sh-mode-syntax-table-input '((sh . nil)) @@ -611,7 +609,7 @@ sign. See `sh-feature'." (defvar sh-header-marker nil "When non-nil is the end of header for prepending by \\[sh-execute-region]. That command is also used for setting this variable.") - +(make-variable-buffer-local 'sh-header-marker) (defcustom sh-beginning-of-command "\\([;({`|&]\\|\\`\\|[^\\]\n\\)[ \t]*\\([/~[:alnum:]:]\\)" @@ -942,7 +940,6 @@ See `sh-feature'.") ;; These are used for the syntax table stuff (derived from cperl-mode). ;; Note: parse-sexp-lookup-properties must be set to t for it to work. (defconst sh-st-punc (string-to-syntax ".")) -(defconst sh-st-symbol (string-to-syntax "_")) (defconst sh-here-doc-syntax (string-to-syntax "|")) ;; generic string (defconst sh-escaped-line-re @@ -960,7 +957,7 @@ See `sh-feature'.") (defvar sh-here-doc-re sh-here-doc-open-re) (make-variable-buffer-local 'sh-here-doc-re) -(defun sh-font-lock-close-heredoc (bol eof indented) +(defun sh-font-lock-close-heredoc (bol eof indented eol) "Determine the syntax of the \\n after an EOF. If non-nil INDENTED indicates that the EOF was indented." (let* ((eof-re (if eof (regexp-quote eof) "")) @@ -974,6 +971,8 @@ If non-nil INDENTED indicates that the EOF was indented." (ere (concat "^" (if indented "[ \t]*") eof-re "\n")) (start (save-excursion (goto-char bol) + ;; FIXME: will incorrectly find a <<EOF embedded inside + ;; the heredoc. (re-search-backward (concat sre "\\|" ere) nil t)))) ;; If subgroup 1 matched, we found an open-heredoc, otherwise we first ;; found a close-heredoc which makes the current close-heredoc inoperant. @@ -993,7 +992,7 @@ If non-nil INDENTED indicates that the EOF was indented." (sh-in-comment-or-string (point))))) ;; No <<EOF2 found after our <<. (= (point) start))) - sh-here-doc-syntax) + (put-text-property eol (1+ eol) 'syntax-table sh-here-doc-syntax)) ((not (or start (save-excursion (re-search-forward sre nil t)))) ;; There's no <<EOF either before or after us, ;; so we should remove ourselves from font-lock's keywords. @@ -1003,7 +1002,7 @@ If non-nil INDENTED indicates that the EOF was indented." (regexp-opt sh-here-doc-markers t) "\\(\n\\)")) nil)))) -(defun sh-font-lock-open-heredoc (start string) +(defun sh-font-lock-open-heredoc (start string eol) "Determine the syntax of the \\n after a <<EOF. START is the position of <<. STRING is the actual word used as delimiter (e.g. \"EOF\"). @@ -1033,13 +1032,8 @@ Point is at the beginning of the next line." ;; Don't bother fixing it now, but place a multiline property so ;; that when jit-lock-context-* refontifies the rest of the ;; buffer, it also refontifies the current line with it. - (put-text-property start (point) 'font-lock-multiline t))) - sh-here-doc-syntax)) - -(defun sh-font-lock-here-doc (limit) - "Search for a heredoc marker." - ;; This looks silly, but it's because `sh-here-doc-re' keeps changing. - (re-search-forward sh-here-doc-re limit t)) + (put-text-property start (point) 'syntax-multiline t))) + (put-text-property eol (1+ eol) 'syntax-table sh-here-doc-syntax))) (defun sh-font-lock-quoted-subshell (limit) "Search for a subshell embedded in a string. @@ -1048,9 +1042,7 @@ subshells can nest." ;; FIXME: This can (and often does) match multiple lines, yet it makes no ;; effort to handle multiline cases correctly, so it ends up being ;; rather flakey. - (when (and (re-search-forward "\"\\(?:\\(?:.\\|\n\\)*?[^\\]\\(?:\\\\\\\\\\)*\\)??\\(\\$(\\|`\\)" limit t) - ;; Make sure the " we matched is an opening quote. - (eq ?\" (nth 3 (syntax-ppss)))) + (when (eq ?\" (nth 3 (syntax-ppss))) ; Check we matched an opening quote. ;; bingo we have a $( or a ` inside a "" (let ((char (char-after (point))) ;; `state' can be: double-quote, backquote, code. @@ -1085,8 +1077,7 @@ subshells can nest." (double-quote nil) (t (setq state (pop states))))) (t (error "Internal error in sh-font-lock-quoted-subshell"))) - (forward-char 1))) - t)) + (forward-char 1))))) (defun sh-is-quoted-p (pos) @@ -1125,7 +1116,7 @@ subshells can nest." (when (progn (backward-char 2) (if (> start (line-end-position)) (put-text-property (point) (1+ start) - 'font-lock-multiline t)) + 'syntax-multiline t)) ;; FIXME: The `in' may just be a random argument to ;; a normal command rather than the real `in' keyword. ;; I.e. we should look back to try and find the @@ -1139,40 +1130,44 @@ subshells can nest." sh-st-punc nil)) -(defun sh-font-lock-flush-syntax-ppss-cache (limit) - ;; This should probably be a standard function provided by font-lock.el - ;; (or syntax.el). - (syntax-ppss-flush-cache (point)) - (goto-char limit) - nil) - -(defconst sh-font-lock-syntactic-keywords - ;; A `#' begins a comment when it is unquoted and at the beginning of a - ;; word. In the shell, words are separated by metacharacters. - ;; The list of special chars is taken from the single-unix spec - ;; of the shell command language (under `quoting') but with `$' removed. - `(("[^|&;<>()`\\\"' \t\n]\\(#+\\)" 1 ,sh-st-symbol) - ;; In a '...' the backslash is not escaping. - ("\\(\\\\\\)'" (1 (sh-font-lock-backslash-quote))) - ;; The previous rule uses syntax-ppss, but the subsequent rules may - ;; change the syntax, so we have to tell syntax-ppss that the states it - ;; has just computed will need to be recomputed. - (sh-font-lock-flush-syntax-ppss-cache) - ;; Make sure $@ and $? are correctly recognized as sexps. - ("\\$\\([?@]\\)" 1 ,sh-st-symbol) - ;; Find HEREDOC starters and add a corresponding rule for the ender. - (sh-font-lock-here-doc - (2 (sh-font-lock-open-heredoc - (match-beginning 0) (match-string 1)) nil t) - (5 (sh-font-lock-close-heredoc - (match-beginning 0) (match-string 4) - (and (match-beginning 3) (/= (match-beginning 3) (match-end 3)))) - nil t)) - ;; Distinguish the special close-paren in `case'. - (")" 0 (sh-font-lock-paren (match-beginning 0))) - ;; highlight (possibly nested) subshells inside "" quoted regions correctly. - ;; This should be at the very end because it uses syntax-ppss. - (sh-font-lock-quoted-subshell))) +(defun sh-syntax-propertize-function (start end) + (goto-char start) + (while (prog1 + (re-search-forward sh-here-doc-re end 'move) + (save-excursion + (save-match-data + (funcall + (syntax-propertize-rules + ;; A `#' begins a comment when it is unquoted and at the + ;; beginning of a word. In the shell, words are separated by + ;; metacharacters. The list of special chars is taken from + ;; the single-unix spec of the shell command language (under + ;; `quoting') but with `$' removed. + ("[^|&;<>()`\\\"' \t\n]\\(#+\\)" (1 "_")) + ;; In a '...' the backslash is not escaping. + ("\\(\\\\\\)'" (1 (sh-font-lock-backslash-quote))) + ;; Make sure $@ and $? are correctly recognized as sexps. + ("\\$\\([?@]\\)" (1 "_")) + ;; Distinguish the special close-paren in `case'. + (")" (0 (sh-font-lock-paren (match-beginning 0)))) + ;; Highlight (possibly nested) subshells inside "" quoted + ;; regions correctly. + ("\"\\(?:\\(?:.\\|\n\\)*?[^\\]\\(?:\\\\\\\\\\)*\\)??\\(\\$(\\|`\\)" + (1 (ignore + ;; Save excursion because we want to also apply other + ;; syntax-propertize rules within the affected region. + (save-excursion + (sh-font-lock-quoted-subshell end)))))) + (prog1 start (setq start (point))) (point))))) + (if (match-beginning 2) + ;; FIXME: actually, once we see an heredoc opener, we should just + ;; search for its ender without propertizing anything in it. + (sh-font-lock-open-heredoc + (match-beginning 0) (match-string 1) (match-beginning 2)) + (sh-font-lock-close-heredoc + (match-beginning 0) (match-string 4) + (and (match-beginning 3) (/= (match-beginning 3) (match-end 3))) + (match-beginning 5))))) (defun sh-font-lock-syntactic-face-function (state) (let ((q (nth 3 state))) @@ -1480,7 +1475,7 @@ frequently editing existing scripts with different styles.") ;; mode-command and utility functions ;;;###autoload -(defun sh-mode () +(define-derived-mode sh-mode prog-mode "Shell-script" "Major mode for editing shell scripts. This mode works for many shells, since they all have roughly the same syntax, as far as commands, arguments, variables, pipes, comments etc. are concerned. @@ -1533,62 +1528,44 @@ indicate what shell it is use `sh-alias-alist' to translate. If your shell gives error messages with line numbers, you can use \\[executable-interpret] with your script for an edit-interpret-debug cycle." - (interactive) - (kill-all-local-variables) - (setq major-mode 'sh-mode - mode-name "Shell-script") - (use-local-map sh-mode-map) - (make-local-variable 'skeleton-end-hook) - (make-local-variable 'paragraph-start) - (make-local-variable 'paragraph-separate) - (make-local-variable 'comment-start) - (make-local-variable 'comment-start-skip) - (make-local-variable 'require-final-newline) - (make-local-variable 'sh-header-marker) (make-local-variable 'sh-shell-file) (make-local-variable 'sh-shell) - (make-local-variable 'skeleton-pair-alist) - (make-local-variable 'skeleton-pair-filter-function) - (make-local-variable 'comint-dynamic-complete-functions) - (make-local-variable 'comint-prompt-regexp) - (make-local-variable 'font-lock-defaults) - (make-local-variable 'skeleton-filter-function) - (make-local-variable 'skeleton-newline-indent-rigidly) - (make-local-variable 'sh-shell-variables) - (make-local-variable 'sh-shell-variables-initialized) - (make-local-variable 'imenu-generic-expression) - (make-local-variable 'sh-indent-supported-here) - (make-local-variable 'skeleton-pair-default-alist) - (setq skeleton-pair-default-alist sh-skeleton-pair-default-alist) - (setq skeleton-end-hook (lambda () - (or (eolp) (newline) (indent-relative))) - paragraph-start (concat page-delimiter "\\|$") - paragraph-separate paragraph-start - comment-start "# " - comment-start-skip "#+[\t ]*" - local-abbrev-table sh-mode-abbrev-table - comint-dynamic-complete-functions sh-dynamic-complete-functions - ;; we can't look if previous line ended with `\' - comint-prompt-regexp "^[ \t]*" - imenu-case-fold-search nil - font-lock-defaults - `((sh-font-lock-keywords - sh-font-lock-keywords-1 sh-font-lock-keywords-2) - nil nil - ((?/ . "w") (?~ . "w") (?. . "w") (?- . "w") (?_ . "w")) nil - (font-lock-syntactic-keywords . sh-font-lock-syntactic-keywords) - (font-lock-syntactic-face-function - . sh-font-lock-syntactic-face-function)) - skeleton-pair-alist '((?` _ ?`)) - skeleton-pair-filter-function 'sh-quoted-p - skeleton-further-elements '((< '(- (min sh-indentation - (current-column))))) - skeleton-filter-function 'sh-feature - skeleton-newline-indent-rigidly t - sh-indent-supported-here nil) + + (set (make-local-variable 'skeleton-pair-default-alist) + sh-skeleton-pair-default-alist) + (set (make-local-variable 'skeleton-end-hook) + (lambda () (or (eolp) (newline) (indent-relative)))) + + (set (make-local-variable 'paragraph-start) (concat page-delimiter "\\|$")) + (set (make-local-variable 'paragraph-separate) paragraph-start) + (set (make-local-variable 'comment-start) "# ") + (set (make-local-variable 'comment-start-skip) "#+[\t ]*") + (set (make-local-variable 'local-abbrev-table) sh-mode-abbrev-table) + (set (make-local-variable 'comint-dynamic-complete-functions) + sh-dynamic-complete-functions) + ;; we can't look if previous line ended with `\' + (set (make-local-variable 'comint-prompt-regexp) "^[ \t]*") + (set (make-local-variable 'imenu-case-fold-search) nil) + (set (make-local-variable 'font-lock-defaults) + `((sh-font-lock-keywords + sh-font-lock-keywords-1 sh-font-lock-keywords-2) + nil nil + ((?/ . "w") (?~ . "w") (?. . "w") (?- . "w") (?_ . "w")) nil + (font-lock-syntactic-face-function + . sh-font-lock-syntactic-face-function))) + (set (make-local-variable 'syntax-propertize-function) + #'sh-syntax-propertize-function) + (add-hook 'syntax-propertize-extend-region-functions + #'syntax-propertize-multiline 'append 'local) + (set (make-local-variable 'skeleton-pair-alist) '((?` _ ?`))) + (set (make-local-variable 'skeleton-pair-filter-function) 'sh-quoted-p) + (set (make-local-variable 'skeleton-further-elements) + '((< '(- (min sh-indentation (current-column)))))) + (set (make-local-variable 'skeleton-filter-function) 'sh-feature) + (set (make-local-variable 'skeleton-newline-indent-rigidly) t) + (set (make-local-variable 'sh-indent-supported-here) nil) (set (make-local-variable 'defun-prompt-regexp) (concat "^\\(function[ \t]\\|[[:alnum:]]+[ \t]+()[ \t]+\\)")) - (set (make-local-variable 'parse-sexp-ignore-comments) t) ;; Parse or insert magic number for exec, and set all variables depending ;; on the shell thus determined. (sh-set-shell @@ -1613,8 +1590,7 @@ with your script for an edit-interpret-debug cycle." "sh") (t sh-shell-file)) - nil nil) - (run-mode-hooks 'sh-mode-hook)) + nil nil)) ;;;###autoload (defalias 'shell-script-mode 'sh-mode) @@ -1743,21 +1719,20 @@ Calls the value of `sh-set-shell-hook' if set." no-query-flag insert-flag))) (let ((tem (sh-feature sh-require-final-newline))) (if (eq tem t) - (setq require-final-newline mode-require-final-newline))) - (setq - mode-line-process (format "[%s]" sh-shell) - sh-shell-variables nil - sh-shell-variables-initialized nil - imenu-generic-expression (sh-feature sh-imenu-generic-expression)) - (make-local-variable 'sh-mode-syntax-table) + (set (make-local-variable 'require-final-newline) + mode-require-final-newline))) + (setq mode-line-process (format "[%s]" sh-shell)) + (set (make-local-variable 'sh-shell-variables) nil) + (set (make-local-variable 'sh-shell-variables-initialized) nil) + (set (make-local-variable 'imenu-generic-expression) + (sh-feature sh-imenu-generic-expression)) (let ((tem (sh-feature sh-mode-syntax-table-input))) - (setq sh-mode-syntax-table - (if tem (apply 'sh-mode-syntax-table tem) - sh-mode-default-syntax-table))) - (set-syntax-table sh-mode-syntax-table) + (when tem + (set (make-local-variable 'sh-mode-syntax-table) + (apply 'sh-mode-syntax-table tem)) + (set-syntax-table sh-mode-syntax-table))) (dolist (var (sh-feature sh-variables)) (sh-remember-variable var)) - (make-local-variable 'indent-line-function) (if (setq sh-indent-supported-here (sh-feature sh-indent-supported)) (progn (message "Setting up indent for shell type %s" sh-shell) @@ -1770,7 +1745,7 @@ Calls the value of `sh-set-shell-hook' if set." (message "setting up indent stuff") ;; sh-mode has already made indent-line-function local ;; but do it in case this is called before that. - (setq indent-line-function 'sh-indent-line) + (set (make-local-variable 'indent-line-function) 'sh-indent-line) (if sh-make-vars-local (sh-make-vars-local)) (message "Indentation setup for shell type %s" sh-shell)) @@ -2162,11 +2137,7 @@ Return new point if successful, nil if an error occurred." (defun sh-handle-prev-do () (cond ((save-restriction - (narrow-to-region - (point) - (save-excursion - (beginning-of-line) - (point))) + (narrow-to-region (point) (line-beginning-position)) (sh-goto-match-for-done)) (sh-debug "match for done found on THIS line") (list '(+ sh-indent-after-loop-construct))) @@ -2233,10 +2204,9 @@ STRING This is ignored for the purposes of calculating ;; Note: setting result to t means we are done and will return nil. ;;(This function never returns just t.) (cond - ((or (and (boundp 'font-lock-string-face) (not (bobp)) - (eq (get-text-property (1- (point)) 'face) - font-lock-string-face)) + ((or (nth 3 (syntax-ppss (point))) (eq (get-text-property (point) 'face) sh-heredoc-face)) + ;; String continuation -- don't indent (setq result t) (setq have-result t)) ((looking-at "\\s-*#") ; was (equal this-kw "#") @@ -3469,20 +3439,15 @@ CODE can be nil, t or `lambda'. nil means to return the best completion of STRING, or nil if there is none. t means to return a list of all possible completions of STRING. `lambda' means to return t if STRING is a valid completion as it stands." - (let ((sh-shell-variables + (let ((vars (with-current-buffer sh-add-buffer (or sh-shell-variables-initialized (sh-shell-initialize-variables)) (nconc (mapcar (lambda (var) - (let ((name - (substring var 0 (string-match "=" var)))) - (cons name name))) + (substring var 0 (string-match "=" var))) process-environment) sh-shell-variables)))) - (case code - ((nil) (try-completion string sh-shell-variables predicate)) - (lambda (test-completion string sh-shell-variables predicate)) - (t (all-completions string sh-shell-variables predicate))))) + (complete-with-action code vars string predicate))) (defun sh-add (var delta) "Insert an addition of VAR and prefix DELTA for Bourne (type) shell." @@ -3872,5 +3837,4 @@ shell command and conveniently use this command." (provide 'sh-script) -;; arch-tag: eccd8b72-f337-4fc2-ae86-18155a69d937 ;;; sh-script.el ends here diff --git a/lisp/progmodes/simula.el b/lisp/progmodes/simula.el index 3f842903b0d..bfa921841e2 100644 --- a/lisp/progmodes/simula.el +++ b/lisp/progmodes/simula.el @@ -163,17 +163,18 @@ for SIMULA mode to function correctly." (defvar simula-mode-syntax-table nil "Syntax table in SIMULA mode buffers.") -(defconst simula-font-lock-syntactic-keywords - `(;; `comment' directive. - ("\\<\\(c\\)omment\\>" 1 "<") - ;; end comments - (,(concat "\\<end\\>\\([^;\n]\\).*?\\(\n\\|\\(.\\)\\(;\\|" - (regexp-opt '("end" "else" "when" "otherwise")) - "\\)\\)") - (1 "< b") - (3 "> b" nil t)) - ;; non-quoted single-quote char. - ("'\\('\\)'" 1 "."))) +(defconst simula-syntax-propertize-function + (syntax-propertize-rules + ;; `comment' directive. + ("\\<\\(c\\)omment\\>" (1 "<")) + ;; end comments + ((concat "\\<end\\>\\([^;\n]\\).*?\\(\n\\|\\(.\\)\\(;\\|" + (regexp-opt '("end" "else" "when" "otherwise")) + "\\)\\)") + (1 "< b") + (3 "> b")) + ;; non-quoted single-quote char. + ("'\\('\\)'" (1 ".")))) ;; Regexps written with help from Alf-Ivar Holm <alfh@ifi.uio.no>. (defconst simula-font-lock-keywords-1 @@ -330,7 +331,7 @@ for SIMULA mode to function correctly." (popup-menu (cons (concat mode-name " Mode Commands") simula-mode-menu))) ;;;###autoload -(define-derived-mode simula-mode nil "Simula" +(define-derived-mode simula-mode prog-mode "Simula" "Major mode for editing SIMULA code. \\{simula-mode-map} Variables controlling indentation style: @@ -396,8 +397,9 @@ with no arguments, if that value is non-nil." (setq font-lock-defaults '((simula-font-lock-keywords simula-font-lock-keywords-1 simula-font-lock-keywords-2 simula-font-lock-keywords-3) - nil t ((?_ . "w")) nil - (font-lock-syntactic-keywords . simula-font-lock-syntactic-keywords))) + nil t ((?_ . "w")))) + (set (make-local-variable 'syntax-propertize-function) + simula-syntax-propertize-function) (abbrev-mode 1)) (defun simula-indent-exp () @@ -962,7 +964,7 @@ If COUNT is negative, move backward instead." (simula-previous-statement 1) (simula-skip-comment-backward))) (setq start-line - (save-excursion (beginning-of-line) (point)) + (line-beginning-position) ;; - perhaps this is a continued statement continued (save-excursion @@ -1021,7 +1023,7 @@ If COUNT is negative, move backward instead." (car simula-continued-statement-offset) simula-continued-statement-offset)))) (setq start-line - (save-excursion (beginning-of-line) (point)) + (line-beginning-position) continued nil)) ;; search failed .. point is at beginning of line ;; determine if we should continue searching @@ -1062,7 +1064,7 @@ If COUNT is negative, move backward instead." simula-continued-statement-offset)))) ;; while ends if point is at beginning of line at loop test (if (not temp) - (setq start-line (save-excursion (beginning-of-line) (point))) + (setq start-line (line-beginning-position)) (beginning-of-line)))) ;; ;; return indentation @@ -1657,5 +1659,4 @@ If not nil and not t, move to limit of search and return nil." (provide 'simula) -;; arch-tag: 488c1bb0-eebf-4f06-93df-1df603f06255 ;;; simula.el ends here diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el index 6bd0d45bbd9..acb34eacc2b 100644 --- a/lisp/progmodes/sql.el +++ b/lisp/progmodes/sql.el @@ -5,7 +5,7 @@ ;; Author: Alex Schroeder <alex@gnu.org> ;; Maintainer: Michael Mauger <mmaug@yahoo.com> -;; Version: 2.0.2 +;; Version: 2.8 ;; Keywords: comm languages processes ;; URL: http://savannah.gnu.org/projects/emacs/ ;; URL: http://www.emacswiki.org/cgi-bin/wiki.pl?SqlMode @@ -103,83 +103,75 @@ ;; identifiers; ms (Microsoft SQLServer) also supports identifiers ;; enclosed within brackets []. -;; ChangeLog available on request. - ;;; Product Support: ;; To add support for additional SQL products the following steps ;; must be followed ("xyz" is the name of the product in the examples ;; below): -;; 1) Add the product to `sql-product' choice list. +;; 1) Add the product to the list of known products. -;; (const :tag "XyzDB" xyz) +;; (sql-add-product 'xyz "XyzDB" +;; '(:free-software t)) -;; 2) Add an entry to the `sql-product-alist' list. +;; 2) Define font lock settings. All ANSI keywords will be +;; highlighted automatically, so only product specific keywords +;; need to be defined here. -;; (xyz -;; :font-lock sql-mode-xyz-font-lock-keywords -;; :sqli-login (user password server database) -;; :sqli-connect sql-connect-xyz -;; :sqli-prompt-regexp "^xyzdb> " -;; :sqli-prompt-length 7 -;; :sqli-input-sender nil -;; :syntax-alist ((?# . "w"))) +;; (defvar my-sql-mode-xyz-font-lock-keywords +;; '(("\\b\\(red\\|orange\\|yellow\\)\\b" +;; . font-lock-keyword-face)) +;; "XyzDB SQL keywords used by font-lock.") -;; 3) Add customizable values for the product interpreter and options. +;; (sql-set-product-feature 'xyz +;; :font-lock +;; 'my-sql-mode-xyz-font-lock-keywords) -;; ;; Customization for XyzDB -;; -;; (defcustom sql-xyz-program "ixyz" -;; "*Command to start ixyz by XyzDB." +;; 3) Define any special syntax characters including comments and +;; identifier characters. + +;; (sql-set-product-feature 'xyz +;; :syntax-alist ((?# . "w"))) + +;; 4) Define the interactive command interpreter for the database +;; product. + +;; (defcustom my-sql-xyz-program "ixyz" +;; "Command to start ixyz by XyzDB." ;; :type 'file ;; :group 'SQL) ;; -;; (defcustom sql-xyz-options '("-X" "-Y" "-Z") -;; "*List of additional options for `sql-xyz-program'." -;; :type '(repeat string) +;; (sql-set-product-feature 'xyz +;; :sqli-program 'my-sql-xyz-program) +;; (sql-set-product-feature 'xyz +;; :prompt-regexp "^xyzdb> ") +;; (sql-set-product-feature 'xyz +;; :prompt-length 7) + +;; 5) Define login parameters and command line formatting. + +;; (defcustom my-sql-xyz-login-params '(user password server database) +;; "Login parameters to needed to connect to XyzDB." +;; :type 'sql-login-params ;; :group 'SQL) +;; +;; (sql-set-product-feature 'xyz +;; :sqli-login 'my-sql-xyz-login-params) -;; 4) Add an entry to SQL->Product submenu. - -;; ["XyzDB" sql-highlight-xyz-keywords -;; :style radio -;; :selected (eq sql-product 'xyz)] - -;; 5) Add the font-lock specifications. At a minimum, default to -;; using ANSI keywords. See sql-mode-oracle-font-lock-keywords for -;; a more complex example. - -;; (defvar sql-mode-xyz-font-lock-keywords nil -;; "XyzDB SQL keywords used by font-lock.") - -;; 6) Add a product highlighting function. - -;; (defun sql-highlight-xyz-keywords () -;; "Highlight XyzDB keywords." -;; (interactive) -;; (sql-set-product 'xyz)) - -;; 7) Add an autoloaded SQLi function. - -;; ;;;###autoload -;; (defun sql-xyz () -;; "Run ixyz by XyzDB as an inferior process." -;; (interactive) -;; (sql-product-interactive 'xyz)) - -;; 8) Add a connect function which formats the command line arguments -;; and starts the product interpreter in a comint buffer. See the -;; existing connect functions for examples of the types of -;; processing available. +;; (defcustom my-sql-xyz-options '("-X" "-Y" "-Z") +;; "List of additional options for `sql-xyz-program'." +;; :type '(repeat string) +;; :group 'SQL) +;; +;; (sql-set-product-feature 'xyz +;; :sqli-options 'my-sql-xyz-options)) -;; (defun sql-connect-xyz () -;; "Create comint buffer and connect to XyzDB using the login -;; parameters and command options." +;; (defun my-sql-comint-xyz (product options) +;; "Connect ti XyzDB in a comint buffer." ;; ;; ;; Do something with `sql-user', `sql-password', ;; ;; `sql-database', and `sql-server'. -;; (let ((params sql-xyz-options)) +;; (let ((params options)) ;; (if (not (string= "" sql-server)) ;; (setq params (append (list "-S" sql-server) params))) ;; (if (not (string= "" sql-database)) @@ -188,25 +180,36 @@ ;; (setq params (append (list "-P" sql-password) params))) ;; (if (not (string= "" sql-user)) ;; (setq params (append (list "-U" sql-user) params))) -;; (set-buffer (apply 'make-comint "SQL" sql-xyz-program -;; nil params)))) +;; (sql-comint product params))) +;; +;; (sql-set-product-feature 'xyz +;; :sqli-comint-func 'my-sql-comint-xyz) + +;; 6) Define a convienence function to invoke the SQL interpreter. -;; 9) Save and compile sql.el. +;; (defun my-sql-xyz (&optional buffer) +;; "Run ixyz by XyzDB as an inferior process." +;; (interactive "P") +;; (sql-product-interactive 'xyz buffer)) ;;; To Do: -;; Add better hilight support for other brands; there is a bias towards -;; Oracle because that's what I use at work. Anybody else just send in -;; your lists of reserved words, keywords and builtin functions! As -;; long as I don't receive any feedback, everything is hilighted with -;; ANSI keywords only. I received the list of ANSI keywords from a -;; user; if you know of any changes, let me know. +;; Improve keyword highlighting for individual products. I have tried +;; to update those database that I use. Feel free to send me updates, +;; or direct me to the reference manuals for your favorite database. -;; Add different hilighting levels. +;; When there are no keywords defined, the ANSI keywords are +;; highlighted. ANSI keywords are highlighted even if the keyword is +;; not used for your current product. This should help identify +;; portability concerns. + +;; Add different highlighting levels. + +;; Add support for listing available tables or the columns in a table. ;;; Thanks to all the people who helped me out: -;; Alex Schroeder <alex@gnu.org> +;; Alex Schroeder <alex@gnu.org> -- the original author ;; Kai Blauberg <kai.blauberg@metla.fi> ;; <ibalaban@dalet.com> ;; Yair Friedman <yfriedma@JohnBryce.Co.Il> @@ -217,7 +220,7 @@ ;; Michael Mauger <mmaug@yahoo.com> -- improved product support ;; Drew Adams <drew.adams@oracle.com> -- Emacs 20 support ;; Harald Maier <maierh@myself.com> -- sql-send-string -;; Stefan Monnier <monnier@iro.umontreal.ca> -- font-lock corrections +;; Stefan Monnier <monnier@iro.umontreal.ca> -- font-lock corrections; code polish @@ -229,7 +232,7 @@ (require 'regexp-opt)) (require 'custom) (eval-when-compile ;; needed in Emacs 19, 20 - (setq max-specpdl-size 2000)) + (setq max-specpdl-size (max max-specpdl-size 2000))) (defvar font-lock-keyword-face) (defvar font-lock-set-defaults) @@ -240,144 +243,275 @@ (defgroup SQL nil "Running a SQL interpreter from within Emacs buffers." :version "20.4" + :group 'languages :group 'processes) ;; These four variables will be used as defaults, if set. (defcustom sql-user "" - "*Default username." + "Default username." :type 'string - :group 'SQL) + :group 'SQL + :safe 'stringp) (defcustom sql-password "" - "*Default password. + "Default password. Storing your password in a textfile such as ~/.emacs could be dangerous. Customizing your password will store it in your ~/.emacs file." :type 'string - :group 'SQL) + :group 'SQL + :risky t) (defcustom sql-database "" - "*Default database." + "Default database." :type 'string - :group 'SQL) + :group 'SQL + :safe 'stringp) (defcustom sql-server "" - "*Default server or host." + "Default server or host." :type 'string - :group 'SQL) + :group 'SQL + :safe 'stringp) + +(defcustom sql-port 0 + "Default port." + :version "24.1" + :type 'number + :group 'SQL + :safe 'numberp) + +;; Login parameter type + +(define-widget 'sql-login-params 'lazy + "Widget definition of the login parameters list" + ;; FIXME: does not implement :default property for the user, + ;; database and server options. Anybody have some guidance on how to + ;; do this. + :tag "Login Parameters" + :type '(repeat (choice + (const user) + (const password) + (choice :tag "server" + (const server) + (list :tag "file" + (const :format "" server) + (const :format "" :file) + regexp) + (list :tag "completion" + (const :format "" server) + (const :format "" :completion) + (restricted-sexp + :match-alternatives (listp stringp)))) + (choice :tag "database" + (const database) + (list :tag "file" + (const :format "" database) + (const :format "" :file) + regexp) + (list :tag "completion" + (const :format "" database) + (const :format "" :completion) + (restricted-sexp + :match-alternatives (listp stringp)))) + (const port)))) ;; SQL Product support (defvar sql-interactive-product nil "Product under `sql-interactive-mode'.") +(defvar sql-connection nil + "Connection name if interactive session started by `sql-connect'.") + (defvar sql-product-alist '((ansi :name "ANSI" :font-lock sql-mode-ansi-font-lock-keywords) + (db2 :name "DB2" :font-lock sql-mode-db2-font-lock-keywords - :sqli-login nil - :sqli-connect sql-connect-db2 - :sqli-prompt-regexp "^db2 => " - :sqli-prompt-length 7) + :sqli-program sql-db2-program + :sqli-options sql-db2-options + :sqli-login sql-db2-login-params + :sqli-comint-func sql-comint-db2 + :prompt-regexp "^db2 => " + :prompt-length 7 + :prompt-cont-regexp "^db2 (cont\.) => " + :input-filter sql-escape-newlines-filter) + (informix + :name "Informix" :font-lock sql-mode-informix-font-lock-keywords - :sqli-login (database) - :sqli-connect sql-connect-informix - :sqli-prompt-regexp "^SQL> " - :sqli-prompt-length 5) + :sqli-program sql-informix-program + :sqli-options sql-informix-options + :sqli-login sql-informix-login-params + :sqli-comint-func sql-comint-informix + :prompt-regexp "^> " + :prompt-length 2 + :syntax-alist ((?{ . "<") (?} . ">"))) + (ingres + :name "Ingres" :font-lock sql-mode-ingres-font-lock-keywords - :sqli-login (database) - :sqli-connect sql-connect-ingres - :sqli-prompt-regexp "^\* " - :sqli-prompt-length 2) + :sqli-program sql-ingres-program + :sqli-options sql-ingres-options + :sqli-login sql-ingres-login-params + :sqli-comint-func sql-comint-ingres + :prompt-regexp "^\* " + :prompt-length 2 + :prompt-cont-regexp "^\* ") + (interbase + :name "Interbase" :font-lock sql-mode-interbase-font-lock-keywords - :sqli-login (user password database) - :sqli-connect sql-connect-interbase - :sqli-prompt-regexp "^SQL> " - :sqli-prompt-length 5) + :sqli-program sql-interbase-program + :sqli-options sql-interbase-options + :sqli-login sql-interbase-login-params + :sqli-comint-func sql-comint-interbase + :prompt-regexp "^SQL> " + :prompt-length 5) + (linter + :name "Linter" :font-lock sql-mode-linter-font-lock-keywords - :sqli-login (user password database server) - :sqli-connect sql-connect-linter - :sqli-prompt-regexp "^SQL>" - :sqli-prompt-length 4) + :sqli-program sql-linter-program + :sqli-options sql-linter-options + :sqli-login sql-linter-login-params + :sqli-comint-func sql-comint-linter + :prompt-regexp "^SQL>" + :prompt-length 4) + (ms - :name "MS SQLServer" + :name "Microsoft" :font-lock sql-mode-ms-font-lock-keywords - :sqli-login (user password server database) - :sqli-connect sql-connect-ms - :sqli-prompt-regexp "^[0-9]*>" - :sqli-prompt-length 5 - :syntax-alist ((?@ . "w"))) + :sqli-program sql-ms-program + :sqli-options sql-ms-options + :sqli-login sql-ms-login-params + :sqli-comint-func sql-comint-ms + :prompt-regexp "^[0-9]*>" + :prompt-length 5 + :syntax-alist ((?@ . "w")) + :terminator ("^go" . "go")) + (mysql :name "MySQL" + :free-software t :font-lock sql-mode-mysql-font-lock-keywords - :sqli-login (user password database server) - :sqli-connect sql-connect-mysql - :sqli-prompt-regexp "^mysql> " - :sqli-prompt-length 6) + :sqli-program sql-mysql-program + :sqli-options sql-mysql-options + :sqli-login sql-mysql-login-params + :sqli-comint-func sql-comint-mysql + :list-all "SHOW TABLES;" + :list-table "DESCRIBE %s;" + :prompt-regexp "^mysql> " + :prompt-length 6 + :prompt-cont-regexp "^ -> " + :input-filter sql-remove-tabs-filter) + (oracle + :name "Oracle" :font-lock sql-mode-oracle-font-lock-keywords - :sqli-login (user password database) - :sqli-connect sql-connect-oracle - :sqli-prompt-regexp "^SQL> " - :sqli-prompt-length 5 - :syntax-alist ((?$ . "w") (?# . "w"))) + :sqli-program sql-oracle-program + :sqli-options sql-oracle-options + :sqli-login sql-oracle-login-params + :sqli-comint-func sql-comint-oracle + :prompt-regexp "^SQL> " + :prompt-length 5 + :prompt-cont-regexp "^\\s-*\\d+> " + :syntax-alist ((?$ . "w") (?# . "w")) + :terminator ("\\(^/\\|;\\)" . "/") + :input-filter sql-placeholders-filter) + (postgres + :name "Postgres" + :free-software t :font-lock sql-mode-postgres-font-lock-keywords - :sqli-login (user database server) - :sqli-connect sql-connect-postgres - :sqli-prompt-regexp "^.*[#>] *" - :sqli-prompt-length 5) + :sqli-program sql-postgres-program + :sqli-options sql-postgres-options + :sqli-login sql-postgres-login-params + :sqli-comint-func sql-comint-postgres + :list-all ("\\d+" . "\\dS+") + :list-table ("\\d+ %s" . "\\dS+ %s") + :prompt-regexp "^.*=[#>] " + :prompt-length 5 + :prompt-cont-regexp "^.*[-(][#>] " + :input-filter sql-remove-tabs-filter + :terminator ("\\(^\\s-*\\\\g\\|;\\)" . ";")) + (solid + :name "Solid" :font-lock sql-mode-solid-font-lock-keywords - :sqli-login (user password server) - :sqli-connect sql-connect-solid - :sqli-prompt-regexp "^" - :sqli-prompt-length 0) + :sqli-program sql-solid-program + :sqli-options sql-solid-options + :sqli-login sql-solid-login-params + :sqli-comint-func sql-comint-solid + :prompt-regexp "^" + :prompt-length 0) + (sqlite :name "SQLite" + :free-software t :font-lock sql-mode-sqlite-font-lock-keywords - :sqli-login (database) - :sqli-connect sql-connect-sqlite - :sqli-prompt-regexp "^sqlite> " - :sqli-prompt-length 8) + :sqli-program sql-sqlite-program + :sqli-options sql-sqlite-options + :sqli-login sql-sqlite-login-params + :sqli-comint-func sql-comint-sqlite + :list-all ".tables" + :list-table ".schema %s" + :prompt-regexp "^sqlite> " + :prompt-length 8 + :prompt-cont-regexp "^ ...> " + :terminator ";") + (sybase + :name "Sybase" :font-lock sql-mode-sybase-font-lock-keywords - :sqli-login (server user password database) - :sqli-connect sql-connect-sybase - :sqli-prompt-regexp "^SQL> " - :sqli-prompt-length 5 - :syntax-alist ((?@ . "w"))) + :sqli-program sql-sybase-program + :sqli-options sql-sybase-options + :sqli-login sql-sybase-login-params + :sqli-comint-func sql-comint-sybase + :prompt-regexp "^SQL> " + :prompt-length 5 + :syntax-alist ((?@ . "w")) + :terminator ("^go" . "go")) ) - "This variable contains a list of product features for each of the -SQL products handled by `sql-mode'. Without an entry in this list a -product will not be properly highlighted and will not support -`sql-interactive-mode'. + "An alist of product specific configuration settings. + +Without an entry in this list a product will not be properly +highlighted and will not support `sql-interactive-mode'. Each element in the list is in the following format: \(PRODUCT FEATURE VALUE ...) -where PRODUCT is the appropriate value of `sql-product'. The product -name is then followed by FEATURE-VALUE pairs. If a FEATURE is not -specified, its VALUE is treated as nil. FEATURE must be one of the -following: +where PRODUCT is the appropriate value of `sql-product'. The +product name is then followed by FEATURE-VALUE pairs. If a +FEATURE is not specified, its VALUE is treated as nil. FEATURE +may be any one of the following: + + :name string containing the displayable name of + the product. + + :free-software is the product Free (as in Freedom) software? :font-lock name of the variable containing the product specific font lock highlighting patterns. - :sqli-login a list of login parameters (i.e., user, - password, database and server) needed to - connect to the database. + :sqli-program name of the variable containing the product + specific interactive program name. + + :sqli-options name of the variable containing the list + of product specific options. - :sqli-connect the name of a function which accepts no + :sqli-login name of the variable containing the list of + login parameters (i.e., user, password, + database and server) needed to connect to + the database. + + :sqli-comint-func name of a function which accepts no parameters that will use the values of `sql-user', `sql-password', `sql-database' and `sql-server' to open a @@ -385,19 +519,114 @@ following: database. Do product specific configuration of comint in this function. - :sqli-prompt-regexp a regular expression string that matches + :list-all Command string or function which produces + a listing of all objects in the database. + If it's a cons cell, then the car + produces the standard list of objects and + the cdr produces an enhanced list of + objects. What \"enhanced\" means is + dependent on the SQL product and may not + exist. In general though, the + \"enhanced\" list should include visible + objects from other schemas. + + :list-table Command string or function which produces + a detailed listing of a specific database + table. If its a cons cell, then the car + produces the standard list and the cdr + produces an enhanced list. + + :prompt-regexp regular expression string that matches the prompt issued by the product - interpreter. (Not needed in 21.3+) - - :sqli-prompt-length the length of the prompt on the line.(Not - needed in 21.3+) - - :syntax-alist an alist of syntax table entries to enable - special character treatment by font-lock and - imenu. ") + interpreter. + + :prompt-length length of the prompt on the line. + + :prompt-cont-regexp regular expression string that matches + the continuation prompt issued by the + product interpreter. + + :input-filter function which can filter strings sent to + the command interpreter. It is also used + by the `sql-send-string', + `sql-send-region', `sql-send-paragraph' + and `sql-send-buffer' functions. The + function is passed the string sent to the + command interpreter and must return the + filtered string. May also be a list of + such functions. + + :terminator the terminator to be sent after a + `sql-send-string', `sql-send-region', + `sql-send-paragraph' and + `sql-send-buffer' command. May be the + literal string or a cons of a regexp to + match an existing terminator in the + string and the terminator to be used if + its absent. By default \";\". + + :syntax-alist alist of syntax table entries to enable + special character treatment by font-lock + and imenu. + +Other features can be stored but they will be ignored. However, +you can develop new functionality which is product independent by +using `sql-get-product-feature' to lookup the product specific +settings.") + +(defvar sql-indirect-features + '(:font-lock :sqli-program :sqli-options :sqli-login)) + +(defcustom sql-connection-alist nil + "An alist of connection parameters for interacting with a SQL + product. + +Each element of the alist is as follows: + + \(CONNECTION \(SQL-VARIABLE VALUE) ...) + +Where CONNECTION is a symbol identifying the connection, SQL-VARIABLE +is the symbol name of a SQL mode variable, and VALUE is the value to +be assigned to the variable. + +The most common SQL-VARIABLE settings associated with a connection +are: + + `sql-product' + `sql-user' + `sql-password' + `sql-port' + `sql-server' + `sql-database' + +If a SQL-VARIABLE is part of the connection, it will not be +prompted for during login." + + :type `(alist :key-type (string :tag "Connection") + :value-type + (set + (group (const :tag "Product" sql-product) + (choice + ,@(mapcar (lambda (prod-info) + `(const :tag + ,(or (plist-get (cdr prod-info) :name) + (capitalize (symbol-name (car prod-info)))) + (quote ,(car prod-info)))) + sql-product-alist))) + (group (const :tag "Username" sql-user) string) + (group (const :tag "Password" sql-password) string) + (group (const :tag "Server" sql-server) string) + (group (const :tag "Database" sql-database) string) + (group (const :tag "Port" sql-port) integer) + (repeat :inline t + (list :tab "Other" + (symbol :tag " Variable Symbol") + (sexp :tag "Value Expression"))))) + :version "24.1" + :group 'SQL) (defcustom sql-product 'ansi - "*Select the SQL database product used so that buffers can be + "Select the SQL database product used so that buffers can be highlighted properly when you open them." :type `(choice ,@(mapcar (lambda (prod-info) @@ -406,9 +635,11 @@ highlighted properly when you open them." (capitalize (symbol-name (car prod-info)))) ,(car prod-info))) sql-product-alist)) - :group 'SQL) + :group 'SQL + :safe 'symbolp) +(defvaralias 'sql-dialect 'sql-product) -;; misc customization of sql.el behavior +;; misc customization of sql.el behaviour (defcustom sql-electric-stuff nil "Treat some input as electric. @@ -424,14 +655,44 @@ current input in the SQLi buffer to the process." :version "20.8" :group 'SQL) -(defcustom sql-pop-to-buffer-after-send-region nil - "*If t, pop to the buffer SQL statements are sent to. +(defcustom sql-send-terminator nil + "When non-nil, add a terminator to text sent to the SQL interpreter. + +When text is sent to the SQL interpreter (via `sql-send-string', +`sql-send-region', `sql-send-paragraph' or `sql-send-buffer'), a +command terminator can be automatically sent as well. The +terminator is not sent, if the string sent already ends with the +terminator. + +If this value is t, then the default command terminator for the +SQL interpreter is sent. If this value is a string, then the +string is sent. + +If the value is a cons cell of the form (PAT . TERM), then PAT is +a regexp used to match the terminator in the string and TERM is +the terminator to be sent. This form is useful if the SQL +interpreter has more than one way of submitting a SQL command. +The PAT regexp can match any of them, and TERM is the way we do +it automatically." + + :type '(choice (const :tag "No Terminator" nil) + (const :tag "Default Terminator" t) + (string :tag "Terminator String") + (cons :tag "Terminator Pattern and String" + (string :tag "Terminator Pattern") + (string :tag "Terminator String"))) + :version "22.2" + :group 'SQL) -After a call to `sql-send-region' or `sql-send-buffer', -the window is split and the SQLi buffer is shown. If this -variable is not nil, that buffer's window will be selected -by calling `pop-to-buffer'. If this variable is nil, that -buffer is shown using `display-buffer'." +(defcustom sql-pop-to-buffer-after-send-region nil + "When non-nil, pop to the buffer SQL statements are sent to. + +After a call to `sql-sent-string', `sql-send-region', +`sql-send-paragraph' or `sql-send-buffer', the window is split +and the SQLi buffer is shown. If this variable is not nil, that +buffer's window will be selected by calling `pop-to-buffer'. If +this variable is nil, that buffer is shown using +`display-buffer'." :type 'boolean :group 'SQL) @@ -445,6 +706,7 @@ buffer is shown using `display-buffer'." ("Functions" "^\\s-*\\(create\\s-+\\(\\w+\\s-+\\)*\\)?function\\s-+\\(\\w+\\)" 3) ("Procedures" "^\\s-*\\(create\\s-+\\(\\w+\\s-+\\)*\\)?proc\\(edure\\)?\\s-+\\(\\w+\\)" 4) ("Packages" "^\\s-*create\\s-+\\(\\w+\\s-+\\)*package\\s-+\\(body\\s-+\\)?\\(\\w+\\)" 3) + ("Types" "^\\s-*create\\s-+\\(\\w+\\s-+\\)*type\\s-+\\(body\\s-+\\)?\\(\\w+\\)" 3) ("Indexes" "^\\s-*create\\s-+\\(\\w+\\s-+\\)*index\\s-+\\(\\w+\\)" 2) ("Tables/Views" "^\\s-*create\\s-+\\(\\w+\\s-+\\)*\\(table\\|view\\)\\s-+\\(\\w+\\)" 3)) "Define interesting points in the SQL buffer for `imenu'. @@ -457,7 +719,7 @@ a local variable.") ;; history file (defcustom sql-input-ring-file-name nil - "*If non-nil, name of the file to read/write input history. + "If non-nil, name of the file to read/write input history. You have to set this variable if you want the history of your commands saved from one Emacs session to the next. If this variable is set, @@ -474,7 +736,7 @@ Note that the size of the input history is determined by the variable :group 'SQL) (defcustom sql-input-ring-separator "\n--\n" - "*Separator between commands in the history file. + "Separator between commands in the history file. If set to \"\\n\", each line in the history file will be interpreted as one command. Multi-line commands are split into several commands when @@ -492,17 +754,17 @@ commands when the input history is read, as if you had set ;; The usual hooks (defcustom sql-interactive-mode-hook '() - "*Hook for customizing `sql-interactive-mode'." + "Hook for customizing `sql-interactive-mode'." :type 'hook :group 'SQL) (defcustom sql-mode-hook '() - "*Hook for customizing `sql-mode'." + "Hook for customizing `sql-mode'." :type 'hook :group 'SQL) (defcustom sql-set-sqli-hook '() - "*Hook for reacting to changes of `sql-buffer'. + "Hook for reacting to changes of `sql-buffer'. This is called by `sql-set-sqli-buffer' when the value of `sql-buffer' is changed." @@ -512,142 +774,189 @@ is changed." ;; Customization for Oracle (defcustom sql-oracle-program "sqlplus" - "*Command to start sqlplus by Oracle. + "Command to start sqlplus by Oracle. Starts `sql-interactive-mode' after doing some setup. -On Windows, \"sqlplus\" usually starts the sqlplus \"GUI\". In order to -start the sqlplus console, use \"plus33\" or something similar. You -will find the file in your Orant\\bin directory. - -The program can also specify a TCP connection. See `make-comint'." +On Windows, \"sqlplus\" usually starts the sqlplus \"GUI\". In order +to start the sqlplus console, use \"plus33\" or something similar. +You will find the file in your Orant\\bin directory." :type 'file :group 'SQL) (defcustom sql-oracle-options nil - "*List of additional options for `sql-oracle-program'." + "List of additional options for `sql-oracle-program'." :type '(repeat string) :version "20.8" :group 'SQL) -;; Customization for SQLite +(defcustom sql-oracle-login-params '(user password database) + "List of login parameters needed to connect to Oracle." + :type 'sql-login-params + :version "24.1" + :group 'SQL) -(defcustom sql-sqlite-program "sqlite" - "*Command to start SQLite. +(defcustom sql-oracle-scan-on t + "Non-nil if placeholders should be replaced in Oracle SQLi. -Starts `sql-interactive-mode' after doing some setup. +When non-nil, Emacs will scan text sent to sqlplus and prompt +for replacement text for & placeholders as sqlplus does. This +is needed on Windows where sqlplus output is buffered and the +prompts are not shown until after the text is entered. + +You will probably want to issue the following command in sqlplus +to be safe: + + SET SCAN OFF" + :type 'boolean + :group 'SQL) + +;; Customization for SQLite -The program can also specify a TCP connection. See `make-comint'." +(defcustom sql-sqlite-program (or (executable-find "sqlite3") + (executable-find "sqlite") + "sqlite") + "Command to start SQLite. + +Starts `sql-interactive-mode' after doing some setup." :type 'file :group 'SQL) (defcustom sql-sqlite-options nil - "*List of additional options for `sql-sqlite-program'." + "List of additional options for `sql-sqlite-program'." :type '(repeat string) :version "20.8" :group 'SQL) +(defcustom sql-sqlite-login-params '((database :file ".*\\.\\(db\\|sqlite[23]?\\)")) + "List of login parameters needed to connect to SQLite." + :type 'sql-login-params + :version "24.1" + :group 'SQL) + ;; Customization for MySql (defcustom sql-mysql-program "mysql" - "*Command to start mysql by TcX. - -Starts `sql-interactive-mode' after doing some setup. + "Command to start mysql by TcX. -The program can also specify a TCP connection. See `make-comint'." +Starts `sql-interactive-mode' after doing some setup." :type 'file :group 'SQL) (defcustom sql-mysql-options nil - "*List of additional options for `sql-mysql-program'. + "List of additional options for `sql-mysql-program'. The following list of options is reported to make things work on Windows: \"-C\" \"-t\" \"-f\" \"-n\"." :type '(repeat string) :version "20.8" :group 'SQL) +(defcustom sql-mysql-login-params '(user password database server) + "List of login parameters needed to connect to MySql." + :type 'sql-login-params + :version "24.1" + :group 'SQL) + ;; Customization for Solid (defcustom sql-solid-program "solsql" - "*Command to start SOLID SQL Editor. - -Starts `sql-interactive-mode' after doing some setup. + "Command to start SOLID SQL Editor. -The program can also specify a TCP connection. See `make-comint'." +Starts `sql-interactive-mode' after doing some setup." :type 'file :group 'SQL) -;; Customization for SyBase +(defcustom sql-solid-login-params '(user password server) + "List of login parameters needed to connect to Solid." + :type 'sql-login-params + :version "24.1" + :group 'SQL) + +;; Customization for Sybase (defcustom sql-sybase-program "isql" - "*Command to start isql by SyBase. - -Starts `sql-interactive-mode' after doing some setup. + "Command to start isql by Sybase. -The program can also specify a TCP connection. See `make-comint'." +Starts `sql-interactive-mode' after doing some setup." :type 'file :group 'SQL) (defcustom sql-sybase-options nil - "*List of additional options for `sql-sybase-program'. + "List of additional options for `sql-sybase-program'. Some versions of isql might require the -n option in order to work." :type '(repeat string) :version "20.8" :group 'SQL) +(defcustom sql-sybase-login-params '(server user password database) + "List of login parameters needed to connect to Sybase." + :type 'sql-login-params + :version "24.1" + :group 'SQL) + ;; Customization for Informix (defcustom sql-informix-program "dbaccess" - "*Command to start dbaccess by Informix. - -Starts `sql-interactive-mode' after doing some setup. + "Command to start dbaccess by Informix. -The program can also specify a TCP connection. See `make-comint'." +Starts `sql-interactive-mode' after doing some setup." :type 'file :group 'SQL) +(defcustom sql-informix-login-params '(database) + "List of login parameters needed to connect to Informix." + :type 'sql-login-params + :version "24.1" + :group 'SQL) + ;; Customization for Ingres (defcustom sql-ingres-program "sql" - "*Command to start sql by Ingres. + "Command to start sql by Ingres. -Starts `sql-interactive-mode' after doing some setup. - -The program can also specify a TCP connection. See `make-comint'." +Starts `sql-interactive-mode' after doing some setup." :type 'file :group 'SQL) +(defcustom sql-ingres-login-params '(database) + "List of login parameters needed to connect to Ingres." + :type 'sql-login-params + :version "24.1" + :group 'SQL) + ;; Customization for Microsoft (defcustom sql-ms-program "osql" - "*Command to start osql by Microsoft. + "Command to start osql by Microsoft. -Starts `sql-interactive-mode' after doing some setup. - -The program can also specify a TCP connection. See `make-comint'." +Starts `sql-interactive-mode' after doing some setup." :type 'file :group 'SQL) (defcustom sql-ms-options '("-w" "300" "-n") ;; -w is the linesize - "*List of additional options for `sql-ms-program'." + "List of additional options for `sql-ms-program'." :type '(repeat string) :version "22.1" :group 'SQL) +(defcustom sql-ms-login-params '(user password server database) + "List of login parameters needed to connect to Microsoft." + :type 'sql-login-params + :version "24.1" + :group 'SQL) + ;; Customization for Postgres (defcustom sql-postgres-program "psql" "Command to start psql by Postgres. -Starts `sql-interactive-mode' after doing some setup. - -The program can also specify a TCP connection. See `make-comint'." +Starts `sql-interactive-mode' after doing some setup." :type 'file :group 'SQL) (defcustom sql-postgres-options '("-P" "pager=off") - "*List of additional options for `sql-postgres-program'. + "List of additional options for `sql-postgres-program'. The default setting includes the -P option which breaks older versions of the psql client (such as version 6.5.3). The -P option is equivalent to the --pset option. If you want the psql to prompt you for a user @@ -658,55 +967,77 @@ add your name with a \"-U\" prefix (such as \"-Umark\") to the list." :version "20.8" :group 'SQL) +(defcustom sql-postgres-login-params `((user :default ,(user-login-name)) + (database :default ,(user-login-name)) + server) + "List of login parameters needed to connect to Postgres." + :type 'sql-login-params + :version "24.1" + :group 'SQL) + ;; Customization for Interbase (defcustom sql-interbase-program "isql" - "*Command to start isql by Interbase. + "Command to start isql by Interbase. -Starts `sql-interactive-mode' after doing some setup. - -The program can also specify a TCP connection. See `make-comint'." +Starts `sql-interactive-mode' after doing some setup." :type 'file :group 'SQL) (defcustom sql-interbase-options nil - "*List of additional options for `sql-interbase-program'." + "List of additional options for `sql-interbase-program'." :type '(repeat string) :version "20.8" :group 'SQL) +(defcustom sql-interbase-login-params '(user password database) + "List of login parameters needed to connect to Interbase." + :type 'sql-login-params + :version "24.1" + :group 'SQL) + ;; Customization for DB2 (defcustom sql-db2-program "db2" - "*Command to start db2 by IBM. + "Command to start db2 by IBM. -Starts `sql-interactive-mode' after doing some setup. - -The program can also specify a TCP connection. See `make-comint'." +Starts `sql-interactive-mode' after doing some setup." :type 'file :group 'SQL) (defcustom sql-db2-options nil - "*List of additional options for `sql-db2-program'." + "List of additional options for `sql-db2-program'." :type '(repeat string) :version "20.8" :group 'SQL) +(defcustom sql-db2-login-params nil + "List of login parameters needed to connect to DB2." + :type 'sql-login-params + :version "24.1" + :group 'SQL) + ;; Customization for Linter (defcustom sql-linter-program "inl" - "*Command to start inl by RELEX. + "Command to start inl by RELEX. Starts `sql-interactive-mode' after doing some setup." :type 'file :group 'SQL) (defcustom sql-linter-options nil - "*List of additional options for `sql-linter-program'." + "List of additional options for `sql-linter-program'." :type '(repeat string) :version "21.3" :group 'SQL) +(defcustom sql-linter-login-params '(user password database server) + "Login parameters to needed to connect to Linter." + :type 'sql-login-params + :version "24.1" + :group 'SQL) + ;;; Variables which do not need customization @@ -722,6 +1053,12 @@ Starts `sql-interactive-mode' after doing some setup." ;; Passwords are not kept in a history. +(defvar sql-product-history nil + "History of products used.") + +(defvar sql-connection-history nil + "History of connections used.") + (defvar sql-buffer nil "Current SQLi buffer. @@ -741,11 +1078,33 @@ You can change `sql-prompt-regexp' on `sql-interactive-mode-hook'.") You can change `sql-prompt-length' on `sql-interactive-mode-hook'.") +(defvar sql-prompt-cont-regexp nil + "Prompt pattern of statement continuation prompts.") + (defvar sql-alternate-buffer-name nil "Buffer-local string used to possibly rename the SQLi buffer. Used by `sql-rename-buffer'.") +(defun sql-buffer-live-p (buffer &optional product) + "Returns non-nil if the process associated with buffer is live. + +BUFFER can be a buffer object or a buffer name. The buffer must +be a live buffer, have an running process attached to it, be in +`sql-interactive-mode', and, if PRODUCT is specified, it's +`sql-product' must match." + + (when buffer + (setq buffer (get-buffer buffer)) + (and buffer + (buffer-live-p buffer) + (get-buffer-process buffer) + (comint-check-proc buffer) + (with-current-buffer buffer + (and (derived-mode-p 'sql-interactive-mode) + (or (not product) + (eq product sql-product))))))) + ;; Keymap for sql-interactive-mode. (defvar sql-interactive-mode-map @@ -761,6 +1120,8 @@ Used by `sql-rename-buffer'.") (define-key map (kbd "O") 'sql-magic-go) (define-key map (kbd "o") 'sql-magic-go) (define-key map (kbd ";") 'sql-magic-semicolon) + (define-key map (kbd "C-c C-l a") 'sql-list-all) + (define-key map (kbd "C-c C-l t") 'sql-list-table) map) "Mode map used for `sql-interactive-mode'. Based on `comint-mode-map'.") @@ -773,6 +1134,9 @@ Based on `comint-mode-map'.") (define-key map (kbd "C-c C-r") 'sql-send-region) (define-key map (kbd "C-c C-s") 'sql-send-string) (define-key map (kbd "C-c C-b") 'sql-send-buffer) + (define-key map (kbd "C-c C-i") 'sql-product-interactive) + (define-key map (kbd "C-c C-l a") 'sql-list-all) + (define-key map (kbd "C-c C-l t") 'sql-list-table) map) "Mode map used for `sql-mode'.") @@ -782,18 +1146,25 @@ Based on `comint-mode-map'.") sql-mode-menu sql-mode-map "Menu for `sql-mode'." `("SQL" - ["Send Paragraph" sql-send-paragraph (and (buffer-live-p sql-buffer) - (get-buffer-process sql-buffer))] - ["Send Region" sql-send-region (and (or (and (boundp 'mark-active); Emacs - mark-active) - (mark t)); XEmacs - (buffer-live-p sql-buffer) - (get-buffer-process sql-buffer))] - ["Send Buffer" sql-send-buffer (and (buffer-live-p sql-buffer) - (get-buffer-process sql-buffer))] - ["Send String" sql-send-string t] - ["--" nil nil] - ["Start SQLi session" sql-product-interactive (sql-product-feature :sqli-connect)] + ["Send Paragraph" sql-send-paragraph (sql-buffer-live-p sql-buffer)] + ["Send Region" sql-send-region (and mark-active + (sql-buffer-live-p sql-buffer))] + ["Send Buffer" sql-send-buffer (sql-buffer-live-p sql-buffer)] + ["Send String" sql-send-string (sql-buffer-live-p sql-buffer)] + "--" + ["List all objects" sql-list-all (sql-buffer-live-p sql-buffer)] + ["List table details" sql-list-table (sql-buffer-live-p sql-buffer)] + "--" + ["Start SQLi session" sql-product-interactive + :visible (not sql-connection-alist) + :enable (sql-get-product-feature sql-product :sqli-comint-func)] + ("Start..." + :visible sql-connection-alist + :filter sql-connection-menu-filter + "--" + ["New SQLi Session" sql-product-interactive (sql-get-product-feature sql-product :sqli-comint-func)]) + ["--" + :visible sql-connection-alist] ["Show SQLi buffer" sql-show-sqli-buffer t] ["Set SQLi buffer" sql-set-sqli-buffer t] ["Pop to SQLi buffer after send" @@ -821,7 +1192,11 @@ Based on `comint-mode-map'.") sql-interactive-mode-menu sql-interactive-mode-map "Menu for `sql-interactive-mode'." '("SQL" - ["Rename Buffer" sql-rename-buffer t])) + ["Rename Buffer" sql-rename-buffer t] + ["Save Connection" sql-save-connection (not sql-connection)] + "--" + ["List all objects" sql-list-all t] + ["List table details" sql-list-table t])) ;; Abbreviations -- if you want more of them, define them in your ;; ~/.emacs file. Abbrevs have to be enabled in your ~/.emacs, too. @@ -886,25 +1261,64 @@ The pattern matches the name in a CREATE, DROP or ALTER statement. The format of variable should be a valid `font-lock-keywords' entry.") -(defmacro sql-keywords-re (&rest keywords) - "Compile-time generation of regexp matching any one of KEYWORDS." - `(eval-when-compile - (concat "\\b" - (regexp-opt ',keywords t) - "\\b"))) +;; While there are international and American standards for SQL, they +;; are not followed closely, and most vendors offer significant +;; capabilities beyond those defined in the standard specifications. + +;; SQL mode provides support for hilighting based on the product. In +;; addition to hilighting the product keywords, any ANSI keywords not +;; used by the product are also hilighted. This will help identify +;; keywords that could be restricted in future versions of the product +;; or might be a problem if ported to another product. + +;; To reduce the complexity and size of the regular expressions +;; generated to match keywords, ANSI keywords are filtered out of +;; product keywords if they are equivalent. To do this, we define a +;; function `sql-font-lock-keywords-builder' that removes any keywords +;; that are matched by the ANSI patterns and results in the same face +;; being applied. For this to work properly, we must play some games +;; with the execution and compile time behavior. This code is a +;; little tricky but works properly. + +;; When defining the keywords for individual products you should +;; include all of the keywords that you want matched. The filtering +;; against the ANSI keywords will be automatic if you use the +;; `sql-font-lock-keywords-builder' function and follow the +;; implementation pattern used for the other products in this file. -(defvar sql-mode-ansi-font-lock-keywords - (let ((ansi-funcs (sql-keywords-re -"abs" "avg" "bit_length" "cardinality" "cast" "char_length" -"character_length" "coalesce" "convert" "count" "current_date" -"current_path" "current_role" "current_time" "current_timestamp" -"current_user" "extract" "localtime" "localtimestamp" "lower" "max" -"min" "mod" "nullif" "octet_length" "overlay" "placing" "session_user" -"substring" "sum" "system_user" "translate" "treat" "trim" "upper" -"user" -)) +(eval-when-compile + (defvar sql-mode-ansi-font-lock-keywords) + (setq sql-mode-ansi-font-lock-keywords nil)) + +(eval-and-compile + (defun sql-font-lock-keywords-builder (face boundaries &rest keywords) + "Generation of regexp matching any one of KEYWORDS." + + (let ((bdy (or boundaries '("\\b" . "\\b"))) + kwd) + + ;; Remove keywords that are defined in ANSI + (setq kwd keywords) + (dolist (k keywords) + (catch 'next + (dolist (a sql-mode-ansi-font-lock-keywords) + (when (and (eq face (cdr a)) + (eq (string-match (car a) k 0) 0) + (eq (match-end 0) (length k))) + (setq kwd (delq k kwd)) + (throw 'next nil))))) + + ;; Create a properly formed font-lock-keywords item + (cons (concat (car bdy) + (regexp-opt kwd t) + (cdr bdy)) + face)))) - (ansi-non-reserved (sql-keywords-re +(eval-when-compile + (setq sql-mode-ansi-font-lock-keywords + (list + ;; ANSI Non Reserved keywords + (sql-font-lock-keywords-builder 'font-lock-keyword-face nil "ada" "asensitive" "assignment" "asymmetric" "atomic" "between" "bitvar" "called" "catalog_name" "chain" "character_set_catalog" "character_set_name" "character_set_schema" "checked" "class_origin" @@ -932,9 +1346,9 @@ statement. The format of variable should be a valid "trigger_name" "trigger_schema" "type" "uncommitted" "unnamed" "user_defined_type_catalog" "user_defined_type_name" "user_defined_type_schema" -)) - - (ansi-reserved (sql-keywords-re +) + ;; ANSI Reserved keywords + (sql-font-lock-keywords-builder 'font-lock-keyword-face nil "absolute" "action" "add" "admin" "after" "aggregate" "alias" "all" "allocate" "alter" "and" "any" "are" "as" "asc" "assertion" "at" "authorization" "before" "begin" "both" "breadth" "by" "call" @@ -970,21 +1384,29 @@ statement. The format of variable should be a valid "trigger" "true" "under" "union" "unique" "unknown" "unnest" "update" "usage" "using" "value" "values" "variable" "view" "when" "whenever" "where" "with" "without" "work" "write" "year" -)) +) - (ansi-types (sql-keywords-re + ;; ANSI Functions + (sql-font-lock-keywords-builder 'font-lock-builtin-face nil +"abs" "avg" "bit_length" "cardinality" "cast" "char_length" +"character_length" "coalesce" "convert" "count" "current_date" +"current_path" "current_role" "current_time" "current_timestamp" +"current_user" "extract" "localtime" "localtimestamp" "lower" "max" +"min" "mod" "nullif" "octet_length" "overlay" "placing" "session_user" +"substring" "sum" "system_user" "translate" "treat" "trim" "upper" +"user" +) + ;; ANSI Data Types + (sql-font-lock-keywords-builder 'font-lock-type-face nil "array" "binary" "bit" "blob" "boolean" "char" "character" "clob" "date" "dec" "decimal" "double" "float" "int" "integer" "interval" "large" "national" "nchar" "nclob" "numeric" "object" "precision" "real" "ref" "row" "scope" "smallint" "time" "timestamp" "varchar" "varying" "zone" -))) - - `((,ansi-non-reserved . font-lock-keyword-face) - (,ansi-reserved . font-lock-keyword-face) - (,ansi-funcs . font-lock-builtin-face) - (,ansi-types . font-lock-type-face))) +)))) +(defvar sql-mode-ansi-font-lock-keywords + (eval-when-compile sql-mode-ansi-font-lock-keywords) "ANSI SQL keywords used by font-lock. This variable is used by `sql-mode' and `sql-interactive-mode'. The @@ -994,7 +1416,54 @@ you define your own `sql-mode-ansi-font-lock-keywords'. You may want to add functions and PL/SQL keywords.") (defvar sql-mode-oracle-font-lock-keywords - (let ((oracle-functions (sql-keywords-re + (eval-when-compile + (list + ;; Oracle SQL*Plus Commands + (cons + (concat + "^\\s-*\\(?:\\(?:" (regexp-opt '( +"@" "@@" "accept" "append" "archive" "attribute" "break" +"btitle" "change" "clear" "column" "connect" "copy" "define" +"del" "describe" "disconnect" "edit" "execute" "exit" "get" "help" +"host" "input" "list" "password" "pause" "print" "prompt" "recover" +"remark" "repfooter" "repheader" "run" "save" "show" "shutdown" +"spool" "start" "startup" "store" "timing" "ttitle" "undefine" +"variable" "whenever" +) t) + + "\\)\\|" + "\\(?:compute\\s-+\\(?:avg\\|cou\\|min\\|max\\|num\\|sum\\|std\\|var\\)\\)\\|" + "\\(?:set\\s-+\\(" + + (regexp-opt + '("appi" "appinfo" "array" "arraysize" "auto" "autocommit" + "autop" "autoprint" "autorecovery" "autot" "autotrace" "blo" + "blockterminator" "buffer" "closecursor" "cmds" "cmdsep" + "colsep" "com" "compatibility" "con" "concat" "constraint" + "constraints" "copyc" "copycommit" "copytypecheck" "database" + "def" "define" "document" "echo" "editf" "editfile" "emb" + "embedded" "esc" "escape" "feed" "feedback" "flagger" "flu" + "flush" "hea" "heading" "heads" "headsep" "instance" "lin" + "linesize" "lobof" "loboffset" "logsource" "long" "longc" + "longchunksize" "maxdata" "newp" "newpage" "null" "num" + "numf" "numformat" "numwidth" "pages" "pagesize" "pau" + "pause" "recsep" "recsepchar" "role" "scan" "serveroutput" + "shift" "shiftinout" "show" "showmode" "space" "sqlbl" + "sqlblanklines" "sqlc" "sqlcase" "sqlco" "sqlcontinue" "sqln" + "sqlnumber" "sqlp" "sqlpluscompat" "sqlpluscompatibility" + "sqlpre" "sqlprefix" "sqlprompt" "sqlt" "sqlterminator" + "statement_id" "suf" "suffix" "tab" "term" "termout" "ti" + "time" "timi" "timing" "transaction" "trim" "trimout" "trims" + "trimspool" "truncate" "und" "underline" "ver" "verify" "wra" + "wrap")) "\\)\\)" + + "\\)\\b.*" + ) + 'font-lock-doc-face) + '("^\\s-*rem\\(?:ark\\)?\\>.*" . font-lock-comment-face) + + ;; Oracle Functions + (sql-font-lock-keywords-builder 'font-lock-builtin-face nil "abs" "acos" "add_months" "ascii" "asciistr" "asin" "atan" "atan2" "avg" "bfilename" "bin_to_num" "bitand" "cast" "ceil" "chartorowid" "chr" "coalesce" "compose" "concat" "convert" "corr" "cos" "cosh" @@ -1025,9 +1494,9 @@ to add functions and PL/SQL keywords.") "userenv" "var_pop" "var_samp" "variance" "vsize" "width_bucket" "xml" "xmlagg" "xmlattribute" "xmlcolattval" "xmlconcat" "xmlelement" "xmlforest" "xmlsequence" "xmltransform" -)) - - (oracle-keywords (sql-keywords-re +) + ;; Oracle Keywords + (sql-font-lock-keywords-builder 'font-lock-keyword-face nil "abort" "access" "accessed" "account" "activate" "add" "admin" "advise" "after" "agent" "aggregate" "all" "allocate" "allow" "alter" "always" "analyze" "ancillary" "and" "any" "apply" "archive" @@ -1113,22 +1582,29 @@ to add functions and PL/SQL keywords.") "use" "using" "validate" "validation" "value" "values" "variable" "varray" "version" "view" "wait" "when" "whenever" "where" "with" "without" "wnds" "wnps" "work" "write" "xmldata" "xmlschema" "xmltype" -)) - - (oracle-types (sql-keywords-re +) + ;; Oracle Data Types + (sql-font-lock-keywords-builder 'font-lock-type-face nil "bfile" "blob" "byte" "char" "character" "clob" "date" "dec" "decimal" "double" "float" "int" "integer" "interval" "long" "national" "nchar" "nclob" "number" "numeric" "nvarchar2" "precision" "raw" "real" "rowid" "second" "smallint" "time" "timestamp" "urowid" "varchar" "varchar2" "varying" "year" "zone" -)) +) - (plsql-functions (sql-keywords-re + ;; Oracle PL/SQL Attributes + (sql-font-lock-keywords-builder 'font-lock-builtin-face '("" . "\\b") "%bulk_rowcount" "%found" "%isopen" "%notfound" "%rowcount" "%rowtype" -"%type" "extend" "prior" -)) +"%type" +) + + ;; Oracle PL/SQL Functions + (sql-font-lock-keywords-builder 'font-lock-builtin-face nil +"extend" "prior" +) - (plsql-keywords (sql-keywords-re + ;; Oracle PL/SQL Keywords + (sql-font-lock-keywords-builder 'font-lock-keyword-face nil "autonomous_transaction" "bulk" "char_base" "collect" "constant" "cursor" "declare" "do" "elsif" "exception_init" "execute" "exit" "extends" "false" "fetch" "forall" "goto" "hour" "if" "interface" @@ -1136,14 +1612,16 @@ to add functions and PL/SQL keywords.") "separate" "serially_reusable" "sql" "sqlcode" "sqlerrm" "subtype" "the" "timezone_abbr" "timezone_hour" "timezone_minute" "timezone_region" "true" "varrying" "while" -)) +) - (plsql-type (sql-keywords-re + ;; Oracle PL/SQL Data Types + (sql-font-lock-keywords-builder 'font-lock-type-face nil "binary_integer" "boolean" "naturaln" "pls_integer" "positive" "positiven" "record" "signtype" "string" -)) +) - (plsql-warning (sql-keywords-re + ;; Oracle PL/SQL Exceptions + (sql-font-lock-keywords-builder 'font-lock-warning-face nil "access_into_null" "case_not_found" "collection_is_null" "cursor_already_open" "dup_val_on_index" "invalid_cursor" "invalid_number" "login_denied" "no_data_found" "not_logged_on" @@ -1151,55 +1629,7 @@ to add functions and PL/SQL keywords.") "subscript_beyond_count" "subscript_outside_limit" "sys_invalid_rowid" "timeout_on_resource" "too_many_rows" "value_error" "zero_divide" "exception" "notfound" -)) - - (sqlplus-commands - (eval-when-compile (concat "^\\(\\(" - (regexp-opt '( -"@" "@@" "accept" "append" "archive" "attribute" "break" -"btitle" "change" "clear" "column" "connect" "copy" "define" -"del" "describe" "disconnect" "edit" "execute" "exit" "get" "help" -"host" "input" "list" "password" "pause" "print" "prompt" "recover" -"remark" "repfooter" "repheader" "run" "save" "show" "shutdown" -"spool" "start" "startup" "store" "timing" "ttitle" "undefine" -"variable" "whenever" - -) t) - - "\\)\\|" - "\\(compute\\s-+\\(avg\\|cou\\|min\\|max\\|num\\|sum\\|std\\|var\\)\\)\\|" - "\\(set\\s-+\\(appi\\(nfo\\)?\\|array\\(size\\)?\\|" - "auto\\(commit\\)?\\|autop\\(rint\\)?\\|autorecovery\\|" - "autot\\(race\\)?\\|blo\\(ckterminator\\)?\\|cmds\\(ep\\)?\\|" - "colsep\\|com\\(patibility\\)?\\|con\\(cat\\)?\\|" - "copyc\\(ommit\\)?\\|copytypecheck\\|def\\(ine\\)?\\|" - "describe\\|echo\\|editf\\(ile\\)?\\|emb\\(edded\\)?\\|" - "esc\\(ape\\)?\\|feed\\(back\\)?\\|flagger\\|" - "flu\\(sh\\)?\\|hea\\(ding\\)?\\|heads\\(ep\\)?\\|" - "instance\\|lin\\(esize\\)?\\|lobof\\(fset\\)?\\|" - "logsource\\|long\\|longc\\(hunksize\\)?\\|mark\\(up\\)?\\|" - "newp\\(age\\)?\\|null\\|numf\\(ormat\\)?\\|" - "num\\(width\\)?\\|pages\\(ize\\)?\\|pau\\(se\\)?\\|" - "recsep\\|recsepchar\\|serverout\\(put\\)?\\|" - "shift\\(inout\\)?\\|show\\(mode\\)?\\|" - "sqlbl\\(anklines\\)?\\|sqlc\\(ase\\)?\\|" - "sqlco\\(ntinue\\)?\\|sqln\\(umber\\)?\\|" - "sqlpluscompat\\(ibility\\)?\\|sqlpre\\(fix\\)?\\|" - "sqlp\\(rompt\\)?\\|sqlt\\(erminator\\)?\\|" - "suf\\(fix\\)?\\|tab\\|term\\(out\\)?\\|ti\\(me\\)?\\|" - "timi\\(ng\\)?\\|trim\\(out\\)?\\|trims\\(pool\\)?\\|" - "und\\(erline\\)?\\|ver\\(ify\\)?\\|wra\\(p\\)?\\)\\)\\)" - "\\b.*$" - )))) - - `((,sqlplus-commands . font-lock-doc-face) - (,oracle-functions . font-lock-builtin-face) - (,oracle-keywords . font-lock-keyword-face) - (,oracle-types . font-lock-type-face) - (,plsql-functions . font-lock-builtin-face) - (,plsql-keywords . font-lock-keyword-face) - (,plsql-type . font-lock-type-face) - (,plsql-warning . font-lock-warning-face))) +))) "Oracle SQL keywords used by font-lock. @@ -1210,85 +1640,157 @@ you define your own `sql-mode-oracle-font-lock-keywords'. You may want to add functions and PL/SQL keywords.") (defvar sql-mode-postgres-font-lock-keywords - (let ((pg-funcs (sql-keywords-re -"abbrev" "abs" "acos" "age" "area" "ascii" "asin" "atab2" "atan" -"atan2" "avg" "bit_length" "both" "broadcast" "btrim" "cbrt" "ceil" -"center" "char_length" "chr" "coalesce" "col_description" "convert" -"cos" "cot" "count" "current_database" "current_date" "current_schema" -"current_schemas" "current_setting" "current_time" "current_timestamp" -"current_user" "currval" "date_part" "date_trunc" "decode" "degrees" -"diameter" "encode" "exp" "extract" "floor" "get_bit" "get_byte" -"has_database_privilege" "has_function_privilege" -"has_language_privilege" "has_schema_privilege" "has_table_privilege" -"height" "host" "initcap" "isclosed" "isfinite" "isopen" "leading" -"length" "ln" "localtime" "localtimestamp" "log" "lower" "lpad" -"ltrim" "masklen" "max" "min" "mod" "netmask" "network" "nextval" -"now" "npoints" "nullif" "obj_description" "octet_length" "overlay" -"pclose" "pg_client_encoding" "pg_function_is_visible" -"pg_get_constraintdef" "pg_get_indexdef" "pg_get_ruledef" -"pg_get_userbyid" "pg_get_viewdef" "pg_opclass_is_visible" -"pg_operator_is_visible" "pg_table_is_visible" "pg_type_is_visible" -"pi" "popen" "position" "pow" "quote_ident" "quote_literal" "radians" -"radius" "random" "repeat" "replace" "round" "rpad" "rtrim" -"session_user" "set_bit" "set_byte" "set_config" "set_masklen" -"setval" "sign" "sin" "split_part" "sqrt" "stddev" "strpos" "substr" -"substring" "sum" "tan" "timeofday" "to_ascii" "to_char" "to_date" -"to_hex" "to_number" "to_timestamp" "trailing" "translate" "trim" -"trunc" "upper" "variance" "version" "width" -)) - - (pg-reserved (sql-keywords-re -"abort" "access" "add" "after" "aggregate" "alignment" "all" "alter" -"analyze" "and" "any" "as" "asc" "assignment" "authorization" -"backward" "basetype" "before" "begin" "between" "binary" "by" "cache" -"called" "cascade" "case" "cast" "characteristics" "check" -"checkpoint" "class" "close" "cluster" "column" "comment" "commit" -"committed" "commutator" "constraint" "constraints" "conversion" -"copy" "create" "createdb" "createuser" "cursor" "cycle" "database" -"deallocate" "declare" "default" "deferrable" "deferred" "definer" -"delete" "delimiter" "desc" "distinct" "do" "domain" "drop" "each" -"element" "else" "encoding" "encrypted" "end" "escape" "except" -"exclusive" "execute" "exists" "explain" "extended" "external" "false" -"fetch" "finalfunc" "for" "force" "foreign" "forward" "freeze" "from" -"full" "function" "grant" "group" "gtcmp" "handler" "hashes" "having" -"immediate" "immutable" "implicit" "in" "increment" "index" "inherits" -"initcond" "initially" "input" "insensitive" "insert" "instead" -"internallength" "intersect" "into" "invoker" "is" "isnull" -"isolation" "join" "key" "language" "leftarg" "level" "like" "limit" -"listen" "load" "local" "location" "lock" "ltcmp" "main" "match" -"maxvalue" "merges" "minvalue" "mode" "move" "natural" "negator" -"next" "nocreatedb" "nocreateuser" "none" "not" "nothing" "notify" -"notnull" "null" "of" "offset" "oids" "on" "only" "operator" "or" -"order" "output" "owner" "partial" "passedbyvalue" "password" "plain" -"prepare" "primary" "prior" "privileges" "procedural" "procedure" -"public" "read" "recheck" "references" "reindex" "relative" "rename" -"reset" "restrict" "returns" "revoke" "rightarg" "rollback" "row" -"rule" "schema" "scroll" "security" "select" "sequence" "serializable" -"session" "set" "sfunc" "share" "show" "similar" "some" "sort1" -"sort2" "stable" "start" "statement" "statistics" "storage" "strict" -"stype" "sysid" "table" "temp" "template" "temporary" "then" "to" -"transaction" "trigger" "true" "truncate" "trusted" "type" -"unencrypted" "union" "unique" "unknown" "unlisten" "until" "update" -"usage" "user" "using" "vacuum" "valid" "validator" "values" -"variable" "verbose" "view" "volatile" "when" "where" "with" "without" -"work" -)) - - (pg-types (sql-keywords-re -"anyarray" "bigint" "bigserial" "bit" "boolean" "box" "bytea" "char" -"character" "cidr" "circle" "cstring" "date" "decimal" "double" -"float4" "float8" "inet" "int2" "int4" "int8" "integer" "internal" -"interval" "language_handler" "line" "lseg" "macaddr" "money" -"numeric" "oid" "opaque" "path" "point" "polygon" "precision" "real" -"record" "regclass" "regoper" "regoperator" "regproc" "regprocedure" -"regtype" "serial" "serial4" "serial8" "smallint" "text" "time" -"timestamp" "varchar" "varying" "void" "zone" + (eval-when-compile + (list + ;; Postgres psql commands + '("^\\s-*\\\\.*$" . font-lock-doc-face) + + ;; Postgres unreserved words but may have meaning + (sql-font-lock-keywords-builder 'font-lock-builtin-face nil "a" +"abs" "absent" "according" "ada" "alias" "allocate" "are" "array_agg" +"asensitive" "atomic" "attribute" "attributes" "avg" "base64" +"bernoulli" "bit_length" "bitvar" "blob" "blocked" "bom" "breadth" "c" +"call" "cardinality" "catalog_name" "ceil" "ceiling" "char_length" +"character_length" "character_set_catalog" "character_set_name" +"character_set_schema" "characters" "checked" "class_origin" "clob" +"cobol" "collation" "collation_catalog" "collation_name" +"collation_schema" "collect" "column_name" "columns" +"command_function" "command_function_code" "completion" "condition" +"condition_number" "connect" "connection_name" "constraint_catalog" +"constraint_name" "constraint_schema" "constructor" "contains" +"control" "convert" "corr" "corresponding" "count" "covar_pop" +"covar_samp" "cube" "cume_dist" "current_default_transform_group" +"current_path" "current_transform_group_for_type" "cursor_name" +"datalink" "datetime_interval_code" "datetime_interval_precision" "db" +"defined" "degree" "dense_rank" "depth" "deref" "derived" "describe" +"descriptor" "destroy" "destructor" "deterministic" "diagnostics" +"disconnect" "dispatch" "dlnewcopy" "dlpreviouscopy" "dlurlcomplete" +"dlurlcompleteonly" "dlurlcompletewrite" "dlurlpath" "dlurlpathonly" +"dlurlpathwrite" "dlurlscheme" "dlurlserver" "dlvalue" "dynamic" +"dynamic_function" "dynamic_function_code" "element" "empty" +"end-exec" "equals" "every" "exception" "exec" "existing" "exp" "file" +"filter" "final" "first_value" "flag" "floor" "fortran" "found" "free" +"fs" "fusion" "g" "general" "generated" "get" "go" "goto" "grouping" +"hex" "hierarchy" "host" "id" "ignore" "implementation" "import" +"indent" "indicator" "infix" "initialize" "instance" "instantiable" +"integrity" "intersection" "iterate" "k" "key_member" "key_type" "lag" +"last_value" "lateral" "lead" "length" "less" "library" "like_regex" +"link" "ln" "locator" "lower" "m" "map" "matched" "max" +"max_cardinality" "member" "merge" "message_length" +"message_octet_length" "message_text" "method" "min" "mod" "modifies" +"modify" "module" "more" "multiset" "mumps" "namespace" "nclob" +"nesting" "new" "nfc" "nfd" "nfkc" "nfkd" "nil" "normalize" +"normalized" "nth_value" "ntile" "nullable" "number" +"occurrences_regex" "octet_length" "octets" "old" "open" "operation" +"ordering" "ordinality" "others" "output" "overriding" "p" "pad" +"parameter" "parameter_mode" "parameter_name" +"parameter_ordinal_position" "parameter_specific_catalog" +"parameter_specific_name" "parameter_specific_schema" "parameters" +"pascal" "passing" "passthrough" "percent_rank" "percentile_cont" +"percentile_disc" "permission" "pli" "position_regex" "postfix" +"power" "prefix" "preorder" "public" "rank" "reads" "recovery" "ref" +"referencing" "regr_avgx" "regr_avgy" "regr_count" "regr_intercept" +"regr_r2" "regr_slope" "regr_sxx" "regr_sxy" "regr_syy" "requiring" +"respect" "restore" "result" "return" "returned_cardinality" +"returned_length" "returned_octet_length" "returned_sqlstate" "rollup" +"routine" "routine_catalog" "routine_name" "routine_schema" +"row_count" "row_number" "scale" "schema_name" "scope" "scope_catalog" +"scope_name" "scope_schema" "section" "selective" "self" "sensitive" +"server_name" "sets" "size" "source" "space" "specific" +"specific_name" "specifictype" "sql" "sqlcode" "sqlerror" +"sqlexception" "sqlstate" "sqlwarning" "sqrt" "state" "static" +"stddev_pop" "stddev_samp" "structure" "style" "subclass_origin" +"sublist" "submultiset" "substring_regex" "sum" "system_user" "t" +"table_name" "tablesample" "terminate" "than" "ties" "timezone_hour" +"timezone_minute" "token" "top_level_count" "transaction_active" +"transactions_committed" "transactions_rolled_back" "transform" +"transforms" "translate" "translate_regex" "translation" +"trigger_catalog" "trigger_name" "trigger_schema" "trim_array" +"uescape" "under" "unlink" "unnamed" "unnest" "untyped" "upper" "uri" +"usage" "user_defined_type_catalog" "user_defined_type_code" +"user_defined_type_name" "user_defined_type_schema" "var_pop" +"var_samp" "varbinary" "variable" "whenever" "width_bucket" "within" +"xmlagg" "xmlbinary" "xmlcast" "xmlcomment" "xmldeclaration" +"xmldocument" "xmlexists" "xmliterate" "xmlnamespaces" "xmlquery" +"xmlschema" "xmltable" "xmltext" "xmlvalidate" +) + + ;; Postgres non-reserved words + (sql-font-lock-keywords-builder 'font-lock-builtin-face nil +"abort" "absolute" "access" "action" "add" "admin" "after" "aggregate" +"also" "alter" "always" "assertion" "assignment" "at" "backward" +"before" "begin" "between" "by" "cache" "called" "cascade" "cascaded" +"catalog" "chain" "characteristics" "checkpoint" "class" "close" +"cluster" "coalesce" "comment" "comments" "commit" "committed" +"configuration" "connection" "constraints" "content" "continue" +"conversion" "copy" "cost" "createdb" "createrole" "createuser" "csv" +"current" "cursor" "cycle" "data" "database" "day" "deallocate" "dec" +"declare" "defaults" "deferred" "definer" "delete" "delimiter" +"delimiters" "dictionary" "disable" "discard" "document" "domain" +"drop" "each" "enable" "encoding" "encrypted" "enum" "escape" +"exclude" "excluding" "exclusive" "execute" "exists" "explain" +"external" "extract" "family" "first" "float" "following" "force" +"forward" "function" "functions" "global" "granted" "greatest" +"handler" "header" "hold" "hour" "identity" "if" "immediate" +"immutable" "implicit" "including" "increment" "index" "indexes" +"inherit" "inherits" "inline" "inout" "input" "insensitive" "insert" +"instead" "invoker" "isolation" "key" "language" "large" "last" +"lc_collate" "lc_ctype" "least" "level" "listen" "load" "local" +"location" "lock" "login" "mapping" "match" "maxvalue" "minute" +"minvalue" "mode" "month" "move" "name" "names" "national" "nchar" +"next" "no" "nocreatedb" "nocreaterole" "nocreateuser" "noinherit" +"nologin" "none" "nosuperuser" "nothing" "notify" "nowait" "nullif" +"nulls" "object" "of" "oids" "operator" "option" "options" "out" +"overlay" "owned" "owner" "parser" "partial" "partition" "password" +"plans" "position" "preceding" "prepare" "prepared" "preserve" "prior" +"privileges" "procedural" "procedure" "quote" "range" "read" +"reassign" "recheck" "recursive" "reindex" "relative" "release" +"rename" "repeatable" "replace" "replica" "reset" "restart" "restrict" +"returns" "revoke" "role" "rollback" "row" "rows" "rule" "savepoint" +"schema" "scroll" "search" "second" "security" "sequence" "sequences" +"serializable" "server" "session" "set" "setof" "share" "show" +"simple" "stable" "standalone" "start" "statement" "statistics" +"stdin" "stdout" "storage" "strict" "strip" "substring" "superuser" +"sysid" "system" "tables" "tablespace" "temp" "template" "temporary" +"transaction" "treat" "trigger" "trim" "truncate" "trusted" "type" +"unbounded" "uncommitted" "unencrypted" "unknown" "unlisten" "until" +"update" "vacuum" "valid" "validator" "value" "values" "version" +"view" "volatile" "whitespace" "work" "wrapper" "write" +"xmlattributes" "xmlconcat" "xmlelement" "xmlforest" "xmlparse" +"xmlpi" "xmlroot" "xmlserialize" "year" "yes" +) + + ;; Postgres Reserved + (sql-font-lock-keywords-builder 'font-lock-keyword-face nil +"all" "analyse" "analyze" "and" "any" "array" "asc" "as" "asymmetric" +"authorization" "binary" "both" "case" "cast" "check" "collate" +"column" "concurrently" "constraint" "create" "cross" +"current_catalog" "current_date" "current_role" "current_schema" +"current_time" "current_timestamp" "current_user" "default" +"deferrable" "desc" "distinct" "do" "else" "end" "except" "false" +"fetch" "foreign" "for" "freeze" "from" "full" "grant" "group" +"having" "ilike" "initially" "inner" "in" "intersect" "into" "isnull" +"is" "join" "leading" "left" "like" "limit" "localtime" +"localtimestamp" "natural" "notnull" "not" "null" "off" "offset" +"only" "on" "order" "or" "outer" "overlaps" "over" "placing" "primary" +"references" "returning" "right" "select" "session_user" "similar" +"some" "symmetric" "table" "then" "to" "trailing" "true" "union" +"unique" "user" "using" "variadic" "verbose" "when" "where" "window" +"with" +) + + ;; Postgres Data Types + (sql-font-lock-keywords-builder 'font-lock-type-face nil +"bigint" "bigserial" "bit" "bool" "boolean" "box" "bytea" "char" +"character" "cidr" "circle" "date" "decimal" "double" "float4" +"float8" "inet" "int" "int2" "int4" "int8" "integer" "interval" "line" +"lseg" "macaddr" "money" "numeric" "path" "point" "polygon" +"precision" "real" "serial" "serial4" "serial8" "smallint" "text" +"time" "timestamp" "timestamptz" "timetz" "tsquery" "tsvector" +"txid_snapshot" "uuid" "varbit" "varchar" "varying" "without" +"xml" "zone" ))) - `((,pg-funcs . font-lock-builtin-face) - (,pg-reserved . font-lock-keyword-face) - (,pg-types . font-lock-type-face))) - "Postgres SQL keywords used by font-lock. This variable is used by `sql-mode' and `sql-interactive-mode'. The @@ -1297,7 +1799,10 @@ function `regexp-opt'. Therefore, take a look at the source before you define your own `sql-mode-postgres-font-lock-keywords'.") (defvar sql-mode-linter-font-lock-keywords - (let ((linter-keywords (sql-keywords-re + (eval-when-compile + (list + ;; Linter Keywords + (sql-font-lock-keywords-builder 'font-lock-keyword-face nil "autocommit" "autoinc" "autorowid" "cancel" "cascade" "channel" "committed" "count" "countblob" "cross" "current" "data" "database" "datafile" "datafiles" "datesplit" "dba" "dbname" "default" "deferred" @@ -1322,9 +1827,10 @@ you define your own `sql-mode-postgres-font-lock-keywords'.") "trigger_info_size" "true" "trunc" "uncommitted" "unicode" "unknown" "unlimited" "unlisted" "user" "utf8" "value" "varying" "volumes" "wait" "windows_code" "workspace" "write" "xml" -)) +) - (linter-reserved (sql-keywords-re + ;; Linter Reserved + (sql-font-lock-keywords-builder 'font-lock-keyword-face nil "access" "action" "add" "address" "after" "all" "alter" "always" "and" "any" "append" "as" "asc" "ascic" "async" "at_begin" "at_end" "audit" "aud_obj_name_len" "backup" "base" "before" "between" "blobfile" @@ -1342,16 +1848,10 @@ you define your own `sql-mode-postgres-font-lock-keywords'.") "start" "stop" "sync" "synchronize" "synonym" "sysdate" "table" "then" "to" "union" "unique" "unlock" "until" "update" "using" "values" "view" "when" "where" "with" "without" -)) +) - (linter-types (sql-keywords-re -"bigint" "bitmap" "blob" "boolean" "char" "character" "date" -"datetime" "dec" "decimal" "double" "float" "int" "integer" "nchar" -"number" "numeric" "real" "smallint" "varbyte" "varchar" "byte" -"cursor" "long" -)) - - (linter-functions (sql-keywords-re + ;; Linter Functions + (sql-font-lock-keywords-builder 'font-lock-builtin-face nil "abs" "acos" "asin" "atan" "atan2" "avg" "ceil" "cos" "cosh" "divtime" "exp" "floor" "getbits" "getblob" "getbyte" "getlong" "getraw" "getstr" "gettext" "getword" "hextoraw" "lenblob" "length" "log" @@ -1362,12 +1862,15 @@ you define your own `sql-mode-postgres-font-lock-keywords'.") "to_gmtime" "to_localtime" "to_number" "trim" "upper" "decode" "substr" "substring" "chr" "dayname" "days" "greatest" "hex" "initcap" "instr" "least" "multime" "replace" "width" -))) +) - `((,linter-keywords . font-lock-keyword-face) - (,linter-reserved . font-lock-keyword-face) - (,linter-functions . font-lock-builtin-face) - (,linter-types . font-lock-type-face))) + ;; Linter Data Types + (sql-font-lock-keywords-builder 'font-lock-type-face nil +"bigint" "bitmap" "blob" "boolean" "char" "character" "date" +"datetime" "dec" "decimal" "double" "float" "int" "integer" "nchar" +"number" "numeric" "real" "smallint" "varbyte" "varchar" "byte" +"cursor" "long" +))) "Linter SQL keywords used by font-lock. @@ -1376,7 +1879,29 @@ regular expressions are created during compilation by calling the function `regexp-opt'.") (defvar sql-mode-ms-font-lock-keywords - (let ((ms-reserved (sql-keywords-re + (eval-when-compile + (list + ;; MS isql/osql Commands + (cons + (concat + "^\\(?:\\(?:set\\s-+\\(?:" + (regexp-opt '( +"datefirst" "dateformat" "deadlock_priority" "lock_timeout" +"concat_null_yields_null" "cursor_close_on_commit" +"disable_def_cnst_chk" "fips_flagger" "identity_insert" "language" +"offsets" "quoted_identifier" "arithabort" "arithignore" "fmtonly" +"nocount" "noexec" "numeric_roundabort" "parseonly" +"query_governor_cost_limit" "rowcount" "textsize" "ansi_defaults" +"ansi_null_dflt_off" "ansi_null_dflt_on" "ansi_nulls" "ansi_padding" +"ansi_warnings" "forceplan" "showplan_all" "showplan_text" +"statistics" "implicit_transactions" "remote_proc_transactions" +"transaction" "xact_abort" +) t) + "\\)\\)\\|go\\s-*\\|use\\s-+\\|setuser\\s-+\\|dbcc\\s-+\\).*$") + 'font-lock-doc-face) + + ;; MS Reserved + (sql-font-lock-keywords-builder 'font-lock-keyword-face nil "absolute" "add" "all" "alter" "and" "any" "as" "asc" "authorization" "avg" "backup" "begin" "between" "break" "browse" "bulk" "by" "cascade" "case" "check" "checkpoint" "close" "clustered" "coalesce" @@ -1409,19 +1934,10 @@ function `regexp-opt'.") "updlock" "use" "user" "values" "view" "waitfor" "when" "where" "while" "with" "work" "writetext" "collate" "function" "openxml" "returns" -)) +) - (ms-types (sql-keywords-re -"binary" "bit" "char" "character" "cursor" "datetime" "dec" "decimal" -"double" "float" "image" "int" "integer" "money" "national" "nchar" -"ntext" "numeric" "numeric" "nvarchar" "precision" "real" -"smalldatetime" "smallint" "smallmoney" "text" "timestamp" "tinyint" -"uniqueidentifier" "varbinary" "varchar" "varying" -)) - - (ms-vars "\\b@[a-zA-Z0-9_]*\\b") - - (ms-functions (sql-keywords-re + ;; MS Functions + (sql-font-lock-keywords-builder 'font-lock-builtin-face nil "@@connections" "@@cpu_busy" "@@cursor_rows" "@@datefirst" "@@dbts" "@@error" "@@fetch_status" "@@identity" "@@idle" "@@io_busy" "@@langid" "@@language" "@@lock_timeout" "@@max_connections" @@ -1450,30 +1966,19 @@ function `regexp-opt'.") "suser_id" "suser_name" "suser_sid" "suser_sname" "system_user" "tan" "textptr" "textvalid" "typeproperty" "unicode" "upper" "user" "user_id" "user_name" "var" "varp" "year" -)) +) - (ms-commands - (eval-when-compile - (concat "^\\(\\(set\\s-+\\(" - (regexp-opt '( -"datefirst" "dateformat" "deadlock_priority" "lock_timeout" -"concat_null_yields_null" "cursor_close_on_commit" -"disable_def_cnst_chk" "fips_flagger" "identity_insert" "language" -"offsets" "quoted_identifier" "arithabort" "arithignore" "fmtonly" -"nocount" "noexec" "numeric_roundabort" "parseonly" -"query_governor_cost_limit" "rowcount" "textsize" "ansi_defaults" -"ansi_null_dflt_off" "ansi_null_dflt_on" "ansi_nulls" "ansi_padding" -"ansi_warnings" "forceplan" "showplan_all" "showplan_text" -"statistics" "implicit_transactions" "remote_proc_transactions" -"transaction" "xact_abort" -) t) - "\\)\\)\\|go\\s-*\\|use\\s-+\\|setuser\\s-+\\|dbcc\\s-+\\).*$")))) + ;; MS Variables + '("\\b@[a-zA-Z0-9_]*\\b" . font-lock-variable-name-face) - `((,ms-commands . font-lock-doc-face) - (,ms-reserved . font-lock-keyword-face) - (,ms-functions . font-lock-builtin-face) - (,ms-vars . font-lock-variable-name-face) - (,ms-types . font-lock-type-face))) + ;; MS Types + (sql-font-lock-keywords-builder 'font-lock-type-face nil +"binary" "bit" "char" "character" "cursor" "datetime" "dec" "decimal" +"double" "float" "image" "int" "integer" "money" "national" "nchar" +"ntext" "numeric" "numeric" "nvarchar" "precision" "real" +"smalldatetime" "smallint" "smallmoney" "text" "timestamp" "tinyint" +"uniqueidentifier" "varbinary" "varchar" "varying" +))) "Microsoft SQLServer SQL keywords used by font-lock. @@ -1523,7 +2028,10 @@ function `regexp-opt'. Therefore, take a look at the source before you define your own `sql-mode-solid-font-lock-keywords'.") (defvar sql-mode-mysql-font-lock-keywords - (let ((mysql-funcs (sql-keywords-re + (eval-when-compile + (list + ;; MySQL Functions + (sql-font-lock-keywords-builder 'font-lock-builtin-face nil "ascii" "avg" "bdmpolyfromtext" "bdmpolyfromwkb" "bdpolyfromtext" "bdpolyfromwkb" "benchmark" "bin" "bit_and" "bit_length" "bit_or" "bit_xor" "both" "cast" "char_length" "character_length" "coalesce" @@ -1546,9 +2054,10 @@ you define your own `sql-mode-solid-font-lock-keywords'.") "release_lock" "repeat" "replace" "reverse" "rpad" "rtrim" "soundex" "space" "std" "stddev" "substring" "substring_index" "sum" "sysdate" "trailing" "trim" "ucase" "unix_timestamp" "upper" "user" "variance" -)) +) - (mysql-keywords (sql-keywords-re + ;; MySQL Keywords + (sql-font-lock-keywords-builder 'font-lock-keyword-face nil "action" "add" "after" "against" "all" "alter" "and" "as" "asc" "auto_increment" "avg_row_length" "bdb" "between" "by" "cascade" "case" "change" "character" "check" "checksum" "close" "collate" @@ -1574,9 +2083,10 @@ you define your own `sql-mode-solid-font-lock-keywords'.") "then" "to" "transaction" "truncate" "type" "uncommitted" "union" "unique" "unlock" "update" "use" "using" "values" "when" "where" "with" "write" "xor" -)) +) - (mysql-types (sql-keywords-re + ;; MySQL Data Types + (sql-font-lock-keywords-builder 'font-lock-type-face nil "bigint" "binary" "bit" "blob" "bool" "boolean" "char" "curve" "date" "datetime" "dec" "decimal" "double" "enum" "fixed" "float" "geometry" "geometrycollection" "int" "integer" "line" "linearring" "linestring" @@ -1588,10 +2098,6 @@ you define your own `sql-mode-solid-font-lock-keywords'.") "zerofill" ))) - `((,mysql-funcs . font-lock-builtin-face) - (,mysql-keywords . font-lock-keyword-face) - (,mysql-types . font-lock-type-face))) - "MySQL SQL keywords used by font-lock. This variable is used by `sql-mode' and `sql-interactive-mode'. The @@ -1599,7 +2105,54 @@ regular expressions are created during compilation by calling the function `regexp-opt'. Therefore, take a look at the source before you define your own `sql-mode-mysql-font-lock-keywords'.") -(defvar sql-mode-sqlite-font-lock-keywords nil +(defvar sql-mode-sqlite-font-lock-keywords + (eval-when-compile + (list + ;; SQLite commands + '("^[.].*$" . font-lock-doc-face) + + ;; SQLite Keyword + (sql-font-lock-keywords-builder 'font-lock-keyword-face nil +"abort" "action" "add" "after" "all" "alter" "analyze" "and" "as" +"asc" "attach" "autoincrement" "before" "begin" "between" "by" +"cascade" "case" "cast" "check" "collate" "column" "commit" "conflict" +"constraint" "create" "cross" "database" "default" "deferrable" +"deferred" "delete" "desc" "detach" "distinct" "drop" "each" "else" +"end" "escape" "except" "exclusive" "exists" "explain" "fail" "for" +"foreign" "from" "full" "glob" "group" "having" "if" "ignore" +"immediate" "in" "index" "indexed" "initially" "inner" "insert" +"instead" "intersect" "into" "is" "isnull" "join" "key" "left" "like" +"limit" "match" "natural" "no" "not" "notnull" "null" "of" "offset" +"on" "or" "order" "outer" "plan" "pragma" "primary" "query" "raise" +"references" "regexp" "reindex" "release" "rename" "replace" +"restrict" "right" "rollback" "row" "savepoint" "select" "set" "table" +"temp" "temporary" "then" "to" "transaction" "trigger" "union" +"unique" "update" "using" "vacuum" "values" "view" "virtual" "when" +"where" +) + ;; SQLite Data types + (sql-font-lock-keywords-builder 'font-lock-type-face nil +"int" "integer" "tinyint" "smallint" "mediumint" "bigint" "unsigned" +"big" "int2" "int8" "character" "varchar" "varying" "nchar" "native" +"nvarchar" "text" "clob" "blob" "real" "double" "precision" "float" +"numeric" "number" "decimal" "boolean" "date" "datetime" +) + ;; SQLite Functions + (sql-font-lock-keywords-builder 'font-lock-builtin-face nil +;; Core functions +"abs" "changes" "coalesce" "glob" "ifnull" "hex" "last_insert_rowid" +"length" "like" "load_extension" "lower" "ltrim" "max" "min" "nullif" +"quote" "random" "randomblob" "replace" "round" "rtrim" "soundex" +"sqlite_compileoption_get" "sqlite_compileoption_used" +"sqlite_source_id" "sqlite_version" "substr" "total_changes" "trim" +"typeof" "upper" "zeroblob" +;; Date/time functions +"time" "julianday" "strftime" +"current_date" "current_time" "current_timestamp" +;; Aggregate functions +"avg" "count" "group_concat" "max" "min" "sum" "total" +))) + "SQLite SQL keywords used by font-lock. This variable is used by `sql-mode' and `sql-interactive-mode'. The @@ -1626,45 +2179,149 @@ highlighting rules in SQL mode.") ;;; SQL Product support functions -(defun sql-product-feature (feature &optional product) - "Lookup `feature' needed to support the current SQL product. +(defun sql-read-product (prompt &optional initial) + "Read a valid SQL product." + (let ((init (or (and initial (symbol-name initial)) "ansi"))) + (intern (completing-read + prompt + (mapcar (lambda (info) (symbol-name (car info))) + sql-product-alist) + nil 'require-match + init 'sql-product-history init)))) + +(defun sql-add-product (product display &rest plist) + "Add support for a database product in `sql-mode'. + +Add PRODUCT to `sql-product-alist' which enables `sql-mode' to +properly support syntax highlighting and interactive interaction. +DISPLAY is the name of the SQL product that will appear in the +menu bar and in messages. PLIST initializes the product +configuration." + + ;; Don't do anything if the product is already supported + (if (assoc product sql-product-alist) + (message "Product `%s' is already defined" product) + + ;; Add product to the alist + (add-to-list 'sql-product-alist `((,product :name ,display . ,plist))) + ;; Add a menu item to the SQL->Product menu + (easy-menu-add-item sql-mode-menu '("Product") + ;; Each product is represented by a radio + ;; button with it's display name. + `[,display + (sql-set-product ',product) + :style radio + :selected (eq sql-product ',product)] + ;; Maintain the product list in + ;; (case-insensitive) alphabetic order of the + ;; display names. Loop thru each keymap item + ;; looking for an item whose display name is + ;; after this product's name. + (let ((next-item) + (down-display (downcase display))) + (map-keymap (lambda (k b) + (when (and (not next-item) + (string-lessp down-display + (downcase (cadr b)))) + (setq next-item k))) + (easy-menu-get-map sql-mode-menu '("Product"))) + next-item)) + product)) + +(defun sql-del-product (product) + "Remove support for PRODUCT in `sql-mode'." + + ;; Remove the menu item based on the display name + (easy-menu-remove-item sql-mode-menu '("Product") (sql-get-product-feature product :name)) + ;; Remove the product alist item + (setq sql-product-alist (assq-delete-all product sql-product-alist)) + nil) + +(defun sql-set-product-feature (product feature newvalue) + "Set FEATURE of database PRODUCT to NEWVALUE. + +The PRODUCT must be a symbol which identifies the database +product. The product must have already exist on the product +list. See `sql-add-product' to add new products. The FEATURE +argument must be a plist keyword accepted by +`sql-product-alist'." + + (let* ((p (assoc product sql-product-alist)) + (v (plist-get (cdr p) feature))) + (if p + (if (and + (member feature sql-indirect-features) + (symbolp v)) + (set v newvalue) + (setcdr p (plist-put (cdr p) feature newvalue))) + (message "`%s' is not a known product; use `sql-add-product' to add it first." product)))) + +(defun sql-get-product-feature (product feature &optional fallback not-indirect) + "Lookup FEATURE associated with a SQL PRODUCT. + +If the FEATURE is nil for PRODUCT, and FALLBACK is specified, +then the FEATURE associated with the FALLBACK product is +returned. + +If the FEATURE is in the list `sql-indirect-features', and the +NOT-INDIRECT parameter is not set, then the value of the symbol +stored in the connect alist is returned. See `sql-product-alist' for a list of products and supported features." - (plist-get - (cdr (assoc (or product sql-product) - sql-product-alist)) - feature)) + (let* ((p (assoc product sql-product-alist)) + (v (plist-get (cdr p) feature))) + + (if p + ;; If no value and fallback, lookup feature for fallback + (if (and (not v) + fallback + (not (eq product fallback))) + (sql-get-product-feature fallback feature) + + (if (and + (member feature sql-indirect-features) + (not not-indirect) + (symbolp v)) + (symbol-value v) + v)) + (message "`%s' is not a known product; use `sql-add-product' to add it first." product) + nil))) (defun sql-product-font-lock (keywords-only imenu) - "Sets `font-lock-defaults' and `font-lock-keywords' based on -the product-specific keywords and syntax-alists defined in -`sql-product-alist'." + "Configure font-lock and imenu with product-specific settings. + +The KEYWORDS-ONLY flag is passed to font-lock to specify whether +only keywords should be hilighted and syntactic hilighting +skipped. The IMENU flag indicates whether `imenu-mode' should +also be configured." + (let ;; Get the product-specific syntax-alist. ((syntax-alist (append - (sql-product-feature :syntax-alist) + (sql-get-product-feature sql-product :syntax-alist) '((?_ . "w") (?. . "w"))))) ;; Get the product-specific keywords. (setq sql-mode-font-lock-keywords (append (unless (eq sql-product 'ansi) - (eval (sql-product-feature :font-lock))) + (sql-get-product-feature sql-product :font-lock)) ;; Always highlight ANSI keywords - (eval (sql-product-feature :font-lock 'ansi)) + (sql-get-product-feature 'ansi :font-lock) ;; Fontify object names in CREATE, DROP and ALTER DDL ;; statements (list sql-mode-font-lock-object-name))) ;; Setup font-lock. Force re-parsing of `font-lock-defaults'. - (set (make-local-variable 'font-lock-set-defaults) nil) + (kill-local-variable 'font-lock-set-defaults) (setq font-lock-defaults (list 'sql-mode-font-lock-keywords keywords-only t syntax-alist)) ;; Force font lock to reinitialize if it is already on ;; Otherwise, we can wait until it can be started. (when (and (fboundp 'font-lock-mode) + (boundp 'font-lock-mode) font-lock-mode) (font-lock-mode-internal nil) (font-lock-mode-internal t)) @@ -1681,13 +2338,13 @@ the product-specific keywords and syntax-alists defined in ;; Setup imenu; it needs the same syntax-alist. (when imenu - (setq imenu-syntax-alist syntax-alist)))) + (setq imenu-syntax-alist syntax-alist)))) ;;;###autoload (defun sql-add-product-keywords (product keywords &optional append) "Add highlighting KEYWORDS for SQL PRODUCT. -PRODUCT should be a symbol, the name of a sql product, such as +PRODUCT should be a symbol, the name of a SQL product, such as `oracle'. KEYWORDS should be a list; see the variable `font-lock-keywords'. By default they are added at the beginning of the current highlighting list. If optional argument APPEND is @@ -1703,36 +2360,48 @@ For example: adds a fontification pattern to fontify identifiers ending in `_t' as data types." - (let ((font-lock (sql-product-feature :font-lock product)) - old) - (setq old (eval font-lock)) - (set font-lock + (let* ((sql-indirect-features nil) + (font-lock-var (sql-get-product-feature product :font-lock)) + (old-val)) + + (setq old-val (symbol-value font-lock-var)) + (set font-lock-var (if (eq append 'set) keywords (if append - (append old keywords) - (append keywords old)))))) + (append old-val keywords) + (append keywords old-val)))))) + +(defun sql-for-each-login (login-params body) + "Iterates through login parameters and returns a list of results." + + (delq nil + (mapcar + (lambda (param) + (let ((token (or (and (listp param) (car param)) param)) + (plist (or (and (listp param) (cdr param)) nil))) + + (funcall body token plist))) + login-params))) ;;; Functions to switch highlighting (defun sql-highlight-product () - "Turn on the appropriate font highlighting for the SQL product selected." + "Turn on the font highlighting for the SQL product selected." (when (derived-mode-p 'sql-mode) ;; Setup font-lock (sql-product-font-lock nil t) ;; Set the mode name to include the product. - (setq mode-name (concat "SQL[" (prin1-to-string sql-product) "]")))) + (setq mode-name (concat "SQL[" (or (sql-get-product-feature sql-product :name) + (symbol-name sql-product)) "]")))) (defun sql-set-product (product) - "Set `sql-product' to product and enable appropriate highlighting." + "Set `sql-product' to PRODUCT and enable appropriate highlighting." (interactive - (list (completing-read "Enter SQL product: " - (mapcar (lambda (info) (symbol-name (car info))) - sql-product-alist) - nil 'require-match))) + (list (sql-read-product "SQL product: "))) (if (stringp product) (setq product (intern product))) (when (not (assoc product sql-product-alist)) (error "SQL product %s is not supported; treated as ANSI" product) @@ -1784,6 +2453,30 @@ the regular expression `comint-prompt-regexp', a buffer local variable." (newline)) (indent-according-to-mode)) +(defun sql-help-list-products (indent freep) + "Generate listing of products available for use under SQLi. + +List products with :free-softare attribute set to FREEP. Indent +each line with INDENT." + + (let (sqli-func doc) + (setq doc "") + (dolist (p sql-product-alist) + (setq sqli-func (intern (concat "sql-" (symbol-name (car p))))) + + (if (and (fboundp sqli-func) + (eq (sql-get-product-feature (car p) :free-software) freep)) + (setq doc + (concat doc + indent + (or (sql-get-product-feature (car p) :name) + (symbol-name (car p))) + ":\t" + "\\[" + (symbol-name sqli-func) + "]\n")))) + doc)) + ;;;###autoload (defun sql-help () "Show short help for the SQL modes. @@ -1793,24 +2486,17 @@ usually named `*SQL*'. The name of the major mode is SQLi. Use the following commands to start a specific SQL interpreter: - PostGres: \\[sql-postgres] - MySQL: \\[sql-mysql] - SQLite: \\[sql-sqlite] + \\\\FREE Other non-free SQL implementations are also supported: - Solid: \\[sql-solid] - Oracle: \\[sql-oracle] - Informix: \\[sql-informix] - Sybase: \\[sql-sybase] - Ingres: \\[sql-ingres] - Microsoft: \\[sql-ms] - DB2: \\[sql-db2] - Interbase: \\[sql-interbase] - Linter: \\[sql-linter] + \\\\NONFREE But we urge you to choose a free implementation instead of these. +You can also use \\[sql-product-interactive] to invoke the +interpreter for the current `sql-product'. + Once you have the SQLi buffer, you can enter SQL statements in the buffer. The output generated is appended to the buffer and a new prompt is generated. See the In/Out menu in the SQLi buffer for some functions @@ -1825,12 +2511,84 @@ In this SQL buffer (SQL mode), you can send the region or the entire buffer to the interactive SQL buffer (SQLi mode). The results are appended to the SQLi buffer without disturbing your SQL buffer." (interactive) + + ;; Insert references to loaded products into the help buffer string + (let ((doc (documentation 'sql-help t)) + changedp) + (setq changedp nil) + + ;; Insert FREE software list + (when (string-match "^\\(\\s-*\\)[\\\\][\\\\]FREE\\s-*\n" doc 0) + (setq doc (replace-match (sql-help-list-products (match-string 1 doc) t) + t t doc 0) + changedp t)) + + ;; Insert non-FREE software list + (when (string-match "^\\(\\s-*\\)[\\\\][\\\\]NONFREE\\s-*\n" doc 0) + (setq doc (replace-match (sql-help-list-products (match-string 1 doc) nil) + t t doc 0) + changedp t)) + + ;; If we changed the help text, save the change so that the help + ;; sub-system will see it + (when changedp + (put 'sql-help 'function-documentation doc))) + + ;; Call help on this function (describe-function 'sql-help)) (defun sql-read-passwd (prompt &optional default) "Read a password using PROMPT. Optional DEFAULT is password to start with." (read-passwd prompt nil default)) +(defun sql-get-login-ext (prompt last-value history-var plist) + "Prompt user with extended login parameters. + +If PLIST is nil, then the user is simply prompted for a string +value. + +The property `:default' specifies the default value. If the +`:number' property is non-nil then ask for a number. + +The `:file' property prompts for a file name that must match the +regexp pattern specified in its value. + +The `:completion' property prompts for a string specified by its +value. (The property value is used as the PREDICATE argument to +`completing-read'.)" + (let* ((default (plist-get plist :default)) + (prompt-def + (if default + (if (string-match "\\(\\):[ \t]*\\'" prompt) + (replace-match (format " (default \"%s\")" default) t t prompt 1) + (replace-regexp-in-string "[ \t]*\\'" + (format " (default \"%s\") " default) + prompt t t)) + prompt)) + (use-dialog-box nil)) + (cond + ((plist-member plist :file) + (expand-file-name + (read-file-name prompt + (file-name-directory last-value) default t + (file-name-nondirectory last-value) + (when (plist-get plist :file) + `(lambda (f) + (string-match + (concat "\\<" ,(plist-get plist :file) "\\>") + (file-name-nondirectory f))))))) + + ((plist-member plist :completion) + (completing-read prompt-def (plist-get plist :completion) nil t + last-value history-var default)) + + ((plist-get plist :number) + (read-number prompt (or default last-value 0))) + + (t + (let ((r (read-from-minibuffer prompt-def last-value nil nil history-var nil))) + (if (string= "" r) (or default "") r)))))) + (defun sql-get-login (&rest what) "Get username, password and database from the user. @@ -1840,55 +2598,77 @@ Usernames, servers and databases are stored in `sql-user-history', `sql-server-history' and `database-history'. Passwords are not stored in a history. -Parameter WHAT is a list of the arguments passed to this function. -The function asks for the username if WHAT contains symbol `user', for -the password if it contains symbol `password', for the server if it -contains symbol `server', and for the database if it contains symbol -`database'. The members of WHAT are processed in the order in which -they are provided. +Parameter WHAT is a list of tokens passed as arguments in the +function call. The function asks for the username if WHAT +contains the symbol `user', for the password if it contains the +symbol `password', for the server if it contains the symbol +`server', and for the database if it contains the symbol +`database'. The members of WHAT are processed in the order in +which they are provided. + +Each token may also be a list with the token in the car and a +plist of options as the cdr. The following properties are +supported: + + :file <filename-regexp> + :completion <list-of-strings-or-function> + :default <default-value> + :number t In order to ask the user for username, password and database, call the function like this: (sql-get-login 'user 'password 'database)." (interactive) - (while what - (cond - ((eq (car what) 'user) ; user - (setq sql-user - (read-from-minibuffer "User: " sql-user nil nil - sql-user-history))) - ((eq (car what) 'password) ; password - (setq sql-password - (sql-read-passwd "Password: " sql-password))) - ((eq (car what) 'server) ; server - (setq sql-server - (read-from-minibuffer "Server: " sql-server nil nil - sql-server-history))) - ((eq (car what) 'database) ; database - (setq sql-database - (read-from-minibuffer "Database: " sql-database nil nil - sql-database-history)))) - (setq what (cdr what)))) - -(defun sql-find-sqli-buffer () - "Return the current default SQLi buffer or nil. -In order to qualify, the SQLi buffer must be alive, -be in `sql-interactive-mode' and have a process." - (let ((default-buffer (default-value 'sql-buffer))) - (if (and (buffer-live-p default-buffer) - (get-buffer-process default-buffer)) - default-buffer - (save-current-buffer - (let ((buflist (buffer-list)) - (found)) - (while (not (or (null buflist) - found)) - (let ((candidate (car buflist))) - (set-buffer candidate) - (if (and (derived-mode-p 'sql-interactive-mode) - (get-buffer-process candidate)) - (setq found candidate)) - (setq buflist (cdr buflist)))) - found))))) + (mapcar + (lambda (w) + (let ((token (or (and (consp w) (car w)) w)) + (plist (or (and (consp w) (cdr w)) nil))) + + (cond + ((eq token 'user) ; user + (setq sql-user + (sql-get-login-ext "User: " sql-user + 'sql-user-history plist))) + + ((eq token 'password) ; password + (setq sql-password + (sql-read-passwd "Password: " sql-password))) + + ((eq token 'server) ; server + (setq sql-server + (sql-get-login-ext "Server: " sql-server + 'sql-server-history plist))) + + ((eq token 'database) ; database + (setq sql-database + (sql-get-login-ext "Database: " sql-database + 'sql-database-history plist))) + + ((eq token 'port) ; port + (setq sql-port + (sql-get-login-ext "Port: " sql-port + nil (append '(:number t) plist))))))) + what)) + +(defun sql-find-sqli-buffer (&optional product) + "Returns the name of the current default SQLi buffer or nil. +In order to qualify, the SQLi buffer must be alive, be in +`sql-interactive-mode' and have a process." + (let ((buf sql-buffer) + (prod (or product sql-product))) + (or + ;; Current sql-buffer, if there is one. + (and (sql-buffer-live-p buf prod) + buf) + ;; Global sql-buffer + (and (setq buf (default-value 'sql-buffer)) + (sql-buffer-live-p buf prod) + buf) + ;; Look thru each buffer + (car (apply 'append + (mapcar (lambda (b) + (and (sql-buffer-live-p b prod) + (list (buffer-name b)))) + (buffer-list))))))) (defun sql-set-sqli-buffer-generally () "Set SQLi buffer for all SQL buffers that have none. @@ -1900,16 +2680,17 @@ using `sql-find-sqli-buffer'. If `sql-buffer' is set, (interactive) (save-excursion (let ((buflist (buffer-list)) - (default-sqli-buffer (sql-find-sqli-buffer))) - (setq-default sql-buffer default-sqli-buffer) + (default-buffer (sql-find-sqli-buffer))) + (setq-default sql-buffer default-buffer) (while (not (null buflist)) (let ((candidate (car buflist))) (set-buffer candidate) (if (and (derived-mode-p 'sql-mode) - (not (buffer-live-p sql-buffer))) + (not (sql-buffer-live-p sql-buffer))) (progn - (setq sql-buffer default-sqli-buffer) - (run-hooks 'sql-set-sqli-hook)))) + (setq sql-buffer default-buffer) + (when default-buffer + (run-hooks 'sql-set-sqli-hook))))) (setq buflist (cdr buflist)))))) (defun sql-set-sqli-buffer () @@ -1927,19 +2708,13 @@ If you call it from anywhere else, it sets the global copy of (interactive) (let ((default-buffer (sql-find-sqli-buffer))) (if (null default-buffer) - (error "There is no suitable SQLi buffer")) - (let ((new-buffer - (get-buffer - (read-buffer "New SQLi buffer: " default-buffer t)))) - (if (null (get-buffer-process new-buffer)) - (error "Buffer %s has no process" (buffer-name new-buffer))) - (if (null (with-current-buffer new-buffer - (equal major-mode 'sql-interactive-mode))) - (error "Buffer %s is no SQLi buffer" (buffer-name new-buffer))) - (if new-buffer - (progn - (setq sql-buffer new-buffer) - (run-hooks 'sql-set-sqli-hook)))))) + (error "There is no suitable SQLi buffer") + (let ((new-buffer (read-buffer "New SQLi buffer: " default-buffer t))) + (if (null (sql-buffer-live-p new-buffer)) + (error "Buffer %s is not a working SQLi buffer" new-buffer) + (when new-buffer + (setq sql-buffer new-buffer) + (run-hooks 'sql-set-sqli-hook))))))) (defun sql-show-sqli-buffer () "Show the name of current SQLi buffer. @@ -1947,32 +2722,108 @@ If you call it from anywhere else, it sets the global copy of This is the buffer SQL strings are sent to. It is stored in the variable `sql-buffer'. See `sql-help' on how to create such a buffer." (interactive) - (if (null (buffer-live-p sql-buffer)) + (if (null (buffer-live-p (get-buffer sql-buffer))) (message "%s has no SQLi buffer set." (buffer-name (current-buffer))) (if (null (get-buffer-process sql-buffer)) - (message "Buffer %s has no process." (buffer-name sql-buffer)) - (message "Current SQLi buffer is %s." (buffer-name sql-buffer))))) + (message "Buffer %s has no process." sql-buffer) + (message "Current SQLi buffer is %s." sql-buffer)))) (defun sql-make-alternate-buffer-name () "Return a string that can be used to rename a SQLi buffer. This is used to set `sql-alternate-buffer-name' within -`sql-interactive-mode'." - (concat (if (string= "" sql-user) - (if (string= "" (user-login-name)) - () - (concat (user-login-name) "/")) - (concat sql-user "/")) - (if (string= "" sql-database) - (if (string= "" sql-server) - (system-name) - sql-server) - sql-database))) +`sql-interactive-mode'. -(defun sql-rename-buffer () - "Rename a SQLi buffer." - (interactive) - (rename-buffer (format "*SQL: %s*" sql-alternate-buffer-name) t)) +If the session was started with `sql-connect' then the alternate +name would be the name of the connection. + +Otherwise, it uses the parameters identified by the :sqlilogin +parameter. + +If all else fails, the alternate name would be the user and +server/database name." + + (let ((name "")) + + ;; Build a name using the :sqli-login setting + (setq name + (apply 'concat + (cdr + (apply 'append nil + (sql-for-each-login + (sql-get-product-feature sql-product :sqli-login) + (lambda (token plist) + (cond + ((eq token 'user) + (unless (string= "" sql-user) + (list "/" sql-user))) + ((eq token 'port) + (unless (or (not (numberp sql-port)) + (= 0 sql-port)) + (list ":" (number-to-string sql-port)))) + ((eq token 'server) + (unless (string= "" sql-server) + (list "." + (if (plist-member plist :file) + (file-name-nondirectory sql-server) + sql-server)))) + ((eq token 'database) + (unless (string= "" sql-database) + (list "@" + (if (plist-member plist :file) + (file-name-nondirectory sql-database) + sql-database)))) + + ((eq token 'password) nil) + (t nil)))))))) + + ;; If there's a connection, use it and the name thus far + (if sql-connection + (format "<%s>%s" sql-connection (or name "")) + + ;; If there is no name, try to create something meaningful + (if (string= "" (or name "")) + (concat + (if (string= "" sql-user) + (if (string= "" (user-login-name)) + () + (concat (user-login-name) "/")) + (concat sql-user "/")) + (if (string= "" sql-database) + (if (string= "" sql-server) + (system-name) + sql-server) + sql-database)) + + ;; Use the name we've got + name)))) + +(defun sql-rename-buffer (&optional new-name) + "Rename a SQL interactive buffer. + +Prompts for the new name if command is preceeded by +\\[universal-argument]. If no buffer name is provided, then the +`sql-alternate-buffer-name' is used. + +The actual buffer name set will be \"*SQL: NEW-NAME*\". If +NEW-NAME is empty, then the buffer name will be \"*SQL*\"." + (interactive "P") + + (if (not (derived-mode-p 'sql-interactive-mode)) + (message "Current buffer is not a SQL interactive buffer") + + (setq sql-alternate-buffer-name + (cond + ((stringp new-name) new-name) + ((consp new-name) + (read-string "Buffer name (\"*SQL: XXX*\"; enter `XXX'): " + sql-alternate-buffer-name)) + (t sql-alternate-buffer-name))) + + (rename-buffer (if (string= "" sql-alternate-buffer-name) + "*SQL*" + (format "*SQL: %s*" sql-alternate-buffer-name)) + t))) (defun sql-copy-column () "Copy current column to the end of buffer. @@ -1980,7 +2831,7 @@ Inserts SELECT or commas if appropriate." (interactive) (let ((column)) (save-excursion - (setq column (buffer-substring + (setq column (buffer-substring-no-properties (progn (forward-char 1) (backward-sexp 1) (point)) (progn (forward-sexp 1) (point)))) (goto-char (point-max)) @@ -2011,62 +2862,143 @@ Inserts SELECT or commas if appropriate." (defvar sql-placeholder-history nil "History of placeholder values used.") -(defun sql-query-placeholders-and-send (proc string) - "Send to PROC input STRING, maybe replacing placeholders. -Placeholders are words starting with an ampersand like &this. -This function is used for `comint-input-sender' if using -`sql-oracle' on Windows." - (while (string-match "&\\(\\sw+\\)" string) - (setq string (replace-match - (read-from-minibuffer - (format "Enter value for %s: " (match-string 1 string)) - nil nil nil sql-placeholder-history) - t t string))) - (comint-send-string proc string) - (if comint-input-sender-no-newline - (if (not (string-equal string "")) - (process-send-eof)) - (comint-send-string proc "\n"))) +(defun sql-placeholders-filter (string) + "Replace placeholders in STRING. +Placeholders are words starting with an ampersand like &this." + + (when sql-oracle-scan-on + (while (string-match "&\\(\\sw+\\)" string) + (setq string (replace-match + (read-from-minibuffer + (format "Enter value for %s: " (match-string 1 string)) + nil nil nil 'sql-placeholder-history) + t t string)))) + string) ;; Using DB2 interactively, newlines must be escaped with " \". ;; The space before the backslash is relevant. -(defun sql-escape-newlines-and-send (proc string) - "Send to PROC input STRING, escaping newlines if necessary. +(defun sql-escape-newlines-filter (string) + "Escape newlines in STRING. Every newline in STRING will be preceded with a space and a backslash." (let ((result "") (start 0) mb me) (while (string-match "\n" string start) (setq mb (match-beginning 0) - me (match-end 0)) - (if (and (> mb 1) - (string-equal " \\" (substring string (- mb 2) mb))) - (setq result (concat result (substring string start me))) - (setq result (concat result (substring string start mb) " \\\n"))) - (setq start me)) - (setq result (concat result (substring string start))) - (comint-send-string proc result) - (if comint-input-sender-no-newline - (if (not (string-equal string "")) - (process-send-eof)) - (comint-send-string proc "\n")))) + me (match-end 0) + result (concat result + (substring string start mb) + (if (and (> mb 1) + (string-equal " \\" (substring string (- mb 2) mb))) + "" " \\\n")) + start me)) + (concat result (substring string start)))) +;;; Input sender for SQLi buffers + +(defvar sql-output-newline-count 0 + "Number of newlines in the input string. + +Allows the suppression of continuation prompts.") + +(defvar sql-output-by-send nil + "Non-nil if the command in the input was generated by `sql-send-string'.") + +(defun sql-input-sender (proc string) + "Send STRING to PROC after applying filters." + + (let* ((product (with-current-buffer (process-buffer proc) sql-product)) + (filter (sql-get-product-feature product :input-filter))) + + ;; Apply filter(s) + (cond + ((not filter) + nil) + ((functionp filter) + (setq string (funcall filter string))) + ((listp filter) + (mapc (lambda (f) (setq string (funcall f string))) filter)) + (t nil)) + + ;; Count how many newlines in the string + (setq sql-output-newline-count 0) + (mapc (lambda (ch) + (when (eq ch ?\n) + (setq sql-output-newline-count (1+ sql-output-newline-count)))) + string) + + ;; Send the string + (comint-simple-send proc string))) + +;;; Strip out continuation prompts + +(defun sql-interactive-remove-continuation-prompt (oline) + "Strip out continuation prompts out of the OLINE. + +Added to the `comint-preoutput-filter-functions' hook in a SQL +interactive buffer. If `sql-outut-newline-count' is greater than +zero, then an output line matching the continuation prompt is filtered +out. If the count is one, then the prompt is replaced with a newline +to force the output from the query to appear on a new line." + (if (and sql-prompt-cont-regexp + sql-output-newline-count + (numberp sql-output-newline-count) + (>= sql-output-newline-count 1)) + (progn + (while (and oline + sql-output-newline-count + (> sql-output-newline-count 0) + (string-match sql-prompt-cont-regexp oline)) + + (setq oline + (replace-match (if (and + (= 1 sql-output-newline-count) + sql-output-by-send) + "\n" "") + nil nil oline) + sql-output-newline-count + (1- sql-output-newline-count))) + (if (= sql-output-newline-count 0) + (setq sql-output-newline-count nil)) + (setq sql-output-by-send nil)) + (setq sql-output-newline-count nil)) + oline) + ;;; Sending the region to the SQLi buffer. +(defun sql-send-string (str) + "Send the string STR to the SQL process." + (interactive "sSQL Text: ") + + (let ((comint-input-sender-no-newline nil) + (s (replace-regexp-in-string "[[:space:]\n\r]+\\'" "" str))) + (if (sql-buffer-live-p sql-buffer) + (progn + ;; Ignore the hoping around... + (save-excursion + ;; Set product context + (with-current-buffer sql-buffer + ;; Send the string (trim the trailing whitespace) + (sql-input-sender (get-buffer-process sql-buffer) s) + + ;; Send a command terminator if we must + (if sql-send-terminator + (sql-send-magic-terminator sql-buffer s sql-send-terminator)) + + (message "Sent string to buffer %s." sql-buffer))) + + ;; Display the sql buffer + (if sql-pop-to-buffer-after-send-region + (pop-to-buffer sql-buffer) + (display-buffer sql-buffer))) + + ;; We don't have no stinkin' sql + (message "No SQL process started.")))) + (defun sql-send-region (start end) "Send a region to the SQL process." (interactive "r") - (if (buffer-live-p sql-buffer) - (save-excursion - (comint-send-region sql-buffer start end) - (if (string-match "\n$" (buffer-substring start end)) - () - (comint-send-string sql-buffer "\n")) - (message "Sent string to buffer %s." (buffer-name sql-buffer)) - (if sql-pop-to-buffer-after-send-region - (pop-to-buffer sql-buffer) - (display-buffer sql-buffer))) - (message "No SQL process started."))) + (sql-send-string (buffer-substring-no-properties start end))) (defun sql-send-paragraph () "Send the current paragraph to the SQL process." @@ -2084,18 +3016,40 @@ Every newline in STRING will be preceded with a space and a backslash." (interactive) (sql-send-region (point-min) (point-max))) -(defun sql-send-string (str) - "Send a string to the SQL process." - (interactive "sSQL Text: ") - (if (buffer-live-p sql-buffer) - (save-excursion - (comint-send-string sql-buffer str) - (comint-send-string sql-buffer "\n") - (message "Sent string to buffer %s." (buffer-name sql-buffer)) - (if sql-pop-to-buffer-after-send-region - (pop-to-buffer sql-buffer) - (display-buffer sql-buffer))) - (message "No SQL process started."))) +(defun sql-send-magic-terminator (buf str terminator) + "Send TERMINATOR to buffer BUF if its not present in STR." + (let (comint-input-sender-no-newline pat term) + ;; If flag is merely on(t), get product-specific terminator + (if (eq terminator t) + (setq terminator (sql-get-product-feature sql-product :terminator))) + + ;; If there is no terminator specified, use default ";" + (unless terminator + (setq terminator ";")) + + ;; Parse the setting into the pattern and the terminator string + (cond ((stringp terminator) + (setq pat (regexp-quote terminator) + term terminator)) + ((consp terminator) + (setq pat (car terminator) + term (cdr terminator))) + (t + nil)) + + ;; Check to see if the pattern is present in the str already sent + (unless (and pat term + (string-match (concat pat "\\'") str)) + (comint-simple-send (get-buffer-process buf) term) + (setq sql-output-newline-count + (if sql-output-newline-count + (1+ sql-output-newline-count) + 1))) + (setq sql-output-by-send t))) + +(defun sql-remove-tabs-filter (str) + "Replace tab characters with spaces." + (replace-regexp-in-string "\t" " " str nil t)) (defun sql-toggle-pop-to-buffer-after-send-region (&optional value) "Toggle `sql-pop-to-buffer-after-send-region'. @@ -2106,7 +3060,172 @@ If given the optional parameter VALUE, sets (if value (setq sql-pop-to-buffer-after-send-region value) (setq sql-pop-to-buffer-after-send-region - (null sql-pop-to-buffer-after-send-region )))) + (null sql-pop-to-buffer-after-send-region)))) + + + +;;; Redirect output functions + +(defun sql-redirect (command combuf &optional outbuf save-prior) + "Execute the SQL command and send output to OUTBUF. + +COMBUF must be an active SQL interactive buffer. OUTBUF may be +an existing buffer, or the name of a non-existing buffer. If +omitted the output is sent to a temporary buffer which will be +killed after the command completes. COMMAND should be a string +of commands accepted by the SQLi program." + + (with-current-buffer combuf + (let ((buf (get-buffer-create (or outbuf " *SQL-Redirect*"))) + (proc (get-buffer-process (current-buffer))) + (comint-prompt-regexp (sql-get-product-feature sql-product + :prompt-regexp)) + (start nil)) + (with-current-buffer buf + (toggle-read-only -1) + (unless save-prior + (erase-buffer)) + (goto-char (point-max)) + (unless (zerop (buffer-size)) + (insert "\n")) + (setq start (point))) + + ;; Run the command + (message "Executing SQL command...") + (comint-redirect-send-command-to-process command buf proc nil t) + (while (null comint-redirect-completed) + (accept-process-output nil 1)) + (message "Executing SQL command...done") + + ;; Clean up the output results + (with-current-buffer buf + ;; Remove trailing whitespace + (goto-char (point-max)) + (when (looking-back "[ \t\f\n\r]*" start) + (delete-region (match-beginning 0) (match-end 0))) + ;; Remove echo if there was one + (goto-char start) + (when (looking-at (concat "^" (regexp-quote command) "[\\n]")) + (delete-region (match-beginning 0) (match-end 0))) + (goto-char start))))) + +(defun sql-redirect-value (command combuf regexp &optional regexp-groups) + "Execute the SQL command and return part of result. + +COMBUF must be an active SQL interactive buffer. COMMAND should +be a string of commands accepted by the SQLi program. From the +output, the REGEXP is repeatedly matched and the list of +REGEXP-GROUPS submatches is returned. This behaves much like +\\[comint-redirect-results-list-from-process] but instead of +returning a single submatch it returns a list of each submatch +for each match." + + (let ((outbuf " *SQL-Redirect-values*") + (results nil)) + (sql-redirect command combuf outbuf nil) + (with-current-buffer outbuf + (while (re-search-forward regexp nil t) + (push + (cond + ;; no groups-return all of them + ((null regexp-groups) + (let ((i 1) + (r nil)) + (while (match-beginning i) + (push (match-string i) r)) + (nreverse r))) + ;; one group specified + ((numberp regexp-groups) + (match-string regexp-groups)) + ;; list of numbers; return the specified matches only + ((consp regexp-groups) + (mapcar (lambda (c) + (cond + ((numberp c) (match-string c)) + ((stringp c) (match-substitute-replacement c)) + (t (error "sql-redirect-value: unknown REGEXP-GROUPS value - %s" c)))) + regexp-groups)) + ;; String is specified; return replacement string + ((stringp regexp-groups) + (match-substitute-replacement regexp-groups)) + (t + (error "sql-redirect-value: unknown REGEXP-GROUPS value - %s" + regexp-groups))) + results))) + (nreverse results))) + +(defun sql-execute (sqlbuf outbuf command arg) + "Executes a command in a SQL interacive buffer and captures the output. + +The commands are run in SQLBUF and the output saved in OUTBUF. +COMMAND must be a string, a function or a list of such elements. +Functions are called with SQLBUF, OUTBUF and ARG as parameters; +strings are formatted with ARG and executed. + +If the results are empty the OUTBUF is deleted, otherwise the +buffer is popped into a view window. " + (mapc + (lambda (c) + (cond + ((stringp c) + (sql-redirect (if arg (format c arg) c) sqlbuf outbuf) t) + ((functionp c) + (apply c sqlbuf outbuf arg)) + (t (error "Unknown sql-execute item %s" c)))) + (if (consp command) command (cons command nil))) + + (setq outbuf (get-buffer outbuf)) + (if (zerop (buffer-size outbuf)) + (kill-buffer outbuf) + (let ((one-win (eq (selected-window) + (get-lru-window)))) + (with-current-buffer outbuf + (set-buffer-modified-p nil) + (toggle-read-only 1)) + (view-buffer-other-window outbuf) + (when one-win + (shrink-window-if-larger-than-buffer))))) + +(defun sql-execute-feature (sqlbuf outbuf feature enhanced arg) + "List objects or details in a separate display buffer." + (let (command) + (with-current-buffer sqlbuf + (setq command (sql-get-product-feature sql-product feature))) + (unless command + (error "%s does not support %s" sql-product feature)) + (when (consp command) + (setq command (if enhanced + (cdr command) + (car command)))) + (sql-execute sqlbuf outbuf command arg))) + +(defun sql-read-table-name (prompt) + "Read the name of a database table." + ;; TODO: Fetch table/view names from database and provide completion. + ;; Also implement thing-at-point if the buffer has valid names in it + ;; (i.e. sql-mode, sql-interactive-mode, or sql-list-all buffers) + (read-from-minibuffer prompt)) + +(defun sql-list-all (&optional enhanced) + "List all database objects." + (interactive "P") + (let ((sqlbuf (sql-find-sqli-buffer))) + (unless sqlbuf + (error "No SQL interactive buffer found")) + (sql-execute-feature sqlbuf "*List All*" :list-all enhanced nil))) + +(defun sql-list-table (name &optional enhanced) + "List the details of a database table. " + (interactive + (list (sql-read-table-name "Table name: ") + current-prefix-arg)) + (let ((sqlbuf (sql-find-sqli-buffer))) + (unless sqlbuf + (error "No SQL interactive buffer found")) + (unless name + (error "No table name specified")) + (sql-execute-feature sqlbuf (format "*List %s*" name) + :list-table enhanced name))) @@ -2249,24 +3368,29 @@ you entered, right above the output it created. \(setq comint-output-filter-functions \(function (lambda (STR) (comint-show-output))))" (delay-mode-hooks (comint-mode)) + ;; Get the `sql-product' for this interactive session. (set (make-local-variable 'sql-product) (or sql-interactive-product sql-product)) + ;; Setup the mode. (setq major-mode 'sql-interactive-mode) - (setq mode-name (concat "SQLi[" (prin1-to-string sql-product) "]")) + (setq mode-name (concat "SQLi[" (or (sql-get-product-feature sql-product :name) + (symbol-name sql-product)) "]")) (use-local-map sql-interactive-mode-map) (if sql-interactive-mode-menu (easy-menu-add sql-interactive-mode-menu)) ; XEmacs (set-syntax-table sql-mode-syntax-table) (make-local-variable 'sql-mode-font-lock-keywords) (make-local-variable 'font-lock-defaults) + ;; Note that making KEYWORDS-ONLY nil will cause havoc if you try ;; SELECT 'x' FROM DUAL with SQL*Plus, because the title of the column ;; will have just one quote. Therefore syntactic hilighting is ;; disabled for interactive buffers. No imenu support. (sql-product-font-lock t nil) + ;; Enable commenting and uncommenting of the region. (make-local-variable 'comment-start) (setq comment-start "--") @@ -2275,22 +3399,36 @@ you entered, right above the output it created. (setq local-abbrev-table sql-mode-abbrev-table) (setq abbrev-all-caps 1) ;; Exiting the process will call sql-stop. - (set-process-sentinel (get-buffer-process sql-buffer) 'sql-stop) + (set-process-sentinel (get-buffer-process (current-buffer)) 'sql-stop) + ;; Save the connection name + (make-local-variable 'sql-connection) ;; Create a usefull name for renaming this buffer later. (make-local-variable 'sql-alternate-buffer-name) (setq sql-alternate-buffer-name (sql-make-alternate-buffer-name)) ;; User stuff. Initialize before the hook. (set (make-local-variable 'sql-prompt-regexp) - (sql-product-feature :sqli-prompt-regexp)) + (sql-get-product-feature sql-product :prompt-regexp)) (set (make-local-variable 'sql-prompt-length) - (sql-product-feature :sqli-prompt-length)) + (sql-get-product-feature sql-product :prompt-length)) + (set (make-local-variable 'sql-prompt-cont-regexp) + (sql-get-product-feature sql-product :prompt-cont-regexp)) + (make-local-variable 'sql-output-newline-count) + (make-local-variable 'sql-output-by-send) + (add-hook 'comint-preoutput-filter-functions + 'sql-interactive-remove-continuation-prompt nil t) (make-local-variable 'sql-input-ring-separator) (make-local-variable 'sql-input-ring-file-name) - ;; Run hook. + ;; Run the mode hook (along with comint's hooks). (run-mode-hooks 'sql-interactive-mode-hook) ;; Set comint based on user overrides. - (setq comint-prompt-regexp sql-prompt-regexp) + (setq comint-prompt-regexp + (if sql-prompt-cont-regexp + (concat "\\(" sql-prompt-regexp + "\\|" sql-prompt-cont-regexp "\\)") + sql-prompt-regexp)) (setq left-margin sql-prompt-length) + ;; Install input sender + (set (make-local-variable 'comint-input-sender) 'sql-input-sender) ;; People wanting a different history file for each ;; buffer/process/client/whatever can change separator and file-name ;; on the sql-interactive-mode-hook. @@ -2316,36 +3454,239 @@ Sentinels will always get the two parameters PROCESS and EVENT." +;;; Connection handling + +(defun sql-read-connection (prompt &optional initial default) + "Read a connection name." + (let ((completion-ignore-case t)) + (completing-read prompt + (mapcar (lambda (c) (car c)) + sql-connection-alist) + nil t initial 'sql-connection-history default))) + +;;;###autoload +(defun sql-connect (connection) + "Connect to an interactive session using CONNECTION settings. + +See `sql-connection-alist' to see how to define connections and +their settings. + +The user will not be prompted for any login parameters if a value +is specified in the connection settings." + + ;; Prompt for the connection from those defined in the alist + (interactive + (if sql-connection-alist + (list (sql-read-connection "Connection: " nil '(nil))) + nil)) + + ;; Are there connections defined + (if sql-connection-alist + ;; Was one selected + (when connection + ;; Get connection settings + (let ((connect-set (assoc connection sql-connection-alist))) + ;; Settings are defined + (if connect-set + ;; Set the desired parameters + (eval `(let* + (,@(cdr connect-set) + ;; :sqli-login params variable + (param-var (sql-get-product-feature sql-product + :sqli-login nil t)) + ;; :sqli-login params value + (login-params (sql-get-product-feature sql-product + :sqli-login)) + ;; which params are in the connection + (set-params (mapcar + (lambda (v) + (cond + ((eq (car v) 'sql-user) 'user) + ((eq (car v) 'sql-password) 'password) + ((eq (car v) 'sql-server) 'server) + ((eq (car v) 'sql-database) 'database) + ((eq (car v) 'sql-port) 'port) + (t (car v)))) + (cdr connect-set))) + ;; the remaining params (w/o the connection params) + (rem-params (sql-for-each-login + login-params + (lambda (token plist) + (unless (member token set-params) + (if plist + (cons token plist) + token))))) + ;; Remember the connection + (sql-connection connection)) + + ;; Set the remaining parameters and start the + ;; interactive session + (eval `(let ((,param-var ',rem-params)) + (sql-product-interactive sql-product))))) + (message "SQL Connection <%s> does not exist" connection) + nil))) + (message "No SQL Connections defined") + nil)) + +(defun sql-save-connection (name) + "Captures the connection information of the current SQLi session. + +The information is appended to `sql-connection-alist' and +optionally is saved to the user's init file." + + (interactive "sNew connection name: ") + + (if sql-connection + (message "This session was started by a connection; it's already been saved.") + + (let ((login (sql-get-product-feature sql-product :sqli-login)) + (alist sql-connection-alist) + connect) + + ;; Remove the existing connection if the user says so + (when (and (assoc name alist) + (yes-or-no-p (format "Replace connection definition <%s>? " name))) + (setq alist (assq-delete-all name alist))) + + ;; Add the new connection if it doesn't exist + (if (assoc name alist) + (message "Connection <%s> already exists" name) + (setq connect + (append (list name) + (sql-for-each-login + `(product ,@login) + (lambda (token plist) + (cond + ((eq token 'product) `(sql-product ',sql-product)) + ((eq token 'user) `(sql-user ,sql-user)) + ((eq token 'database) `(sql-database ,sql-database)) + ((eq token 'server) `(sql-server ,sql-server)) + ((eq token 'port) `(sql-port ,sql-port))))))) + + (setq alist (append alist (list connect))) + + ;; confirm whether we want to save the connections + (if (yes-or-no-p "Save the connections for future sessions? ") + (customize-save-variable 'sql-connection-alist alist) + (customize-set-variable 'sql-connection-alist alist)))))) + +(defun sql-connection-menu-filter (tail) + "Generates menu entries for using each connection." + (append + (mapcar + (lambda (conn) + (vector + (format "Connection <%s>" (car conn)) + (list 'sql-connect (car conn)) + t)) + sql-connection-alist) + tail)) + + + ;;; Entry functions for different SQL interpreters. ;;;###autoload -(defun sql-product-interactive (&optional product) - "Run product interpreter as an inferior process. +(defun sql-product-interactive (&optional product new-name) + "Run PRODUCT interpreter as an inferior process. If buffer `*SQL*' exists but no process is running, make a new process. If buffer exists and a process is running, just switch to buffer `*SQL*'. +To specify the SQL product, prefix the call with +\\[universal-argument]. To set the buffer name as well, prefix +the call to \\[sql-product-interactive] with +\\[universal-argument] \\[universal-argument]. + \(Type \\[describe-mode] in the SQL buffer for a list of commands.)" - (interactive) - (setq product (or product sql-product)) - (when (sql-product-feature :sqli-connect product) - (if (comint-check-proc "*SQL*") - (pop-to-buffer "*SQL*") - ;; Get credentials. - (apply 'sql-get-login (sql-product-feature :sqli-login product)) - ;; Connect to database. - (message "Login...") - (funcall (sql-product-feature :sqli-connect product)) - ;; Set SQLi mode. - (setq sql-interactive-product product) - (setq sql-buffer (current-buffer)) - (sql-interactive-mode) - ;; All done. - (message "Login...done") - (pop-to-buffer sql-buffer)))) + (interactive "P") + + ;; Handle universal arguments if specified + (when (not (or executing-kbd-macro noninteractive)) + (when (and (consp product) + (not (cdr product)) + (numberp (car product))) + (when (>= (prefix-numeric-value product) 16) + (when (not new-name) + (setq new-name '(4))) + (setq product '(4))))) + + ;; Get the value of product that we need + (setq product + (cond + ((and product ; Product specified + (symbolp product)) product) + ((= (prefix-numeric-value product) 4) ; C-u, prompt for product + (sql-read-product "SQL product: " sql-product)) + (t sql-product))) ; Default to sql-product + + ;; If we have a product and it has a interactive mode + (if product + (when (sql-get-product-feature product :sqli-comint-func) + ;; If no new name specified, try to pop to an active SQL + ;; interactive for the same product + (let ((buf (sql-find-sqli-buffer product))) + (if (and (not new-name) buf) + (pop-to-buffer buf) + + ;; We have a new name or sql-buffer doesn't exist or match + ;; Start by remembering where we start + (let ((start-buffer (current-buffer)) + new-sqli-buffer) + + ;; Get credentials. + (apply 'sql-get-login (sql-get-product-feature product :sqli-login)) + + ;; Connect to database. + (message "Login...") + (funcall (sql-get-product-feature product :sqli-comint-func) + product + (sql-get-product-feature product :sqli-options)) + + ;; Set SQLi mode. + (setq new-sqli-buffer (current-buffer)) + (let ((sql-interactive-product product)) + (sql-interactive-mode)) + + ;; Set the new buffer name + (when new-name + (sql-rename-buffer new-name)) + + ;; Set `sql-buffer' in the new buffer and the start buffer + (setq sql-buffer (buffer-name new-sqli-buffer)) + (with-current-buffer start-buffer + (setq sql-buffer (buffer-name new-sqli-buffer)) + (run-hooks 'sql-set-sqli-hook)) + + ;; All done. + (message "Login...done") + (pop-to-buffer sql-buffer))))) + (message "No default SQL product defined. Set `sql-product'."))) + +(defun sql-comint (product params) + "Set up a comint buffer to run the SQL processor. + +PRODUCT is the SQL product. PARAMS is a list of strings which are +passed as command line arguments." + (let ((program (sql-get-product-feature product :sqli-program)) + (buf-name "SQL")) + ;; make sure we can find the program + (unless (executable-find program) + (error "Unable to locate SQL program \'%s\'" program)) + ;; Make sure buffer name is unique + (when (sql-buffer-live-p (format "*%s*" buf-name)) + (setq buf-name (format "SQL-%s" product)) + (when (sql-buffer-live-p (format "*%s*" buf-name)) + (let ((i 1)) + (while (sql-buffer-live-p + (format "*%s*" + (setq buf-name (format "SQL-%s%d" product i)))) + (setq i (1+ i)))))) + (set-buffer + (apply 'make-comint buf-name program nil params)))) ;;;###autoload -(defun sql-oracle () +(defun sql-oracle (&optional buffer) "Run sqlplus by Oracle as an inferior process. If buffer `*SQL*' exists but no process is running, make a new process. @@ -2360,6 +3701,11 @@ the list `sql-oracle-options'. The buffer is put in SQL interactive mode, giving commands for sending input. See `sql-interactive-mode'. +To set the buffer name directly, use \\[universal-argument] +before \\[sql-oracle]. Once session has started, +\\[sql-rename-buffer] can be called separately to rename the +buffer. + To specify a coding system for converting non-ASCII characters in the input and output to the process, use \\[universal-coding-system-argument] before \\[sql-oracle]. You can also specify this with \\[set-buffer-process-coding-system] @@ -2368,36 +3714,32 @@ The default comes from `process-coding-system-alist' and `default-process-coding-system'. \(Type \\[describe-mode] in the SQL buffer for a list of commands.)" - (interactive) - (sql-product-interactive 'oracle)) + (interactive "P") + (sql-product-interactive 'oracle buffer)) -(defun sql-connect-oracle () - "Create comint buffer and connect to Oracle using the login -parameters and command options." +(defun sql-comint-oracle (product options) + "Create comint buffer and connect to Oracle." ;; Produce user/password@database construct. Password without user ;; is meaningless; database without user/password is meaningless, ;; because "@param" will ask sqlplus to interpret the script ;; "param". - (let ((parameter - (if (not (string= "" sql-user)) - (if (not (string= "" sql-password)) - (concat sql-user "/" sql-password) - sql-user)))) + (let ((parameter nil)) + (if (not (string= "" sql-user)) + (if (not (string= "" sql-password)) + (setq parameter (concat sql-user "/" sql-password)) + (setq parameter sql-user))) (if (and parameter (not (string= "" sql-database))) (setq parameter (concat parameter "@" sql-database))) - (setq parameter (if parameter - (nconc (list parameter) sql-oracle-options) - sql-oracle-options)) - (set-buffer (apply 'make-comint "SQL" sql-oracle-program nil parameter)) - ;; SQL*Plus is buffered on Windows; this handles &placeholders. - (if (eq window-system 'w32) - (setq comint-input-sender 'sql-query-placeholders-and-send)))) + (if parameter + (setq parameter (nconc (list parameter) options)) + (setq parameter options)) + (sql-comint product parameter))) ;;;###autoload -(defun sql-sybase () - "Run isql by SyBase as an inferior process. +(defun sql-sybase (&optional buffer) + "Run isql by Sybase as an inferior process. If buffer `*SQL*' exists but no process is running, make a new process. If buffer exists and a process is running, just switch to buffer @@ -2411,6 +3753,11 @@ can be stored in the list `sql-sybase-options'. The buffer is put in SQL interactive mode, giving commands for sending input. See `sql-interactive-mode'. +To set the buffer name directly, use \\[universal-argument] +before \\[sql-sybase]. Once session has started, +\\[sql-rename-buffer] can be called separately to rename the +buffer. + To specify a coding system for converting non-ASCII characters in the input and output to the process, use \\[universal-coding-system-argument] before \\[sql-sybase]. You can also specify this with \\[set-buffer-process-coding-system] @@ -2419,15 +3766,14 @@ The default comes from `process-coding-system-alist' and `default-process-coding-system'. \(Type \\[describe-mode] in the SQL buffer for a list of commands.)" - (interactive) - (sql-product-interactive 'sybase)) + (interactive "P") + (sql-product-interactive 'sybase buffer)) -(defun sql-connect-sybase () - "Create comint buffer and connect to Sybase using the login -parameters and command options." +(defun sql-comint-sybase (product options) + "Create comint buffer and connect to Sybase." ;; Put all parameters to the program (if defined) in a list and call ;; make-comint. - (let ((params sql-sybase-options)) + (let ((params options)) (if (not (string= "" sql-server)) (setq params (append (list "-S" sql-server) params))) (if (not (string= "" sql-database)) @@ -2436,13 +3782,12 @@ parameters and command options." (setq params (append (list "-P" sql-password) params))) (if (not (string= "" sql-user)) (setq params (append (list "-U" sql-user) params))) - (set-buffer (apply 'make-comint "SQL" sql-sybase-program - nil params)))) + (sql-comint product params))) ;;;###autoload -(defun sql-informix () +(defun sql-informix (&optional buffer) "Run dbaccess by Informix as an inferior process. If buffer `*SQL*' exists but no process is running, make a new process. @@ -2455,6 +3800,11 @@ the variable `sql-database' as default, if set. The buffer is put in SQL interactive mode, giving commands for sending input. See `sql-interactive-mode'. +To set the buffer name directly, use \\[universal-argument] +before \\[sql-informix]. Once session has started, +\\[sql-rename-buffer] can be called separately to rename the +buffer. + To specify a coding system for converting non-ASCII characters in the input and output to the process, use \\[universal-coding-system-argument] before \\[sql-informix]. You can also specify this with \\[set-buffer-process-coding-system] @@ -2463,21 +3813,23 @@ The default comes from `process-coding-system-alist' and `default-process-coding-system'. \(Type \\[describe-mode] in the SQL buffer for a list of commands.)" - (interactive) - (sql-product-interactive 'informix)) + (interactive "P") + (sql-product-interactive 'informix buffer)) -(defun sql-connect-informix () - "Create comint buffer and connect to Informix using the login -parameters and command options." +(defun sql-comint-informix (product options) + "Create comint buffer and connect to Informix." ;; username and password are ignored. - (set-buffer (if (string= "" sql-database) - (make-comint "SQL" sql-informix-program nil) - (make-comint "SQL" sql-informix-program nil sql-database "-")))) + (let ((db (if (string= "" sql-database) + "-" + (if (string= "" sql-server) + sql-database + (concat sql-database "@" sql-server))))) + (sql-comint product (append `(,db "-") options)))) ;;;###autoload -(defun sql-sqlite () +(defun sql-sqlite (&optional buffer) "Run sqlite as an inferior process. SQLite is free software. @@ -2494,6 +3846,11 @@ can be stored in the list `sql-sqlite-options'. The buffer is put in SQL interactive mode, giving commands for sending input. See `sql-interactive-mode'. +To set the buffer name directly, use \\[universal-argument] +before \\[sql-sqlite]. Once session has started, +\\[sql-rename-buffer] can be called separately to rename the +buffer. + To specify a coding system for converting non-ASCII characters in the input and output to the process, use \\[universal-coding-system-argument] before \\[sql-sqlite]. You can also specify this with \\[set-buffer-process-coding-system] @@ -2502,26 +3859,24 @@ The default comes from `process-coding-system-alist' and `default-process-coding-system'. \(Type \\[describe-mode] in the SQL buffer for a list of commands.)" - (interactive) - (sql-product-interactive 'sqlite)) + (interactive "P") + (sql-product-interactive 'sqlite buffer)) -(defun sql-connect-sqlite () - "Create comint buffer and connect to SQLite using the login -parameters and command options." +(defun sql-comint-sqlite (product options) + "Create comint buffer and connect to SQLite." ;; Put all parameters to the program (if defined) in a list and call ;; make-comint. (let ((params)) (if (not (string= "" sql-database)) - (setq params (append (list sql-database) params))) - (if (not (null sql-sqlite-options)) - (setq params (append sql-sqlite-options params))) - (set-buffer (apply 'make-comint "SQL" sql-sqlite-program - nil params)))) + (setq params (append (list (expand-file-name sql-database)) + params))) + (setq params (append options params)) + (sql-comint product params))) ;;;###autoload -(defun sql-mysql () +(defun sql-mysql (&optional buffer) "Run mysql by TcX as an inferior process. Mysql versions 3.23 and up are free software. @@ -2538,6 +3893,11 @@ can be stored in the list `sql-mysql-options'. The buffer is put in SQL interactive mode, giving commands for sending input. See `sql-interactive-mode'. +To set the buffer name directly, use \\[universal-argument] +before \\[sql-mysql]. Once session has started, +\\[sql-rename-buffer] can be called separately to rename the +buffer. + To specify a coding system for converting non-ASCII characters in the input and output to the process, use \\[universal-coding-system-argument] before \\[sql-mysql]. You can also specify this with \\[set-buffer-process-coding-system] @@ -2546,12 +3906,11 @@ The default comes from `process-coding-system-alist' and `default-process-coding-system'. \(Type \\[describe-mode] in the SQL buffer for a list of commands.)" - (interactive) - (sql-product-interactive 'mysql)) + (interactive "P") + (sql-product-interactive 'mysql buffer)) -(defun sql-connect-mysql () - "Create comint buffer and connect to MySQL using the login -parameters and command options." +(defun sql-comint-mysql (product options) + "Create comint buffer and connect to MySQL." ;; Put all parameters to the program (if defined) in a list and call ;; make-comint. (let ((params)) @@ -2559,19 +3918,19 @@ parameters and command options." (setq params (append (list sql-database) params))) (if (not (string= "" sql-server)) (setq params (append (list (concat "--host=" sql-server)) params))) + (if (not (= 0 sql-port)) + (setq params (append (list (concat "--port=" (number-to-string sql-port))) params))) (if (not (string= "" sql-password)) (setq params (append (list (concat "--password=" sql-password)) params))) (if (not (string= "" sql-user)) (setq params (append (list (concat "--user=" sql-user)) params))) - (if (not (null sql-mysql-options)) - (setq params (append sql-mysql-options params))) - (set-buffer (apply 'make-comint "SQL" sql-mysql-program - nil params)))) + (setq params (append options params)) + (sql-comint product params))) ;;;###autoload -(defun sql-solid () +(defun sql-solid (&optional buffer) "Run solsql by Solid as an inferior process. If buffer `*SQL*' exists but no process is running, make a new process. @@ -2585,6 +3944,11 @@ defaults, if set. The buffer is put in SQL interactive mode, giving commands for sending input. See `sql-interactive-mode'. +To set the buffer name directly, use \\[universal-argument] +before \\[sql-solid]. Once session has started, +\\[sql-rename-buffer] can be called separately to rename the +buffer. + To specify a coding system for converting non-ASCII characters in the input and output to the process, use \\[universal-coding-system-argument] before \\[sql-solid]. You can also specify this with \\[set-buffer-process-coding-system] @@ -2593,28 +3957,26 @@ The default comes from `process-coding-system-alist' and `default-process-coding-system'. \(Type \\[describe-mode] in the SQL buffer for a list of commands.)" - (interactive) - (sql-product-interactive 'solid)) + (interactive "P") + (sql-product-interactive 'solid buffer)) -(defun sql-connect-solid () - "Create comint buffer and connect to Solid using the login -parameters and command options." +(defun sql-comint-solid (product options) + "Create comint buffer and connect to Solid." ;; Put all parameters to the program (if defined) in a list and call ;; make-comint. - (let ((params)) + (let ((params options)) ;; It only makes sense if both username and password are there. (if (not (or (string= "" sql-user) (string= "" sql-password))) (setq params (append (list sql-user sql-password) params))) (if (not (string= "" sql-server)) (setq params (append (list sql-server) params))) - (set-buffer (apply 'make-comint "SQL" sql-solid-program - nil params)))) + (sql-comint product params))) ;;;###autoload -(defun sql-ingres () +(defun sql-ingres (&optional buffer) "Run sql by Ingres as an inferior process. If buffer `*SQL*' exists but no process is running, make a new process. @@ -2627,6 +3989,11 @@ the variable `sql-database' as default, if set. The buffer is put in SQL interactive mode, giving commands for sending input. See `sql-interactive-mode'. +To set the buffer name directly, use \\[universal-argument] +before \\[sql-ingres]. Once session has started, +\\[sql-rename-buffer] can be called separately to rename the +buffer. + To specify a coding system for converting non-ASCII characters in the input and output to the process, use \\[universal-coding-system-argument] before \\[sql-ingres]. You can also specify this with \\[set-buffer-process-coding-system] @@ -2635,21 +4002,22 @@ The default comes from `process-coding-system-alist' and `default-process-coding-system'. \(Type \\[describe-mode] in the SQL buffer for a list of commands.)" - (interactive) - (sql-product-interactive 'ingres)) + (interactive "P") + (sql-product-interactive 'ingres buffer)) -(defun sql-connect-ingres () - "Create comint buffer and connect to Ingres using the login -parameters and command options." +(defun sql-comint-ingres (product options) + "Create comint buffer and connect to Ingres." ;; username and password are ignored. - (set-buffer (if (string= "" sql-database) - (make-comint "SQL" sql-ingres-program nil) - (make-comint "SQL" sql-ingres-program nil sql-database)))) + (sql-comint product + (append (if (string= "" sql-database) + nil + (list sql-database)) + options))) ;;;###autoload -(defun sql-ms () +(defun sql-ms (&optional buffer) "Run osql by Microsoft as an inferior process. If buffer `*SQL*' exists but no process is running, make a new process. @@ -2664,6 +4032,11 @@ in the list `sql-ms-options'. The buffer is put in SQL interactive mode, giving commands for sending input. See `sql-interactive-mode'. +To set the buffer name directly, use \\[universal-argument] +before \\[sql-ms]. Once session has started, +\\[sql-rename-buffer] can be called separately to rename the +buffer. + To specify a coding system for converting non-ASCII characters in the input and output to the process, use \\[universal-coding-system-argument] before \\[sql-ms]. You can also specify this with \\[set-buffer-process-coding-system] @@ -2672,15 +4045,14 @@ The default comes from `process-coding-system-alist' and `default-process-coding-system'. \(Type \\[describe-mode] in the SQL buffer for a list of commands.)" - (interactive) - (sql-product-interactive 'ms)) + (interactive "P") + (sql-product-interactive 'ms buffer)) -(defun sql-connect-ms () - "Create comint buffer and connect to Microsoft using the login -parameters and command options." +(defun sql-comint-ms (product options) + "Create comint buffer and connect to Microsoft SQL Server." ;; Put all parameters to the program (if defined) in a list and call ;; make-comint. - (let ((params sql-ms-options)) + (let ((params options)) (if (not (string= "" sql-server)) (setq params (append (list "-S" sql-server) params))) (if (not (string= "" sql-database)) @@ -2696,13 +4068,12 @@ parameters and command options." ;; If -P is passed to ISQL as the last argument without a ;; password, it's considered null. (setq params (append params (list "-P"))))) - (set-buffer (apply 'make-comint "SQL" sql-ms-program - nil params)))) + (sql-comint product params))) ;;;###autoload -(defun sql-postgres () +(defun sql-postgres (&optional buffer) "Run psql by Postgres as an inferior process. If buffer `*SQL*' exists but no process is running, make a new process. @@ -2717,6 +4088,11 @@ Additional command line parameters can be stored in the list The buffer is put in SQL interactive mode, giving commands for sending input. See `sql-interactive-mode'. +To set the buffer name directly, use \\[universal-argument] +before \\[sql-postgres]. Once session has started, +\\[sql-rename-buffer] can be called separately to rename the +buffer. + To specify a coding system for converting non-ASCII characters in the input and output to the process, use \\[universal-coding-system-argument] before \\[sql-postgres]. You can also specify this with \\[set-buffer-process-coding-system] @@ -2730,31 +4106,31 @@ Try to set `comint-output-filter-functions' like this: '(comint-strip-ctrl-m))) \(Type \\[describe-mode] in the SQL buffer for a list of commands.)" - (interactive) - (sql-product-interactive 'postgres)) + (interactive "P") + (sql-product-interactive 'postgres buffer)) -(defun sql-connect-postgres () - "Create comint buffer and connect to Postgres using the login -parameters and command options." +(defun sql-comint-postgres (product options) + "Create comint buffer and connect to Postgres." ;; username and password are ignored. Mark Stosberg suggest to add ;; the database at the end. Jason Beegan suggest using --pset and ;; pager=off instead of \\o|cat. The later was the solution by ;; Gregor Zych. Jason's suggestion is the default value for ;; sql-postgres-options. - (let ((params sql-postgres-options)) + (let ((params options)) (if (not (string= "" sql-database)) (setq params (append params (list sql-database)))) (if (not (string= "" sql-server)) (setq params (append (list "-h" sql-server) params))) (if (not (string= "" sql-user)) (setq params (append (list "-U" sql-user) params))) - (set-buffer (apply 'make-comint "SQL" sql-postgres-program - nil params)))) + (if (not (= 0 sql-port)) + (setq params (append (list "-p" sql-port) params))) + (sql-comint product params))) ;;;###autoload -(defun sql-interbase () +(defun sql-interbase (&optional buffer) "Run isql by Interbase as an inferior process. If buffer `*SQL*' exists but no process is running, make a new process. @@ -2768,6 +4144,11 @@ defaults, if set. The buffer is put in SQL interactive mode, giving commands for sending input. See `sql-interactive-mode'. +To set the buffer name directly, use \\[universal-argument] +before \\[sql-interbase]. Once session has started, +\\[sql-rename-buffer] can be called separately to rename the +buffer. + To specify a coding system for converting non-ASCII characters in the input and output to the process, use \\[universal-coding-system-argument] before \\[sql-interbase]. You can also specify this with \\[set-buffer-process-coding-system] @@ -2776,28 +4157,26 @@ The default comes from `process-coding-system-alist' and `default-process-coding-system'. \(Type \\[describe-mode] in the SQL buffer for a list of commands.)" - (interactive) - (sql-product-interactive 'interbase)) + (interactive "P") + (sql-product-interactive 'interbase buffer)) -(defun sql-connect-interbase () - "Create comint buffer and connect to Interbase using the login -parameters and command options." +(defun sql-comint-interbase (product options) + "Create comint buffer and connect to Interbase." ;; Put all parameters to the program (if defined) in a list and call ;; make-comint. - (let ((params sql-interbase-options)) + (let ((params options)) (if (not (string= "" sql-user)) (setq params (append (list "-u" sql-user) params))) (if (not (string= "" sql-password)) (setq params (append (list "-p" sql-password) params))) (if (not (string= "" sql-database)) (setq params (cons sql-database params))) ; add to the front! - (set-buffer (apply 'make-comint "SQL" sql-interbase-program - nil params)))) + (sql-comint product params))) ;;;###autoload -(defun sql-db2 () +(defun sql-db2 (&optional buffer) "Run db2 by IBM as an inferior process. If buffer `*SQL*' exists but no process is running, make a new process. @@ -2815,6 +4194,11 @@ db2, newlines will be escaped if necessary. If you don't want that, set `comint-input-sender' back to `comint-simple-send' by writing an after advice. See the elisp manual for more information. +To set the buffer name directly, use \\[universal-argument] +before \\[sql-db2]. Once session has started, +\\[sql-rename-buffer] can be called separately to rename the +buffer. + To specify a coding system for converting non-ASCII characters in the input and output to the process, use \\[universal-coding-system-argument] before \\[sql-db2]. You can also specify this with \\[set-buffer-process-coding-system] @@ -2823,21 +4207,18 @@ The default comes from `process-coding-system-alist' and `default-process-coding-system'. \(Type \\[describe-mode] in the SQL buffer for a list of commands.)" - (interactive) - (sql-product-interactive 'db2)) + (interactive "P") + (sql-product-interactive 'db2 buffer)) -(defun sql-connect-db2 () - "Create comint buffer and connect to DB2 using the login -parameters and command options." +(defun sql-comint-db2 (product options) + "Create comint buffer and connect to DB2." ;; Put all parameters to the program (if defined) in a list and call ;; make-comint. - (set-buffer (apply 'make-comint "SQL" sql-db2-program - nil sql-db2-options)) - ;; Properly escape newlines when DB2 is interactive. - (setq comint-input-sender 'sql-escape-newlines-and-send)) + (sql-comint product options) +) ;;;###autoload -(defun sql-linter () +(defun sql-linter (&optional buffer) "Run inl by RELEX as an inferior process. If buffer `*SQL*' exists but no process is running, make a new process. @@ -2847,7 +4228,7 @@ If buffer exists and a process is running, just switch to buffer Interpreter used comes from variable `sql-linter-program' - usually `inl'. Login uses the variables `sql-user', `sql-password', `sql-database' and `sql-server' as defaults, if set. Additional command line parameters -can be stored in the list `sql-linter-options'. Run inl -h to get help on +can be stored in the list `sql-linter-options'. Run inl -h to get help on parameters. `sql-database' is used to set the LINTER_MBX environment variable for @@ -2859,16 +4240,22 @@ an empty password. The buffer is put in SQL interactive mode, giving commands for sending input. See `sql-interactive-mode'. +To set the buffer name directly, use \\[universal-argument] +before \\[sql-linter]. Once session has started, +\\[sql-rename-buffer] can be called separately to rename the +buffer. + \(Type \\[describe-mode] in the SQL buffer for a list of commands.)" - (interactive) - (sql-product-interactive 'linter)) + (interactive "P") + (sql-product-interactive 'linter buffer)) -(defun sql-connect-linter () - "Create comint buffer and connect to Linter using the login -parameters and command options." +(defun sql-comint-linter (product options) + "Create comint buffer and connect to Linter." ;; Put all parameters to the program (if defined) in a list and call ;; make-comint. - (let ((params sql-linter-options) (login nil) (old-mbx (getenv "LINTER_MBX"))) + (let ((params options) + (login nil) + (old-mbx (getenv "LINTER_MBX"))) (if (not (string= "" sql-user)) (setq login (concat sql-user "/" sql-password))) (setq params (append (list "-u" login) params)) @@ -2877,8 +4264,7 @@ parameters and command options." (if (string= "" sql-database) (setenv "LINTER_MBX" nil) (setenv "LINTER_MBX" sql-database)) - (set-buffer (apply 'make-comint "SQL" sql-linter-program nil - params)) + (sql-comint product params) (setenv "LINTER_MBX" old-mbx))) @@ -2886,3 +4272,4 @@ parameters and command options." (provide 'sql) ;;; sql.el ends here + diff --git a/lisp/progmodes/subword.el b/lisp/progmodes/subword.el index 4081791ae2e..7df42c8b9a2 100644 --- a/lisp/progmodes/subword.el +++ b/lisp/progmodes/subword.el @@ -76,7 +76,7 @@ ;; the old `c-forward-into-nomenclature' originally contributed by ;; Terry_Glanfield dot Southern at rxuk dot xerox dot com. -;; TODO: ispell-word and subword oriented C-w in isearch. +;; TODO: ispell-word. ;;; Code: diff --git a/lisp/progmodes/tcl.el b/lisp/progmodes/tcl.el index cb69d49fcbd..620d236078b 100644 --- a/lisp/progmodes/tcl.el +++ b/lisp/progmodes/tcl.el @@ -411,9 +411,10 @@ This variable is generally set from `tcl-proc-regexp', `tcl-typeword-list', and `tcl-keyword-list' by the function `tcl-set-font-lock-keywords'.") -(defvar tcl-font-lock-syntactic-keywords - ;; Mark the few `#' that are not comment-markers. - '(("[^;[{ \t\n][ \t]*\\(#\\)" (1 "."))) +(defconst tcl-syntax-propertize-function + (syntax-propertize-rules + ;; Mark the few `#' that are not comment-markers. + ("[^;[{ \t\n][ \t]*\\(#\\)" (1 "."))) "Syntactic keywords for `tcl-mode'.") ;; FIXME need some way to recognize variables because array refs look @@ -545,7 +546,7 @@ Uses variables `tcl-proc-regexp' and `tcl-keyword-list'." ;; ;;;###autoload -(define-derived-mode tcl-mode nil "Tcl" +(define-derived-mode tcl-mode prog-mode "Tcl" "Major mode for editing Tcl code. Expression and list commands understand all Tcl brackets. Tab indents for Tcl code. @@ -593,9 +594,9 @@ Commands: (set (make-local-variable 'outline-level) 'tcl-outline-level) (set (make-local-variable 'font-lock-defaults) - '(tcl-font-lock-keywords nil nil nil beginning-of-defun - (font-lock-syntactic-keywords . tcl-font-lock-syntactic-keywords) - (parse-sexp-lookup-properties . t))) + '(tcl-font-lock-keywords nil nil nil beginning-of-defun)) + (set (make-local-variable 'syntax-propertize-function) + tcl-syntax-propertize-function) (set (make-local-variable 'imenu-generic-expression) tcl-imenu-generic-expression) @@ -1199,8 +1200,7 @@ as input to future invocations. FLAG is nil if not in comment, t otherwise. If in comment, leaves point at beginning of comment." (let ((bol (save-excursion (goto-char end) - (beginning-of-line) - (point))) + (line-beginning-position))) real-comment last-cstart) (while (and (not last-cstart) (< (point) end)) @@ -1548,5 +1548,4 @@ The first line is assumed to look like \"#!.../program ...\"." (provide 'tcl) -;; arch-tag: 8a032554-c3ef-422e-b84c-acec0522179d ;;; tcl.el ends here diff --git a/lisp/progmodes/vera-mode.el b/lisp/progmodes/vera-mode.el index 96877a000a1..0d119503f31 100644 --- a/lisp/progmodes/vera-mode.el +++ b/lisp/progmodes/vera-mode.el @@ -770,7 +770,7 @@ the offset is simply returned." relpos 0) (setq offset (vera-evaluate-offset offset langelem symbol))) (+ (if (and relpos - (< relpos (save-excursion (beginning-of-line) (point)))) + (< relpos (line-beginning-position))) (save-excursion (goto-char relpos) (current-column)) @@ -1482,5 +1482,4 @@ If `vera-intelligent-tab' is nil, always indent line." (provide 'vera-mode) -;; arch-tag: 22eae722-7ac5-47ac-a713-c4db1cf623a9 ;;; vera-mode.el ends here diff --git a/lisp/progmodes/verilog-mode.el b/lisp/progmodes/verilog-mode.el index a75ed1b47d3..42527ff60eb 100644 --- a/lisp/progmodes/verilog-mode.el +++ b/lisp/progmodes/verilog-mode.el @@ -1378,19 +1378,8 @@ If set will become buffer local.") ;; Macros ;; -(defsubst verilog-get-beg-of-line (&optional arg) - (save-excursion - (beginning-of-line arg) - (point))) - -(defsubst verilog-get-end-of-line (&optional arg) - (save-excursion - (end-of-line arg) - (point))) - (defsubst verilog-within-string () - (save-excursion - (nth 3 (parse-partial-sexp (verilog-get-beg-of-line) (point))))) + (nth 3 (parse-partial-sexp (point-at-bol) (point)))) (defsubst verilog-string-replace-matches (from-string to-string fixedcase literal string) "Replace occurrences of FROM-STRING with TO-STRING. @@ -1480,7 +1469,7 @@ This speeds up complicated regexp matches." (search-forward substr bound noerror)) (save-excursion (beginning-of-line) - (setq done (re-search-forward regexp (verilog-get-end-of-line) noerror))) + (setq done (re-search-forward regexp (point-at-eol) noerror))) (unless (and (<= (match-beginning 0) (point)) (>= (match-end 0) (point))) (setq done nil))) @@ -1500,7 +1489,7 @@ This speeds up complicated regexp matches." (search-backward substr bound noerror)) (save-excursion (end-of-line) - (setq done (re-search-backward regexp (verilog-get-beg-of-line) noerror))) + (setq done (re-search-backward regexp (point-at-bol) noerror))) (unless (and (<= (match-beginning 0) (point)) (>= (match-end 0) (point))) (setq done nil))) @@ -2919,7 +2908,7 @@ Use filename, if current buffer being edited shorten to just buffer name." (catch 'skip (if (eq nest 'yes) (let ((depth 1) - here ) + here) (while (verilog-re-search-forward reg nil 'move) (cond ((match-end md) ; a closer in regular expression, so we are climbing out @@ -3925,7 +3914,7 @@ primitive or interface named NAME." (or kill-existing-comment (not (save-excursion (end-of-line) - (search-backward "//" (verilog-get-beg-of-line) t))))) + (search-backward "//" (point-at-bol) t))))) (let ((nest 1) b e m (else (if (match-end 2) "!" " "))) @@ -3978,7 +3967,7 @@ primitive or interface named NAME." (or kill-existing-comment (not (save-excursion (end-of-line) - (search-backward "//" (verilog-get-beg-of-line) t))))) + (search-backward "//" (point-at-bol) t))))) (let ((type (car indent-str))) (unless (eq type 'declaration) (unless (looking-at (concat "\\(" verilog-end-block-ordered-re "\\)[ \t]*:")) ;; ignore named ends @@ -4512,7 +4501,7 @@ becomes: (cond ((looking-at "// surefire lint_off_line ") (goto-char (match-end 0)) - (let ((lim (save-excursion (end-of-line) (point)))) + (let ((lim (point-at-eol))) (if (re-search-forward code lim 'move) (throw 'already t) (insert (concat " " code))))) @@ -8287,8 +8276,7 @@ Some macros and such are also found and included. For dinotrace.el." ": Can't find verilog-getopt-file -f file: " filename))) (goto-char (point-min)) (while (not (eobp)) - (setq line (buffer-substring (point) - (save-excursion (end-of-line) (point)))) + (setq line (buffer-substring (point) (point-at-eol))) (forward-line 1) (when (string-match "//" line) (setq line (substring line 0 (match-beginning 0)))) @@ -11915,7 +11903,7 @@ Clicking on the middle-mouse button loads them in a buffer (as in dired)." (verilog-save-scan-cache (let (end-point) (goto-char end) - (setq end-point (verilog-get-end-of-line)) + (setq end-point (point-at-eol)) (goto-char beg) (beginning-of-line) ; scan entire line ;; delete overlays existing on this line @@ -12139,5 +12127,4 @@ but instead, [[Fill in here]] happens!. ;; checkdoc-force-docstrings-flag:nil ;; End: -;; arch-tag: 87923725-57b3-41b5-9494-be21118c6a6f ;;; verilog-mode.el ends here diff --git a/lisp/progmodes/vhdl-mode.el b/lisp/progmodes/vhdl-mode.el index 1210592af18..c7814fed8a0 100644 --- a/lisp/progmodes/vhdl-mode.el +++ b/lisp/progmodes/vhdl-mode.el @@ -199,21 +199,6 @@ Examples: "Customizations for modes." :group 'vhdl) -(defcustom vhdl-electric-mode t - "*Non-nil enables electrification (automatic template generation). -If nil, template generators can still be invoked through key bindings and -menu. Is indicated in the modeline by \"/e\" after the mode name and can be -toggled by `\\[vhdl-electric-mode]'." - :type 'boolean - :group 'vhdl-mode) - -(defcustom vhdl-stutter-mode t - "*Non-nil enables stuttering. -Is indicated in the modeline by \"/s\" after the mode name and can be toggled -by `\\[vhdl-stutter-mode]'." - :type 'boolean - :group 'vhdl-mode) - (defcustom vhdl-indent-tabs-mode nil "*Non-nil means indentation can insert tabs. Overrides local variable `indent-tabs-mode'." @@ -3466,13 +3451,11 @@ STRING are replaced by `-' and substrings are converted to lower case." ("Mode" ["Electric Mode" (progn (customize-set-variable 'vhdl-electric-mode - (not vhdl-electric-mode)) - (vhdl-mode-line-update)) + (not vhdl-electric-mode))) :style toggle :selected vhdl-electric-mode :keys "C-c C-m C-e"] ["Stutter Mode" (progn (customize-set-variable 'vhdl-stutter-mode - (not vhdl-stutter-mode)) - (vhdl-mode-line-update)) + (not vhdl-stutter-mode))) :style toggle :selected vhdl-stutter-mode :keys "C-c C-m C-s"] ["Indent Tabs Mode" (progn (customize-set-variable 'vhdl-indent-tabs-mode @@ -4670,7 +4653,10 @@ Key bindings: (interactive) (kill-all-local-variables) (setq major-mode 'vhdl-mode) - (setq mode-name "VHDL") + (setq mode-name '("VHDL" + (vhdl-electric-mode "/" (vhdl-stutter-mode "/")) + (vhdl-electric-mode "e") + (vhdl-stutter-mode "s"))) ;; set maps and tables (use-local-map vhdl-mode-map) @@ -4707,8 +4693,15 @@ Key bindings: (set (make-local-variable 'font-lock-defaults) (list '(nil vhdl-font-lock-keywords) nil - (not vhdl-highlight-case-sensitive) '((?\_ . "w")) 'beginning-of-line - '(font-lock-syntactic-keywords . vhdl-font-lock-syntactic-keywords))) + (not vhdl-highlight-case-sensitive) '((?\_ . "w")) 'beginning-of-line)) + (if (eval-when-compile (fboundp 'syntax-propertize-rules)) + (set (make-local-variable 'syntax-propertize-function) + (syntax-propertize-rules + ;; Mark single quotes as having string quote syntax in + ;; 'c' instances. + ("\\(\'\\).\\(\'\\)" (1 "\"'") (2 "\"'")))) + (set (make-local-variable 'font-lock-syntactic-keywords) + vhdl-font-lock-syntactic-keywords)) (unless vhdl-emacs-21 (set (make-local-variable 'font-lock-support-mode) 'lazy-lock-mode) (set (make-local-variable 'lazy-lock-defer-contextually) nil) @@ -4737,7 +4730,6 @@ Key bindings: ;; miscellaneous (vhdl-ps-print-init) (vhdl-write-file-hooks-init) - (vhdl-mode-line-update) (message "VHDL Mode %s.%s" vhdl-version (if noninteractive "" " See menu for documentation and release notes.")) @@ -4757,8 +4749,7 @@ Key bindings: (vhdl-write-file-hooks-init) (vhdl-update-mode-menu) (vhdl-hideshow-init) - (run-hooks 'menu-bar-update-hook) - (vhdl-mode-line-update)) + (run-hooks 'menu-bar-update-hook)) (defun vhdl-write-file-hooks-init () "Add/remove hooks when buffer is saved." @@ -7278,7 +7269,7 @@ indentation is done before aligning." (save-excursion (goto-char begin) (let (element - (eol (save-excursion (progn (end-of-line) (point))))) + (eol (point-at-eol))) (setq element (nth 0 copy)) (when (and (or (and (listp (car element)) (memq major-mode (car element))) @@ -7304,7 +7295,7 @@ the token in MATCH." ;; Determine the greatest whitespace distance to the alignment ;; character (goto-char begin) - (setq eol (progn (end-of-line) (point)) + (setq eol (point-at-eol) bol (setq begin (progn (beginning-of-line) (point)))) (while (< bol end) (save-excursion @@ -7315,13 +7306,13 @@ the token in MATCH." (setq max distance)))) (forward-line) (setq bol (point) - eol (save-excursion (end-of-line) (point))) + eol (point-at-eol)) (setq lines (1+ lines))) ;; Now insert enough maxs to push each assignment operator to ;; the same column. We need to use 'lines' as a counter, since ;; the location of the mark may change (goto-char (setq bol begin)) - (setq eol (save-excursion (end-of-line) (point))) + (setq eol (point-at-eol)) (while (> lines 0) (when (and (re-search-forward match eol t) (not (vhdl-in-literal))) @@ -7333,7 +7324,7 @@ the token in MATCH." (beginning-of-line) (forward-line) (setq bol (point) - eol (save-excursion (end-of-line) (point))) + eol (point-at-eol)) (setq lines (1- lines)))))) (defun vhdl-align-region-groups (beg end &optional spacing @@ -7997,7 +7988,7 @@ buffer." (forward-char) (vhdl-forward-syntactic-ws)) (goto-char end) - (when (> pos (save-excursion (end-of-line) (point))) + (when (> pos (point-at-eol)) (error "ERROR: Not within a generic/port clause")) ;; delete closing parenthesis on separate line (not supported style) (when (save-excursion (beginning-of-line) (looking-at "^\\s-*);")) @@ -8010,7 +8001,7 @@ buffer." (condition-case () (forward-sexp) (error (goto-char (point-max)))) (< (point) end)) - (delete-backward-char 1)) + (delete-char -1)) ;; add closing parenthesis (when (> (point) end) (goto-char end) @@ -8055,31 +8046,15 @@ project is defined." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Enabling/disabling -(defun vhdl-mode-line-update () - "Update the modeline string for VHDL major mode." - (setq mode-name (concat "VHDL" - (and (or vhdl-electric-mode vhdl-stutter-mode) "/") - (and vhdl-electric-mode "e") - (and vhdl-stutter-mode "s"))) - (force-mode-line-update t)) - -(defun vhdl-electric-mode (arg) +(define-minor-mode vhdl-electric-mode "Toggle VHDL electric mode. Turn on if ARG positive, turn off if ARG negative, toggle if ARG zero or nil." - (interactive "P") - (setq vhdl-electric-mode - (cond ((or (not arg) (zerop arg)) (not vhdl-electric-mode)) - ((> arg 0) t) (t nil))) - (vhdl-mode-line-update)) + :global t) -(defun vhdl-stutter-mode (arg) +(define-minor-mode vhdl-stutter-mode "Toggle VHDL stuttering mode. Turn on if ARG positive, turn off if ARG negative, toggle if ARG zero or nil." - (interactive "P") - (setq vhdl-stutter-mode - (cond ((or (not arg) (zerop arg)) (not vhdl-stutter-mode)) - ((> arg 0) t) (t nil))) - (vhdl-mode-line-update)) + :global t) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Stuttering @@ -8137,7 +8112,7 @@ Turn on if ARG positive, turn off if ARG negative, toggle if ARG zero or nil." (interactive "p") (if (and vhdl-stutter-mode (= count 1) (not (vhdl-in-literal))) (if (= (preceding-char) last-input-event) - (progn (delete-backward-char 1) (insert-char ?\" 1)) + (progn (delete-char -1) (insert-char ?\" 1)) (insert-char ?\' 1)) (self-insert-command count))) @@ -8204,7 +8179,7 @@ Turn on if ARG positive, turn off if ARG negative, toggle if ARG zero or nil." (unless (vhdl-template-field (concat "[type" (and (vhdl-standard-p 'ams) " or nature") "]") nil t) - (delete-backward-char 3)) + (delete-char -3)) (vhdl-insert-keyword " IS ") (vhdl-template-field "name" ";") (vhdl-comment-insert-inline)))) @@ -8568,7 +8543,7 @@ a configuration declaration if not within a design unit." (vhdl-template-field "library name" "." nil nil nil nil (vhdl-work-library)) (vhdl-template-field "configuration name" ";")) - (t (delete-backward-char 1) (insert ";") t)))))) + (t (delete-char -1) (insert ";") t)))))) (defun vhdl-template-configuration-decl () @@ -8735,7 +8710,7 @@ a configuration declaration if not within a design unit." (vhdl-insert-keyword " OPEN ") (unless (vhdl-template-field "[READ_MODE | WRITE_MODE | APPEND_MODE]" nil t) - (delete-backward-char 6))) + (delete-char -6))) (vhdl-insert-keyword " IS ") (when (vhdl-standard-p '87) (vhdl-template-field "[IN | OUT]" " " t)) @@ -9063,7 +9038,7 @@ otherwise." (insert "\n") (indent-to margin)) (delete-region end-pos (point)) - (delete-backward-char 1) + (delete-char -1) (insert ")") (when vhdl-auto-align (vhdl-align-region-groups start (point) 1)) t) @@ -9437,7 +9412,7 @@ otherwise." (vhdl-insert-keyword "REPORT ") (if (equal "\"\"" (vhdl-template-field "string expression" nil t start (point) t)) - (delete-backward-char 2) + (delete-char -2) (setq start (point)) (vhdl-insert-keyword " SEVERITY ") (unless (vhdl-template-field "[NOTE | WARNING | ERROR | FAILURE]" nil t) @@ -9585,7 +9560,7 @@ otherwise." "[scalar type | ARRAY | RECORD | ACCESS | FILE]" nil t) "")))) (cond ((equal definition "") - (delete-backward-char 4) + (delete-char -4) (insert ";")) ((equal definition "ARRAY") (delete-region (point) (progn (forward-word -1) (point))) @@ -10085,13 +10060,13 @@ If starting after end-comment-column, start a new line." (if (not (or (and string (progn (insert string) t)) (vhdl-template-field "[comment]" nil t))) (delete-region position (point)) - (while (= (preceding-char) ? ) (delete-backward-char 1)) -; (when (> (current-column) end-comment-column) -; (setq position (point-marker)) -; (re-search-backward "-- ") -; (insert "\n") -; (indent-to comment-column) -; (goto-char position)) + (while (= (preceding-char) ?\ ) (delete-char -1)) + ;; (when (> (current-column) end-comment-column) + ;; (setq position (point-marker)) + ;; (re-search-backward "-- ") + ;; (insert "\n") + ;; (indent-to comment-column) + ;; (goto-char position)) )))) (defun vhdl-comment-block () @@ -10224,7 +10199,7 @@ Point is left between them." (when semicolon-pos (goto-char semicolon-pos)) (if not-empty (progn (delete-char 1) (insert ")")) - (delete-backward-char 2)))) + (delete-char -2)))) (defun vhdl-template-generic-list (optional &optional no-value) "Read from user a generic spec argument list." @@ -12140,9 +12115,7 @@ options vhdl-upper-case-{keywords,types,attributes,enum-values}." "Return the line number of the line containing point." (save-restriction (widen) - (save-excursion - (beginning-of-line) - (1+ (count-lines (point-min) (point)))))) + (1+ (count-lines (point-min) (point-at-bol))))) (defun vhdl-line-kill-entire (&optional arg) "Delete entire line." @@ -12159,8 +12132,7 @@ options vhdl-upper-case-{keywords,types,attributes,enum-values}." "Copy current line." (interactive "p") (save-excursion - (beginning-of-line) - (let ((position (point))) + (let ((position (point-at-bol))) (forward-line (or arg 1)) (copy-region-as-kill position (point))))) @@ -12533,7 +12505,7 @@ File statistics: \"%s\"\n\ (add-hook 'hs-minor-mode-hook 'hs-hide-all) (remove-hook 'hs-minor-mode-hook 'hs-hide-all)) (hs-minor-mode arg) - (vhdl-mode-line-update))) ; hack to update menu bar + (force-mode-line-update))) ; hack to update menu bar ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -12946,10 +12918,9 @@ This does background highlighting of translate-off regions.") "Re-initialize fontification and fontify buffer." (interactive) (setq font-lock-defaults - (list - 'vhdl-font-lock-keywords nil - (not vhdl-highlight-case-sensitive) '((?\_ . "w")) 'beginning-of-line - '(font-lock-syntactic-keywords . vhdl-font-lock-syntactic-keywords))) + `(vhdl-font-lock-keywords + nil ,(not vhdl-highlight-case-sensitive) ((?\_ . "w")) + beginning-of-line)) (when (fboundp 'font-lock-unset-defaults) (font-lock-unset-defaults)) ; not implemented in XEmacs (font-lock-set-defaults) @@ -15942,7 +15913,7 @@ current project/directory." &optional insert-conf) "Generate block configuration for architecture." (let ((margin (current-indentation)) - (beg (save-excursion (beginning-of-line) (point))) + (beg (point-at-bol)) ent-entry inst-entry inst-path inst-prev-path cons-key tmp-alist) ;; insert block configuration (for architecture) (vhdl-insert-keyword "FOR ") (insert arch-name "\n") @@ -17003,5 +16974,4 @@ to visually support naming conventions.") (provide 'vhdl-mode) -;; arch-tag: 780d7073-9b5d-4c6c-b0d8-26b28783aba3 ;;; vhdl-mode.el ends here diff --git a/lisp/progmodes/xscheme.el b/lisp/progmodes/xscheme.el index 0324bc3c5b2..217424b9424 100644 --- a/lisp/progmodes/xscheme.el +++ b/lisp/progmodes/xscheme.el @@ -701,12 +701,7 @@ parse an expression from the beginning of the line and send that instead." "Send the current line to the Scheme process. Useful for working with debugging Scheme under adb." (interactive) - (let ((line - (save-excursion - (beginning-of-line) - (let ((start (point))) - (end-of-line) - (buffer-substring start (point)))))) + (let ((line (buffer-substring (line-beginning-position) (line-end-position)))) (end-of-line) (insert ?\n) (xscheme-send-string-2 line))) @@ -1224,5 +1219,4 @@ the remaining input.") (provide 'xscheme) -;; arch-tag: cfc14adc-2917-409e-ad16-432e8d0017de ;;; xscheme.el ends here |