diff options
Diffstat (limited to 'lisp/progmodes')
51 files changed, 7375 insertions, 3241 deletions
diff --git a/lisp/progmodes/ada-mode.el b/lisp/progmodes/ada-mode.el index 68b6c872d3f..0d07d573155 100644 --- a/lisp/progmodes/ada-mode.el +++ b/lisp/progmodes/ada-mode.el @@ -31,11 +31,6 @@ ;; independent from the GNU Ada compiler GNAT, distributed by Ada ;; Core Technologies. All the other files rely heavily on features ;; provided only by GNAT. -;; -;; Note: this mode will not work with Emacs 19. If you are on a VMS -;; system, where the latest version of Emacs is 19.28, you will need -;; another file, called ada-vms.el, that provides some required -;; functions. ;;; Usage: ;; Emacs should enter Ada mode automatically when you load an Ada file. diff --git a/lisp/progmodes/ada-xref.el b/lisp/progmodes/ada-xref.el index 7cad848fda8..4bc37451e6e 100644 --- a/lisp/progmodes/ada-xref.el +++ b/lisp/progmodes/ada-xref.el @@ -651,12 +651,6 @@ Call `ada-require-project-file' first to ensure a project exists." (find-file (car (cdr pos))) (goto-char (car pos))))) -(defun ada-convert-file-name (name) - "Convert from NAME to a name that can be used by the compilation commands. -This is overridden on VMS to convert from VMS filenames to Unix filenames." - name) -;; FIXME: use convert-standard-filename instead - (defun ada-set-default-project-file (file) "Set FILE as the current project file." (interactive "fProject file:") @@ -1465,7 +1459,7 @@ by replacing the file extension with `.ali'." (get-file-buffer ali-file-name)) (kill-buffer (get-file-buffer ali-file-name))) - (let* ((name (ada-convert-file-name file)) + (let* ((name (convert-standard-filename file)) (body-name (or (ada-get-body-name name) name))) ;; Always recompile the body when we can. We thus temporarily switch to a diff --git a/lisp/progmodes/cap-words.el b/lisp/progmodes/cap-words.el deleted file mode 100644 index b03daf4cd5a..00000000000 --- a/lisp/progmodes/cap-words.el +++ /dev/null @@ -1,98 +0,0 @@ -;;; cap-words.el --- minor mode for motion in CapitalizedWordIdentifiers - -;; Copyright (C) 2002-2014 Free Software Foundation, Inc. - -;; Author: Dave Love <fx@gnu.org> -;; Keywords: languages - -;; 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: - -;; Provides Capitalized Words minor mode for word movement in -;; identifiers CapitalizedLikeThis. - -;; Note that the same effect could be obtained by frobbing the -;; category of upper case characters to produce word boundaries, but -;; the necessary processing isn't done for ASCII characters. - -;; Fixme: This doesn't work properly for mouse double clicks. - -;;; Code: - -(defun capitalized-find-word-boundary (pos limit) - "Function for use in `find-word-boundary-function-table'. -Looks for word boundaries before capitals." - (save-excursion - (goto-char pos) - (let (case-fold-search) - (if (<= pos limit) - ;; Fixme: Are these regexps the best? - (or (and (re-search-forward "\\=.\\w*[[:upper:]]" - limit t) - (progn (backward-char) - t)) - (re-search-forward "\\>" limit t)) - (or (re-search-backward "[[:upper:]]\\w*\\=" limit t) - (re-search-backward "\\<" limit t)))) - (point))) - - -(defconst capitalized-find-word-boundary-function-table - (let ((tab (make-char-table nil))) - (set-char-table-range tab t #'capitalized-find-word-boundary) - tab) - "Assigned to `find-word-boundary-function-table' in Capitalized Words mode.") - -;;;###autoload -(define-minor-mode capitalized-words-mode - "Toggle Capitalized Words mode. -With a prefix argument ARG, enable Capitalized Words mode if ARG -is positive, and disable it otherwise. If called from Lisp, -enable the mode if ARG is omitted or nil. - -Capitalized Words mode is a buffer-local minor mode. When -enabled, a word boundary occurs immediately before an uppercase -letter in a symbol. This is in addition to all the normal -boundaries given by the syntax and category tables. There is no -restriction to ASCII. - -E.g. the beginning of words in the following identifier are as marked: - - capitalizedWorDD - ^ ^ ^^ - -Note that these word boundaries only apply for word motion and -marking commands such as \\[forward-word]. This mode does not affect word -boundaries found by regexp matching (`\\>', `\\w' &c). - -This style of identifiers is common in environments like Java ones, -where underscores aren't trendy enough. Capitalization rules are -sometimes part of the language, e.g. Haskell, which may thus encourage -such a style. It is appropriate to add `capitalized-words-mode' to -the mode hook for programming language modes in which you encounter -variables like this, e.g. `java-mode-hook'. It's unlikely to cause -trouble if such identifiers aren't used. - -See also `glasses-mode' and `studlify-word'. -Obsoletes `c-forward-into-nomenclature'." - nil " Caps" nil :group 'programming - (set (make-local-variable 'find-word-boundary-function-table) - capitalized-find-word-boundary-function-table)) - -(provide 'cap-words) - -;;; cap-words.el ends here diff --git a/lisp/progmodes/cc-align.el b/lisp/progmodes/cc-align.el index 05d796c470e..5800dc95385 100644 --- a/lisp/progmodes/cc-align.el +++ b/lisp/progmodes/cc-align.el @@ -1229,6 +1229,18 @@ Works with: Any syntactic symbol." (back-to-indentation) (vector (current-column)))) +(defun c-lineup-respect-col-0 (langelem) + "If the current line starts at column 0, return [0]. Otherwise return nil. + +This can be used for comments (in conjunction with, say, +`c-lineup-comment'), to keep comments already at column 0 +anchored there, but reindent other comments." + (save-excursion + (back-to-indentation) + (if (eq (current-column) 0) + [0] + nil))) + (defun c-snug-do-while (syntax pos) "Dynamically calculate brace hanginess for do-while statements. @@ -1333,4 +1345,8 @@ For other semicolon contexts, no determination is made." (cc-provide 'cc-align) +;;; Local Variables: +;;; indent-tabs-mode: t +;;; tab-width: 8 +;;; End: ;;; cc-align.el ends here diff --git a/lisp/progmodes/cc-awk.el b/lisp/progmodes/cc-awk.el index 44d69d7d0f1..2fcd0fd1831 100644 --- a/lisp/progmodes/cc-awk.el +++ b/lisp/progmodes/cc-awk.el @@ -61,7 +61,6 @@ (cc-bytecomp-defun c-backward-token-1) (cc-bytecomp-defun c-beginning-of-statement-1) (cc-bytecomp-defun c-backward-sws) -(cc-bytecomp-defun c-forward-sws) (defvar awk-mode-syntax-table (let ((st (make-syntax-table))) @@ -1147,4 +1146,8 @@ comment at the start of cc-engine.el for more info." (cc-provide 'cc-awk) ; Changed from 'awk-mode, ACM 2002/5/21 +;;; Local Variables: +;;; indent-tabs-mode: t +;;; tab-width: 8 +;;; End: ;;; awk-mode.el ends here diff --git a/lisp/progmodes/cc-bytecomp.el b/lisp/progmodes/cc-bytecomp.el index 19366279b6c..2db5a100050 100644 --- a/lisp/progmodes/cc-bytecomp.el +++ b/lisp/progmodes/cc-bytecomp.el @@ -65,8 +65,7 @@ ;; elsewhere in the load path. ;; ;; To suppress byte compiler warnings, use the macros -;; `cc-bytecomp-defun', `cc-bytecomp-defvar', -;; `cc-bytecomp-obsolete-fun', and `cc-bytecomp-obsolete-var'. +;; `cc-bytecomp-defun' and `cc-bytecomp-defvar'. ;; ;; This file is not used at all after the package has been byte ;; compiled. It is however necessary when running uncompiled. @@ -78,6 +77,12 @@ (defvar cc-bytecomp-original-functions nil) (defvar cc-bytecomp-original-properties nil) (defvar cc-bytecomp-loaded-files nil) + +(setq cc-bytecomp-unbound-variables nil) +(setq cc-bytecomp-original-functions nil) +(setq cc-bytecomp-original-properties nil) +(setq cc-bytecomp-loaded-files nil) + (defvar cc-bytecomp-environment-set nil) (defmacro cc-bytecomp-debug-msg (&rest args) @@ -370,33 +375,6 @@ the file. Don't use outside `eval-when-compile'." "cc-bytecomp-put: Bound property %s for %s to %s" ,propname ,symbol ,value))) -(defmacro cc-bytecomp-obsolete-var (symbol) - "Suppress warnings that the given symbol is an obsolete variable. -Don't use within `eval-when-compile'." - `(eval-when-compile - (if (get ',symbol 'byte-obsolete-variable) - (cc-bytecomp-put ',symbol 'byte-obsolete-variable nil) - ;; This avoids a superfluous compiler warning - ;; about calling `get' for effect. - t))) - -(defun cc-bytecomp-ignore-obsolete (form) - ;; Wraps a call to `byte-compile-obsolete' that suppresses the warning. - (let ((byte-compile-warnings byte-compile-warnings)) - (byte-compile-disable-warning 'obsolete) - (byte-compile-obsolete form))) - -(defmacro cc-bytecomp-obsolete-fun (symbol) - "Suppress warnings that the given symbol is an obsolete function. -Don't use within `eval-when-compile'." - `(eval-when-compile - (if (eq (get ',symbol 'byte-compile) 'byte-compile-obsolete) - (cc-bytecomp-put ',symbol 'byte-compile - 'cc-bytecomp-ignore-obsolete) - ;; This avoids a superfluous compiler warning - ;; about calling `get' for effect. - t))) - (defmacro cc-bytecomp-boundp (symbol) "Return non-nil if the given symbol is bound as a variable outside the compilation. This is the same as using `boundp' but additionally @@ -423,4 +401,8 @@ exclude any functions that have been bound during compilation with (provide 'cc-bytecomp) +;;; Local Variables: +;;; indent-tabs-mode: t +;;; tab-width: 8 +;;; End: ;;; cc-bytecomp.el ends here diff --git a/lisp/progmodes/cc-cmds.el b/lisp/progmodes/cc-cmds.el index 4f205d62a4c..0724697f8e8 100644 --- a/lisp/progmodes/cc-cmds.el +++ b/lisp/progmodes/cc-cmds.el @@ -258,9 +258,11 @@ With universal argument, inserts the analysis as a comment on that line." "a" "") (if c-hungry-delete-key "h" "") (if (and - ;; subword might not be loaded. - (boundp 'subword-mode) - (symbol-value 'subword-mode)) + ;; (cc-)subword might not be loaded. + (boundp 'c-subword-mode) + (symbol-value 'c-subword-mode)) + ;; FIXME: subword-mode already comes with its + ;; own lighter! "w" ""))) ;; FIXME: Derived modes might want to use something else @@ -1090,7 +1092,7 @@ 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 found-delim case-fold-search) + final-pos found-delim case-fold-search) (self-insert-command (prefix-numeric-value arg)) (setq final-pos (point)) @@ -1155,11 +1157,12 @@ numeric argument is supplied, or the point is inside a literal." (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))))) + ;; Currently (2014-10-19), the syntax-table text properties on < and > + ;; are only applied in code called during Emacs redisplay. We thus + ;; explicitly cause a redisplay so that these properties have been + ;; applied when `blink-paren-function' gets called. + (sit-for 0) + (funcall blink-paren-function))))) (defun c-electric-paren (arg) "Insert a parenthesis. @@ -1303,20 +1306,43 @@ keyword on the line, the keyword is not inserted inside a literal, and (declare-function subword-forward "subword" (&optional arg)) (declare-function subword-backward "subword" (&optional arg)) +(cond + ((and (fboundp 'subword-mode) (not (fboundp 'c-subword-mode))) + ;; Recent Emacsen come with their own subword support. Use that. + (define-obsolete-function-alias 'c-subword-mode 'subword-mode "24.3") + (define-obsolete-variable-alias 'c-subword-mode 'subword-mode "24.3")) + (t + ;; Autoload directive for emacsen that doesn't have an older CC Mode + ;; version in the dist. + (autoload 'c-subword-mode "cc-subword" + "Mode enabling subword movement and editing keys." t))) + ;; "nomenclature" functions + c-scope-operator. (defun c-forward-into-nomenclature (&optional arg) "Compatibility alias for `c-forward-subword'." (interactive "p") - (require 'subword) - (subword-forward arg)) -(make-obsolete 'c-forward-into-nomenclature 'subword-forward "23.2") + (if (fboundp 'subword-mode) + (progn + (require 'subword) + (subword-forward arg)) + (require 'cc-subword) + (c-forward-subword arg))) +(make-obsolete 'c-forward-into-nomenclature + (if (fboundp 'subword-mode) 'subword-forward 'c-forward-subword) + "23.2") (defun c-backward-into-nomenclature (&optional arg) "Compatibility alias for `c-backward-subword'." (interactive "p") - (require 'subword) - (subword-backward arg)) -(make-obsolete 'c-backward-into-nomenclature 'subword-backward "23.2") + (if (fboundp 'subword-mode) + (progn + (require 'subword) + (subword-backward arg)) + (require 'cc-subword) + (c-backward-subword arg))) +(make-obsolete + 'c-backward-into-nomenclature + (if (fboundp 'subword-mode) 'subword-backward 'c-backward-subword) "23.2") (defun c-scope-operator () "Insert a double colon scope operator at point. @@ -1416,12 +1442,15 @@ No indentation or other \"electric\" behavior is performed." (car (c-beginning-of-decl-1 ;; NOTE: If we're in a K&R region, this might be the start ;; of a parameter declaration, not the actual function. + ;; It might also leave us at a label or "label" like + ;; "private:". (and least-enclosing ; LIMIT for c-b-of-decl-1 (c-safe-position least-enclosing paren-state))))) ;; Has the declaration we've gone back to got braces? - (setq brace-decl-p - (save-excursion + (or (eq decl-result 'label) + (setq brace-decl-p + (save-excursion (and (c-syntactic-re-search-forward "[;{]" nil t t) (or (eq (char-before) ?\{) (and c-recognize-knr-p @@ -1429,10 +1458,11 @@ No indentation or other \"electric\" behavior is performed." ;; ';' in a K&R argdecl. In ;; that case the declaration ;; should contain a block. - (c-in-knr-argdecl)))))) + (c-in-knr-argdecl))))))) (cond - ((= (point) kluge-start) ; might be BOB or unbalanced parens. + ((or (eq decl-result 'label) ; e.g. "private:" or invalid syntax. + (= (point) kluge-start)) ; might be BOB or unbalanced parens. 'outwith-function) ((eq decl-result 'same) (if brace-decl-p @@ -1580,7 +1610,7 @@ defun." (or (not (eq this-command 'c-beginning-of-defun)) (eq last-command 'c-beginning-of-defun) - (and transient-mark-mode mark-active) + (c-region-is-active-p) (push-mark)) (c-save-buffer-state @@ -1704,7 +1734,7 @@ the open-parenthesis that starts a defun; see `beginning-of-defun'." (or (not (eq this-command 'c-end-of-defun)) (eq last-command 'c-end-of-defun) - (and transient-mark-mode mark-active) + (c-region-is-active-p) (push-mark)) (c-save-buffer-state @@ -1808,7 +1838,7 @@ with a brace block." (looking-at c-symbol-key)) (match-string-no-properties 0)) - ((looking-at "DEFUN\\_>") + ((looking-at "DEFUN\\s-*(") ;"DEFUN\\_>") think of XEmacs! ;; DEFUN ("file-name-directory", Ffile_name_directory, Sfile_name_directory, ...) ==> Ffile_name_directory ;; DEFUN(POSIX::STREAM-LOCK, stream lockp &key BLOCK SHARED START LENGTH) ==> POSIX::STREAM-LOCK (down-list 1) @@ -2001,7 +2031,7 @@ function does not require the declaration to contain a brace block." (eq last-command 'c-mark-function))) (push-mark-p (and (eq this-command 'c-mark-function) (not extend-region-p) - (not (and transient-mark-mode mark-active))))) + (not (c-region-is-active-p))))) (if push-mark-p (push-mark (point))) (if extend-region-p (progn @@ -3338,7 +3368,7 @@ Otherwise, with a prefix argument, rigidly reindent the expression starting on the current line. Otherwise reindent just the current line." (interactive - (list current-prefix-arg (use-region-p))) + (list current-prefix-arg (c-region-is-active-p))) (if region (c-indent-region (region-beginning) (region-end)) (c-indent-command arg))) @@ -4727,4 +4757,8 @@ normally bound to C-o. See `c-context-line-break' for the details." (cc-provide 'cc-cmds) +;;; Local Variables: +;;; indent-tabs-mode: t +;;; tab-width: 8 +;;; End: ;;; cc-cmds.el ends here diff --git a/lisp/progmodes/cc-defs.el b/lisp/progmodes/cc-defs.el index 18e23d4e861..46cb2f98621 100644 --- a/lisp/progmodes/cc-defs.el +++ b/lisp/progmodes/cc-defs.el @@ -64,15 +64,14 @@ (not (fboundp 'push))) (cc-load "cc-fix"))) -; (eval-after-load "font-lock" ; 2006-07-09. font-lock is now preloaded -; ' -(if (and (featurep 'xemacs) ; There is now (2005/12) code in GNU Emacs CVS - ; to make the call to f-l-c-k throw an error. - (not (featurep 'cc-fix)) ; only load the file once. - (let (font-lock-keywords) - (font-lock-compile-keywords '("\\<\\>")) - font-lock-keywords)) ; did the previous call foul this up? - (load "cc-fix")) ;) +(when (featurep 'xemacs) ; There is now (2005/12) code in GNU Emacs CVS + ; to make the call to f-l-c-k throw an error. + (eval-after-load "font-lock" + '(if (and (not (featurep 'cc-fix)) ; only load the file once. + (let (font-lock-keywords) + (font-lock-compile-keywords '("\\<\\>")) + font-lock-keywords)) ; did the previous call foul this up? + (load "cc-fix")))) ;; The above takes care of the delayed loading, but this is necessary ;; to ensure correct byte compilation. @@ -86,10 +85,15 @@ font-lock-keywords))) (cc-load "cc-fix"))) +;; XEmacs 21.4 doesn't have `delete-dups'. +(eval-and-compile + (if (and (not (fboundp 'delete-dups)) + (not (featurep 'cc-fix))) + (cc-load "cc-fix"))) ;;; Variables also used at compile time. -(defconst c-version "5.32.5" +(defconst c-version "5.33" "CC Mode version number.") (defconst c-version-sym (intern c-version)) @@ -331,16 +335,42 @@ to it is returned. This function does not modify the point or the mark." (t (error "Unknown buffer position requested: %s" position)))) (point)))) +(eval-and-compile + ;; Constant to decide at compilation time whether to use category + ;; properties. Currently (2010-03) they're available only on GNU Emacs. + (defconst c-use-category + (with-temp-buffer + (let ((parse-sexp-lookup-properties t) + (lookup-syntax-properties t)) + (set-syntax-table (make-syntax-table)) + (insert "<()>") + (put-text-property (point-min) (1+ (point-min)) + 'category 'c-<-as-paren-syntax) + (put-text-property (+ 3 (point-min)) (+ 4 (point-min)) + 'category 'c->-as-paren-syntax) + (goto-char (point-min)) + (forward-sexp) + (= (point) (+ 4 (point-min))))))) + +(defvar c-use-extents) + +(defmacro c-next-single-property-change (position prop &optional object limit) + ;; See the doc string for either of the defuns expanded to. + (if (and c-use-extents + (fboundp 'next-single-char-property-change)) + ;; XEmacs >= 2005-01-25 + `(next-single-char-property-change ,position ,prop ,object ,limit) + ;; Emacs and earlier XEmacs + `(next-single-property-change ,position ,prop ,object ,limit))) + (defmacro c-region-is-active-p () ;; Return t when the region is active. The determination of region ;; activeness is different in both Emacs and XEmacs. - ;; FIXME? Emacs has region-active-p since 23.1, so maybe this test - ;; should be updated. - (if (cc-bytecomp-boundp 'mark-active) - ;; Emacs. - 'mark-active - ;; XEmacs. - '(region-active-p))) + (if (cc-bytecomp-fboundp 'region-active-p) + ;; XEmacs. + '(region-active-p) + ;; Old Emacs. + 'mark-active)) (defmacro c-set-region-active (activate) ;; Activate the region if ACTIVE is non-nil, deactivate it @@ -827,6 +857,8 @@ be after it." (defmacro c-with-syntax-table (table &rest code) ;; Temporarily switches to the specified syntax table in a failsafe ;; way to execute code. + ;; Maintainers' note: If TABLE is `c++-template-syntax-table', DON'T call + ;; any forms inside this that call `c-parse-state'. !!!! `(let ((c-with-syntax-table-orig-table (syntax-table))) (unwind-protect (progn @@ -915,6 +947,12 @@ MODE is either a mode symbol or a list of mode symbols." (cc-bytecomp-fboundp 'delete-extent) (cc-bytecomp-fboundp 'map-extents)))) +(defconst c-<-as-paren-syntax '(4 . ?>)) +(put 'c-<-as-paren-syntax 'syntax-table c-<-as-paren-syntax) + +(defconst c->-as-paren-syntax '(5 . ?<)) +(put 'c->-as-paren-syntax 'syntax-table c->-as-paren-syntax) + ;; `c-put-char-property' is complex enough in XEmacs and Emacs < 21 to ;; make it a function. (defalias 'c-put-char-property-fun @@ -1048,8 +1086,8 @@ nil; point is then left undefined." (while (and (< place ,(or limit '(point-max))) - (not (equal (get-text-property place ,property) ,value))) - (setq place (next-single-property-change + (not (equal (c-get-char-property place ,property) ,value))) + (setq place (c-next-single-property-change place ,property nil ,(or limit '(point-max))))) (when (< place ,(or limit '(point-max))) (goto-char place) @@ -1067,10 +1105,15 @@ point is then left undefined." (while (and (> place ,(or limit '(point-min))) - (not (equal (get-text-property (1- place) ,property) ,value))) - (setq place (previous-single-property-change + (not (equal (c-get-char-property (1- place) ,property) ,value))) + (setq place (,(if (and c-use-extents + (fboundp 'previous-single-char-property-change)) + ;; XEmacs > 2005-01-25. + 'previous-single-char-property-change + ;; Emacs and earlier XEmacs. + 'previous-single-property-change) place ,property nil ,(or limit '(point-min))))) - (when (> place ,(or limit '(point-max))) + (when (> place ,(or limit '(point-min))) (goto-char place) (search-backward-regexp ".") ; to set the match-data. (point)))) @@ -1087,9 +1130,9 @@ been put there by c-put-char-property. POINT remains unchanged." (and (< place to) (not (equal (get-text-property place property) value))) - (setq place (next-single-property-change place property nil to))) + (setq place (c-next-single-property-change place property nil to))) (< place to)) - (setq end-place (next-single-property-change place property nil to)) + (setq end-place (c-next-single-property-change place property nil to)) (remove-text-properties place end-place (cons property nil)) ;; Do we have to do anything with stickiness here? (setq place end-place)))) @@ -1106,7 +1149,7 @@ been put there by c-put-char-property. POINT remains unchanged." (if (equal (extent-property ext -property-) val) (delete-extent ext))) nil ,from ,to ,value nil -property-)) - ;; Gnu Emacs + ;; GNU Emacs `(c-clear-char-property-with-value-function ,from ,to ,property ,value))) ;; Macros to put overlays (Emacs) or extents (XEmacs) on buffer text. @@ -1190,42 +1233,43 @@ been put there by c-put-char-property. POINT remains unchanged." (if (< (point) start) (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) +(defmacro c-mark-<-as-paren (pos) ;; Mark the "<" character at POS as a template opener using the - ;; `syntax-table' property via the `category' property. + ;; `syntax-table' property either directly (XEmacs) or via a `category' + ;; property (GNU Emacs). ;; ;; 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)) + (if c-use-category + `(c-put-char-property ,pos 'category 'c-<-as-paren-syntax) + `(c-put-char-property ,pos 'syntax-table 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) +(defmacro c-mark->-as-paren (pos) ;; Mark the ">" character at POS as an sexp list closer using the - ;; syntax-table property. + ;; `syntax-table' property either directly (XEmacs) or via a `category' + ;; property (GNU Emacs). ;; ;; 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. + (if c-use-category + `(c-put-char-property ,pos 'category 'c->-as-paren-syntax) + `(c-put-char-property ,pos 'syntax-table c->-as-paren-syntax))) + +(defmacro c-unmark-<->-as-paren (pos) + ;; Unmark the "<" or "<" character at POS as an sexp list opener using the + ;; `syntax-table' property either directly or indirectly through a + ;; `category' text property. ;; - ;; This function does a hidden buffer change. Note that we use + ;; This function does a hidden buffer change. Note that we try to 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)) + `(c-clear-char-property ,pos ,(if c-use-category ''category ''syntax-table))) (defsubst c-suppress-<->-as-parens () ;; Suppress the syntactic effect of all marked < and > as parens. Note @@ -1306,6 +1350,124 @@ been put there by c-put-char-property. POINT remains unchanged." (widen) (c-set-cpp-delimiters ,beg ,end))))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; The following macros are to be used only in `c-parse-state' and its +;; subroutines. Their main purpose is to simplify the handling of C++/Java +;; template delimiters and CPP macros. In GNU Emacs, this is done slickly by +;; the judicious use of 'category properties. These don't exist in XEmacs. +;; +;; Note: in the following macros, there is no special handling for parentheses +;; inside CPP constructs. That is because CPPs are always syntactically +;; balanced, thanks to `c-neutralize-CPP-line' in cc-mode.el. +(defmacro c-sc-scan-lists-no-category+1+1 (from) + ;; Do a (scan-lists FROM 1 1). Any finishing position which either (i) is + ;; determined by and angle bracket; or (ii) is inside a macro whose start + ;; isn't POINT-MACRO-START doesn't count as a finishing position. + `(let ((here (point)) + (pos (scan-lists ,from 1 1))) + (while (eq (char-before pos) ?>) + (setq pos (scan-lists pos 1 1))) + pos)) + +(defmacro c-sc-scan-lists-no-category+1-1 (from) + ;; Do a (scan-lists FROM 1 -1). Any finishing position which either (i) is + ;; determined by an angle bracket; or (ii) is inside a macro whose start + ;; isn't POINT-MACRO-START doesn't count as a finishing position. + `(let ((here (point)) + (pos (scan-lists ,from 1 -1))) + (while (eq (char-before pos) ?<) + (setq pos (scan-lists pos 1 1)) + (setq pos (scan-lists pos 1 -1))) + pos)) + +(defmacro c-sc-scan-lists-no-category-1+1 (from) + ;; Do a (scan-lists FROM -1 1). Any finishing position which either (i) is + ;; determined by and angle bracket; or (ii) is inside a macro whose start + ;; isn't POINT-MACRO-START doesn't count as a finishing position. + `(let ((here (point)) + (pos (scan-lists ,from -1 1))) + (while (eq (char-after pos) ?<) + (setq pos (scan-lists pos -1 1))) + pos)) + +(defmacro c-sc-scan-lists-no-category-1-1 (from) + ;; Do a (scan-lists FROM -1 -1). Any finishing position which either (i) is + ;; determined by and angle bracket; or (ii) is inside a macro whose start + ;; isn't POINT-MACRO-START doesn't count as a finishing position. + `(let ((here (point)) + (pos (scan-lists ,from -1 -1))) + (while (eq (char-after pos) ?>) + (setq pos (scan-lists pos -1 1)) + (setq pos (scan-lists pos -1 -1))) + pos)) + +(defmacro c-sc-scan-lists (from count depth) + (if c-use-category + `(scan-lists ,from ,count ,depth) + (cond + ((and (eq count 1) (eq depth 1)) + `(c-sc-scan-lists-no-category+1+1 ,from)) + ((and (eq count 1) (eq depth -1)) + `(c-sc-scan-lists-no-category+1-1 ,from)) + ((and (eq count -1) (eq depth 1)) + `(c-sc-scan-lists-no-category-1+1 ,from)) + ((and (eq count -1) (eq depth -1)) + `(c-sc-scan-lists-no-category-1-1 ,from)) + (t (error "Invalid parameter(s) to c-sc-scan-lists"))))) + + +(defun c-sc-parse-partial-sexp-no-category (from to targetdepth stopbefore + oldstate) + ;; Do a parse-partial-sexp using the supplied arguments, disregarding + ;; template/generic delimiters < > and disregarding macros other than the + ;; one at POINT-MACRO-START. + ;; + ;; NOTE that STOPBEFORE must be nil. TARGETDEPTH should be one less than + ;; the depth in OLDSTATE. This function is thus a SPECIAL PURPOSE variation + ;; on parse-partial-sexp, designed for calling from + ;; `c-remove-stale-state-cache'. + ;; + ;; Any finishing position which is determined by an angle bracket delimiter + ;; doesn't count as a finishing position. + ;; + ;; Note there is no special handling of CPP constructs here, since these are + ;; always syntactically balanced (thanks to `c-neutralize-CPP-line'). + (let ((state + (parse-partial-sexp from to targetdepth stopbefore oldstate))) + (while + (and (< (point) to) + ;; We must have hit targetdepth. + (or (eq (char-before) ?<) + (eq (char-before) ?>))) + (setcar state + (if (memq (char-before) '(?> ?\) ?\} ?\])) + (1+ (car state)) + (1- (car state)))) + (setq state + (parse-partial-sexp (point) to targetdepth stopbefore oldstate))) + state)) + +(defmacro c-sc-parse-partial-sexp (from to &optional targetdepth stopbefore + oldstate) + (if c-use-category + `(parse-partial-sexp ,from ,to ,targetdepth ,stopbefore ,oldstate) + `(c-sc-parse-partial-sexp-no-category ,from ,to ,targetdepth ,stopbefore + ,oldstate))) + + +(defvar c-emacs-features) + +(defmacro c-looking-at-non-alphnumspace () + "Are we looking at a character which isn't alphanumeric or space?" + (if (memq 'gen-comment-delim c-emacs-features) + `(looking-at +"\\([;#]\\|\\'\\|\\s(\\|\\s)\\|\\s\"\\|\\s\\\\|\\s$\\|\\s<\\|\\s>\\|\\s!\\)") + `(or (looking-at +"\\([;#]\\|\\'\\|\\s(\\|\\s)\\|\\s\"\\|\\s\\\\|\\s$\\|\\s<\\|\\s>\\)" + (let ((prop (c-get-char-property (point) 'syntax-table))) + (eq prop '(14))))))) ; '(14) is generic comment delimiter. + + (defsubst c-intersect-lists (list alist) ;; return the element of ALIST that matches the first element found ;; in LIST. Uses assq. @@ -1421,8 +1583,8 @@ Notably, null elements in LIST are ignored." (defun c-make-keywords-re (adorn list &optional mode) "Make a regexp that matches all the strings the list. -Duplicates and nil elements in the list are removed. The resulting -regexp may contain zero or more submatch expressions. +Duplicates and nil elements in the list are removed. The +resulting regexp may contain zero or more submatch expressions. If ADORN is t there will be at least one submatch and the first surrounds the matched alternative, and the regexp will also not match @@ -1440,11 +1602,7 @@ The optional MODE specifies the language to get `c-nonsymbol-key' from when it's needed. The default is the current language taken from `c-buffer-is-cc-mode'." - (let (unique) - (dolist (elt list) - (unless (member elt unique) - (push elt unique))) - (setq list (delete nil unique))) + (setq list (delete nil (delete-dups list))) (if list (let (re) @@ -1558,6 +1716,8 @@ non-nil, a caret is prepended to invert the set." (cc-bytecomp-defvar open-paren-in-column-0-is-defun-start) +(defvar lookup-syntax-properties) ;XEmacs. + (defconst c-emacs-features (let (list) @@ -1609,6 +1769,9 @@ non-nil, a caret is prepended to invert the set." (not (end-of-defun)))) (setq list (cons 'argumentative-bod-function list)))) + ;; Record whether the `category' text property works. + (if c-use-category (setq list (cons 'category-properties list))) + (let ((buf (generate-new-buffer " test")) parse-sexp-lookup-properties parse-sexp-ignore-comments @@ -1638,13 +1801,13 @@ non-nil, a caret is prepended to invert the set." "support for the `syntax-table' text property " "is required."))) - ;; Find out if generic comment delimiters work. + ;; Find out if "\\s!" (generic comment delimiters) work. (c-safe (modify-syntax-entry ?x "!") (if (string-match "\\s!" "x") (setq list (cons 'gen-comment-delim list)))) - ;; Find out if generic string delimiters work. + ;; Find out if "\\s|" (generic string delimiters) work. (c-safe (modify-syntax-entry ?x "|") (if (string-match "\\s|" "x") @@ -1691,7 +1854,8 @@ non-nil, a caret is prepended to invert the set." (kill-buffer buf)) ;; See if `parse-partial-sexp' returns the eighth element. - (if (c-safe (>= (length (save-excursion (parse-partial-sexp (point) (point)))) + (if (c-safe (>= (length (save-excursion + (parse-partial-sexp (point) (point)))) 10)) (setq list (cons 'pps-extended-state list)) (error (concat @@ -1707,13 +1871,14 @@ might be present: '8-bit 8 bit syntax entry flags (XEmacs style). '1-bit 1 bit syntax entry flags (Emacs style). -'argumentative-bod-function beginning-of-defun passes ARG through - to a non-null beginning-of-defun-function. It is assumed - the end-of-defun does the same thing. +'argumentative-bod-function beginning-of-defun and end-of-defun pass + ARG through to beginning/end-of-defun-function. 'syntax-properties It works to override the syntax for specific characters in the buffer with the 'syntax-table property. It's always set - CC Mode no longer works in emacsen without this feature. +'category-properties Syntax routines can add a level of indirection to text + properties using the 'category property. 'gen-comment-delim Generic comment delimiters work (i.e. the syntax class `!'). 'gen-string-delim Generic string delimiters work @@ -1804,11 +1969,11 @@ system." (put mode 'c-fallback-mode base-mode)) (defvar c-lang-constants (make-vector 151 0)) -;; This obarray is a cache to keep track of the language constants -;; defined by `c-lang-defconst' and the evaluated values returned by -;; `c-lang-const'. It's mostly used at compile time but it's not +;; Obarray used as a cache to keep track of the language constants. +;; The constants stored are those defined by `c-lang-defconst' and the values +;; computed by `c-lang-const'. It's mostly used at compile time but it's not ;; stored in compiled files. -;; + ;; The obarray contains all the language constants as symbols. The ;; value cells hold the evaluated values as alists where each car is ;; the mode name symbol and the corresponding cdr is the evaluated @@ -1831,7 +1996,9 @@ system." (t ;; Being evaluated interactively. (buffer-file-name))))) - (and file (file-name-base file)))) + (and file + (file-name-sans-extension + (file-name-nondirectory file))))) (defmacro c-lang-defconst-eval-immediately (form) "Can be used inside a VAL in `c-lang-defconst' to evaluate FORM @@ -1899,7 +2066,7 @@ constant. A file is identified by its base name." pre-files) (or (symbolp name) - (error "Not a symbol: %s" name)) + (error "Not a symbol: %S" name)) (when (stringp (car-safe args)) ;; The docstring is hardly used anywhere since there's no normal @@ -1909,7 +2076,7 @@ constant. A file is identified by its base name." (setq args (cdr args))) (or args - (error "No assignments in `c-lang-defconst' for %s" name)) + (error "No assignments in `c-lang-defconst' for %S" name)) ;; Rework ARGS to an association list to make it easier to handle. ;; It's reversed at the same time to make it easier to implement @@ -1923,17 +2090,17 @@ constant. A file is identified by its base name." ((listp (car args)) (mapcar (lambda (lang) (or (symbolp lang) - (error "Not a list of symbols: %s" + (error "Not a list of symbols: %S" (car args))) (intern (concat (symbol-name lang) "-mode"))) (car args))) - (t (error "Not a symbol or a list of symbols: %s" + (t (error "Not a symbol or a list of symbols: %S" (car args))))) val) (or (cdr args) - (error "No value for %s" (car args))) + (error "No value for %S" (car args))) (setq args (cdr args) val (car args)) @@ -1947,7 +2114,7 @@ constant. A file is identified by its base name." ;; dependencies on the `c-lang-const's in VAL.) (setq val (c--macroexpand-all val)) - (setq bindings (cons (cons assigned-mode val) bindings) + (setq bindings `(cons (cons ',assigned-mode (lambda () ,val)) ,bindings) args (cdr args)))) ;; Compile in the other files that have provided source @@ -1959,7 +2126,7 @@ constant. A file is identified by its base name." (mapcar 'car (get sym 'source)))) `(eval-and-compile - (c-define-lang-constant ',name ',bindings + (c-define-lang-constant ',name ,bindings ,@(and pre-files `(',pre-files)))))) (put 'c-lang-defconst 'lisp-indent-function 1) @@ -2024,19 +2191,16 @@ language. NAME and LANG are not evaluated so they should not be quoted." (or (symbolp name) - (error "Not a symbol: %s" name)) + (error "Not a symbol: %S" name)) (or (symbolp lang) - (error "Not a symbol: %s" lang)) + (error "Not a symbol: %S" lang)) (let ((sym (intern (symbol-name name) c-lang-constants)) - mode source-files args) + (mode (when lang (intern (concat (symbol-name lang) "-mode"))))) - (when lang - (setq mode (intern (concat (symbol-name lang) "-mode"))) - (unless (get mode 'c-mode-prefix) - (error - "Unknown language %S since it got no `c-mode-prefix' property" - (symbol-name lang)))) + (or (get mode 'c-mode-prefix) (null mode) + (error "Unknown language %S: no `c-mode-prefix' property" + lang)) (if (eq c-lang-const-expansion 'immediate) ;; No need to find out the source file(s) when we evaluate @@ -2044,49 +2208,56 @@ quoted." ;; `source' property. `',(c-get-lang-constant name nil mode) - (let ((file (c-get-current-file))) - (if file (setq file (intern file))) - ;; Get the source file(s) that must be loaded to get the value - ;; of the constant. If the symbol isn't defined yet we assume - ;; that its definition will come later in this file, and thus - ;; are no file dependencies needed. - (setq source-files (nreverse - ;; Reverse to get the right load order. - (apply 'nconc - (mapcar (lambda (elem) - (if (eq file (car elem)) - nil ; Exclude our own file. - (list (car elem)))) - (get sym 'source)))))) - - ;; Make some effort to do a compact call to - ;; `c-get-lang-constant' since it will be compiled in. - (setq args (and mode `(',mode))) - (if (or source-files args) - (setq args (cons (and source-files `',source-files) - args))) - - (if (or (eq c-lang-const-expansion 'call) - (and (not c-lang-const-expansion) - (not mode)) - load-in-progress - (not (boundp 'byte-compile-dest-file)) - (not (stringp byte-compile-dest-file))) - ;; Either a straight call is requested in the context, or - ;; we're in an "uncontrolled" context and got no language, - ;; or we're not being byte compiled so the compile time - ;; stuff below is unnecessary. - `(c-get-lang-constant ',name ,@args) - - ;; Being compiled. If the loading and compiling version is - ;; the same we use a value that is evaluated at compile time, - ;; otherwise it's evaluated at runtime. - `(if (eq c-version-sym ',c-version-sym) - (cc-eval-when-compile - (c-get-lang-constant ',name ,@args)) - (c-get-lang-constant ',name ,@args)))))) - -(defvar c-lang-constants-under-evaluation nil) + (let ((source-files + (let ((file (c-get-current-file))) + (if file (setq file (intern file))) + ;; Get the source file(s) that must be loaded to get the value + ;; of the constant. If the symbol isn't defined yet we assume + ;; that its definition will come later in this file, and thus + ;; are no file dependencies needed. + (nreverse + ;; Reverse to get the right load order. + (apply 'nconc + (mapcar (lambda (elem) + (if (eq file (car elem)) + nil ; Exclude our own file. + (list (car elem)))) + (get sym 'source)))))) + ;; Make some effort to do a compact call to + ;; `c-get-lang-constant' since it will be compiled in. + (args (and mode `(',mode)))) + + (if (or source-files args) + (push (and source-files `',source-files) args)) + + (if (or (eq c-lang-const-expansion 'call) + (and (not c-lang-const-expansion) + (not mode)) + load-in-progress + (not (boundp 'byte-compile-dest-file)) + (not (stringp byte-compile-dest-file))) + ;; Either a straight call is requested in the context, or + ;; we're in an "uncontrolled" context and got no language, + ;; or we're not being byte compiled so the compile time + ;; stuff below is unnecessary. + `(c-get-lang-constant ',name ,@args) + + ;; Being compiled. If the loading and compiling version is + ;; the same we use a value that is evaluated at compile time, + ;; otherwise it's evaluated at runtime. + `(if (eq c-version-sym ',c-version-sym) + (cc-eval-when-compile + (c-get-lang-constant ',name ,@args)) + (c-get-lang-constant ',name ,@args))))))) + +(defvar c-lang-constants-under-evaluation nil + "Alist of constants in the process of being evaluated. +The `cdr' of each entry indicates how far we've looked in the list +of definitions, so that the def for var FOO in c-mode can be defined in +terms of the def for that same var FOO (which will then rely on the +fallback definition for all modes, to break the cycle).") + +(defconst c-lang--novalue "novalue") (defun c-get-lang-constant (name &optional source-files mode) ;; Used by `c-lang-const'. @@ -2152,7 +2323,7 @@ quoted." ;; mode might have an explicit entry before that. (eq (setq value (c-find-assignment-for-mode (cdr source-pos) mode nil name)) - c-lang-constants) + c-lang--novalue) ;; Try again with the fallback mode from the ;; original position. Note that ;; `c-buffer-is-cc-mode' still is the real mode if @@ -2160,22 +2331,22 @@ quoted." (eq (setq value (c-find-assignment-for-mode (setcdr source-pos backup-source-pos) fallback t name)) - c-lang-constants))) + c-lang--novalue))) ;; A simple lookup with no fallback mode. (eq (setq value (c-find-assignment-for-mode (cdr source-pos) mode t name)) - c-lang-constants)) + c-lang--novalue)) (error - "`%s' got no (prior) value in %s (might be a cyclic reference)" + "`%s' got no (prior) value in %S (might be a cyclic reference)" name mode)) (condition-case err - (setq value (eval value)) + (setq value (funcall value)) (error ;; Print a message to aid in locating the error. We don't ;; print the error itself since that will be done later by ;; some caller higher up. - (message "Eval error in the `c-lang-defconst' for `%s' in %s:" + (message "Eval error in the `c-lang-defconst' for `%S' in %s:" sym mode) (makunbound sym) (signal (car err) (cdr err)))) @@ -2183,13 +2354,13 @@ quoted." (set sym (cons (cons mode value) (symbol-value sym))) value)))) -(defun c-find-assignment-for-mode (source-pos mode match-any-lang name) +(defun c-find-assignment-for-mode (source-pos mode match-any-lang _name) ;; Find the first assignment entry that applies to MODE at or after ;; SOURCE-POS. If MATCH-ANY-LANG is non-nil, entries with `t' as ;; the language list are considered to match, otherwise they don't. ;; On return SOURCE-POS is updated to point to the next assignment ;; after the returned one. If no assignment is found, - ;; `c-lang-constants' is returned as a magic value. + ;; `c-lang--novalue' is returned as a magic value. ;; ;; SOURCE-POS is a vector that points out a specific assignment in ;; the double alist that's used in the `source' property. The first @@ -2245,7 +2416,7 @@ quoted." match-any-lang) (throw 'found (cdr assignment)))) - c-lang-constants))) + c-lang--novalue))) (defun c-lang-major-mode-is (mode) ;; `c-major-mode-is' expands to a call to this function inside @@ -2266,4 +2437,8 @@ quoted." (cc-provide 'cc-defs) +;;; Local Variables: +;;; indent-tabs-mode: t +;;; tab-width: 8 +;;; End: ;;; cc-defs.el ends here diff --git a/lisp/progmodes/cc-engine.el b/lisp/progmodes/cc-engine.el index 3e14dd18397..9a6e975dd93 100644 --- a/lisp/progmodes/cc-engine.el +++ b/lisp/progmodes/cc-engine.el @@ -147,18 +147,19 @@ (cc-require-when-compile 'cc-langs) (cc-require 'cc-vars) +(eval-when-compile (require 'cl)) + ;; Make declarations for all the `c-lang-defvar' variables in cc-langs. (defmacro c-declare-lang-variables () `(progn - ,@(apply 'nconc - (mapcar (lambda (init) - `(,(if (elt init 2) - `(defvar ,(car init) nil ,(elt init 2)) - `(defvar ,(car init) nil)) - (make-variable-buffer-local ',(car init)))) - (cdr c-lang-variable-inits))))) + ,@(mapcan (lambda (init) + `(,(if (elt init 2) + `(defvar ,(car init) nil ,(elt init 2)) + `(defvar ,(car init) nil)) + (make-variable-buffer-local ',(car init)))) + (cdr c-lang-variable-inits)))) (c-declare-lang-variables) @@ -533,7 +534,7 @@ comment at the start of cc-engine.el for more info." (while (progn (when (eq (get-text-property (point) 'c-type) value) (c-clear-char-property (point) 'c-type)) - (goto-char (next-single-property-change (point) 'c-type nil to)) + (goto-char (c-next-single-property-change (point) 'c-type nil to)) (< (point) to))))) @@ -845,7 +846,6 @@ comment at the start of cc-engine.el for more info." ;; Record this as the first token if not starting inside it. (setq tok start)) - ;; The following while loop goes back one sexp (balanced parens, ;; etc. with contents, or symbol or suchlike) each iteration. This ;; movement is accomplished with a call to c-backward-sexp approx 170 @@ -1052,7 +1052,10 @@ comment at the start of cc-engine.el for more info." ;; Just gone back over a brace block? ((and (eq (char-after) ?{) - (not (c-looking-at-inexpr-block lim nil t))) + (not (c-looking-at-inexpr-block lim nil t)) + (save-excursion + (c-backward-token-2 1 t nil) + (not (looking-at "=\\([^=]\\|$\\)")))) (save-excursion (c-forward-sexp) (point))) ;; Just gone back over some paren block? @@ -1720,7 +1723,7 @@ comment at the start of cc-engine.el for more info." ;; the cases when the marked rung is complete. ;; (`next-single-property-change' is certain to move at least one ;; step forward.) - (setq rung-pos (1- (next-single-property-change + (setq rung-pos (1- (c-next-single-property-change rung-is-marked 'c-is-sws nil rung-end-pos))) ;; Got no marked rung here. Since the simple ws might have started ;; inside a line comment or cpp directive we must set `rung-pos' as @@ -1736,7 +1739,7 @@ comment at the start of cc-engine.el for more info." ;; The following search is the main reason that `c-in-sws' ;; and `c-is-sws' aren't combined to one property. - (goto-char (next-single-property-change + (goto-char (c-next-single-property-change (point) 'c-in-sws nil (point-max))) (unless (get-text-property (point) 'c-is-sws) ;; If the `c-in-sws' region extended past the last @@ -1858,7 +1861,7 @@ comment at the start of cc-engine.el for more info." ;; possible since we can't be in the ending ws of a line comment or ;; cpp directive now. (if (setq rung-is-marked next-rung-is-marked) - (setq rung-pos (1- (next-single-property-change + (setq rung-pos (1- (c-next-single-property-change rung-is-marked 'c-is-sws nil rung-end-pos))) (setq rung-pos next-rung-pos)) (setq safe-start t))) @@ -1936,7 +1939,7 @@ comment at the start of cc-engine.el for more info." (unless (get-text-property (point) 'c-is-sws) ;; If the `c-in-sws' region extended past the first ;; `c-is-sws' char we have to go forward a bit. - (goto-char (next-single-property-change + (goto-char (c-next-single-property-change (point) 'c-is-sws))) (c-debug-sws-msg @@ -2175,7 +2178,6 @@ comment at the start of cc-engine.el for more info." ;; 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. @@ -2545,7 +2547,7 @@ comment at the start of cc-engine.el for more info." (setq pos here+) (c-safe (while - (setq ren+1 (scan-lists pos 1 1)) ; might signal + (setq ren+1 (c-sc-scan-lists pos 1 1)) ; might signal (setq lonely-rens (cons ren+1 lonely-rens) pos ren+1))))) @@ -2557,7 +2559,7 @@ comment at the start of cc-engine.el for more info." (c-safe (while (and lonely-rens ; actual values aren't used. - (setq pa (scan-lists pos -1 1))) + (setq pa (c-sc-scan-lists pos -1 1))) (setq pos pa) (setq lonely-rens (cdr lonely-rens))))) pos)) @@ -2713,8 +2715,8 @@ comment at the start of cc-engine.el for more info." (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 + (and (setq ce (c-sc-scan-lists bra -1 -1)) ; back past )/]/}; might signal + (setq bra (c-sc-scan-lists ce -1 1)) ; back past (/[/{; might signal (or (> bra here) ;(> ce here) (and (< ce here) @@ -2766,7 +2768,7 @@ comment at the start of cc-engine.el for more info." (not (c-beginning-of-macro)))) (setq c-state-cache (cons (cons (1- bra+1) - (scan-lists bra+1 1 1)) + (c-sc-scan-lists bra+1 1 1)) (if (consp (car c-state-cache)) (cdr c-state-cache) c-state-cache))) @@ -2795,7 +2797,7 @@ comment at the start of cc-engine.el for more info." 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+1 ; just after L bra-ce. bra+1s ; list of OLD values of bra+1. mstart) ; start of a macro. @@ -2816,9 +2818,9 @@ comment at the start of cc-engine.el for more info." ;; 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 + (setq pa+1 (c-sc-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 + (setq ren+1 (c-sc-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))) @@ -2842,7 +2844,7 @@ comment at the start of cc-engine.el for more info." ;; 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. + (c-safe (setq ren+1 (c-sc-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) @@ -2945,7 +2947,7 @@ comment at the start of cc-engine.el for more info." ;; 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 + ;; (car c-state-cache). There can be no open parens/braces/brackets ;; between `start-point'/`start-point-actual-macro-start' and HERE, ;; due to the interface spec to this function. (setq pos (if (and start-point-actual-macro-end @@ -2969,7 +2971,7 @@ comment at the start of cc-engine.el for more info." ;; Scan! (setq pps-state - (parse-partial-sexp + (c-sc-parse-partial-sexp (point) (if (< (point) pps-point) pps-point here) target-depth nil pps-state)) @@ -3000,9 +3002,10 @@ comment at the start of cc-engine.el for more info." ))) (if (< (point) pps-point) - (setq pps-state (parse-partial-sexp (point) pps-point - nil nil ; TARGETDEPTH, STOPBEFORE - pps-state))) + (setq pps-state (c-sc-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'. @@ -3123,12 +3126,15 @@ comment at the start of cc-engine.el for more info." (save-restriction (narrow-to-region here-bol (point-max)) (setq pos here-lit-start) - (c-safe (while (setq pa (scan-lists pos -1 1)) + (c-safe (while (setq pa (c-sc-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. + ((save-restriction + (narrow-to-region too-far-back (point-max)) + (setq ren (c-safe (c-sc-scan-lists pos -1 -1)))) + + ;; CASE 3: After a }/)/] before `here''s BOL. (list (1+ ren) (and dropped-cons pos) nil)) ; Return value (t @@ -3311,7 +3317,7 @@ comment at the start of cc-engine.el for more info." (setq res (c-remove-stale-state-cache start-point here here-bopl)) (setq cache-pos (car res) scan-backward-pos (cadr res) - cons-separated (car (cddr res)) + cons-separated (car (cddr res)) bopl-state (cadr (cddr res))) ; will be nil if (< here-bopl ; start-point) (if (and scan-backward-pos @@ -3350,15 +3356,19 @@ comment at the start of cc-engine.el for more info." ;; 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))))) + (if (eval-when-compile (memq 'category-properties c-emacs-features)) + ;; Emacs + (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)))) + ;; XEmacs + (c-invalidate-state-cache-1 here))) (defmacro c-state-maybe-marker (place marker) ;; If PLACE is non-nil, return a marker marking it, otherwise nil. @@ -3386,13 +3396,17 @@ comment at the start of cc-engine.el for more info." ;; 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)))) + (if (eval-when-compile (memq 'category-properties c-emacs-features)) + ;; Emacs + (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)))) + ;; XEmacs + (c-parse-state-1)) (setq c-state-old-cpp-beg (c-state-maybe-marker here-cpp-beg c-state-old-cpp-beg-marker) c-state-old-cpp-end @@ -3407,6 +3421,7 @@ comment at the start of cc-engine.el for more info." (defvar c-parse-state-point nil) (defvar c-parse-state-state nil) +(make-variable-buffer-local 'c-parse-state-state) (defun c-record-parse-state-state () (setq c-parse-state-point (point)) (setq c-parse-state-state @@ -3414,9 +3429,9 @@ comment at the start of cc-engine.el for more info." (lambda (arg) (let ((val (symbol-value arg))) (cons arg - (if (consp val) - (copy-tree val) - val)))) + (cond ((consp val) (copy-tree val)) + ((markerp val) (copy-marker val)) + (t val))))) '(c-state-cache c-state-cache-good-pos c-state-nonlit-pos-cache @@ -3436,7 +3451,11 @@ comment at the start of cc-engine.el for more info." (concat "(setq " (mapconcat (lambda (arg) - (format "%s %s%s" (car arg) (if (atom (cdr arg)) "" "'") (cdr arg))) + (format "%s %s%s" (car arg) + (if (atom (cdr arg)) "" "'") + (if (markerp (cdr arg)) + (format "(copy-marker %s)" (marker-position (cdr arg))) + (cdr arg)))) c-parse-state-state " ") ")"))) @@ -4181,7 +4200,7 @@ comment at the start of cc-engine.el for more info." ;; Use `parse-partial-sexp' from a safe position down to the point to check ;; if it's outside comments and strings. (save-excursion - (let ((pos (point)) safe-pos state pps-end-pos) + (let ((pos (point)) safe-pos state) ;; Pick a safe position as close to the point as possible. ;; ;; FIXME: Consult `syntax-ppss' here if our cache doesn't give a good @@ -4263,16 +4282,18 @@ comment at the start of cc-engine.el for more info." ;; loops when it hasn't succeeded. (while (and - (< (skip-chars-backward skip-chars limit) 0) + (let ((pos (point))) + (while (and + (< (skip-chars-backward skip-chars limit) 0) + ;; Don't stop inside a literal. + (when (setq lit-beg (c-ssb-lit-begin)) + (goto-char lit-beg) + t))) + (< (point) pos)) (let ((pos (point)) state-2 pps-end-pos) (cond - ;; Don't stop inside a literal - ((setq lit-beg (c-ssb-lit-begin)) - (goto-char lit-beg) - t) - ((and paren-level (save-excursion (setq state-2 (parse-partial-sexp @@ -4778,7 +4799,7 @@ comment at the start of cc-engine.el for more info." (unless cfd-prop-match (save-excursion (while (progn - (goto-char (next-single-property-change + (goto-char (c-next-single-property-change (point) 'c-type nil cfd-limit)) (and (< (point) cfd-limit) (not (eq (c-get-char-property (1- (point)) 'c-type) @@ -4818,7 +4839,7 @@ comment at the start of cc-engine.el for more info." ;; Pseudo match inside a comment or string literal. Skip out ;; of comments and string literals. (while (progn - (goto-char (next-single-property-change + (goto-char (c-next-single-property-change (point) 'face nil cfd-limit)) (and (< (point) cfd-limit) (c-got-face-at (point) c-literal-faces)))) @@ -4873,14 +4894,17 @@ comment at the start of cc-engine.el for more info." ;; it should return non-nil to ensure that the next search will find them. ;; ;; Such a spot is: - ;; o The first token after bob. - ;; o The first token after the end of submatch 1 in - ;; `c-decl-prefix-or-start-re' when that submatch matches. - ;; o The start of each `c-decl-prefix-or-start-re' match when - ;; submatch 1 doesn't match. - ;; o The first token after the end of each occurrence of the - ;; `c-type' text property with the value `c-decl-end', provided - ;; `c-type-decl-end-used' is set. + ;; o The first token after bob. + ;; o The first token after the end of submatch 1 in + ;; `c-decl-prefix-or-start-re' when that submatch matches. This + ;; submatch is typically a (L or R) brace or paren, a ;, or a ,. + ;; o The start of each `c-decl-prefix-or-start-re' match when + ;; submatch 1 doesn't match. This is, for example, the keyword + ;; "class" in Pike. + ;; o The start of a previously recognized declaration; "recognized" + ;; means that the last char of the previous token has a `c-type' + ;; text property with the value `c-decl-end'; this only holds + ;; when `c-type-decl-end-used' is set. ;; ;; Only a spot that match CFD-DECL-RE and whose face is in the ;; CFD-FACE-CHECKLIST list causes CFD-FUN to be called. The face @@ -4912,7 +4936,7 @@ comment at the start of cc-engine.el for more info." ;; ;; This function might do hidden buffer changes. - (let ((cfd-start-pos (point)) + (let ((cfd-start-pos (point)) ; never changed (cfd-buffer-end (point-max)) ;; The end of the token preceding the decl spot last found ;; with `c-decl-prefix-or-start-re'. `cfd-limit' if there's @@ -4951,10 +4975,20 @@ comment at the start of cc-engine.el for more info." ;; statement or declaration, which is earlier than the first ;; returned match. + ;; This `cond' moves back over any literals or macros. It has special + ;; handling for when the region being searched is entirely within a + ;; macro. It sets `cfd-continue-pos' (unless we've reached + ;; `cfd-limit'). (cond ;; First we need to move to a syntactically relevant position. ;; Begin by backing out of comment or string literals. + ;; + ;; This arm of the cond actually triggers if we're in a literal, + ;; and cfd-limit is at most at BONL. ((and + ;; This arm of the `and' moves backwards out of a literal when + ;; the face at point is a literal face. In this case, its value + ;; is always non-nil. (when (c-got-face-at (point) c-literal-faces) ;; Try to use the faces to back up to the start of the ;; literal. FIXME: What if the point is on a declaration @@ -4983,7 +5017,7 @@ comment at the start of cc-engine.el for more info." (let ((range (c-literal-limits))) (if range (goto-char (car range))))) - (setq start-in-literal (point))) + (setq start-in-literal (point))) ; end of `and' arm. ;; The start is in a literal. If the limit is in the same ;; one we don't have to find a syntactic position etc. We @@ -4994,22 +5028,22 @@ comment at the start of cc-engine.el for more info." (save-excursion (goto-char cfd-start-pos) (while (progn - (goto-char (next-single-property-change + (goto-char (c-next-single-property-change (point) 'face nil cfd-limit)) (and (< (point) cfd-limit) (c-got-face-at (point) c-literal-faces)))) - (= (point) cfd-limit))) + (= (point) cfd-limit))) ; end of `cond' arm condition ;; Completely inside a literal. Set up variables to trig the ;; (< cfd-continue-pos cfd-start-pos) case below and it'll ;; find a suitable start position. - (setq cfd-continue-pos start-in-literal)) + (setq cfd-continue-pos start-in-literal)) ; end of `cond' arm ;; Check if the region might be completely inside a macro, to ;; optimize that like the completely-inside-literal above. ((save-excursion (and (= (forward-line 1) 0) - (bolp) ; forward-line has funny behavior at eob. + (bolp) ; forward-line has funny behavior at eob. (>= (point) cfd-limit) (progn (backward-char) (eq (char-before) ?\\)))) @@ -5019,6 +5053,8 @@ comment at the start of cc-engine.el for more info." (setq cfd-continue-pos (1- cfd-start-pos) start-in-macro t)) + ;; The default arm of the `cond' moves back over any macro we're in + ;; and over any syntactic WS. It sets `c-find-decl-syntactic-pos'. (t ;; Back out of any macro so we don't miss any declaration ;; that could follow after it. @@ -5065,10 +5101,10 @@ comment at the start of cc-engine.el for more info." (< (point) cfd-limit)) ;; Do an initial search now. In the bob case above it's ;; only done to search for a `c-decl-end' spot. - (c-find-decl-prefix-search)) + (c-find-decl-prefix-search)) ; sets cfd-continue-pos (setq c-find-decl-match-pos (and (< cfd-match-pos cfd-start-pos) - cfd-match-pos))))) + cfd-match-pos))))) ; end of `cond' ;; Advance `cfd-continue-pos' if it's before the start position. ;; The closest continue position that might have effect at or @@ -5127,7 +5163,7 @@ comment at the start of cc-engine.el for more info." ;; `cfd-match-pos' so we can continue at the start position. ;; (Note that we don't get here if the first match is below ;; it.) - (goto-char cfd-start-pos))) + (goto-char cfd-start-pos))) ; end of `cond' ;; Delete found matches if they are before our new continue ;; position, so that `c-find-decl-prefix-search' won't back up @@ -5136,7 +5172,7 @@ comment at the start of cc-engine.el for more info." (when (and cfd-re-match (< cfd-re-match cfd-continue-pos)) (setq cfd-re-match nil)) (when (and cfd-prop-match (< cfd-prop-match cfd-continue-pos)) - (setq cfd-prop-match nil))) + (setq cfd-prop-match nil))) ; end of `when' (if syntactic-pos ;; This is the normal case and we got a proper syntactic @@ -5157,9 +5193,10 @@ comment at the start of cc-engine.el for more info." ;; good start position for the search, so do it. (c-find-decl-prefix-search))) - ;; Now loop. Round what? (ACM, 2006/7/5). We already got the first match. - + ;; Now loop, one decl spot per iteration. We already have the first + ;; match in `cfd-match-pos'. (while (progn + ;; Go forward over "false matches", one per iteration. (while (and (< cfd-match-pos cfd-limit) @@ -5200,10 +5237,10 @@ comment at the start of cc-engine.el for more info." (goto-char cfd-continue-pos) t))) - (< (point) cfd-limit)) - (c-find-decl-prefix-search)) + (< (point) cfd-limit)) ; end of "false matches" condition + (c-find-decl-prefix-search)) ; end of "false matches" loop - (< (point) cfd-limit)) + (< (point) cfd-limit)) ; end of condition for "decl-spot" while (when (and (>= (point) cfd-start-pos) @@ -5231,7 +5268,7 @@ comment at the start of cc-engine.el for more info." ;; The matched token was the last thing in the macro, ;; so the whole match is bogus. (setq cfd-macro-end 0) - nil)))) + nil)))) ; end of when condition (c-debug-put-decl-spot-faces cfd-match-pos (point)) (if (funcall cfd-fun cfd-match-pos (/= cfd-macro-end 0)) @@ -5411,8 +5448,8 @@ comment at the start of cc-engine.el for more info." (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)))) + (c-unmark-<->-as-paren (1- (point)))) + (c-unmark-<->-as-paren pos)))) (defun c-clear->-pair-props (&optional pos) ;; POS (default point) is at a > character. If it is marked with @@ -5428,8 +5465,8 @@ comment at the start of cc-engine.el for more info." (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)))) + (c-unmark-<->-as-paren (point))) + (c-unmark-<->-as-paren pos)))) (defun c-clear-<>-pair-props (&optional pos) ;; POS (default point) is at a < or > character. If it has an @@ -5518,9 +5555,10 @@ comment at the start of cc-engine.el for more info." (c-syntactic-skip-backward "^;{}" (c-determine-limit 512)) (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) + ;; Remove the syntax-table/category properties from each pertinent <...> + ;; pair. Firsly, the ones with the < before beg and > after beg. + (while + (c-search-forward-char-property 'syntax-table c-<-as-paren-syntax beg) (if (c-clear-<-pair-props-if-match-after beg (1- (point))) (setq need-new-beg t))) @@ -5531,7 +5569,7 @@ comment at the start of cc-engine.el for more info." ;; 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) + (while (c-search-backward-char-property 'syntax-table c->-as-paren-syntax end) (if (c-clear->-pair-props-if-match-before end) (setq need-new-end t))) @@ -5544,8 +5582,6 @@ comment at the start of cc-engine.el for more info." (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 ;; c-recognize-<>-arglists' is set. It ensures that no "<" or ">" @@ -5880,7 +5916,6 @@ comment at the start of cc-engine.el for more info." ;; Recursive part of `c-forward-<>-arglist'. ;; ;; This function might do hidden buffer changes. - (let ((start (point)) res pos tmp ;; Cover this so that any recorded found type ranges are ;; automatically lost if it turns out to not be an angle @@ -5916,32 +5951,31 @@ comment at the start of cc-engine.el for more info." (while (and (progn (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) - (c-record-found-types t)) - (c-forward-type)))) - - (c-forward-syntactic-ws) - - (when (or (looking-at "extends") - (looking-at "super")) - (forward-word) - (c-forward-syntactic-ws) + (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) (c-record-found-types t)) - (c-forward-type) - (c-forward-syntactic-ws)))))) + (c-forward-type)))) + + (c-forward-syntactic-ws) + + (when (or (looking-at "extends") + (looking-at "super")) + (forward-word) + (c-forward-syntactic-ws) + (let ((c-promote-possible-types t) + (c-record-found-types t)) + (c-forward-type) + (c-forward-syntactic-ws))))) - (setq pos (point)) ; e.g. first token inside the '<' + (setq pos (point)) ; e.g. first token inside the '<' ;; Note: These regexps exploit the match order in \| so ;; that "<>" is matched by "<" rather than "[^>:-]>". @@ -5957,7 +5991,7 @@ comment at the start of cc-engine.el for more info." ;; Either an operator starting with '>' or the end of ;; the angle bracket arglist. - (if (looking-at c->-op-cont-regexp) + (if (looking-at c->-op-without->-cont-regexp) (progn (goto-char (match-end 0)) t) ; Continue the loop. @@ -6006,7 +6040,6 @@ comment at the start of cc-engine.el for more info." (c-keyword-member (c-keyword-sym (match-string 1)) 'c-<>-type-kwds))))))) - ;; It was an angle bracket arglist. (setq c-record-found-types subres) @@ -6032,7 +6065,7 @@ comment at the start of cc-engine.el for more info." (or (and (eq (char-before) ?&) (not (eq (char-after) ?&))) (eq (char-before) ?,))) - ;; Just another argument. Record the position. The + ;; 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))) @@ -6299,7 +6332,8 @@ comment at the start of cc-engine.el for more info." ;; `*-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 identifier that might be a type; or + ;; o - 'maybe if it's an identifier that might be a type; + ;; o - 'decltype if it's a decltype(variable) declaration; - 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. @@ -6329,6 +6363,16 @@ comment at the start of cc-engine.el for more info." (setq res 'prefix))) (cond + ((looking-at c-typeof-key) ; e.g. C++'s "decltype". + (goto-char (match-end 1)) + (c-forward-syntactic-ws) + (setq res (and (eq (char-after) ?\() + (c-safe (c-forward-sexp)) + 'decltype)) + (if res + (c-forward-syntactic-ws) + (goto-char start))) + ((looking-at c-type-prefix-key) ; e.g. "struct", "class", but NOT ; "typedef". (goto-char (match-end 1)) @@ -6444,18 +6488,19 @@ 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) ; 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 ;; too. - (when c-opt-type-suffix-key + (when c-opt-type-suffix-key ; e.g. "..." (while (looking-at c-opt-type-suffix-key) (goto-char (match-end 1)) (c-forward-syntactic-ws))) @@ -6532,7 +6577,7 @@ comment at the start of cc-engine.el for more info." (progn (c-forward-syntactic-ws) t) (if (looking-at "(") (c-go-list-forward) - t))) + t))) (defmacro c-pull-open-brace (ps) ;; Pull the next open brace from PS (which has the form of paren-state), @@ -6543,6 +6588,36 @@ comment at the start of cc-engine.el for more info." (prog1 (car ,ps) (setq ,ps (cdr ,ps))))) +(defun c-back-over-member-initializer-braces () + ;; Point is just after a closing brace/parenthesis. Try to parse this as a + ;; C++ member initializer list, going back to just after the introducing ":" + ;; and returning t. Otherwise return nil, leaving point unchanged. + (let ((here (point)) res) + (setq res + (catch 'done + (when (not (c-go-list-backward)) + (throw 'done nil)) + (c-backward-syntactic-ws) + (when (not (c-simple-skip-symbol-backward)) + (throw 'done nil)) + (c-backward-syntactic-ws) + + (while (eq (char-before) ?,) + (backward-char) + (c-backward-syntactic-ws) + (when (not (memq (char-before) '(?\) ?}))) + (throw 'done nil)) + (when (not (c-go-list-backward)) + (throw 'done nil)) + (c-backward-syntactic-ws) + (when (not (c-simple-skip-symbol-backward)) + (throw 'done nil)) + (c-backward-syntactic-ws)) + + (eq (char-before) ?:))) + (or res (goto-char here)) + res)) + (defun c-back-over-member-initializers () ;; Test whether we are in a C++ member initializer list, and if so, go back ;; to the introducing ":", returning the position of the opening paren of @@ -6667,6 +6742,13 @@ comment at the start of cc-engine.el for more info." ;; Foo::Foo (int b) : Base (b) {} ;; car ^ ^ point ;; + ;; auto foo = 5; + ;; car ^ ^ point + ;; auto cplusplus_11 (int a, char *b) -> decltype (bar): + ;; car ^ ^ point + ;; + ;; + ;; ;; 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 @@ -6732,6 +6814,10 @@ 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 + ;; This stores `kwd-sym' of the symbol before the current one. + ;; This is needed to distinguish the C++11 version of "auto" from + ;; the pre C++11 meaning. + backup-kwd-sym ;; Set if we've found a specifier (apart from "typedef") that makes ;; the defined identifier(s) types. at-type-decl @@ -6740,6 +6826,10 @@ comment at the start of cc-engine.el for more info." ;; Set if we've found a specifier that can start a declaration ;; where there's no type. maybe-typeless + ;; Save the value of kwd-sym between loops of the "Check for a + ;; type" loop. Needed to distinguish a C++11 "auto" from a pre + ;; C++11 one. + prev-kwd-sym ;; If a specifier is found that also can be a type prefix, ;; these flags are set instead of those above. If we need to ;; back up an identifier, they are copied to the real flag @@ -6757,6 +6847,8 @@ comment at the start of cc-engine.el for more info." backup-if-not-cast ;; For casts, the return position. cast-end + ;; Have we got a new-style C++11 "auto"? + new-style-auto ;; Save `c-record-type-identifiers' and ;; `c-record-ref-identifiers' since ranges are recorded ;; speculatively and should be thrown away if it turns out @@ -6775,11 +6867,12 @@ comment at the start of cc-engine.el for more info." (let* ((start (point)) kwd-sym kwd-clause-end found-type) ;; Look for a specifier keyword clause. - (when (or (looking-at c-prefix-spec-kwds-re) + (when (or (looking-at c-prefix-spec-kwds-re) ;FIXME!!! includes auto (and (c-major-mode-is 'java-mode) (looking-at "@[A-Za-z0-9]+"))) - (if (looking-at c-typedef-key) - (setq at-typedef t)) + (save-match-data + (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) @@ -6787,6 +6880,12 @@ comment at the start of cc-engine.el for more info." (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 (and (c-major-mode-is 'c++-mode) ; C++11 style "auto"? + (eq prev-kwd-sym (c-keyword-sym "auto")) + (looking-at "[=(]")) ; FIXME!!! proper regexp. + (setq new-style-auto t) + (setq found-type nil) + (goto-char start)) ; position of foo in "auto foo" (when at-type ;; Got two identifiers with nothing but whitespace @@ -6805,6 +6904,7 @@ comment at the start of cc-engine.el for more info." (setq backup-at-type at-type backup-type-start type-start backup-id-start id-start + backup-kwd-sym kwd-sym at-type found-type type-start start id-start (point) @@ -6860,6 +6960,7 @@ comment at the start of cc-engine.el for more info." ;; specifier keyword and we know we're in a ;; declaration. (setq at-decl-or-cast t) + (setq prev-kwd-sym kwd-sym) (goto-char kwd-clause-end)))) @@ -7051,50 +7152,60 @@ comment at the start of cc-engine.el for more info." (c-forward-syntactic-ws)) - (when (and (or maybe-typeless backup-maybe-typeless) - (not got-identifier) - (not got-prefix) - at-type) + (when (or (and new-style-auto + (looking-at c-auto-ops-re)) + (and (or maybe-typeless backup-maybe-typeless) + (not got-identifier) + (not got-prefix) + at-type)) ;; Have found no identifier but `c-typeless-decl-kwds' has ;; matched so we know we're inside a declaration. The ;; preceding type must be the identifier instead. (c-fdoc-shift-type-backward)) + ;; Prepare the "-> type;" for fontification later on. + (when (and new-style-auto + (looking-at c-haskell-op-re)) + (save-excursion + (goto-char (match-end 0)) + (c-forward-syntactic-ws) + (setq type-start (point)) + (setq at-type (c-forward-type)))) + (setq at-decl-or-cast (catch 'at-decl-or-cast ;; CASE 1 - (when (> paren-depth 0) - ;; Encountered something inside parens that isn't matched by - ;; the `c-type-decl-*' regexps, so it's not a type decl - ;; expression. Try to skip out to the same paren depth to - ;; not confuse the cast check below. - (c-safe (goto-char (scan-lists (point) 1 paren-depth))) - ;; 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 at-decl-end - (looking-at (cond ((eq context '<>) "[,>]") - (context "[,\)]") - (t "[,;]")))) - - ;; Now we've collected info about various characteristics of - ;; the construct we're looking at. Below follows a decision - ;; tree based on that. It's ordered to check more certain - ;; signs before less certain ones. - - (if got-identifier - (progn - - ;; CASE 2 - (when (and (or at-type maybe-typeless) - (not (or got-prefix got-parens))) - ;; Got another identifier directly after the type, so it's a - ;; declaration. - (throw 'at-decl-or-cast t)) + (when (> paren-depth 0) + ;; Encountered something inside parens that isn't matched by + ;; the `c-type-decl-*' regexps, so it's not a type decl + ;; expression. Try to skip out to the same paren depth to + ;; not confuse the cast check below. + (c-safe (goto-char (scan-lists (point) 1 paren-depth))) + ;; 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 at-decl-end + (looking-at (cond ((eq context '<>) "[,>]") + (context "[,\)]") + (t "[,;]")))) + + ;; Now we've collected info about various characteristics of + ;; the construct we're looking at. Below follows a decision + ;; tree based on that. It's ordered to check more certain + ;; signs before less certain ones. + + (if got-identifier + (progn + ;; CASE 2 + (when (and (or at-type maybe-typeless) + (not (or got-prefix got-parens))) + ;; Got another identifier directly after the type, so it's a + ;; declaration. + (throw 'at-decl-or-cast t)) (when (and got-parens (not got-prefix) @@ -7116,9 +7227,9 @@ comment at the start of cc-engine.el for more info." (c-fdoc-shift-type-backward))) ;; Found no identifier. - (if backup-at-type - (progn + (if backup-at-type + (progn ;; CASE 3 (when (= (point) start) @@ -7141,250 +7252,251 @@ comment at the start of cc-engine.el for more info." (setq backup-if-not-cast t) (throw 'at-decl-or-cast t))) - ;; CASE 4 - (when (and got-suffix - (not got-prefix) - (not got-parens)) - ;; Got a plain list of identifiers followed by some suffix. - ;; If this isn't a cast then the last identifier probably is - ;; the declared one and we should back up to the previous - ;; type. - (setq backup-if-not-cast t) - (throw 'at-decl-or-cast t))) - - ;; CASE 5 - (when (eq at-type t) - ;; If the type is known we know that there can't be any - ;; identifier somewhere else, and it's only in declarations in - ;; e.g. function prototypes and in casts that the identifier may - ;; be left out. - (throw 'at-decl-or-cast t)) - - (when (= (point) start) - ;; Only got a single identifier (parsed as a type so far). - ;; CASE 6 - (if (and - ;; Check that the identifier isn't at the start of an - ;; expression. - at-decl-end - (cond - ((eq context 'decl) - ;; Inside an arglist that contains declarations. If K&R - ;; style declarations and parenthesis style initializers - ;; aren't allowed then the single identifier must be a - ;; type, else we require that it's known or found - ;; (primitive types are handled above). - (or (and (not c-recognize-knr-p) - (not c-recognize-paren-inits)) - (memq at-type '(known found)))) - ((eq context '<>) - ;; Inside a template arglist. Accept known and found - ;; types; other identifiers could just as well be - ;; constants in C++. - (memq at-type '(known found))))) - (throw 'at-decl-or-cast t) - ;; CASE 7 - ;; Can't be a valid declaration or cast, but if we've found a - ;; specifier it can't be anything else either, so treat it as - ;; an invalid/unfinished declaration or cast. - (throw 'at-decl-or-cast at-decl-or-cast)))) - - (if (and got-parens - (not got-prefix) - (not context) - (not (eq at-type t)) - (or backup-at-type - maybe-typeless - backup-maybe-typeless - (when c-recognize-typeless-decls - (or (not got-suffix) - (not (looking-at - c-after-suffixed-type-maybe-decl-key)))))) - ;; Got an empty paren pair and a preceding type that probably - ;; really is the identifier. Shift the type backwards to make - ;; the last one the identifier. This is analogous to the - ;; "backtracking" done inside the `c-type-decl-suffix-key' loop - ;; above. - ;; - ;; Exception: In addition to the conditions in that - ;; "backtracking" code, do not shift backward if we're not - ;; looking at either `c-after-suffixed-type-decl-key' or "[;,]". - ;; Since there's no preceding type, the shift would mean that - ;; the declaration is typeless. But if the regexp doesn't match - ;; then we will simply fall through in the tests below and not - ;; recognize it at all, so it's better to try it as an abstract - ;; declarator instead. - (c-fdoc-shift-type-backward) - - ;; Still no identifier. - ;; CASE 8 - (when (and got-prefix (or got-parens got-suffix)) - ;; Require `got-prefix' together with either `got-parens' or - ;; `got-suffix' to recognize it as an abstract declarator: - ;; `got-parens' only is probably an empty function call. - ;; `got-suffix' only can build an ordinary expression together - ;; with the preceding identifier which we've taken as a type. - ;; We could actually accept on `got-prefix' only, but that can - ;; easily occur temporarily while writing an expression so we - ;; avoid that case anyway. We could do a better job if we knew - ;; the point when the fontification was invoked. - (throw 'at-decl-or-cast t)) - - ;; CASE 9 - (when (and at-type - (not got-prefix) - (not got-parens) - got-suffix-after-parens - (eq (char-after got-suffix-after-parens) ?\()) - ;; Got a type, no declarator but a paren suffix. I.e. it's a - ;; normal function call after all (or perhaps a C++ style object - ;; instantiation expression). - (throw 'at-decl-or-cast nil)))) - - ;; CASE 10 - (when at-decl-or-cast - ;; By now we've located the type in the declaration that we know - ;; we're in. - (throw 'at-decl-or-cast t)) - - ;; CASE 11 - (when (and got-identifier - (not context) - (looking-at c-after-suffixed-type-decl-key) - (if (and got-parens + ;; CASE 4 + (when (and got-suffix (not got-prefix) - (not got-suffix) - (not (eq at-type t))) - ;; Shift the type backward in the case that there's a - ;; single identifier inside parens. That can only - ;; occur in K&R style function declarations so it's - ;; more likely that it really is a function call. - ;; Therefore we only do this after - ;; `c-after-suffixed-type-decl-key' has matched. - (progn (c-fdoc-shift-type-backward) t) - got-suffix-after-parens)) - ;; A declaration according to `c-after-suffixed-type-decl-key'. - (throw 'at-decl-or-cast t)) - - ;; CASE 12 - (when (and (or got-prefix (not got-parens)) - (memq at-type '(t known))) - ;; It's a declaration if a known type precedes it and it can't be a - ;; function call. - (throw 'at-decl-or-cast t)) - - ;; If we get here we can't tell if this is a type decl or a normal - ;; expression by looking at it alone. (That's under the assumption - ;; that normal expressions always can look like type decl expressions, - ;; which isn't really true but the cases where it doesn't hold are so - ;; uncommon (e.g. some placements of "const" in C++) it's not worth - ;; the effort to look for them.) + (not got-parens)) + ;; Got a plain list of identifiers followed by some suffix. + ;; If this isn't a cast then the last identifier probably is + ;; the declared one and we should back up to the previous + ;; type. + (setq backup-if-not-cast t) + (throw 'at-decl-or-cast t))) + + ;; CASE 5 + (when (eq at-type t) + ;; If the type is known we know that there can't be any + ;; identifier somewhere else, and it's only in declarations in + ;; e.g. function prototypes and in casts that the identifier may + ;; be left out. + (throw 'at-decl-or-cast t)) + + (when (= (point) start) + ;; Only got a single identifier (parsed as a type so far). + ;; CASE 6 + (if (and + ;; Check that the identifier isn't at the start of an + ;; expression. + at-decl-end + (cond + ((eq context 'decl) + ;; Inside an arglist that contains declarations. If K&R + ;; style declarations and parenthesis style initializers + ;; aren't allowed then the single identifier must be a + ;; type, else we require that it's known or found + ;; (primitive types are handled above). + (or (and (not c-recognize-knr-p) + (not c-recognize-paren-inits)) + (memq at-type '(known found)))) + ((eq context '<>) + ;; Inside a template arglist. Accept known and found + ;; types; other identifiers could just as well be + ;; constants in C++. + (memq at-type '(known found))))) + (throw 'at-decl-or-cast t) + ;; CASE 7 + ;; Can't be a valid declaration or cast, but if we've found a + ;; specifier it can't be anything else either, so treat it as + ;; an invalid/unfinished declaration or cast. + (throw 'at-decl-or-cast at-decl-or-cast)))) + + (if (and got-parens + (not got-prefix) + (not context) + (not (eq at-type t)) + (or backup-at-type + maybe-typeless + backup-maybe-typeless + (when c-recognize-typeless-decls + (or (not got-suffix) + (not (looking-at + c-after-suffixed-type-maybe-decl-key)))))) + ;; Got an empty paren pair and a preceding type that probably + ;; really is the identifier. Shift the type backwards to make + ;; the last one the identifier. This is analogous to the + ;; "backtracking" done inside the `c-type-decl-suffix-key' loop + ;; above. + ;; + ;; Exception: In addition to the conditions in that + ;; "backtracking" code, do not shift backward if we're not + ;; looking at either `c-after-suffixed-type-decl-key' or "[;,]". + ;; Since there's no preceding type, the shift would mean that + ;; the declaration is typeless. But if the regexp doesn't match + ;; then we will simply fall through in the tests below and not + ;; recognize it at all, so it's better to try it as an abstract + ;; declarator instead. + (c-fdoc-shift-type-backward) + + ;; Still no identifier. + ;; CASE 8 + (when (and got-prefix (or got-parens got-suffix)) + ;; Require `got-prefix' together with either `got-parens' or + ;; `got-suffix' to recognize it as an abstract declarator: + ;; `got-parens' only is probably an empty function call. + ;; `got-suffix' only can build an ordinary expression together + ;; with the preceding identifier which we've taken as a type. + ;; We could actually accept on `got-prefix' only, but that can + ;; easily occur temporarily while writing an expression so we + ;; avoid that case anyway. We could do a better job if we knew + ;; the point when the fontification was invoked. + (throw 'at-decl-or-cast t)) + + ;; CASE 9 + (when (and at-type + (not got-prefix) + (not got-parens) + got-suffix-after-parens + (eq (char-after got-suffix-after-parens) ?\()) + ;; Got a type, no declarator but a paren suffix. I.e. it's a + ;; normal function call after all (or perhaps a C++ style object + ;; instantiation expression). + (throw 'at-decl-or-cast nil)))) + + ;; CASE 10 + (when at-decl-or-cast + ;; By now we've located the type in the declaration that we know + ;; we're in. + (throw 'at-decl-or-cast t)) + + ;; CASE 11 + (when (and got-identifier + (not context) + (looking-at c-after-suffixed-type-decl-key) + (if (and got-parens + (not got-prefix) + (not got-suffix) + (not (eq at-type t))) + ;; Shift the type backward in the case that there's a + ;; single identifier inside parens. That can only + ;; occur in K&R style function declarations so it's + ;; more likely that it really is a function call. + ;; Therefore we only do this after + ;; `c-after-suffixed-type-decl-key' has matched. + (progn (c-fdoc-shift-type-backward) t) + got-suffix-after-parens)) + ;; A declaration according to `c-after-suffixed-type-decl-key'. + (throw 'at-decl-or-cast t)) + + ;; CASE 12 + (when (and (or got-prefix (not got-parens)) + (memq at-type '(t known))) + ;; It's a declaration if a known type precedes it and it can't be a + ;; function call. + (throw 'at-decl-or-cast t)) + + ;; If we get here we can't tell if this is a type decl or a normal + ;; expression by looking at it alone. (That's under the assumption + ;; that normal expressions always can look like type decl expressions, + ;; which isn't really true but the cases where it doesn't hold are so + ;; uncommon (e.g. some placements of "const" in C++) it's not worth + ;; the effort to look for them.) ;;; 2008-04-16: commented out the next form, to allow the function to recognize ;;; "foo (int bar)" in CC (an implicit type (in class foo) without a semicolon) ;;; as a(n almost complete) declaration, enabling it to be fontified. - ;; CASE 13 - ;; (unless (or at-decl-end (looking-at "=[^=]")) - ;; If this is a declaration it should end here or its initializer(*) - ;; should start here, so check for allowed separation tokens. Note - ;; that this rule doesn't work e.g. with a K&R arglist after a - ;; function header. - ;; - ;; *) Don't check for C++ style initializers using parens - ;; since those already have been matched as suffixes. - ;; - ;; If `at-decl-or-cast' is then we've found some other sign that - ;; it's a declaration or cast, so then it's probably an - ;; invalid/unfinished one. - ;; (throw 'at-decl-or-cast at-decl-or-cast)) - - ;; Below are tests that only should be applied when we're certain to - ;; not have parsed halfway through an expression. - - ;; CASE 14 - (when (memq at-type '(t known)) - ;; The expression starts with a known type so treat it as a - ;; declaration. - (throw 'at-decl-or-cast t)) - - ;; CASE 15 - (when (and (c-major-mode-is 'c++-mode) - ;; In C++ we check if the identifier is a known type, since - ;; (con|de)structors use the class name as identifier. - ;; We've always shifted over the identifier as a type and - ;; then backed up again in this case. - identifier-type - (or (memq identifier-type '(found known)) - (and (eq (char-after identifier-start) ?~) - ;; `at-type' probably won't be 'found for - ;; destructors since the "~" is then part of the - ;; type name being checked against the list of - ;; known types, so do a check without that - ;; operator. - (or (save-excursion - (goto-char (1+ identifier-start)) - (c-forward-syntactic-ws) - (c-with-syntax-table - c-identifier-syntax-table - (looking-at c-known-type-key))) - (save-excursion - (goto-char (1+ identifier-start)) - ;; We have already parsed the type earlier, - ;; so it'd be possible to cache the end - ;; position instead of redoing it here, but - ;; then we'd need to keep track of another - ;; position everywhere. - (c-check-type (point) - (progn (c-forward-type) - (point)))))))) - (throw 'at-decl-or-cast t)) - - (if got-identifier - (progn - ;; CASE 16 - (when (and got-prefix-before-parens - at-type - (or at-decl-end (looking-at "=[^=]")) - (not context) - (not got-suffix)) - ;; Got something like "foo * bar;". Since we're not inside an - ;; arglist it would be a meaningless expression because the - ;; result isn't used. We therefore choose to recognize it as - ;; a declaration. Do not allow a suffix since it could then - ;; be a function call. - (throw 'at-decl-or-cast t)) - - ;; CASE 17 - (when (and (or got-suffix-after-parens - (looking-at "=[^=]")) - (eq at-type 'found) - (not (eq context 'arglist))) - ;; Got something like "a (*b) (c);" or "a (b) = c;". It could - ;; be an odd expression or it could be a declaration. Treat - ;; it as a declaration if "a" has been used as a type - ;; somewhere else (if it's a known type we won't get here). - (throw 'at-decl-or-cast t))) - - ;; CASE 18 - (when (and context - (or got-prefix - (and (eq context 'decl) - (not c-recognize-paren-inits) - (or got-parens got-suffix)))) - ;; Got a type followed by an abstract declarator. If `got-prefix' - ;; is set it's something like "a *" without anything after it. If - ;; `got-parens' or `got-suffix' is set it's "a()", "a[]", "a()[]", - ;; or similar, which we accept only if the context rules out - ;; expressions. - (throw 'at-decl-or-cast t))) - - ;; If we had a complete symbol table here (which rules out - ;; `c-found-types') we should return t due to the disambiguation rule - ;; (in at least C++) that anything that can be parsed as a declaration - ;; is a declaration. Now we're being more defensive and prefer to - ;; highlight things like "foo (bar);" as a declaration only if we're - ;; inside an arglist that contains declarations. - (eq context 'decl)))) + ;; CASE 13 + ;; (unless (or at-decl-end (looking-at "=[^=]")) + ;; If this is a declaration it should end here or its initializer(*) + ;; should start here, so check for allowed separation tokens. Note + ;; that this rule doesn't work e.g. with a K&R arglist after a + ;; function header. + ;; + ;; *) Don't check for C++ style initializers using parens + ;; since those already have been matched as suffixes. + ;; + ;; If `at-decl-or-cast' is then we've found some other sign that + ;; it's a declaration or cast, so then it's probably an + ;; invalid/unfinished one. + ;; (throw 'at-decl-or-cast at-decl-or-cast)) + + ;; Below are tests that only should be applied when we're certain to + ;; not have parsed halfway through an expression. + + ;; CASE 14 + (when (memq at-type '(t known)) + ;; The expression starts with a known type so treat it as a + ;; declaration. + (throw 'at-decl-or-cast t)) + + ;; CASE 15 + (when (and (c-major-mode-is 'c++-mode) + ;; In C++ we check if the identifier is a known type, since + ;; (con|de)structors use the class name as identifier. + ;; We've always shifted over the identifier as a type and + ;; then backed up again in this case. + identifier-type + (or (memq identifier-type '(found known)) + (and (eq (char-after identifier-start) ?~) + ;; `at-type' probably won't be 'found for + ;; destructors since the "~" is then part of the + ;; type name being checked against the list of + ;; known types, so do a check without that + ;; operator. + (or (save-excursion + (goto-char (1+ identifier-start)) + (c-forward-syntactic-ws) + (c-with-syntax-table + c-identifier-syntax-table + (looking-at c-known-type-key))) + (save-excursion + (goto-char (1+ identifier-start)) + ;; We have already parsed the type earlier, + ;; so it'd be possible to cache the end + ;; position instead of redoing it here, but + ;; then we'd need to keep track of another + ;; position everywhere. + (c-check-type (point) + (progn (c-forward-type) + (point)))))))) + (throw 'at-decl-or-cast t)) + + (if got-identifier + (progn + ;; CASE 16 + (when (and got-prefix-before-parens + at-type + (or at-decl-end (looking-at "=[^=]")) + (not context) + (not got-suffix)) + ;; Got something like "foo * bar;". Since we're not inside an + ;; arglist it would be a meaningless expression because the + ;; result isn't used. We therefore choose to recognize it as + ;; a declaration. Do not allow a suffix since it could then + ;; be a function call. + (throw 'at-decl-or-cast t)) + + ;; CASE 17 + (when (and (or got-suffix-after-parens + (looking-at "=[^=]")) + (eq at-type 'found) + (not (eq context 'arglist))) + ;; Got something like "a (*b) (c);" or "a (b) = c;". It could + ;; be an odd expression or it could be a declaration. Treat + ;; it as a declaration if "a" has been used as a type + ;; somewhere else (if it's a known type we won't get here). + (throw 'at-decl-or-cast t))) + + ;; CASE 18 + (when (and context + (or got-prefix + (and (eq context 'decl) + (not c-recognize-paren-inits) + (or got-parens got-suffix)))) + ;; Got a type followed by an abstract declarator. If `got-prefix' + ;; is set it's something like "a *" without anything after it. If + ;; `got-parens' or `got-suffix' is set it's "a()", "a[]", "a()[]", + ;; or similar, which we accept only if the context rules out + ;; expressions. + (throw 'at-decl-or-cast t))) + + ;; If we had a complete symbol table here (which rules out + ;; `c-found-types') we should return t due to the disambiguation rule + ;; (in at least C++) that anything that can be parsed as a declaration + ;; is a declaration. Now we're being more defensive and prefer to + ;; highlight things like "foo (bar);" as a declaration only if we're + ;; inside an arglist that contains declarations. + ;; CASE 19 + (eq context 'decl)))) ;; The point is now after the type decl expression. @@ -7473,6 +7585,8 @@ comment at the start of cc-engine.el for more info." ;; interactive refontification. (c-put-c-type-property (point) 'c-decl-arg-start)) + ;; Record the type's coordinates in `c-record-type-identifiers' for + ;; later fontification. (when (and c-record-type-identifiers at-type ;; (not (eq at-type t)) ;; There seems no reason to exclude a token from ;; fontification just because it's "a known type that can't @@ -7571,10 +7685,10 @@ comment at the start of cc-engine.el for more info." (c-put-c-type-property (1- (point)) 'c-decl-end) t) - ;; It's an unfinished label. We consider the keyword enough - ;; to recognize it as a label, so that it gets fontified. - ;; Leave the point at the end of it, but don't put any - ;; `c-decl-end' marker. + ;; It's an unfinished label. We consider the keyword enough + ;; to recognize it as a label, so that it gets fontified. + ;; Leave the point at the end of it, but don't put any + ;; `c-decl-end' marker. (goto-char kwd-end) t)))) @@ -7759,69 +7873,69 @@ comment at the start of cc-engine.el for more info." ;; ;; This function might do hidden buffer changes. - (let ((start (point)) - start-char - (c-promote-possible-types t) - lim - ;; Turn off recognition of angle bracket arglists while parsing - ;; types here since the protocol reference list might then be - ;; considered part of the preceding name or superclass-name. - c-recognize-<>-arglists) - - (if (or - (when (looking-at - (eval-when-compile - (c-make-keywords-re t - (append (c-lang-const c-protection-kwds objc) - '("@end")) - 'objc-mode))) - (goto-char (match-end 1)) - t) + (let ((start (point)) + start-char + (c-promote-possible-types t) + lim + ;; Turn off recognition of angle bracket arglists while parsing + ;; types here since the protocol reference list might then be + ;; considered part of the preceding name or superclass-name. + c-recognize-<>-arglists) + + (if (or + (when (looking-at + (eval-when-compile + (c-make-keywords-re t + (append (c-lang-const c-protection-kwds objc) + '("@end")) + 'objc-mode))) + (goto-char (match-end 1)) + t) - (and - (looking-at - (eval-when-compile - (c-make-keywords-re t - '("@interface" "@implementation" "@protocol") - 'objc-mode))) + (and + (looking-at + (eval-when-compile + (c-make-keywords-re t + '("@interface" "@implementation" "@protocol") + 'objc-mode))) - ;; Handle the name of the class itself. - (progn -; (c-forward-token-2) ; 2006/1/13 This doesn't move if the token's -; at EOB. - (goto-char (match-end 0)) - (setq lim (point)) - (c-skip-ws-forward) - (c-forward-type)) - - (catch 'break - ;; Look for ": superclass-name" or "( category-name )". - (when (looking-at "[:\(]") - (setq start-char (char-after)) + ;; Handle the name of the class itself. + (progn + ;; (c-forward-token-2) ; 2006/1/13 This doesn't move if the token's + ;; at EOB. + (goto-char (match-end 0)) + (setq lim (point)) + (c-skip-ws-forward) + (c-forward-type)) + + (catch 'break + ;; Look for ": superclass-name" or "( category-name )". + (when (looking-at "[:\(]") + (setq start-char (char-after)) + (forward-char) + (c-forward-syntactic-ws) + (unless (c-forward-type) (throw 'break nil)) + (when (eq start-char ?\() + (unless (eq (char-after) ?\)) (throw 'break nil)) (forward-char) - (c-forward-syntactic-ws) - (unless (c-forward-type) (throw 'break nil)) - (when (eq start-char ?\() - (unless (eq (char-after) ?\)) (throw 'break nil)) - (forward-char) - (c-forward-syntactic-ws))) - - ;; Look for a protocol reference list. - (if (eq (char-after) ?<) - (let ((c-recognize-<>-arglists t) - (c-parse-and-markup-<>-arglists t) - c-restricted-<>-arglists) - (c-forward-<>-arglist t)) - t)))) + (c-forward-syntactic-ws))) - (progn - (c-backward-syntactic-ws lim) - (c-clear-c-type-property start (1- (point)) 'c-decl-end) - (c-put-c-type-property (1- (point)) 'c-decl-end) - t) + ;; Look for a protocol reference list. + (if (eq (char-after) ?<) + (let ((c-recognize-<>-arglists t) + (c-parse-and-markup-<>-arglists t) + c-restricted-<>-arglists) + (c-forward-<>-arglist t)) + t)))) - (c-clear-c-type-property start (point) 'c-decl-end) - nil))) + (progn + (c-backward-syntactic-ws lim) + (c-clear-c-type-property start (1- (point)) 'c-decl-end) + (c-put-c-type-property (1- (point)) 'c-decl-end) + t) + + (c-clear-c-type-property start (point) 'c-decl-end) + nil))) (defun c-beginning-of-inheritance-list (&optional lim) ;; Go to the first non-whitespace after the colon that starts a @@ -7908,7 +8022,7 @@ comment at the start of cc-engine.el for more info." ;; ;; This function might do hidden buffer changes. - (let ((beg (point)) end id-start) + (let ((beg (point)) id-start) (and (eq (c-beginning-of-statement-1 lim) 'same) @@ -7998,54 +8112,54 @@ comment at the start of cc-engine.el for more info." (throw 'knr nil))) (if after-rparen - ;; We're inside a paren. Could it be our argument list....? - (if - (and - (progn - (goto-char after-rparen) - (unless (c-go-list-backward) (throw 'knr nil)) ; - ;; FIXME!!! What about macros between the parens? 2007/01/20 - (setq before-lparen (point))) + ;; We're inside a paren. Could it be our argument list....? + (if + (and + (progn + (goto-char after-rparen) + (unless (c-go-list-backward) (throw 'knr nil)) ; + ;; FIXME!!! What about macros between the parens? 2007/01/20 + (setq before-lparen (point))) - ;; It can't be the arg list if next token is ; or { - (progn (goto-char after-rparen) - (c-forward-syntactic-ws) - (not (memq (char-after) '(?\; ?\{ ?\=)))) + ;; It can't be the arg list if next token is ; or { + (progn (goto-char after-rparen) + (c-forward-syntactic-ws) + (not (memq (char-after) '(?\; ?\{ ?\=)))) - ;; Is the thing preceding the list an identifier (the - ;; function name), or a macro expansion? - (progn - (goto-char before-lparen) - (eq (c-backward-token-2) 0) - (or (eq (c-on-identifier) (point)) - (and (eq (char-after) ?\)) - (c-go-up-list-backward) - (eq (c-backward-token-2) 0) - (eq (c-on-identifier) (point))))) - - ;; Have we got a non-empty list of comma-separated - ;; identifiers? - (progn - (goto-char before-lparen) - (c-forward-token-2) ; to first token inside parens - (and - (c-on-identifier) - (c-forward-token-2) - (catch 'id-list - (while (eq (char-after) ?\,) - (c-forward-token-2) - (unless (c-on-identifier) (throw 'id-list nil)) - (c-forward-token-2)) - (eq (char-after) ?\)))))) - - ;; ...Yes. We've identified the function's argument list. - (throw 'knr - (progn (goto-char after-rparen) - (c-forward-syntactic-ws) - (point))) - - ;; ...No. The current parens aren't the function's arg list. - (goto-char before-lparen)) + ;; Is the thing preceding the list an identifier (the + ;; function name), or a macro expansion? + (progn + (goto-char before-lparen) + (eq (c-backward-token-2) 0) + (or (eq (c-on-identifier) (point)) + (and (eq (char-after) ?\)) + (c-go-up-list-backward) + (eq (c-backward-token-2) 0) + (eq (c-on-identifier) (point))))) + + ;; Have we got a non-empty list of comma-separated + ;; identifiers? + (progn + (goto-char before-lparen) + (c-forward-token-2) ; to first token inside parens + (and + (c-on-identifier) + (c-forward-token-2) + (catch 'id-list + (while (eq (char-after) ?\,) + (c-forward-token-2) + (unless (c-on-identifier) (throw 'id-list nil)) + (c-forward-token-2)) + (eq (char-after) ?\)))))) + + ;; ...Yes. We've identified the function's argument list. + (throw 'knr + (progn (goto-char after-rparen) + (c-forward-syntactic-ws) + (point))) + + ;; ...No. The current parens aren't the function's arg list. + (goto-char before-lparen)) (or (c-go-list-backward) ; backwards over [ .... ] (throw 'knr nil))))))))) @@ -8251,7 +8365,7 @@ comment at the start of cc-engine.el for more info." (and (progn (while ; keep going back to "[;={"s until we either find - ; no more, or get to one which isn't an "operator =" + ; no more, or get to one which isn't an "operator =" (and (c-syntactic-re-search-forward "[;={]" start t t t) (eq (char-before) ?=) c-overloadable-operators-regexp @@ -8365,10 +8479,7 @@ comment at the start of cc-engine.el for more info." (when (and c-recognize-<>-arglists (eq (char-before) ?>)) ;; Could be at the end of a template arglist. - (let ((c-parse-and-markup-<>-arglists t) - (c-disallow-comma-in-<>-arglists - (and containing-sexp - (not (eq (char-after containing-sexp) ?{))))) + (let ((c-parse-and-markup-<>-arglists t)) (while (and (c-backward-<>-arglist nil limit) (progn @@ -8392,31 +8503,44 @@ comment at the start of cc-engine.el for more info." (cond ((c-syntactic-re-search-forward c-decl-block-key open-brace t t t) (goto-char (setq kwd-start (match-beginning 0))) - (or - - ;; Found a keyword that can't be a type? - (match-beginning 1) - - ;; Can be a type too, in which case it's the return type of a - ;; function (under the assumption that no declaration level - ;; block construct starts with a type). - (not (c-forward-type)) - - ;; Jumped over a type, but it could be a declaration keyword - ;; followed by the declared identifier that we've jumped over - ;; instead (e.g. in "class Foo {"). If it indeed is a type - ;; then we should be at the declarator now, so check for a - ;; valid declarator start. - ;; - ;; Note: This doesn't cope with the case when a declared - ;; identifier is followed by e.g. '(' in a language where '(' - ;; also might be part of a declarator expression. Currently - ;; there's no such language. - (not (or (looking-at c-symbol-start) - (looking-at c-type-decl-prefix-key))))) + (and + ;; Exclude cases where we matched what would ordinarily + ;; be a block declaration keyword, except where it's not + ;; legal because it's part of a "compound keyword" like + ;; "enum class". Of course, if c-after-brace-list-key + ;; is nil, we can skip the test. + (or (equal c-after-brace-list-key "\\<\\>") + (save-match-data + (save-excursion + (not + (and + (looking-at c-after-brace-list-key) + (= (c-backward-token-2 1 t) 0) + (looking-at c-brace-list-key)))))) + (or + ;; Found a keyword that can't be a type? + (match-beginning 1) + + ;; Can be a type too, in which case it's the return type of a + ;; function (under the assumption that no declaration level + ;; block construct starts with a type). + (not (c-forward-type)) + + ;; Jumped over a type, but it could be a declaration keyword + ;; followed by the declared identifier that we've jumped over + ;; instead (e.g. in "class Foo {"). If it indeed is a type + ;; then we should be at the declarator now, so check for a + ;; valid declarator start. + ;; + ;; Note: This doesn't cope with the case when a declared + ;; identifier is followed by e.g. '(' in a language where '(' + ;; also might be part of a declarator expression. Currently + ;; there's no such language. + (not (or (looking-at c-symbol-start) + (looking-at c-type-decl-prefix-key)))))) ;; In Pike a list of modifiers may be followed by a brace - ;; to make them apply to many identifiers. Note that the + ;; to make them apply to many identifiers. Note that the ;; match data will be empty on return in this case. ((and (c-major-mode-is 'pike-mode) (progn @@ -8518,11 +8642,44 @@ comment at the start of cc-engine.el for more info." (not (looking-at "="))))) b-pos))) +(defun c-backward-colon-prefixed-type () + ;; We're at the token after what might be a type prefixed with a colon. Try + ;; moving backward over this type and the colon. On success, return t and + ;; leave point before colon; on failure, leave point unchanged. Will clobber + ;; match data. + (let ((here (point)) + (colon-pos nil)) + (save-excursion + (while + (and (eql (c-backward-token-2) 0) + (or (not (looking-at "\\s)")) + (c-go-up-list-backward)) + (cond + ((eql (char-after) ?:) + (setq colon-pos (point)) + (forward-char) + (c-forward-syntactic-ws) + (or (and (c-forward-type) + (progn (c-forward-syntactic-ws) + (eq (point) here))) + (setq colon-pos nil)) + nil) + ((eql (char-after) ?\() + t) + ((looking-at c-symbol-key) + t) + (t nil))))) + (when colon-pos + (goto-char colon-pos) + t))) + (defun c-backward-over-enum-header () ;; We're at a "{". Move back to the enum-like keyword that starts this ;; declaration and return t, otherwise don't move and return nil. (let ((here (point)) up-sexp-pos before-identifier) + (when c-recognize-post-brace-list-type-p + (c-backward-colon-prefixed-type)) (while (and (eq (c-backward-token-2) 0) @@ -8533,10 +8690,11 @@ comment at the start of cc-engine.el for more info." (not before-identifier)) (setq before-identifier t)) ((and before-identifier - (or (eq (char-after) ?,) + (or (eql (char-after) ?,) (looking-at c-postfix-decl-spec-key))) (setq before-identifier nil) t) + ((looking-at c-after-brace-list-key) t) ((looking-at c-brace-list-key) nil) ((and c-recognize-<>-arglists (eq (char-after) ?<) @@ -8574,86 +8732,86 @@ comment at the start of cc-engine.el for more info." (while (and (not bufpos) containing-sexp) (when paren-state - (if (consp (car paren-state)) - (setq lim (cdr (car paren-state)) - paren-state (cdr paren-state)) - (setq lim (car paren-state))) - (when paren-state - (setq next-containing (car paren-state) - paren-state (cdr paren-state)))) - (goto-char containing-sexp) - (if (c-looking-at-inexpr-block next-containing next-containing) - ;; We're in an in-expression block of some kind. Do not - ;; check nesting. We deliberately set the limit to the - ;; containing sexp, so that c-looking-at-inexpr-block - ;; doesn't check for an identifier before it. - (setq containing-sexp nil) - ;; see if the open brace is preceded by = or [...] in - ;; this statement, but watch out for operator= - (setq braceassignp 'dontknow) - (c-backward-token-2 1 t lim) - ;; Checks to do only on the first sexp before the brace. - (when (and c-opt-inexpr-brace-list-key - (eq (char-after) ?\[)) - ;; In Java, an initialization brace list may follow - ;; directly after "new Foo[]", so check for a "new" - ;; earlier. - (while (eq braceassignp 'dontknow) - (setq braceassignp - (cond ((/= (c-backward-token-2 1 t lim) 0) nil) - ((looking-at c-opt-inexpr-brace-list-key) t) - ((looking-at "\\sw\\|\\s_\\|[.[]") - ;; Carry on looking if this is an - ;; identifier (may contain "." in Java) - ;; or another "[]" sexp. - 'dontknow) - (t nil))))) - ;; Checks to do on all sexps before the brace, up to the - ;; beginning of the statement. + (if (consp (car paren-state)) + (setq lim (cdr (car paren-state)) + paren-state (cdr paren-state)) + (setq lim (car paren-state))) + (when paren-state + (setq next-containing (car paren-state) + paren-state (cdr paren-state)))) + (goto-char containing-sexp) + (if (c-looking-at-inexpr-block next-containing next-containing) + ;; We're in an in-expression block of some kind. Do not + ;; check nesting. We deliberately set the limit to the + ;; containing sexp, so that c-looking-at-inexpr-block + ;; doesn't check for an identifier before it. + (setq containing-sexp nil) + ;; see if the open brace is preceded by = or [...] in + ;; this statement, but watch out for operator= + (setq braceassignp 'dontknow) + (c-backward-token-2 1 t lim) + ;; Checks to do only on the first sexp before the brace. + (when (and c-opt-inexpr-brace-list-key + (eq (char-after) ?\[)) + ;; In Java, an initialization brace list may follow + ;; directly after "new Foo[]", so check for a "new" + ;; earlier. (while (eq braceassignp 'dontknow) - (cond ((eq (char-after) ?\;) - (setq braceassignp nil)) - ((and class-key - (looking-at class-key)) - (setq braceassignp nil)) - ((eq (char-after) ?=) - ;; We've seen a =, but must check earlier tokens so - ;; that it isn't something that should be ignored. - (setq braceassignp 'maybe) - (while (and (eq braceassignp 'maybe) - (zerop (c-backward-token-2 1 t lim))) - (setq braceassignp - (cond - ;; Check for operator = - ((and c-opt-op-identifier-prefix - (looking-at c-opt-op-identifier-prefix)) - nil) - ;; Check for `<opchar>= in Pike. - ((and (c-major-mode-is 'pike-mode) - (or (eq (char-after) ?`) - ;; Special case for Pikes - ;; `[]=, since '[' is not in - ;; the punctuation class. - (and (eq (char-after) ?\[) - (eq (char-before) ?`)))) - nil) - ((looking-at "\\s.") 'maybe) - ;; make sure we're not in a C++ template - ;; argument assignment - ((and - (c-major-mode-is 'c++-mode) - (save-excursion - (let ((here (point)) - (pos< (progn - (skip-chars-backward "^<>") - (point)))) - (and (eq (char-before) ?<) - (not (c-crosses-statement-barrier-p - pos< here)) - (not (c-in-literal)) - )))) - nil) - (t t)))))) + (setq braceassignp + (cond ((/= (c-backward-token-2 1 t lim) 0) nil) + ((looking-at c-opt-inexpr-brace-list-key) t) + ((looking-at "\\sw\\|\\s_\\|[.[]") + ;; Carry on looking if this is an + ;; identifier (may contain "." in Java) + ;; or another "[]" sexp. + 'dontknow) + (t nil))))) + ;; Checks to do on all sexps before the brace, up to the + ;; beginning of the statement. + (while (eq braceassignp 'dontknow) + (cond ((eq (char-after) ?\;) + (setq braceassignp nil)) + ((and class-key + (looking-at class-key)) + (setq braceassignp nil)) + ((eq (char-after) ?=) + ;; We've seen a =, but must check earlier tokens so + ;; that it isn't something that should be ignored. + (setq braceassignp 'maybe) + (while (and (eq braceassignp 'maybe) + (zerop (c-backward-token-2 1 t lim))) + (setq braceassignp + (cond + ;; Check for operator = + ((and c-opt-op-identifier-prefix + (looking-at c-opt-op-identifier-prefix)) + nil) + ;; Check for `<opchar>= in Pike. + ((and (c-major-mode-is 'pike-mode) + (or (eq (char-after) ?`) + ;; Special case for Pikes + ;; `[]=, since '[' is not in + ;; the punctuation class. + (and (eq (char-after) ?\[) + (eq (char-before) ?`)))) + nil) + ((looking-at "\\s.") 'maybe) + ;; make sure we're not in a C++ template + ;; argument assignment + ((and + (c-major-mode-is 'c++-mode) + (save-excursion + (let ((here (point)) + (pos< (progn + (skip-chars-backward "^<>") + (point)))) + (and (eq (char-before) ?<) + (not (c-crosses-statement-barrier-p + pos< here)) + (not (c-in-literal)) + )))) + nil) + (t t)))))) (if (and (eq braceassignp 'dontknow) (/= (c-backward-token-2 1 t lim) 0)) (setq braceassignp nil))) @@ -9176,7 +9334,7 @@ comment at the start of cc-engine.el for more info." (max (c-point 'boi paren-pos) (point)))) (t (c-add-syntax 'defun-block-intro nil)))) - (c-add-syntax 'statement-block-intro nil))) + (c-add-syntax 'statement-block-intro nil))) (if (= paren-pos boi) ;; Always done if the open brace was at boi. The @@ -9346,15 +9504,15 @@ comment at the start of cc-engine.el for more info." ;;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) + (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))) @@ -9373,16 +9531,16 @@ comment at the start of cc-engine.el for more info." (not (looking-at c-<-op-cont-regexp)))))) (c-with-syntax-table c++-template-syntax-table (goto-char placeholder) - (c-beginning-of-statement-1 containing-sexp t) - (if (save-excursion - (c-backward-syntactic-ws containing-sexp) - (eq (char-before) ?<)) - ;; In a nested template arglist. - (progn - (goto-char placeholder) - (c-syntactic-skip-backward "^,;" containing-sexp t) - (c-forward-syntactic-ws)) - (back-to-indentation))) + (c-beginning-of-statement-1 containing-sexp t)) + (if (save-excursion + (c-backward-syntactic-ws containing-sexp) + (eq (char-before) ?<)) + ;; In a nested template arglist. + (progn + (goto-char placeholder) + (c-syntactic-skip-backward "^,;" containing-sexp t) + (c-forward-syntactic-ws)) + (back-to-indentation)) ;; FIXME: Should use c-add-stmt-syntax, but it's not yet ;; template aware. (c-add-syntax 'template-args-cont (point) placeholder)) @@ -9405,7 +9563,7 @@ comment at the start of cc-engine.el for more info." ((indent-point (point)) (case-fold-search nil) open-paren-in-column-0-is-defun-start - ;; A whole ugly bunch of various temporary variables. Have + ;; A whole ugly bunch of various temporary variables. Have ;; to declare them here since it's not possible to declare ;; a variable with only the scope of a cond test and the ;; following result clauses, and most of this function is a @@ -9460,22 +9618,26 @@ comment at the start of cc-engine.el for more info." (c-keyword-sym (match-string 1))))) ;; Init some position variables. - (if c-state-cache + (if paren-state (progn (setq containing-sexp (car paren-state) paren-state (cdr paren-state)) (if (consp containing-sexp) - (progn - (setq lim (cdr containing-sexp)) - (if (cdr c-state-cache) - ;; Ignore balanced paren. The next entry - ;; can't be another one. - (setq containing-sexp (car (cdr c-state-cache)) - paren-state (cdr paren-state)) - ;; If there is no surrounding open paren then - ;; put the last balanced pair back on paren-state. - (setq paren-state (cons containing-sexp paren-state) - containing-sexp nil))) + (save-excursion + (goto-char (cdr containing-sexp)) + (if (and (c-major-mode-is 'c++-mode) + (c-back-over-member-initializer-braces)) + (c-syntactic-skip-backward "^}" nil t)) + (setq lim (point)) + (if paren-state + ;; Ignore balanced paren. The next entry + ;; can't be another one. + (setq containing-sexp (car paren-state) + paren-state (cdr paren-state)) + ;; If there is no surrounding open paren then + ;; put the last balanced pair back on paren-state. + (setq paren-state (cons containing-sexp paren-state) + containing-sexp nil))) (setq lim (1+ containing-sexp)))) (setq lim (point-min))) @@ -10040,16 +10202,16 @@ comment at the start of cc-engine.el for more info." (eq (char-after placeholder) ?<)))))) (c-with-syntax-table c++-template-syntax-table (goto-char placeholder) - (c-beginning-of-statement-1 lim t) - (if (save-excursion - (c-backward-syntactic-ws lim) - (eq (char-before) ?<)) - ;; In a nested template arglist. - (progn - (goto-char placeholder) - (c-syntactic-skip-backward "^,;" lim t) - (c-forward-syntactic-ws)) - (back-to-indentation))) + (c-beginning-of-statement-1 lim t)) + (if (save-excursion + (c-backward-syntactic-ws lim) + (eq (char-before) ?<)) + ;; In a nested template arglist. + (progn + (goto-char placeholder) + (c-syntactic-skip-backward "^,;" lim t) + (c-forward-syntactic-ws)) + (back-to-indentation)) ;; FIXME: Should use c-add-stmt-syntax, but it's not yet ;; template aware. (c-add-syntax 'template-args-cont (point) placeholder)) @@ -10289,7 +10451,6 @@ 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 7: line is an expression, not a statement. Most @@ -10318,7 +10479,7 @@ comment at the start of cc-engine.el for more info." paren-state)) ;; CASE 7B: Looking at the opening brace of an - ;; in-expression block or brace list. C.f. cases 4, 16A + ;; in-expression block or brace list. C.f. cases 4, 16A ;; and 17E. ((and (eq char-after-ip ?{) (progn @@ -10440,7 +10601,7 @@ comment at the start of cc-engine.el for more info." ))) ;; CASE 9: we are inside a brace-list - ((and (not (c-major-mode-is 'awk-mode)) ; Maybe this isn't needed (ACM, 2002/3/29) + ((and (not (c-major-mode-is 'awk-mode)) ; Maybe this isn't needed (ACM, 2002/3/29) (setq special-brace-list (or (and c-special-brace-lists ;;;; ALWAYS NIL FOR AWK!! (save-excursion @@ -10492,7 +10653,7 @@ comment at the start of cc-engine.el for more info." (if (eq (point) (c-point 'boi)) (c-add-syntax 'brace-list-close (point)) (setq lim (c-most-enclosing-brace c-state-cache (point))) - (c-beginning-of-statement-1 lim) + (c-beginning-of-statement-1 lim nil nil t) (c-add-stmt-syntax 'brace-list-close nil t lim paren-state))) (t @@ -10654,9 +10815,9 @@ comment at the start of cc-engine.el for more info." )) ;; CASE 19: line is an expression, not a statement, and is directly - ;; contained by a template delimiter. Most likely, we are in a + ;; 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 + ;; 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). @@ -10992,7 +11153,7 @@ Cannot combine absolute offsets %S and %S in `add' method" ;; ;; This function might do hidden buffer changes. (let* ((symbol (c-langelem-sym langelem)) - (match (assq symbol c-offsets-alist)) + (match (assq symbol c-offsets-alist)) (offset (cdr-safe match))) (if match (setq offset (c-evaluate-offset offset langelem symbol)) @@ -11063,4 +11224,8 @@ Cannot combine absolute offsets %S and %S in `add' method" (cc-provide 'cc-engine) +;;; Local Variables: +;;; indent-tabs-mode: t +;;; tab-width: 8 +;;; End: ;;; cc-engine.el ends here diff --git a/lisp/progmodes/cc-fonts.el b/lisp/progmodes/cc-fonts.el index 6ebd6c6a8fc..d39376a2f03 100644 --- a/lisp/progmodes/cc-fonts.el +++ b/lisp/progmodes/cc-fonts.el @@ -266,7 +266,7 @@ ;; This function might do hidden buffer changes. (when (c-got-face-at (point) c-literal-faces) (while (progn - (goto-char (next-single-property-change + (goto-char (c-next-single-property-change (point) 'face nil limit)) (and (< (point) limit) (c-got-face-at (point) c-literal-faces)))) @@ -366,39 +366,7 @@ (parse-sexp-lookup-properties (cc-eval-when-compile (boundp 'parse-sexp-lookup-properties)))) - - ;; (while (re-search-forward ,regexp limit t) - ;; (unless (progn - ;; (goto-char (match-beginning 0)) - ;; (c-skip-comments-and-strings limit)) - ;; (goto-char (match-end 0)) - ;; ,@(mapcar - ;; (lambda (highlight) - ;; (if (integerp (car highlight)) - ;; (progn - ;; (unless (eq (nth 2 highlight) t) - ;; (error - ;; "The override flag must currently be t in %s" - ;; highlight)) - ;; (when (nth 3 highlight) - ;; (error - ;; "The laxmatch flag may currently not be set in %s" - ;; highlight)) - ;; `(save-match-data - ;; (c-put-font-lock-face - ;; (match-beginning ,(car highlight)) - ;; (match-end ,(car highlight)) - ;; ,(elt highlight 1)))) - ;; (when (nth 3 highlight) - ;; (error "Match highlights currently not supported in %s" - ;; highlight)) - ;; `(progn - ;; ,(nth 1 highlight) - ;; (save-match-data ,(car highlight)) - ;; ,(nth 2 highlight)))) - ;; highlights))) ,(c-make-font-lock-search-form regexp highlights)) - nil))) (defun c-make-font-lock-BO-decl-search-function (regexp &rest highlights) @@ -591,8 +559,7 @@ 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 'category))) + (c-unmark-<->-as-paren beg))) nil))))))) ;; #define. @@ -716,7 +683,11 @@ stuff. Used on level 1 and higher." (let ((start (1- (point)))) (save-excursion (and (eq (elt (parse-partial-sexp start (c-point 'eol)) 8) start) - (if (integerp c-multiline-string-start-char) + (if (if (eval-when-compile (integerp ?c)) + ;; Emacs + (integerp c-multiline-string-start-char) + ;; XEmacs + (characterp c-multiline-string-start-char)) ;; There's no multiline string start char before the ;; string, so newlines aren't allowed. (not (eq (char-before start) c-multiline-string-start-char)) @@ -1037,7 +1008,8 @@ casts and declarations are fontified. Used on level 2 and higher." paren-depth id-face got-init c-last-identifier-range - (separator-prop (if types 'c-decl-type-start 'c-decl-id-start))) + (separator-prop (if types 'c-decl-type-start 'c-decl-id-start)) + brackets-after-id) ;; The following `while' fontifies a single declarator id each time round. ;; It loops only when LIST is non-nil. @@ -1110,17 +1082,21 @@ casts and declarations are fontified. Used on level 2 and higher." ;; Search syntactically to the end of the declarator (";", ;; ",", a closing paren, eob etc) or to the beginning of an ;; initializer or function prototype ("=" or "\\s\("). - ;; Note that the open paren will match array specs in - ;; square brackets, and we treat them as initializers too. - (c-syntactic-re-search-forward - "[;,]\\|\\s)\\|\\'\\|\\(=\\|\\s(\\)" limit t t)) + ;; Note that square brackets are now not also treated as + ;; initializers, since this broke when there were also + ;; initializing brace lists. + (let (found) + (while + (and (setq found (c-syntactic-re-search-forward + "[;,]\\|\\s)\\|\\'\\|\\(=\\|\\s(\\)" limit t t)) + (eq (char-before) ?\[) + (c-go-up-list-forward)) + (setq brackets-after-id t)) + found)) (setq next-pos (match-beginning 0) id-face (if (and (eq (char-after next-pos) ?\() - (let (c-last-identifier-range) - (save-excursion - (goto-char next-pos) - (c-at-toplevel-p)))) + (not brackets-after-id)) 'font-lock-function-name-face 'font-lock-variable-name-face) got-init (and (match-beginning 1) @@ -1146,7 +1122,6 @@ casts and declarations are fontified. Used on level 2 and higher." (when list ;; Jump past any initializer or function prototype to see if ;; there's a ',' to continue at. - (cond ((eq id-face 'font-lock-function-name-face) ;; Skip a parenthesized initializer (C++) or a function ;; prototype. @@ -1214,8 +1189,8 @@ casts and declarations are fontified. Used on level 2 and higher." ;; o - nil, if not in an arglist at all. This includes the ;; parenthesized condition which follows "if", "while", etc. context - ;; The position of the next token after the closing paren of - ;; the last detected cast. + ;; A list of starting positions of possible type declarations, or of + ;; the typedef preceding one, if any. last-cast-end ;; The result from `c-forward-decl-or-cast-1'. decl-or-cast @@ -1303,14 +1278,15 @@ casts and declarations are fontified. Used on level 2 and higher." (cond ((not (memq (char-before match-pos) '(?\( ?, ?\[ ?<))) (setq context nil c-restricted-<>-arglists nil)) - ;; A control flow expression + ;; A control flow expression or a decltype ((and (eq (char-before match-pos) ?\() (save-excursion (goto-char match-pos) (backward-char) (c-backward-token-2) (or (looking-at c-block-stmt-2-key) - (looking-at c-block-stmt-1-2-key)))) + (looking-at c-block-stmt-1-2-key) + (looking-at c-typeof-key)))) (setq context nil c-restricted-<>-arglists t)) ;; Near BOB. @@ -1488,33 +1464,38 @@ casts and declarations are fontified. Used on level 2 and higher." c-recognize-knr-p) ; Strictly speaking, bogus, but it ; speeds up lisp.h tremendously. (save-excursion - (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)) - - ;; 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 (point-max) t is-typedef) - nil) - ;; False alarm. Return t to go on to the next check. - (goto-char start-pos) - t)) - t)))))) + (if (c-back-over-member-initializers) + t ; Can't be at a declarator + (unless (or (eobp) + (looking-at "\\s(\\|\\s)")) + (forward-char)) + (setq bod-res (car (c-beginning-of-decl-1 decl-search-lim))) + (if (and (eq bod-res 'same) + (save-excursion + (c-backward-syntactic-ws) + (eq (char-before) ?\}))) + (c-beginning-of-decl-1 decl-search-lim)) + + ;; 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 decltype)) + (progn + (c-font-lock-declarators (point-max) t is-typedef) + nil) + ;; False alarm. Return t to go on to the next check. + (goto-char start-pos) + t)) + t))))))) ;; It was a false alarm. Check if we're in a label (or other ;; construct with `:' except bitfield) instead. @@ -1557,9 +1538,7 @@ casts and declarations are fontified. Used on level 2 and higher." ;; 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)) - ) + (encl-pos (c-most-enclosing-brace paren-state))) (when (and encl-pos (eq (char-after encl-pos) ?\{) @@ -2124,7 +2103,7 @@ need for `c-font-lock-extra-types'.") ;; Got two parenthesized expressions, so we have to look ;; closer at them to decide which is the type. No need to ;; handle `c-record-ref-identifiers' since all references - ;; has already been handled by other fontification rules. + ;; have already been handled by other fontification rules. (let (expr1-res expr2-res) (goto-char expr1-pos) @@ -2159,6 +2138,9 @@ need for `c-font-lock-extra-types'.") ;; unusual than an initializer. (cond ((memq expr1-res '(t known prefix))) ((memq expr2-res '(t known prefix))) + ;; Presumably 'decltype's will be fontified elsewhere. + ((eq expr1-res 'decltype)) + ((eq expr2-res 'decltype)) ((eq expr1-res 'found) (let ((c-promote-possible-types t)) (goto-char expr1-pos) @@ -2721,4 +2703,8 @@ need for `pike-font-lock-extra-types'.") ;; 2006-07-10: awk-font-lock-keywords has been moved back to cc-awk.el. (cc-provide 'cc-fonts) +;;; Local Variables: +;;; indent-tabs-mode: t +;;; tab-width: 8 +;;; End: ;;; cc-fonts.el ends here diff --git a/lisp/progmodes/cc-guess.el b/lisp/progmodes/cc-guess.el index abde007cd04..4c077444adb 100644 --- a/lisp/progmodes/cc-guess.el +++ b/lisp/progmodes/cc-guess.el @@ -504,8 +504,7 @@ is called with one argument, the guessed style." (cond ((or (and a-guessed? b-guessed?) (not (or a-guessed? b-guessed?))) - (string-lessp (symbol-name (car a)) - (symbol-name (car b)))) + (string-lessp (car a) (car b))) (a-guessed? t) (b-guessed? nil))))))) style) @@ -520,7 +519,8 @@ is called with one argument, the guessed style." (goto-char (point-min)) (when (search-forward (concat "(" (symbol-name (car needs-markers)) - " ") nil t) + " ") + nil t) (move-end-of-line 1) (comment-dwim nil) (insert " Guessed value")) @@ -572,4 +572,9 @@ WITH-NAME is asked to the user." (cc-provide 'cc-guess) + +;;; Local Variables: +;;; indent-tabs-mode: t +;;; tab-width: 8 +;;; End: ;;; cc-guess.el ends here diff --git a/lisp/progmodes/cc-langs.el b/lisp/progmodes/cc-langs.el index c5cdc731361..31298d74e48 100644 --- a/lisp/progmodes/cc-langs.el +++ b/lisp/progmodes/cc-langs.el @@ -130,9 +130,7 @@ ;; This file is not always loaded. See note above. -;; Except it is always loaded - see bug#17463. -;;;(cc-external-require 'cl) -(require 'cl-lib) +(cc-external-require 'cl) ;;; Setup for the `c-lang-defvar' system. @@ -253,14 +251,14 @@ the evaluated constant value at compile time." (unless xlate (setq xlate 'identity)) (c-with-syntax-table (c-lang-const c-mode-syntax-table) - (cl-delete-duplicates - (cl-mapcan (lambda (opgroup) + (delete-duplicates + (mapcan (lambda (opgroup) (when (if (symbolp (car opgroup)) (when (funcall opgroup-filter (car opgroup)) (setq opgroup (cdr opgroup)) t) t) - (cl-mapcan (lambda (op) + (mapcan (lambda (op) (when (funcall op-filter op) (let ((res (funcall xlate op))) (if (listp res) res (list res))))) @@ -301,7 +299,8 @@ the evaluated constant value at compile time." ["Set Style..." c-set-style t] ["Show Current Style Name" (message "Style Name: %s" - c-indentation-style) t] + c-indentation-style) + t] ["Guess Style from this Buffer" c-guess-buffer-no-install t] ["Install the Last Guessed Style..." c-guess-install (and c-guess-guessed-offsets-alist @@ -319,9 +318,9 @@ the evaluated constant value at compile time." :style toggle :selected c-auto-newline] ["Hungry delete" c-toggle-hungry-state :style toggle :selected c-hungry-delete-key] - ["Subword mode" subword-mode - :style toggle :selected (and (boundp 'subword-mode) - subword-mode)]))) + ["Subword mode" c-subword-mode + :style toggle :selected (and (boundp 'c-subword-mode) + c-subword-mode)]))) ;;; Syntax tables. @@ -393,7 +392,9 @@ The syntax tables aren't stored directly since they're quite large." ;; lists are parsed. Note that this encourages incorrect parsing of ;; templates since they might contain normal operators that uses the ;; '<' and '>' characters. Therefore this syntax table might go - ;; away when CC Mode handles templates correctly everywhere. + ;; away when CC Mode handles templates correctly everywhere. WHILE + ;; THIS SYNTAX TABLE IS CURRENT, `c-parse-state' MUST _NOT_ BE + ;; CALLED!!! t nil (java c++) `(lambda () (let ((table (funcall ,(c-lang-const c-make-mode-syntax-table)))) @@ -404,7 +405,7 @@ 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 +(c-lang-defconst c-make-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 @@ -412,18 +413,20 @@ The syntax tables aren't stored directly since they're quite large." ;; 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)))) + t (if (c-lang-const c-recognize-<>-arglists) + `(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))) + (and (c-lang-const c-make-no-parens-syntax-table) + (funcall (c-lang-const c-make-no-parens-syntax-table)))) (c-lang-defconst c-identifier-syntax-modifications "A list that describes the modifications that should be done to the @@ -574,9 +577,18 @@ EOL terminated statements." (c c++ objc) t) (c-lang-defvar c-has-bitfields (c-lang-const c-has-bitfields)) +(c-lang-defconst c-modified-constant + "Regexp that matches a \"modified\" constant literal such as \"L'a'\", +a \"long character\". In particular, this recognizes forms of constant +which `c-backward-sexp' needs to be called twice to move backwards over." + t nil + (c c++ objc) "L'\\([^\\'\t\f\n\r]\\|\\\\.\\)'") +;; FIXME!!! Extend this to cover strings, if needed. 2008-04-11 +(c-lang-defvar c-modified-constant (c-lang-const c-modified-constant)) + (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 "_@]") @@ -938,10 +950,13 @@ Note that operators like \".\" and \"->\" which in language references often are described as postfix operators are considered binary here, since CC Mode treats every identifier as an expression." - ;; There's currently no code in CC Mode that exploit all the info + ;; There's currently no code in CC Mode that exploits all the info ;; in this variable; precedence, associativity etc are present as a ;; preparation for future work. + ;; FIXME!!! C++11's "auto" operators "=" and "->" need to go in here + ;; somewhere. 2012-03-24. + t `(;; Preprocessor. ,@(when (c-lang-const c-opt-cpp-prefix) `((prefix "#" @@ -964,7 +979,8 @@ since CC Mode treats every identifier as an expression." ,@(when (c-major-mode-is 'c++-mode) ;; The following need special treatment. `((prefix "dynamic_cast" "static_cast" - "reinterpret_cast" "const_cast" "typeid"))) + "reinterpret_cast" "const_cast" "typeid" + "alignof"))) (left-assoc "." ,@(unless (c-major-mode-is 'java-mode) '("->"))) @@ -1137,7 +1153,8 @@ operators." c++ (append '("&" "<%" "%>" "<:" ":>" "%:" "%:%:") (c-lang-const c-other-op-syntax-tokens)) objc (append '("#" "##" ; Used by cpp. - "+" "-") (c-lang-const c-other-op-syntax-tokens)) + "+" "-") + (c-lang-const c-other-op-syntax-tokens)) idl (append '("#" "##") ; Used by cpp. (c-lang-const c-other-op-syntax-tokens)) pike (append '("..") @@ -1148,7 +1165,7 @@ operators." (c-lang-defconst c-all-op-syntax-tokens ;; List of all tokens in the punctuation and parenthesis syntax ;; classes. - t (cl-delete-duplicates (append (c-lang-const c-other-op-syntax-tokens) + t (delete-duplicates (append (c-lang-const c-other-op-syntax-tokens) (c-lang-const c-operator-list)) :test 'string-equal)) @@ -1215,22 +1232,41 @@ operators." (c-lang-defvar c-<-op-cont-regexp (c-lang-const c-<-op-cont-regexp)) +(c-lang-defconst c->-op-cont-tokens + ;; A list of second and subsequent characters of all multicharacter tokens + ;; that begin with ">". + t (c-filter-ops (c-lang-const c-all-op-syntax-tokens) + t + "\\`>." + (lambda (op) (substring op 1))) + java (c-filter-ops (c-lang-const c-all-op-syntax-tokens) + t + "\\`>[^>]\\|\\`>>[^>]" + (lambda (op) (substring op 1)))) + (c-lang-defconst c->-op-cont-regexp ;; Regexp matching the second and subsequent characters of all ;; multicharacter tokens that begin with ">". - t (c-make-keywords-re nil - (c-filter-ops (c-lang-const c-all-op-syntax-tokens) - t - "\\`>." - (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))))) + t (c-make-keywords-re nil (c-lang-const c->-op-cont-tokens))) (c-lang-defvar c->-op-cont-regexp (c-lang-const c->-op-cont-regexp)) +(c-lang-defconst c->-op-without->-cont-regexp + ;; Regexp matching the second and subsequent characters of all + ;; multicharacter tokens that begin with ">" except for those beginning with + ;; ">>". + t (c-make-keywords-re nil + (set-difference + (c-lang-const c->-op-cont-tokens) + (c-filter-ops (c-lang-const c-all-op-syntax-tokens) + t + "\\`>>" + (lambda (op) (substring op 1))) + :test 'string-equal))) + +(c-lang-defvar c->-op-without->-cont-regexp + (c-lang-const c->-op-without->-cont-regexp)) + (c-lang-defconst c-stmt-delim-chars ;; The characters that should be considered to bound statements. To ;; optimize `c-crosses-statement-barrier-p' somewhat, it's assumed to @@ -1245,6 +1281,21 @@ operators." (c-lang-defvar c-stmt-delim-chars-with-comma (c-lang-const c-stmt-delim-chars-with-comma)) +(c-lang-defconst c-auto-ops + ;; Ops which signal C++11's new auto uses. + t nil + c++ '("=" "->")) +(c-lang-defconst c-auto-ops-re + t (c-make-keywords-re nil (c-lang-const c-auto-ops))) +(c-lang-defvar c-auto-ops-re (c-lang-const c-auto-ops-re)) + +(c-lang-defconst c-haskell-op + ;; Op used in the new C++11 auto function definition, indicating type. + t nil + c++ '("->")) +(c-lang-defconst c-haskell-op-re + t (c-make-keywords-re nil (c-lang-const c-haskell-op))) +(c-lang-defvar c-haskell-op-re (c-lang-const c-haskell-op-re)) ;;; Syntactic whitespace. @@ -1546,13 +1597,14 @@ properly." (c-lang-defvar c-syntactic-eol (c-lang-const c-syntactic-eol)) -;;; Defun functions - -;; The Emacs variables beginning-of-defun-function and -;; end-of-defun-function will be set so that commands like -;; `mark-defun' and `narrow-to-defun' work right. The key sequences -;; C-M-a and C-M-e are, however, bound directly to the CC Mode -;; functions, allowing optimization for large n. +;;; Defun handling. + +;; The Emacs variables beginning-of-defun-function and end-of-defun-function +;; will be set so that commands like `mark-defun' and `narrow-to-defun' work +;; right. In older Emacsen, the key sequences C-M-a and C-M-e are, however, +;; bound directly to the CC Mode functions, allowing optimization for large n. +;; From Emacs 23, this isn't necessary any more, since n is passed to the two +;; functions. (c-lang-defconst beginning-of-defun-function "Function to which beginning-of-defun-function will be set." t 'c-beginning-of-defun @@ -1607,7 +1659,7 @@ the appropriate place for that." '("_Bool" "_Complex" "_Imaginary") ; Conditionally defined in C99. (c-lang-const c-primitive-type-kwds)) c++ (append - '("bool" "wchar_t") + '("bool" "wchar_t" "char16_t" "char32_t") (c-lang-const c-primitive-type-kwds)) ;; Objective-C extends C, but probably not the new stuff in C99. objc (append @@ -1652,6 +1704,18 @@ of a variable declaration." 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-typeof-kwds + "Keywords followed by a parenthesized expression, which stands for +the type of that expression." + t nil + c '("typeof") ; longstanding GNU C(++) extension. + c++ '("decltype" "typeof")) + +(c-lang-defconst c-typeof-key + ;; Adorned regexp matching `c-typeof-kwds'. + t (c-make-keywords-re t (c-lang-const c-typeof-kwds))) +(c-lang-defvar c-typeof-key (c-lang-const c-typeof-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 @@ -1677,7 +1741,7 @@ but they don't build a type of themselves. Unlike the keywords on not the type face." t nil c '("const" "restrict" "volatile") - c++ '("const" "volatile" "throw") + c++ '("const" "constexpr" "noexcept" "volatile" "throw" "final" "override") objc '("const" "volatile")) (c-lang-defconst c-opt-type-modifier-key @@ -1701,7 +1765,7 @@ not the type face." (c-lang-defconst c-type-start-kwds ;; All keywords that can start a type (i.e. are either a type prefix ;; or a complete type). - t (cl-delete-duplicates (append (c-lang-const c-primitive-type-kwds) + t (delete-duplicates (append (c-lang-const c-primitive-type-kwds) (c-lang-const c-type-prefix-kwds) (c-lang-const c-type-modifier-kwds)) :test 'string-equal)) @@ -1754,6 +1818,26 @@ will be handled." t (c-make-keywords-re t (c-lang-const c-brace-list-decl-kwds))) (c-lang-defvar c-brace-list-key (c-lang-const c-brace-list-key)) +(c-lang-defconst c-after-brace-list-decl-kwds + "Keywords that might follow keywords in `c-brace-list-decl-kwds' +and precede the opening brace." + t nil + c++ '("class" "struct")) + +(c-lang-defconst c-after-brace-list-key + ;; Regexp matching keywords that can fall between a brace-list + ;; keyword and the associated brace list. + t (c-make-keywords-re t (c-lang-const c-after-brace-list-decl-kwds))) +(c-lang-defvar c-after-brace-list-key (c-lang-const c-after-brace-list-key)) + +(c-lang-defconst c-recognize-post-brace-list-type-p + "Set to t when we recognize a colon and then a type after an enum, +e.g., enum foo : int { A, B, C };" + t nil + c++ t) +(c-lang-defvar c-recognize-post-brace-list-type-p + (c-lang-const c-recognize-post-brace-list-type-p)) + (c-lang-defconst c-other-block-decl-kwds "Keywords where the following block (if any) contains another declaration level that should not be considered a class. For every @@ -1835,6 +1919,7 @@ will be handled." ;; {...}"). t (append (c-lang-const c-class-decl-kwds) (c-lang-const c-brace-list-decl-kwds)) + c++ (append (c-lang-const c-typeless-decl-kwds) '("auto")) ; C++11. ;; Note: "manages" for CORBA CIDL clashes with its presence on ;; `c-type-list-kwds' for IDL. idl (append (c-lang-const c-typeless-decl-kwds) @@ -1858,7 +1943,8 @@ If any of these also are on `c-type-list-kwds', `c-ref-list-kwds', will be handled." t nil (c c++) '("auto" "extern" "inline" "register" "static") - c++ (append '("explicit" "friend" "mutable" "template" "using" "virtual") + c++ (append '("explicit" "friend" "mutable" "template" "thread_local" + "using" "virtual") (c-lang-const c-modifier-kwds)) objc '("auto" "bycopy" "byref" "extern" "in" "inout" "oneway" "out" "static") ;; FIXME: Some of those below ought to be on `c-other-decl-kwds' instead. @@ -1944,7 +2030,7 @@ one of `c-type-list-kwds', `c-ref-list-kwds', ;; something is a type or just some sort of macro in front of the ;; declaration. They might be ambiguous with types or type ;; prefixes. - t (cl-delete-duplicates (append (c-lang-const c-class-decl-kwds) + t (delete-duplicates (append (c-lang-const c-class-decl-kwds) (c-lang-const c-brace-list-decl-kwds) (c-lang-const c-other-block-decl-kwds) (c-lang-const c-typedef-decl-kwds) @@ -1984,7 +2070,8 @@ one of `c-type-list-kwds', `c-ref-list-kwds', t (c-make-keywords-re t (set-difference (c-lang-const c-keywords) (append (c-lang-const c-type-start-kwds) - (c-lang-const c-prefix-spec-kwds)) + (c-lang-const c-prefix-spec-kwds) + (c-lang-const c-typeof-kwds)) :test 'string-equal))) (c-lang-defvar c-not-decl-init-keywords (c-lang-const c-not-decl-init-keywords)) @@ -2137,7 +2224,7 @@ type identifiers separated by arbitrary tokens." pike '("array" "function" "int" "mapping" "multiset" "object" "program")) (c-lang-defconst c-paren-any-kwds - t (cl-delete-duplicates (append (c-lang-const c-paren-nontype-kwds) + t (delete-duplicates (append (c-lang-const c-paren-nontype-kwds) (c-lang-const c-paren-type-kwds)) :test 'string-equal)) @@ -2163,7 +2250,7 @@ assumed to be set if this isn't nil." (c-lang-defconst c-<>-sexp-kwds ;; All keywords that can be followed by an angle bracket sexp. - t (cl-delete-duplicates (append (c-lang-const c-<>-type-kwds) + t (delete-duplicates (append (c-lang-const c-<>-type-kwds) (c-lang-const c-<>-arglist-kwds)) :test 'string-equal)) @@ -2223,7 +2310,7 @@ Keywords here should also be in `c-block-stmt-1-kwds'." (c-lang-defconst c-block-stmt-kwds ;; Union of `c-block-stmt-1-kwds' and `c-block-stmt-2-kwds'. - t (cl-delete-duplicates (append (c-lang-const c-block-stmt-1-kwds) + t (delete-duplicates (append (c-lang-const c-block-stmt-1-kwds) (c-lang-const c-block-stmt-2-kwds)) :test 'string-equal)) @@ -2309,8 +2396,11 @@ This construct is \"<keyword> <expression> :\"." (c-lang-defconst c-constant-kwds "Keywords for constants." t nil - (c c++) '("NULL" ;; Not a keyword, but practically works as one. + c '("NULL" ;; Not a keyword, but practically works as one. "false" "true") ; Defined in C99. + c++ (append + '("nullptr") + (c-lang-const c-constant-kwds)) objc '("nil" "Nil" "YES" "NO" "NS_DURING" "NS_HANDLER" "NS_ENDHANDLER") idl '("TRUE" "FALSE") java '("true" "false" "null") ; technically "literals", not keywords @@ -2327,7 +2417,7 @@ This construct is \"<keyword> <expression> :\"." (c-lang-defconst c-expr-kwds ;; Keywords that can occur anywhere in expressions. Built from ;; `c-primary-expr-kwds' and all keyword operators in `c-operators'. - t (cl-delete-duplicates + t (delete-duplicates (append (c-lang-const c-primary-expr-kwds) (c-filter-ops (c-lang-const c-operator-list) t @@ -2431,7 +2521,7 @@ Note that Java specific rules are currently applied to tell this from (c-lang-defconst c-keywords ;; All keywords as a list. - t (cl-delete-duplicates + t (delete-duplicates (c-lang-defconst-eval-immediately `(append ,@(mapcar (lambda (kwds-lang-const) `(c-lang-const ,kwds-lang-const)) @@ -2771,7 +2861,7 @@ possible for good performance." (c-lang-defvar c-block-prefix-charset (c-lang-const c-block-prefix-charset)) (c-lang-defconst c-type-decl-prefix-key - "Regexp matching the declarator operators that might precede the + "Regexp matching any declarator operator that might precede the identifier in a declaration, e.g. the \"*\" in \"char *argv\". This regexp should match \"(\" if parentheses are valid in declarators. The end of the first submatch is taken as the end of the operator. @@ -2916,17 +3006,15 @@ is in effect or not." (when (boundp (c-mode-symbol "font-lock-extra-types")) (c-mode-var "font-lock-extra-types"))) (regexp-strings - (apply 'nconc - (mapcar (lambda (re) - (when (string-match "[][.*+?^$\\]" re) - (list re))) - extra-types))) + (delq nil (mapcar (lambda (re) + (when (string-match "[][.*+?^$\\]" re) + re)) + extra-types))) (plain-strings - (apply 'nconc - (mapcar (lambda (re) - (unless (string-match "[][.*+?^$\\]" re) - (list re))) - extra-types)))) + (delq nil (mapcar (lambda (re) + (unless (string-match "[][.*+?^$\\]" re) + re)) + extra-types)))) (concat "\\<\\(" (c-concat-separated (append (list (c-make-keywords-re nil @@ -2970,7 +3058,8 @@ identifier or one of the keywords on `c-<>-type-kwds' or expression is considered to be a type." t (or (consp (c-lang-const c-<>-type-kwds)) (consp (c-lang-const c-<>-arglist-kwds))) - java t) + java t) ; 2008-10-19. This is crude. The syntax for java + ; generics is not yet coded in CC Mode. (c-lang-defvar c-recognize-<>-arglists (c-lang-const c-recognize-<>-arglists)) (c-lang-defconst c-enums-contain-decls @@ -3194,7 +3283,7 @@ accomplish that conveniently." ;; `c-lang-const' will expand to the evaluated ;; constant immediately in `c--macroexpand-all' ;; below. - (cl-mapcan + (mapcan (lambda (init) `(current-var ',(car init) ,(car init) ,(c--macroexpand-all @@ -3269,4 +3358,8 @@ evaluated and should not be quoted." (cc-provide 'cc-langs) +;;; Local Variables: +;;; indent-tabs-mode: t +;;; tab-width: 8 +;;; End: ;;; cc-langs.el ends here diff --git a/lisp/progmodes/cc-menus.el b/lisp/progmodes/cc-menus.el index 67425a0c82c..ae26e9b85c9 100644 --- a/lisp/progmodes/cc-menus.el +++ b/lisp/progmodes/cc-menus.el @@ -269,7 +269,7 @@ nested angle brackets constructs." "\\(" ; method name which gets captured ; into index "[" c-alpha "_]" - "[" c-alnum "_]*" + "[" c-alnum "_]*" "\\)" "[ \t\n\r]*" ;; An argument list that contains zero or more arguments. @@ -361,7 +361,7 @@ Example: p (1+ p)) (cond ;; Is CHAR part of a objc token? - ((and (not inargvar) ; Ignore if CHAR is part of an argument variable. + ((and (not inargvar) ; Ignore if CHAR is part of an argument variable. (eq 0 betweenparen) ; Ignore if CHAR is in parentheses. (or (and (<= ?a char) (<= char ?z)) (and (<= ?A char) (<= char ?Z)) @@ -521,4 +521,8 @@ Example: (cc-provide 'cc-menus) +;;; Local Variables: +;;; indent-tabs-mode: t +;;; tab-width: 8 +;;; End: ;;; cc-menus.el ends here diff --git a/lisp/progmodes/cc-mode.el b/lisp/progmodes/cc-mode.el index 1ce076734ff..a4824479b3c 100644 --- a/lisp/progmodes/cc-mode.el +++ b/lisp/progmodes/cc-mode.el @@ -108,11 +108,6 @@ ;; with your version of Emacs, you are incompatible! (cc-external-require 'easymenu) -;; Autoload directive for emacsen that doesn't have an older CC Mode -;; version in the dist. -(autoload 'subword-mode "subword" - "Mode enabling subword movement and editing keys." t) - ;; Load cc-fonts first after font-lock is loaded, since it isn't ;; necessary until font locking is requested. ; (eval-after-load "font-lock" ; 2006-07-09: font-lock is now preloaded. @@ -185,8 +180,7 @@ control). See \"cc-mode.el\" for more info." (run-hooks 'c-initialization-hook) ;; Fix obsolete variables. (if (boundp 'c-comment-continuation-stars) - (setq c-block-comment-prefix - (symbol-value 'c-comment-continuation-stars))) + (setq c-block-comment-prefix c-comment-continuation-stars)) (add-hook 'change-major-mode-hook 'c-leave-cc-mode-mode) (setq c-initialization-ok t) ;; Connect up with Emacs's electric-indent-mode, for >= Emacs 24.4 @@ -380,7 +374,7 @@ control). See \"cc-mode.el\" for more info." ;; conflicts with OOBR ;;(define-key c-mode-base-map "\C-c\C-v" 'c-version) ;; (define-key c-mode-base-map "\C-c\C-y" 'c-toggle-hungry-state) Commented out by ACM, 2005-11-22. - (define-key c-mode-base-map "\C-c\C-w" 'subword-mode) + (define-key c-mode-base-map "\C-c\C-w" 'c-subword-mode) ) ;; We don't require the outline package, but we configure it a bit anyway. @@ -472,6 +466,14 @@ preferably use the `c-mode-menu' language constant directly." (defvar c-maybe-stale-found-type nil) (make-variable-buffer-local 'c-maybe-stale-found-type) +(defvar c-just-done-before-change nil) +(make-variable-buffer-local 'c-just-done-before-change) +;; This variable is set to t by `c-before-change' and to nil by +;; `c-after-change'. It is used to detect a spurious invocation of +;; `before-change-functions' directly following on from a correct one. This +;; happens in some Emacsen, for example when `basic-save-buffer' does (insert +;; ?\n) when `require-final-newline' is non-nil. + (defun c-basic-common-init (mode default-style) "Do the necessary initialization for the syntax handling routines and the line breaking/filling code. Intended to be used by other @@ -542,10 +544,11 @@ that requires a literal mode spec at compile time." ;; Use this in Emacs 21+ to avoid meddling with the rear-nonsticky ;; property on each character. (when (boundp 'text-property-default-nonsticky) + (make-local-variable 'text-property-default-nonsticky) (mapc (lambda (tprop) (unless (assq tprop text-property-default-nonsticky) - (set (make-local-variable 'text-property-default-nonsticky) - (cons `(,tprop . t) text-property-default-nonsticky)))) + (setq text-property-default-nonsticky + (cons `(,tprop . t) text-property-default-nonsticky)))) '(syntax-table category c-type))) ;; In Emacs 21 and later it's possible to turn off the ad-hoc @@ -605,10 +608,12 @@ that requires a literal mode spec at compile time." (make-local-hook 'before-change-functions) (make-local-hook 'after-change-functions)) (add-hook 'before-change-functions 'c-before-change nil t) + (setq c-just-done-before-change nil) (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 - ; languages with #define (C, C++,; ObjC), and by AWK. + (when (boundp 'font-lock-extend-after-change-region-function) + (set (make-local-variable 'font-lock-extend-after-change-region-function) + 'c-extend-after-change-region))) ; Currently (2009-05) used by all + ; languages with #define (C, C++,; ObjC), and by AWK. (defun c-setup-doc-comment-style () "Initialize the variables that depend on the value of `c-doc-comment-style'." @@ -669,9 +674,11 @@ compatible with old code; callers should always specify it." (or (c-cpp-define-name) (c-defun-name)))) (let ((rfn (assq mode c-require-final-newline))) (when rfn - (and (cdr rfn) - (set (make-local-variable 'require-final-newline) - mode-require-final-newline))))) + (if (boundp 'mode-require-final-newline) + (and (cdr rfn) + (set (make-local-variable 'require-final-newline) + mode-require-final-newline)) + (set (make-local-variable 'require-final-newline) (cdr rfn)))))) (defun c-count-cfss (lv-alist) ;; LV-ALIST is an alist like `file-local-variables-alist'. Count how many @@ -948,7 +955,11 @@ Note that the style variables are always made local to the buffer." c-new-END (min (cdr new-bounds) (c-determine-+ve-limit 500 endd))) ;; 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) + + ;; CPP "comment" markers: + (if (eval-when-compile (memq 'category-properties c-emacs-features));Emacs. + (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. @@ -967,8 +978,10 @@ Note that the style variables are always made local to the buffer." (setq mbeg (point)) (if (> (c-syntactic-end-of-macro) mbeg) (progn - (c-neutralize-CPP-line mbeg (point)) - (c-set-cpp-delimiters mbeg (point))) + (c-neutralize-CPP-line mbeg (point)) ; "punctuation" properties + (if (eval-when-compile + (memq 'category-properties c-emacs-features)) ;Emacs. + (c-set-cpp-delimiters mbeg (point)))) ; "comment" markers (forward-line)) ; no infinite loop with, e.g., "#//" ))))) @@ -988,64 +1001,71 @@ Note that the style variables are always made local to the buffer." ;; it/them from the cache. Don't worry about being inside a string ;; or a comment - "wrongly" removing a symbol from `c-found-types' ;; isn't critical. - (setq c-maybe-stale-found-type nil) - (save-restriction - (save-match-data - (widen) - (save-excursion - ;; Are we inserting/deleting stuff in the middle of an identifier? - (c-unfind-enclosing-token beg) - (c-unfind-enclosing-token end) - ;; Are we coalescing two tokens together, e.g. "fo o" -> "foo"? - (when (< beg end) - (c-unfind-coalesced-tokens beg end)) - ;; Are we (potentially) disrupting the syntactic context which - ;; makes a type a type? E.g. by inserting stuff after "foo" in - ;; "foo bar;", or before "foo" in "typedef foo *bar;"? - ;; - ;; We search for appropriate c-type properties "near" the change. - ;; First, find an appropriate boundary for this property search. - (let (lim - type type-pos - marked-id term-pos - (end1 - (or (and (eq (get-text-property end 'face) 'font-lock-comment-face) - (previous-single-property-change end 'face)) - end))) - (when (>= end1 beg) ; Don't hassle about changes entirely in comments. - ;; Find a limit for the search for a `c-type' property - (while - (and (/= (skip-chars-backward "^;{}") 0) - (> (point) (point-min)) - (memq (c-get-char-property (1- (point)) 'face) - '(font-lock-comment-face font-lock-string-face)))) - (setq lim (max (point-min) (1- (point)))) - - ;; Look for the latest `c-type' property before end1 - (when (and (> end1 (point-min)) - (setq type-pos - (if (get-text-property (1- end1) 'c-type) - end1 - (previous-single-property-change end1 'c-type nil lim)))) - (setq type (get-text-property (max (1- type-pos) lim) 'c-type)) - - (when (memq type '(c-decl-id-start c-decl-type-start)) - ;; Get the identifier, if any, that the property is on. - (goto-char (1- type-pos)) - (setq marked-id - (when (looking-at "\\(\\sw\\|\\s_\\)") - (c-beginning-of-current-token) - (buffer-substring-no-properties (point) type-pos))) - - (goto-char end1) - (skip-chars-forward "^;{}") ; FIXME!!! loop for comment, maybe - (setq lim (point)) - (setq term-pos - (or (next-single-property-change end 'c-type nil lim) lim)) - (setq c-maybe-stale-found-type - (list type marked-id - type-pos term-pos - (buffer-substring-no-properties type-pos term-pos) + (unless c-just-done-before-change ; Guard against a spurious second + ; invocation of before-change-functions. + (setq c-just-done-before-change t) + (setq c-maybe-stale-found-type nil) + (save-restriction + (save-match-data + (widen) + (save-excursion + ;; Are we inserting/deleting stuff in the middle of an identifier? + (c-unfind-enclosing-token beg) + (c-unfind-enclosing-token end) + ;; Are we coalescing two tokens together, e.g. "fo o" -> "foo"? + (when (< beg end) + (c-unfind-coalesced-tokens beg end)) + ;; Are we (potentially) disrupting the syntactic context which + ;; makes a type a type? E.g. by inserting stuff after "foo" in + ;; "foo bar;", or before "foo" in "typedef foo *bar;"? + ;; + ;; We search for appropriate c-type properties "near" the change. + ;; First, find an appropriate boundary for this property search. + (let (lim + type type-pos + marked-id term-pos + (end1 + (or (and (eq (get-text-property end 'face) + 'font-lock-comment-face) + (previous-single-property-change end 'face)) + end))) + (when (>= end1 beg) ; Don't hassle about changes entirely in comments. + ;; Find a limit for the search for a `c-type' property + (while + (and (/= (skip-chars-backward "^;{}") 0) + (> (point) (point-min)) + (memq (c-get-char-property (1- (point)) 'face) + '(font-lock-comment-face font-lock-string-face)))) + (setq lim (max (point-min) (1- (point)))) + + ;; Look for the latest `c-type' property before end1 + (when (and (> end1 (point-min)) + (setq type-pos + (if (get-text-property (1- end1) 'c-type) + end1 + (previous-single-property-change end1 'c-type + nil lim)))) + (setq type (get-text-property (max (1- type-pos) lim) 'c-type)) + + (when (memq type '(c-decl-id-start c-decl-type-start)) + ;; Get the identifier, if any, that the property is on. + (goto-char (1- type-pos)) + (setq marked-id + (when (looking-at "\\(\\sw\\|\\s_\\)") + (c-beginning-of-current-token) + (buffer-substring-no-properties (point) type-pos))) + + (goto-char end1) + (skip-chars-forward "^;{}") ;FIXME!!! loop for comment, maybe + (setq lim (point)) + (setq term-pos + (or (c-next-single-property-change end 'c-type nil lim) + lim)) + (setq c-maybe-stale-found-type + (list type marked-id + type-pos term-pos + (buffer-substring-no-properties type-pos + term-pos) (buffer-substring-no-properties beg end))))))) (if c-get-state-before-change-functions @@ -1056,7 +1076,7 @@ Note that the style variables are always made local to the buffer." ))) ;; The following must be done here rather than in `c-after-change' because ;; newly inserted parens would foul up the invalidation algorithm. - (c-invalidate-state-cache beg)) + (c-invalidate-state-cache beg))) (defvar c-in-after-change-fontification nil) (make-variable-buffer-local 'c-in-after-change-fontification) @@ -1077,6 +1097,7 @@ Note that the style variables are always made local to the buffer." ;; This calls the language variable c-before-font-lock-functions, if non nil. ;; This typically sets `syntax-table' properties. + (setq c-just-done-before-change nil) (c-save-buffer-state (case-fold-search open-paren-in-column-0-is-defun-start) ;; When `combine-after-change-calls' is used we might get calls ;; with regions outside the current narrowing. This has been @@ -1097,11 +1118,12 @@ Note that the style variables are always made local to the buffer." ;; C-y is capable of spuriously converting category properties ;; c-</>-as-paren-syntax and c-cpp-delimiter 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-clear-char-property-with-value beg end 'syntax-table nil) + (when (eval-when-compile (memq 'category-properties c-emacs-features)) + (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-clear-char-property-with-value beg end 'syntax-table nil)) (c-trim-found-types beg end old-len) ; maybe we don't need all of these. (c-invalidate-sws-region-after beg end) @@ -1239,6 +1261,7 @@ This function is called from `c-common-init', once per mode initialization." (make-local-hook 'font-lock-mode-hook)) (add-hook 'font-lock-mode-hook 'c-after-font-lock-init nil t)) +;; Emacs 22 and later. (defun c-extend-after-change-region (_beg _end _old-len) "Extend the region to be fontified, if necessary." ;; Note: the parameters are ignored here. This somewhat indirect @@ -1252,6 +1275,21 @@ This function is called from `c-common-init', once per mode initialization." ;; function. (cons c-new-BEG c-new-END)) +;; Emacs < 22 and XEmacs +(defmacro c-advise-fl-for-region (function) + `(defadvice ,function (before get-awk-region activate) + ;; Make sure that any string/regexp is completely font-locked. + (when c-buffer-is-cc-mode + (save-excursion + (ad-set-arg 1 c-new-END) ; end + (ad-set-arg 0 c-new-BEG))))) ; beg + +(unless (boundp 'font-lock-extend-after-change-region-function) + (c-advise-fl-for-region font-lock-after-change-function) + (c-advise-fl-for-region jit-lock-after-change) + (c-advise-fl-for-region lazy-lock-defer-rest-after-change) + (c-advise-fl-for-region lazy-lock-defer-line-after-change)) + ;; Connect up to `electric-indent-mode' (Emacs 24.4 and later). (defun c-electric-indent-mode-hook () ;; Emacs has en/disabled `electric-indent-mode'. Propagate this through to @@ -1322,6 +1360,7 @@ This function is called from `c-common-init', once per mode initialization." ;;;###autoload (add-to-list 'auto-mode-alist '("\\.i\\'" . c-mode)) ;;;###autoload (add-to-list 'auto-mode-alist '("\\.ii\\'" . c++-mode)) +(unless (fboundp 'prog-mode) (defalias 'prog-mode 'fundamental-mode)) ;;;###autoload (define-derived-mode c-mode prog-mode "C" @@ -1779,4 +1818,8 @@ Key bindings: (cc-provide 'cc-mode) +;;; Local Variables: +;;; indent-tabs-mode: t +;;; tab-width: 8 +;;; End: ;;; cc-mode.el ends here diff --git a/lisp/progmodes/cc-styles.el b/lisp/progmodes/cc-styles.el index 337ef9212d9..793a6eac208 100644 --- a/lisp/progmodes/cc-styles.el +++ b/lisp/progmodes/cc-styles.el @@ -165,8 +165,8 @@ (c-offsets-alist . ((topmost-intro . 0) (substatement . +) (substatement-open . 0) - (case-label . +) - (access-label . -) + (case-label . +) + (access-label . -) (inclass . +) (inline-open . 0)))) ("linux" @@ -209,15 +209,15 @@ (c-offsets-alist . ((inline-open . 0) (topmost-intro-cont . +) (statement-block-intro . +) - (knr-argdecl-intro . 5) + (knr-argdecl-intro . 5) (substatement-open . +) (substatement-label . +) - (label . +) - (statement-case-open . +) - (statement-cont . +) - (arglist-intro . c-lineup-arglist-intro-after-paren) - (arglist-close . c-lineup-arglist) - (access-label . 0) + (label . +) + (statement-case-open . +) + (statement-cont . +) + (arglist-intro . c-lineup-arglist-intro-after-paren) + (arglist-close . c-lineup-arglist) + (access-label . 0) (inher-cont . c-lineup-java-inher) (func-decl-cont . c-lineup-java-throws)))) @@ -663,4 +663,8 @@ DEFAULT-STYLE has the same format as `c-default-style'." (cc-provide 'cc-styles) +;;; Local Variables: +;;; indent-tabs-mode: t +;;; tab-width: 8 +;;; End: ;;; cc-styles.el ends here diff --git a/lisp/progmodes/cc-vars.el b/lisp/progmodes/cc-vars.el index a8d627f94d4..635e382c755 100644 --- a/lisp/progmodes/cc-vars.el +++ b/lisp/progmodes/cc-vars.el @@ -271,17 +271,23 @@ nil." :group 'c) ;;;###autoload(put 'c-basic-offset 'safe-local-variable 'integerp) + (defcustom c-tab-always-indent t "*Controls the operation of the TAB key. If t, hitting TAB always just indents the current line. If nil, hitting TAB indents the current line if point is at the left margin or in the -line's indentation, otherwise it calls `c-insert-tab-function' to -insert a `real' tab character. If some other value (neither nil nor t), -then inserts a tab only within literals (comments and strings), but -always reindents the line. - -Note: the variable `c-comment-only-line-offset' also controls the -indentation of lines containing only comments." +line's indentation, otherwise it inserts a `real' tab character \(see +note\). If some other value (not nil or t), then tab is inserted only +within literals \(comments and strings), but the line is always +reindented. + +Note: The value of `indent-tabs-mode' will determine whether a real +tab character will be inserted, or the equivalent number of spaces. +When inserting a tab, actually the function stored in the variable +`c-insert-tab-function' is called. + +Note: indentation of lines containing only comments is also controlled +by the `c-comment-only-line-offset' variable." :type '(radio (const :tag "TAB key always indents, never inserts TAB" t) (const :tag "TAB key indents in left margin, otherwise inserts TAB" nil) @@ -535,7 +541,7 @@ variable in a mode hook." (const :format "IDL " idl-mode) (regexp :format "%v")) (cons :format "%v" (const :format "Pike " pike-mode) (regexp :format "%v")) - (cons :format "%v" + (cons :format "%v" (const :format "AWK " awk-mode) (regexp :format "%v"))) (cons :format " %v" (const :format "Other " other) (regexp :format "%v")))) @@ -920,7 +926,7 @@ Only currently supported behavior is `alignleft'." (defcustom c-special-indent-hook nil "*Hook for user defined special indentation adjustments. This hook gets called after each line is indented by the mode. It is only -called if `c-syntactic-indentation' is non-nil." +called when `c-syntactic-indentation' is non-nil." :type 'hook :group 'c) @@ -1170,7 +1176,7 @@ can always override the use of `c-default-style' by making calls to (objc-method-args-cont . c-lineup-ObjC-method-args) ;; Anchor pos: At the method start (always at boi). (objc-method-call-cont . (c-lineup-ObjC-method-call-colons - c-lineup-ObjC-method-call +)) + c-lineup-ObjC-method-call +)) ;; Anchor pos: At the open bracket. (extern-lang-open . 0) (namespace-open . 0) @@ -1689,7 +1695,8 @@ as designated in the variable `c-file-style'.") ;; It isn't possible to specify a doc-string without specifying an ;; initial value with `defvar', so the following two variables have been ;; given doc-strings by setting the property `variable-documentation' -;; directly. It's really good not to have an initial value for +;; directly. C-h v will read this documentation only for versions of GNU +;; Emacs from 22.1. It's really good not to have an initial value for ;; variables like these that always should be dynamically bound, so it's ;; worth the inconvenience. @@ -1765,4 +1772,8 @@ It treats escaped EOLs as whitespace.") (cc-provide 'cc-vars) +;;; Local Variables: +;;; indent-tabs-mode: t +;;; tab-width: 8 +;;; End: ;;; cc-vars.el ends here diff --git a/lisp/progmodes/cfengine.el b/lisp/progmodes/cfengine.el index 7d4f6dc25b9..53d5be90cab 100644 --- a/lisp/progmodes/cfengine.el +++ b/lisp/progmodes/cfengine.el @@ -27,9 +27,6 @@ ;; Provides support for editing GNU Cfengine files, including ;; font-locking, Imenu and indentation, but with no special keybindings. -;; The CFEngine 3.x support doesn't have Imenu support but patches are -;; welcome. - ;; By default, CFEngine 3.x syntax is used. ;; You can set it up so either `cfengine2-mode' (2.x and earlier) or @@ -56,7 +53,6 @@ ;;; Code: (autoload 'json-read "json") -(autoload 'regexp-opt "regexp-opt") (defgroup cfengine () "Editing CFEngine files." @@ -815,24 +811,24 @@ bundle agent rcfiles "List of the action keywords supported by Cfengine. This includes those for cfservd as well as cfagent.") - (defconst cfengine3-defuns - (mapcar - 'symbol-name - '(bundle body)) + (defconst cfengine3-defuns '("bundle" "body") "List of the CFEngine 3.x defun headings.") - (defconst cfengine3-defuns-regex - (regexp-opt cfengine3-defuns t) + (defconst cfengine3-defuns-regex (regexp-opt cfengine3-defuns t) "Regex to match the CFEngine 3.x defuns.") + (defconst cfengine3-defun-full-re (concat "^\\s-*" cfengine3-defuns-regex + "\\s-+\\(\\(?:\\w\\|\\s_\\)+\\)" ;type + "\\s-+\\(\\(?:\\w\\|\\s_\\)+\\)" ;id + ) + "Regexp matching full defun declaration (excluding argument list).") + (defconst cfengine3-class-selector-regex "\\([[:alnum:]_().&|!:]+\\)::") (defconst cfengine3-category-regex "\\([[:alnum:]_]+\\):") - (defconst cfengine3-vartypes - (mapcar - 'symbol-name - '(string int real slist ilist rlist irange rrange counter data)) + (defconst cfengine3-vartypes '("string" "int" "real" "slist" "ilist" "rlist" + "irange" "rrange" "counter" "data") "List of the CFEngine 3.x variable types.")) (defvar cfengine2-font-lock-keywords @@ -1231,29 +1227,32 @@ Should not be necessary unless you reinstall CFEngine." (setq cfengine-mode-syntax-cache nil)) (defun cfengine3-make-syntax-cache () - "Build the CFEngine 3 syntax cache. -Calls `cfengine-cf-promises' with \"-s json\"" - (let ((syntax (cddr (assoc cfengine-cf-promises cfengine-mode-syntax-cache)))) - (if cfengine-cf-promises - (or syntax - (with-demoted-errors - (with-temp-buffer - (call-process-shell-command cfengine-cf-promises - nil ; no input - t ; current buffer - nil ; no redisplay - "-s" "json") - (goto-char (point-min)) - (setq syntax (json-read)) - (setq cfengine-mode-syntax-cache - (cons (cons cfengine-cf-promises syntax) - cfengine-mode-syntax-cache)) - (setq cfengine-mode-syntax-functions-regex - (regexp-opt (mapcar (lambda (def) - (format "%s" (car def))) - (cdr (assq 'functions syntax))) - 'symbols)))))) - cfengine3-fallback-syntax)) + "Build the CFEngine 3 syntax cache and return the syntax. +Calls `cfengine-cf-promises' with \"-s json\"." + (or (cdr (assoc cfengine-cf-promises cfengine-mode-syntax-cache)) + (let ((syntax (or (when cfengine-cf-promises + (with-demoted-errors "cfengine3-make-syntax-cache: %S" + (with-temp-buffer + (or (zerop (process-file cfengine-cf-promises + nil ; no input + t ; output + nil ; no redisplay + "-s" "json")) + (error "%s" (buffer-substring + (point-min) + (progn (goto-char (point-min)) + (line-end-position))))) + (goto-char (point-min)) + (json-read)))) + cfengine3-fallback-syntax))) + (push (cons cfengine-cf-promises syntax) + cfengine-mode-syntax-cache) + (setq cfengine-mode-syntax-functions-regex + (regexp-opt (mapcar (lambda (def) + (format "%s" (car def))) + (cdr (assq 'functions syntax))) + 'symbols)) + syntax))) (defun cfengine3-documentation-function () "Document CFengine 3 functions around point. @@ -1265,7 +1264,6 @@ Use it by enabling `eldoc-mode'." (defun cfengine3-completion-function () "Return completions for function name around or before point." - (cfengine3-make-syntax-cache) (let* ((bounds (save-excursion (let ((p (point))) (skip-syntax-backward "w_" (point-at-bol)) @@ -1306,6 +1304,26 @@ Use it by enabling `eldoc-mode'." ("=>" . ?⇒) ("::" . ?∷))) +(defun cfengine3-create-imenu-index () + "A function for `imenu-create-index-function'. +Note: defun name is separated by space such as `body +package_method opencsw' and imenu will replace spaces according +to `imenu-space-replacement' (which see)." + (goto-char (point-min)) + (let ((defuns ())) + (while (re-search-forward cfengine3-defun-full-re nil t) + (push (cons (mapconcat #'match-string '(1 2 3) " ") + (copy-marker (match-beginning 3))) + defuns)) + (nreverse defuns))) + +(defun cfengine3-current-defun () + "A function for `add-log-current-defun-function'." + (end-of-line) + (beginning-of-defun) + (and (looking-at cfengine3-defun-full-re) + (mapconcat #'match-string '(1 2 3) " "))) + ;;;###autoload (define-derived-mode cfengine3-mode prog-mode "CFE3" "Major mode for editing CFEngine3 input. @@ -1332,17 +1350,17 @@ to the action header." (when buffer-file-name (shell-quote-argument buffer-file-name))))) - (set (make-local-variable 'eldoc-documentation-function) - #'cfengine3-documentation-function) + (setq-local eldoc-documentation-function #'cfengine3-documentation-function) (add-hook 'completion-at-point-functions #'cfengine3-completion-function nil t) ;; Use defuns as the essential syntax block. - (set (make-local-variable 'beginning-of-defun-function) - #'cfengine3-beginning-of-defun) - (set (make-local-variable 'end-of-defun-function) - #'cfengine3-end-of-defun)) + (setq-local beginning-of-defun-function #'cfengine3-beginning-of-defun) + (setq-local end-of-defun-function #'cfengine3-end-of-defun) + + (setq-local imenu-create-index-function #'cfengine3-create-imenu-index) + (setq-local add-log-current-defun-function #'cfengine3-current-defun)) ;;;###autoload (define-derived-mode cfengine2-mode prog-mode "CFE2" @@ -1376,15 +1394,18 @@ to the action header." ;;;###autoload (defun cfengine-auto-mode () - "Choose between `cfengine2-mode' and `cfengine3-mode' depending -on the buffer contents" - (let ((v3 nil)) - (save-restriction - (goto-char (point-min)) - (while (not (or (eobp) v3)) - (setq v3 (looking-at (concat cfengine3-defuns-regex "\\_>"))) - (forward-line))) - (if v3 (cfengine3-mode) (cfengine2-mode)))) + "Choose `cfengine2-mode' or `cfengine3-mode' by buffer contents." + (interactive) + (if (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (forward-comment (point-max)) + (or (eobp) + (re-search-forward + (concat "^\\s-*" cfengine3-defuns-regex "\\_>") nil t)))) + (cfengine3-mode) + (cfengine2-mode))) (defalias 'cfengine-mode 'cfengine3-mode) diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el index 2771cee977e..5de2c6afa53 100644 --- a/lisp/progmodes/compile.el +++ b/lisp/progmodes/compile.el @@ -134,7 +134,7 @@ and a string describing how the process finished.") ;; emacs -batch -l compile-tests.el -f ert-run-tests-batch-and-exit (defvar compilation-error-regexp-alist-alist - '((absoft + `((absoft "^\\(?:[Ee]rror on \\|[Ww]arning on\\( \\)\\)?[Ll]ine[ \t]+\\([0-9]+\\)[ \t]+\ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1)) @@ -255,16 +255,46 @@ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1)) ;; 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 -, 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]+\\)\\(?:-\\(?4:[0-9]+\\)\\(?:\\.\\(?5:[0-9]+\\)\\)?\ -\\|[.:]\\(?3:[0-9]+\\)\\(?:-\\(?:\\(?4:[0-9]+\\)\\.\\)?\\(?5:[0-9]+\\)\\)?\\)?:\ -\\(?: *\\(\\(?:Future\\|Runtime\\)?[Ww]arning\\|W:\\)\\|\ - *\\([Ii]nfo\\(?:\\>\\|rmationa?l?\\)\\|I:\\|\\[ skipping .+ \\]\\|\ -\\(?:instantiated\\|required\\) from\\|[Nn]ote\\)\\|\ - *[Ee]rror\\|[0-9]?\\(?:[^0-9\n]\\|$\\)\\|[0-9][0-9][0-9]\\)" + ,(rx + bol + (? (| (regexp "[[:alpha:]][-[:alnum:].]+: ?") + (regexp "[ \t]+\\(?:in \\|from\\)"))) + (group-n 1 (: (regexp "[0-9]*[^0-9\n]") + (*? (| (regexp "[^\n :]") + (regexp " [^-/\n]") + (regexp ":[^ \n]"))))) + (regexp ": ?") + (group-n 2 (regexp "[0-9]+")) + (? (| (: "-" + (group-n 4 (regexp "[0-9]+")) + (? "." (group-n 5 (regexp "[0-9]+")))) + (: (in ".:") + (group-n 3 (regexp "[0-9]+")) + (? "-" + (? (group-n 4 (regexp "[0-9]+")) ".") + (group-n 5 (regexp "[0-9]+")))))) + ":" + (| (: (* " ") + (group-n 6 (| "FutureWarning" + "RuntimeWarning" + "Warning" + "warning" + "W:"))) + (: (* " ") + (group-n 7 (| (regexp "[Ii]nfo\\(?:\\>\\|rmationa?l?\\)") + "I:" + (: "[ skipping " (+ ".") " ]") + "instantiated from" + "required from" + (regexp "[Nn]ote")))) + (: (* " ") + (regexp "[Ee]rror")) + (: (regexp "[0-9]?") + (| (regexp "[^0-9\n]") + eol)) + (regexp "[0-9][0-9][0-9]"))) 1 (2 . 4) (3 . 5) (6 . 7)) (lcc @@ -447,6 +477,8 @@ File = \\(.+\\), Line = \\([0-9]+\\)\\(?:, Column = \\([0-9]+\\)\\)?" ;; "^\\([^ \t\r\n(]+\\) (\\([0-9]+\\):\\([0-9]+\\)) " 1 2 3) + (guile-file "^In \\(.+\\):\n" 1) + (guile-line "^ *\\([0-9]+\\): *\\([0-9]+\\)" nil 1 2) ) "Alist of values for `compilation-error-regexp-alist'.") @@ -937,19 +969,12 @@ POS and RES.") (cons (copy-marker pos) (if prev (copy-marker prev)))) prev) ((and prev (= prev cache)) - (if cache - (set-marker (car compilation--previous-directory-cache) pos) - (setq compilation--previous-directory-cache - (cons (copy-marker pos) nil))) + (set-marker (car compilation--previous-directory-cache) pos) (cdr compilation--previous-directory-cache)) (t - (if cache - (progn - (set-marker cache pos) - (setcdr compilation--previous-directory-cache - (copy-marker prev))) - (setq compilation--previous-directory-cache - (cons (copy-marker pos) (if prev (copy-marker prev))))) + (set-marker cache pos) + (setcdr compilation--previous-directory-cache + (copy-marker prev)) prev)))) (if (markerp res) (marker-position res) res)))) @@ -2054,8 +2079,7 @@ Optional argument MINOR indicates this is called from (if minor (progn (font-lock-add-keywords nil (compilation-mode-font-lock-keywords)) - (if font-lock-mode - (font-lock-fontify-buffer))) + (font-lock-flush)) (setq font-lock-defaults '(compilation-mode-font-lock-keywords t)))) (defun compilation--unsetup () @@ -2064,8 +2088,7 @@ Optional argument MINOR indicates this is called from (remove-hook 'before-change-functions 'compilation--flush-parse t) (kill-local-variable 'compilation--parsed) (compilation--remove-properties) - (if font-lock-mode - (font-lock-fontify-buffer))) + (font-lock-flush)) ;;;###autoload (define-minor-mode compilation-shell-minor-mode @@ -2271,6 +2294,7 @@ looking for the next message." (or (compilation-buffer-p (current-buffer)) (error "Not in a compilation buffer")) (or pt (setq pt (point))) + (compilation--ensure-parse pt) (let* ((msg (get-text-property pt 'compilation-message)) ;; `loc', `msg', and `last' are used by the compilation-loop macro. (loc (and msg (compilation--message->loc msg))) @@ -2283,7 +2307,8 @@ looking for the next message." (line-beginning-position))) (unless (setq msg (get-text-property (max (1- pt) (point-min)) 'compilation-message)) - (setq pt (next-single-property-change pt 'compilation-message nil + (setq pt (compilation-next-single-property-change + pt 'compilation-message nil (line-end-position))) (or (setq msg (get-text-property pt 'compilation-message)) (setq pt (point))))) @@ -2294,7 +2319,6 @@ looking for the next message." "No more %ss yet" "Moved past last %s") (point-max)) - (compilation--ensure-parse pt) ;; Don't move "back" to message at or before point. ;; Pass an explicit (point-min) to make sure pt is non-nil. (setq pt (previous-single-property-change diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el index c4f2b9ffe51..cd60475974c 100644 --- a/lisp/progmodes/cperl-mode.el +++ b/lisp/progmodes/cperl-mode.el @@ -4828,9 +4828,9 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (and (memq (char-syntax (preceding-char)) '(?w ?_)) (progn (backward-sexp) - ;; sub {BLK}, print {BLK} $data, but NOT `bless', `return', `tr' + ;; sub {BLK}, print {BLK} $data, but NOT `bless', `return', `tr', `constant' (or (and (looking-at "[a-zA-Z0-9_:]+[ \t\n\f]*[{#]") ; Method call syntax - (not (looking-at "\\(bless\\|return\\|q[wqrx]?\\|tr\\|[smy]\\)\\>"))) + (not (looking-at "\\(bless\\|return\\|q[wqrx]?\\|tr\\|[smy]\\|constant\\)\\>"))) ;; sub bless::foo {} (progn (cperl-backward-to-noncomment (point-min)) diff --git a/lisp/progmodes/cwarn.el b/lisp/progmodes/cwarn.el index 4e4fc138877..1aa5170591a 100644 --- a/lisp/progmodes/cwarn.el +++ b/lisp/progmodes/cwarn.el @@ -188,7 +188,7 @@ and disable it otherwise. If called from Lisp, enable the mode if ARG is omitted or nil." :group 'cwarn :lighter cwarn-mode-text (cwarn-font-lock-keywords cwarn-mode) - (if font-lock-mode (font-lock-fontify-buffer))) + (font-lock-flush)) ;;;###autoload (define-obsolete-function-alias 'turn-on-cwarn-mode 'cwarn-mode "24.1") diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el new file mode 100644 index 00000000000..c6cab1257a5 --- /dev/null +++ b/lisp/progmodes/elisp-mode.el @@ -0,0 +1,1376 @@ +;;; elisp-mode.el --- Emacs Lisp mode -*- lexical-binding:t -*- + +;; Copyright (C) 1985-1986, 1999-2014 Free Software Foundation, Inc. + +;; Maintainer: emacs-devel@gnu.org +;; Keywords: lisp, languages +;; Package: emacs + +;; 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: + +;; The major mode for editing Emacs Lisp code. +;; This mode is documented in the Emacs manual. + +;;; Code: + +(require 'lisp-mode) + +(defvar emacs-lisp-mode-abbrev-table nil) +(define-abbrev-table 'emacs-lisp-mode-abbrev-table () + "Abbrev table for Emacs Lisp mode. +It has `lisp-mode-abbrev-table' as its parent." + :parents (list lisp-mode-abbrev-table)) + +(defvar emacs-lisp-mode-syntax-table + (let ((table (make-syntax-table lisp--mode-syntax-table))) + (modify-syntax-entry ?\[ "(] " table) + (modify-syntax-entry ?\] ")[ " table) + table) + "Syntax table used in `emacs-lisp-mode'.") + +(defvar emacs-lisp-mode-map + (let ((map (make-sparse-keymap "Emacs-Lisp")) + (menu-map (make-sparse-keymap "Emacs-Lisp")) + (lint-map (make-sparse-keymap)) + (prof-map (make-sparse-keymap)) + (tracing-map (make-sparse-keymap))) + (set-keymap-parent map lisp-mode-shared-map) + (define-key map "\e\t" 'completion-at-point) + (define-key map "\e\C-x" 'eval-defun) + (define-key map "\e\C-q" 'indent-pp-sexp) + (bindings--define-key map [menu-bar emacs-lisp] + (cons "Emacs-Lisp" menu-map)) + (bindings--define-key menu-map [eldoc] + '(menu-item "Auto-Display Documentation Strings" eldoc-mode + :button (:toggle . (bound-and-true-p eldoc-mode)) + :help "Display the documentation string for the item under cursor")) + (bindings--define-key menu-map [checkdoc] + '(menu-item "Check Documentation Strings" checkdoc + :help "Check documentation strings for style requirements")) + (bindings--define-key menu-map [re-builder] + '(menu-item "Construct Regexp" re-builder + :help "Construct a regexp interactively")) + (bindings--define-key menu-map [tracing] (cons "Tracing" tracing-map)) + (bindings--define-key tracing-map [tr-a] + '(menu-item "Untrace All" untrace-all + :help "Untrace all currently traced functions")) + (bindings--define-key tracing-map [tr-uf] + '(menu-item "Untrace Function..." untrace-function + :help "Untrace function, and possibly activate all remaining advice")) + (bindings--define-key tracing-map [tr-sep] menu-bar-separator) + (bindings--define-key tracing-map [tr-q] + '(menu-item "Trace Function Quietly..." trace-function-background + :help "Trace the function with trace output going quietly to a buffer")) + (bindings--define-key tracing-map [tr-f] + '(menu-item "Trace Function..." trace-function + :help "Trace the function given as an argument")) + (bindings--define-key menu-map [profiling] (cons "Profiling" prof-map)) + (bindings--define-key prof-map [prof-restall] + '(menu-item "Remove Instrumentation for All Functions" elp-restore-all + :help "Restore the original definitions of all functions being profiled")) + (bindings--define-key prof-map [prof-restfunc] + '(menu-item "Remove Instrumentation for Function..." elp-restore-function + :help "Restore an instrumented function to its original definition")) + + (bindings--define-key prof-map [sep-rem] menu-bar-separator) + (bindings--define-key prof-map [prof-resall] + '(menu-item "Reset Counters for All Functions" elp-reset-all + :help "Reset the profiling information for all functions being profiled")) + (bindings--define-key prof-map [prof-resfunc] + '(menu-item "Reset Counters for Function..." elp-reset-function + :help "Reset the profiling information for a function")) + (bindings--define-key prof-map [prof-res] + '(menu-item "Show Profiling Results" elp-results + :help "Display current profiling results")) + (bindings--define-key prof-map [prof-pack] + '(menu-item "Instrument Package..." elp-instrument-package + :help "Instrument for profiling all function that start with a prefix")) + (bindings--define-key prof-map [prof-func] + '(menu-item "Instrument Function..." elp-instrument-function + :help "Instrument a function for profiling")) + ;; Maybe this should be in a separate submenu from the ELP stuff? + (bindings--define-key prof-map [sep-natprof] menu-bar-separator) + (bindings--define-key prof-map [prof-natprof-stop] + '(menu-item "Stop Native Profiler" profiler-stop + :help "Stop recording profiling information" + :enable (and (featurep 'profiler) + (profiler-running-p)))) + (bindings--define-key prof-map [prof-natprof-report] + '(menu-item "Show Profiler Report" profiler-report + :help "Show the current profiler report" + :enable (and (featurep 'profiler) + (profiler-running-p)))) + (bindings--define-key prof-map [prof-natprof-start] + '(menu-item "Start Native Profiler..." profiler-start + :help "Start recording profiling information")) + + (bindings--define-key menu-map [lint] (cons "Linting" lint-map)) + (bindings--define-key lint-map [lint-di] + '(menu-item "Lint Directory..." elint-directory + :help "Lint a directory")) + (bindings--define-key lint-map [lint-f] + '(menu-item "Lint File..." elint-file + :help "Lint a file")) + (bindings--define-key lint-map [lint-b] + '(menu-item "Lint Buffer" elint-current-buffer + :help "Lint the current buffer")) + (bindings--define-key lint-map [lint-d] + '(menu-item "Lint Defun" elint-defun + :help "Lint the function at point")) + (bindings--define-key menu-map [edebug-defun] + '(menu-item "Instrument Function for Debugging" edebug-defun + :help "Evaluate the top level form point is in, stepping through with Edebug" + :keys "C-u C-M-x")) + (bindings--define-key menu-map [separator-byte] menu-bar-separator) + (bindings--define-key menu-map [disas] + '(menu-item "Disassemble Byte Compiled Object..." disassemble + :help "Print disassembled code for OBJECT in a buffer")) + (bindings--define-key menu-map [byte-recompile] + '(menu-item "Byte-recompile Directory..." byte-recompile-directory + :help "Recompile every `.el' file in DIRECTORY that needs recompilation")) + (bindings--define-key menu-map [emacs-byte-compile-and-load] + '(menu-item "Byte-compile and Load" emacs-lisp-byte-compile-and-load + :help "Byte-compile the current file (if it has changed), then load compiled code")) + (bindings--define-key menu-map [byte-compile] + '(menu-item "Byte-compile This File" emacs-lisp-byte-compile + :help "Byte compile the file containing the current buffer")) + (bindings--define-key menu-map [separator-eval] menu-bar-separator) + (bindings--define-key menu-map [ielm] + '(menu-item "Interactive Expression Evaluation" ielm + :help "Interactively evaluate Emacs Lisp expressions")) + (bindings--define-key menu-map [eval-buffer] + '(menu-item "Evaluate Buffer" eval-buffer + :help "Execute the current buffer as Lisp code")) + (bindings--define-key menu-map [eval-region] + '(menu-item "Evaluate Region" eval-region + :help "Execute the region as Lisp code" + :enable mark-active)) + (bindings--define-key menu-map [eval-sexp] + '(menu-item "Evaluate Last S-expression" eval-last-sexp + :help "Evaluate sexp before point; print value in echo area")) + (bindings--define-key menu-map [separator-format] menu-bar-separator) + (bindings--define-key menu-map [comment-region] + '(menu-item "Comment Out Region" comment-region + :help "Comment or uncomment each line in the region" + :enable mark-active)) + (bindings--define-key menu-map [indent-region] + '(menu-item "Indent Region" indent-region + :help "Indent each nonblank line in the region" + :enable mark-active)) + (bindings--define-key menu-map [indent-line] + '(menu-item "Indent Line" lisp-indent-line)) + map) + "Keymap for Emacs Lisp mode. +All commands in `lisp-mode-shared-map' are inherited by this map.") + +(defun emacs-lisp-byte-compile () + "Byte compile the file containing the current buffer." + (interactive) + (if buffer-file-name + (byte-compile-file buffer-file-name) + (error "The buffer must be saved in a file first"))) + +(defun emacs-lisp-byte-compile-and-load () + "Byte-compile the current file (if it has changed), then load compiled code." + (interactive) + (or buffer-file-name + (error "The buffer must be saved in a file first")) + (require 'bytecomp) + ;; Recompile if file or buffer has changed since last compilation. + (if (and (buffer-modified-p) + (y-or-n-p (format "Save buffer %s first? " (buffer-name)))) + (save-buffer)) + (byte-recompile-file buffer-file-name nil 0 t)) + +(defun emacs-lisp-macroexpand () + "Macroexpand the form after point. +Comments in the form will be lost." + (interactive) + (let* ((start (point)) + (exp (read (current-buffer))) + ;; Compute it before, since it may signal errors. + (new (macroexpand-1 exp))) + (if (equal exp new) + (message "Not a macro call, nothing to expand") + (delete-region start (point)) + (pp new (current-buffer)) + (if (bolp) (delete-char -1)) + (indent-region start (point))))) + +(defcustom emacs-lisp-mode-hook nil + "Hook run when entering Emacs Lisp mode." + :options '(eldoc-mode imenu-add-menubar-index checkdoc-minor-mode) + :type 'hook + :group 'lisp) + +;;;###autoload +(define-derived-mode emacs-lisp-mode prog-mode "Emacs-Lisp" + "Major mode for editing Lisp code to run in Emacs. +Commands: +Delete converts tabs to spaces as it moves back. +Blank lines separate paragraphs. Semicolons start comments. + +\\{emacs-lisp-mode-map}" + :group 'lisp + (defvar xref-find-function) + (defvar xref-identifier-completion-table-function) + (lisp-mode-variables nil nil 'elisp) + (setq imenu-case-fold-search nil) + (setq-local eldoc-documentation-function + #'elisp-eldoc-documentation-function) + (setq-local xref-find-function #'elisp-xref-find) + (setq-local xref-identifier-completion-table-function + #'elisp--xref-identifier-completion-table) + (add-hook 'completion-at-point-functions + #'elisp-completion-at-point nil 'local)) + +;;; Completion at point for Elisp + +(defun elisp--local-variables-1 (vars sexp) + "Return the vars locally bound around the witness, or nil if not found." + (let (res) + (while + (unless + (setq res + (pcase sexp + (`(,(or `let `let*) ,bindings) + (let ((vars vars)) + (when (eq 'let* (car sexp)) + (dolist (binding (cdr (reverse bindings))) + (push (or (car-safe binding) binding) vars))) + (elisp--local-variables-1 + vars (car (cdr-safe (car (last bindings))))))) + (`(,(or `let `let*) ,bindings . ,body) + (let ((vars vars)) + (dolist (binding bindings) + (push (or (car-safe binding) binding) vars)) + (elisp--local-variables-1 vars (car (last body))))) + (`(lambda ,_args) + ;; FIXME: Look for the witness inside `args'. + (setq sexp nil)) + (`(lambda ,args . ,body) + (elisp--local-variables-1 + (append (remq '&optional (remq '&rest args)) vars) + (car (last body)))) + (`(condition-case ,_ ,e) (elisp--local-variables-1 vars e)) + (`(condition-case ,v ,_ . ,catches) + (elisp--local-variables-1 + (cons v vars) (cdr (car (last catches))))) + (`(quote . ,_) + ;; FIXME: Look for the witness inside sexp. + (setq sexp nil)) + ;; FIXME: Handle `cond'. + (`(,_ . ,_) + (elisp--local-variables-1 vars (car (last sexp)))) + (`elisp--witness--lisp (or vars '(nil))) + (_ nil))) + ;; We didn't find the witness in the last element so we try to + ;; backtrack to the last-but-one. + (setq sexp (ignore-errors (butlast sexp))))) + res)) + +(defun elisp--local-variables () + "Return a list of locally let-bound variables at point." + (save-excursion + (skip-syntax-backward "w_") + (let* ((ppss (syntax-ppss)) + (txt (buffer-substring-no-properties (or (car (nth 9 ppss)) (point)) + (or (nth 8 ppss) (point)))) + (closer ())) + (dolist (p (nth 9 ppss)) + (push (cdr (syntax-after p)) closer)) + (setq closer (apply #'string closer)) + (let* ((sexp (condition-case nil + (car (read-from-string + (concat txt "elisp--witness--lisp" closer))) + ((invalid-read-syntax end-of-file) nil))) + (macroexpand-advice (lambda (expander form &rest args) + (condition-case nil + (apply expander form args) + (error form)))) + (sexp + (unwind-protect + (progn + (advice-add 'macroexpand :around macroexpand-advice) + (macroexpand-all sexp)) + (advice-remove 'macroexpand macroexpand-advice))) + (vars (elisp--local-variables-1 nil sexp))) + (delq nil + (mapcar (lambda (var) + (and (symbolp var) + (not (string-match (symbol-name var) "\\`[&_]")) + ;; Eliminate uninterned vars. + (intern-soft var) + var)) + vars)))))) + +(defvar elisp--local-variables-completion-table + ;; Use `defvar' rather than `defconst' since defconst would purecopy this + ;; value, which would doubly fail: it would fail because purecopy can't + ;; handle the recursive bytecode object, and it would fail because it would + ;; move `lastpos' and `lastvars' to pure space where they'd be immutable! + (let ((lastpos nil) (lastvars nil)) + (letrec ((hookfun (lambda () + (setq lastpos nil) + (remove-hook 'post-command-hook hookfun)))) + (completion-table-dynamic + (lambda (_string) + (save-excursion + (skip-syntax-backward "_w") + (let ((newpos (cons (point) (current-buffer)))) + (unless (equal lastpos newpos) + (add-hook 'post-command-hook hookfun) + (setq lastpos newpos) + (setq lastvars + (mapcar #'symbol-name (elisp--local-variables)))))) + lastvars))))) + +(defun elisp--expect-function-p (pos) + "Return non-nil if the symbol at point is expected to be a function." + (or + (and (eq (char-before pos) ?') + (eq (char-before (1- pos)) ?#)) + (save-excursion + (let ((parent (nth 1 (syntax-ppss pos)))) + (when parent + (goto-char parent) + (and + (looking-at (concat "(\\(cl-\\)?" + (regexp-opt '("declare-function" + "function" "defadvice" + "callf" "callf2" + "defsetf")) + "[ \t\r\n]+")) + (eq (match-end 0) pos))))))) + +(defun elisp--form-quoted-p (pos) + "Return non-nil if the form at POS is not evaluated. +It can be quoted, or be inside a quoted form." + ;; FIXME: Do some macro expansion maybe. + (save-excursion + (let ((state (syntax-ppss pos))) + (or (nth 8 state) ; Code inside strings usually isn't evaluated. + ;; FIXME: The 9th element is undocumented. + (let ((nesting (cons (point) (reverse (nth 9 state)))) + res) + (while (and nesting (not res)) + (goto-char (pop nesting)) + (cond + ((or (eq (char-after) ?\[) + (progn + (skip-chars-backward " ") + (memq (char-before) '(?' ?`)))) + (setq res t)) + ((eq (char-before) ?,) + (setq nesting nil)))) + res))))) + +;; FIXME: Support for Company brings in features which straddle eldoc. +;; We should consolidate this, so that major modes can provide all that +;; data all at once: +;; - a function to extract "the reference at point" (may be more complex +;; than a mere string, to distinguish various namespaces). +;; - a function to jump to such a reference. +;; - a function to show the signature/interface of such a reference. +;; - a function to build a help-buffer about that reference. +;; FIXME: Those functions should also be used by the normal completion code in +;; the *Completions* buffer. + +(defun elisp--company-doc-buffer (str) + (let ((symbol (intern-soft str))) + ;; FIXME: we really don't want to "display-buffer and then undo it". + (save-window-excursion + ;; Make sure we don't display it in another frame, otherwise + ;; save-window-excursion won't be able to undo it. + (let ((display-buffer-overriding-action + '(nil . ((inhibit-switch-frame . t))))) + (ignore-errors + (cond + ((fboundp symbol) (describe-function symbol)) + ((boundp symbol) (describe-variable symbol)) + ((featurep symbol) (describe-package symbol)) + ((facep symbol) (describe-face symbol)) + (t (signal 'user-error nil))) + (help-buffer)))))) + +(defun elisp--company-doc-string (str) + (let* ((symbol (intern-soft str)) + (doc (if (fboundp symbol) + (documentation symbol t) + (documentation-property symbol 'variable-documentation t)))) + (and (stringp doc) + (string-match ".*$" doc) + (match-string 0 doc)))) + +(declare-function find-library-name "find-func" (library)) +(declare-function find-function-library "find-func" (function &optional l-o v)) + +(defun elisp--company-location (str) + (let ((sym (intern-soft str))) + (cond + ((fboundp sym) (find-definition-noselect sym nil)) + ((boundp sym) (find-definition-noselect sym 'defvar)) + ((featurep sym) + (require 'find-func) + (cons (find-file-noselect (find-library-name + (symbol-name sym))) + 0)) + ((facep sym) (find-definition-noselect sym 'defface))))) + +(defun elisp-completion-at-point () + "Function used for `completion-at-point-functions' in `emacs-lisp-mode'." + (with-syntax-table emacs-lisp-mode-syntax-table + (let* ((pos (point)) + (beg (condition-case nil + (save-excursion + (backward-sexp 1) + (skip-syntax-forward "'") + (point)) + (scan-error pos))) + (end + (unless (or (eq beg (point-max)) + (member (char-syntax (char-after beg)) + '(?\s ?\" ?\( ?\)))) + (condition-case nil + (save-excursion + (goto-char beg) + (forward-sexp 1) + (skip-chars-backward "'") + (when (>= (point) pos) + (point))) + (scan-error pos)))) + ;; t if in function position. + (funpos (eq (char-before beg) ?\())) + (when (and end (or (not (nth 8 (syntax-ppss))) + (eq (char-before beg) ?`))) + (let ((table-etc + (if (not funpos) + ;; FIXME: We could look at the first element of the list and + ;; use it to provide a more specific completion table in some + ;; cases. E.g. filter out keywords that are not understood by + ;; the macro/function being called. + (cond + ((elisp--expect-function-p beg) + (list nil obarray + :predicate #'fboundp + :company-doc-buffer #'elisp--company-doc-buffer + :company-docsig #'elisp--company-doc-string + :company-location #'elisp--company-location)) + ((elisp--form-quoted-p beg) + (list nil obarray + ;; Don't include all symbols (bug#16646). + :predicate (lambda (sym) + (or (boundp sym) + (fboundp sym) + (featurep sym) + (symbol-plist sym))) + :annotation-function + (lambda (str) (if (fboundp (intern-soft str)) " <f>")) + :company-doc-buffer #'elisp--company-doc-buffer + :company-docsig #'elisp--company-doc-string + :company-location #'elisp--company-location)) + (t + (list nil (completion-table-merge + elisp--local-variables-completion-table + (apply-partially #'completion-table-with-predicate + obarray + #'boundp + 'strict)) + :company-doc-buffer #'elisp--company-doc-buffer + :company-docsig #'elisp--company-doc-string + :company-location #'elisp--company-location))) + ;; Looks like a funcall position. Let's double check. + (save-excursion + (goto-char (1- beg)) + (let ((parent + (condition-case nil + (progn (up-list -1) (forward-char 1) + (let ((c (char-after))) + (if (eq c ?\() ?\( + (if (memq (char-syntax c) '(?w ?_)) + (read (current-buffer)))))) + (error nil)))) + (pcase parent + ;; FIXME: Rather than hardcode special cases here, + ;; we should use something like a symbol-property. + (`declare + (list t (mapcar (lambda (x) (symbol-name (car x))) + (delete-dups + ;; FIXME: We should include some + ;; docstring with each entry. + (append + macro-declarations-alist + defun-declarations-alist))))) + ((and (or `condition-case `condition-case-unless-debug) + (guard (save-excursion + (ignore-errors + (forward-sexp 2) + (< (point) beg))))) + (list t obarray + :predicate (lambda (sym) (get sym 'error-conditions)))) + ((and ?\( + (guard (save-excursion + (goto-char (1- beg)) + (up-list -1) + (forward-symbol -1) + (looking-at "\\_<let\\*?\\_>")))) + (list t obarray + :predicate #'boundp + :company-doc-buffer #'elisp--company-doc-buffer + :company-docsig #'elisp--company-doc-string + :company-location #'elisp--company-location)) + (_ (list nil obarray + :predicate #'fboundp + :company-doc-buffer #'elisp--company-doc-buffer + :company-docsig #'elisp--company-doc-string + :company-location #'elisp--company-location + )))))))) + (nconc (list beg end) + (if (null (car table-etc)) + (cdr table-etc) + (cons + (if (memq (char-syntax (or (char-after end) ?\s)) + '(?\s ?>)) + (cadr table-etc) + (apply-partially 'completion-table-with-terminator + " " (cadr table-etc))) + (cddr table-etc))))))))) + +(define-obsolete-function-alias + 'lisp-completion-at-point 'elisp-completion-at-point "25.1") + +;;; Xref backend + +(declare-function xref-make-elisp-location "xref" (symbol type file)) +(declare-function xref-make-bogus-location "xref" (message)) +(declare-function xref-make "xref" (description location)) + +(defun elisp-xref-find (action id) + (require 'find-func) + (pcase action + (`definitions + (let ((sym (intern-soft id))) + (when sym + (elisp--xref-find-definitions sym)))) + (`apropos + (elisp--xref-find-apropos id)))) + +(defun elisp--xref-identifier-location (type sym) + (let ((file + (pcase type + (`defun (when (fboundp sym) + (let ((fun-lib + (find-function-library sym))) + (setq sym (car fun-lib)) + (cdr fun-lib)))) + (`defvar (when (boundp sym) + (or (symbol-file sym 'defvar) + (help-C-file-name sym 'var)))) + (`feature (when (featurep sym) + (ignore-errors + (find-library-name (symbol-name sym))))) + (`defface (when (facep sym) + (symbol-file sym 'defface)))))) + (when file + (when (string-match-p "\\.elc\\'" file) + (setq file (substring file 0 -1))) + (xref-make-elisp-location sym type file)))) + +(defun elisp--xref-find-definitions (symbol) + (save-excursion + (let (lst) + (dolist (type '(feature defface defvar defun)) + (let ((loc + (condition-case err + (elisp--xref-identifier-location type symbol) + (error + (xref-make-bogus-location (error-message-string err)))))) + (when loc + (push + (xref-make (format "(%s %s)" type symbol) + loc) + lst)))) + lst))) + +(defun elisp--xref-find-apropos (regexp) + (apply #'nconc + (let (lst) + (dolist (sym (apropos-internal regexp)) + (push (elisp--xref-find-definitions sym) lst)) + (nreverse lst)))) + +(defvar elisp--xref-identifier-completion-table + (apply-partially #'completion-table-with-predicate + obarray + (lambda (sym) + (or (boundp sym) + (fboundp sym) + (featurep sym) + (facep sym))) + 'strict)) + +(defun elisp--xref-identifier-completion-table () + elisp--xref-identifier-completion-table) + +;;; Elisp Interaction mode + +(defvar lisp-interaction-mode-map + (let ((map (make-sparse-keymap)) + (menu-map (make-sparse-keymap "Lisp-Interaction"))) + (set-keymap-parent map lisp-mode-shared-map) + (define-key map "\e\C-x" 'eval-defun) + (define-key map "\e\C-q" 'indent-pp-sexp) + (define-key map "\e\t" 'completion-at-point) + (define-key map "\n" 'eval-print-last-sexp) + (bindings--define-key map [menu-bar lisp-interaction] + (cons "Lisp-Interaction" menu-map)) + (bindings--define-key menu-map [eval-defun] + '(menu-item "Evaluate Defun" eval-defun + :help "Evaluate the top-level form containing point, or after point")) + (bindings--define-key menu-map [eval-print-last-sexp] + '(menu-item "Evaluate and Print" eval-print-last-sexp + :help "Evaluate sexp before point; print value into current buffer")) + (bindings--define-key menu-map [edebug-defun-lisp-interaction] + '(menu-item "Instrument Function for Debugging" edebug-defun + :help "Evaluate the top level form point is in, stepping through with Edebug" + :keys "C-u C-M-x")) + (bindings--define-key menu-map [indent-pp-sexp] + '(menu-item "Indent or Pretty-Print" indent-pp-sexp + :help "Indent each line of the list starting just after point, or prettyprint it")) + (bindings--define-key menu-map [complete-symbol] + '(menu-item "Complete Lisp Symbol" completion-at-point + :help "Perform completion on Lisp symbol preceding point")) + map) + "Keymap for Lisp Interaction mode. +All commands in `lisp-mode-shared-map' are inherited by this map.") + +(define-derived-mode lisp-interaction-mode emacs-lisp-mode "Lisp Interaction" + "Major mode for typing and evaluating Lisp forms. +Like Lisp mode except that \\[eval-print-last-sexp] evals the Lisp expression +before point, and prints its value into the buffer, advancing point. +Note that printing is controlled by `eval-expression-print-length' +and `eval-expression-print-level'. + +Commands: +Delete converts tabs to spaces as it moves back. +Paragraphs are separated only by blank lines. +Semicolons start comments. + +\\{lisp-interaction-mode-map}" + :abbrev-table nil) + +;;; Emacs Lisp Byte-Code mode + +(eval-and-compile + (defconst emacs-list-byte-code-comment-re + (concat "\\(#\\)@\\([0-9]+\\) " + ;; Make sure it's a docstring and not a lazy-loaded byte-code. + "\\(?:[^(]\\|([^\"]\\)"))) + +(defun elisp--byte-code-comment (end &optional _point) + "Try to syntactically mark the #@NNN ....^_ docstrings in byte-code files." + (let ((ppss (syntax-ppss))) + (when (and (nth 4 ppss) + (eq (char-after (nth 8 ppss)) ?#)) + (let* ((n (save-excursion + (goto-char (nth 8 ppss)) + (when (looking-at emacs-list-byte-code-comment-re) + (string-to-number (match-string 2))))) + ;; `maxdiff' tries to make sure the loop below terminates. + (maxdiff n)) + (when n + (let* ((bchar (match-end 2)) + (b (position-bytes bchar))) + (goto-char (+ b n)) + (while (let ((diff (- (position-bytes (point)) b n))) + (unless (zerop diff) + (when (> diff maxdiff) (setq diff maxdiff)) + (forward-char (- diff)) + (setq maxdiff (if (> diff 0) diff + (max (1- maxdiff) 1))) + t)))) + (if (<= (point) end) + (put-text-property (1- (point)) (point) + 'syntax-table + (string-to-syntax "> b")) + (goto-char end))))))) + +(defun elisp-byte-code-syntax-propertize (start end) + (elisp--byte-code-comment end (point)) + (funcall + (syntax-propertize-rules + (emacs-list-byte-code-comment-re + (1 (prog1 "< b" (elisp--byte-code-comment end (point)))))) + start end)) + +;;;###autoload +(add-to-list 'auto-mode-alist '("\\.elc\\'" . elisp-byte-code-mode)) +;;;###autoload +(define-derived-mode elisp-byte-code-mode emacs-lisp-mode + "Elisp-Byte-Code" + "Major mode for *.elc files." + ;; TODO: Add way to disassemble byte-code under point. + (setq-local open-paren-in-column-0-is-defun-start nil) + (setq-local syntax-propertize-function + #'elisp-byte-code-syntax-propertize)) + + +;;; Globally accessible functionality + +(defun eval-print-last-sexp (&optional eval-last-sexp-arg-internal) + "Evaluate sexp before point; print value into current buffer. + +Normally, this function truncates long output according to the value +of the variables `eval-expression-print-length' and +`eval-expression-print-level'. With a prefix argument of zero, +however, there is no such truncation. Such a prefix argument +also causes integers to be printed in several additional formats +\(octal, hexadecimal, and character). + +If `eval-expression-debug-on-error' is non-nil, which is the default, +this command arranges for all errors to enter the debugger." + (interactive "P") + (let ((standard-output (current-buffer))) + (terpri) + (eval-last-sexp (or eval-last-sexp-arg-internal t)) + (terpri))) + + +(defun last-sexp-setup-props (beg end value alt1 alt2) + "Set up text properties for the output of `elisp--eval-last-sexp'. +BEG and END are the start and end of the output in current-buffer. +VALUE is the Lisp value printed, ALT1 and ALT2 are strings for the +alternative printed representations that can be displayed." + (let ((map (make-sparse-keymap))) + (define-key map "\C-m" 'elisp-last-sexp-toggle-display) + (define-key map [down-mouse-2] 'mouse-set-point) + (define-key map [mouse-2] 'elisp-last-sexp-toggle-display) + (add-text-properties + beg end + `(printed-value (,value ,alt1 ,alt2) + mouse-face highlight + keymap ,map + help-echo "RET, mouse-2: toggle abbreviated display" + rear-nonsticky (mouse-face keymap help-echo + printed-value))))) + + +(defun elisp-last-sexp-toggle-display (&optional _arg) + "Toggle between abbreviated and unabbreviated printed representations." + (interactive "P") + (save-restriction + (widen) + (let ((value (get-text-property (point) 'printed-value))) + (when value + (let ((beg (or (previous-single-property-change (min (point-max) (1+ (point))) + 'printed-value) + (point))) + (end (or (next-single-char-property-change (point) 'printed-value) (point))) + (standard-output (current-buffer)) + (point (point))) + (delete-region beg end) + (insert (nth 1 value)) + (or (= beg point) + (setq point (1- (point)))) + (last-sexp-setup-props beg (point) + (nth 0 value) + (nth 2 value) + (nth 1 value)) + (goto-char (min (point-max) point))))))) + +(defun prin1-char (char) ;FIXME: Move it, e.g. to simple.el. + "Return a string representing CHAR as a character rather than as an integer. +If CHAR is not a character, return nil." + (and (integerp char) + (eventp char) + (let ((c (event-basic-type char)) + (mods (event-modifiers char)) + string) + ;; Prevent ?A from turning into ?\S-a. + (if (and (memq 'shift mods) + (zerop (logand char ?\S-\^@)) + (not (let ((case-fold-search nil)) + (char-equal c (upcase c))))) + (setq c (upcase c) mods nil)) + ;; What string are we considering using? + (condition-case nil + (setq string + (concat + "?" + (mapconcat + (lambda (modif) + (cond ((eq modif 'super) "\\s-") + (t (string ?\\ (upcase (aref (symbol-name modif) 0)) ?-)))) + mods "") + (cond + ((memq c '(?\; ?\( ?\) ?\{ ?\} ?\[ ?\] ?\" ?\' ?\\)) (string ?\\ c)) + ((eq c 127) "\\C-?") + (t + (string c))))) + (error nil)) + ;; Verify the string reads a CHAR, not to some other character. + ;; If it doesn't, return nil instead. + (and string + (= (car (read-from-string string)) char) + string)))) + +(defun elisp--preceding-sexp () + "Return sexp before the point." + (let ((opoint (point)) + ignore-quotes + expr) + (save-excursion + (with-syntax-table emacs-lisp-mode-syntax-table + ;; If this sexp appears to be enclosed in `...' + ;; then ignore the surrounding quotes. + (setq ignore-quotes + (or (eq (following-char) ?\') + (eq (preceding-char) ?\'))) + (forward-sexp -1) + ;; If we were after `?\e' (or similar case), + ;; use the whole thing, not just the `e'. + (when (eq (preceding-char) ?\\) + (forward-char -1) + (when (eq (preceding-char) ??) + (forward-char -1))) + + ;; Skip over hash table read syntax. + (and (> (point) (1+ (point-min))) + (looking-back "#s" (- (point) 2)) + (forward-char -2)) + + ;; Skip over `#N='s. + (when (eq (preceding-char) ?=) + (let (labeled-p) + (save-excursion + (skip-chars-backward "0-9#=") + (setq labeled-p (looking-at "\\(#[0-9]+=\\)+"))) + (when labeled-p + (forward-sexp -1)))) + + (save-restriction + (if (and ignore-quotes (eq (following-char) ?`)) + ;; vladimir@cs.ualberta.ca 30-Jul-1997: Skip ` in `variable' so + ;; that the value is returned, not the name. + (forward-char)) + (when (looking-at ",@?") (goto-char (match-end 0))) + (narrow-to-region (point-min) opoint) + (setq expr (read (current-buffer))) + ;; If it's an (interactive ...) form, it's more useful to show how an + ;; interactive call would use it. + ;; FIXME: Is it really the right place for this? + (when (eq (car-safe expr) 'interactive) + (setq expr + `(call-interactively + (lambda (&rest args) ,expr args)))) + expr))))) +(define-obsolete-function-alias 'preceding-sexp 'elisp--preceding-sexp "25.1") + +(defun elisp--eval-last-sexp (eval-last-sexp-arg-internal) + "Evaluate sexp before point; print value in the echo area. +With argument, print output into current buffer. +With a zero prefix arg, print output with no limit on the length +and level of lists, and include additional formats for integers +\(octal, hexadecimal, and character)." + (let ((standard-output (if eval-last-sexp-arg-internal (current-buffer) t))) + ;; Setup the lexical environment if lexical-binding is enabled. + (elisp--eval-last-sexp-print-value + (eval (eval-sexp-add-defvars (elisp--preceding-sexp)) lexical-binding) + eval-last-sexp-arg-internal))) + + +(defun elisp--eval-last-sexp-print-value (value &optional eval-last-sexp-arg-internal) + (let ((unabbreviated (let ((print-length nil) (print-level nil)) + (prin1-to-string value))) + (print-length (and (not (zerop (prefix-numeric-value + eval-last-sexp-arg-internal))) + eval-expression-print-length)) + (print-level (and (not (zerop (prefix-numeric-value + eval-last-sexp-arg-internal))) + eval-expression-print-level)) + (beg (point)) + end) + (prog1 + (prin1 value) + (let ((str (eval-expression-print-format value))) + (if str (princ str))) + (setq end (point)) + (when (and (bufferp standard-output) + (or (not (null print-length)) + (not (null print-level))) + (not (string= unabbreviated + (buffer-substring-no-properties beg end)))) + (last-sexp-setup-props beg end value + unabbreviated + (buffer-substring-no-properties beg end)) + )))) + + +(defvar elisp--eval-last-sexp-fake-value (make-symbol "t")) + +(defun eval-sexp-add-defvars (exp &optional pos) + "Prepend EXP with all the `defvar's that precede it in the buffer. +POS specifies the starting position where EXP was found and defaults to point." + (setq exp (macroexpand-all exp)) ;Eager macro-expansion. + (if (not lexical-binding) + exp + (save-excursion + (unless pos (setq pos (point))) + (let ((vars ())) + (goto-char (point-min)) + (while (re-search-forward + "(def\\(?:var\\|const\\|custom\\)[ \t\n]+\\([^; '()\n\t]+\\)" + pos t) + (let ((var (intern (match-string 1)))) + (and (not (special-variable-p var)) + (save-excursion + (zerop (car (syntax-ppss (match-beginning 0))))) + (push var vars)))) + `(progn ,@(mapcar (lambda (v) `(defvar ,v)) vars) ,exp))))) + +(defun eval-last-sexp (eval-last-sexp-arg-internal) + "Evaluate sexp before point; print value in the echo area. +Interactively, with prefix argument, print output into current buffer. + +Normally, this function truncates long output according to the value +of the variables `eval-expression-print-length' and +`eval-expression-print-level'. With a prefix argument of zero, +however, there is no such truncation. Such a prefix argument +also causes integers to be printed in several additional formats +\(octal, hexadecimal, and character). + +If `eval-expression-debug-on-error' is non-nil, which is the default, +this command arranges for all errors to enter the debugger." + (interactive "P") + (if (null eval-expression-debug-on-error) + (elisp--eval-last-sexp eval-last-sexp-arg-internal) + (let ((value + (let ((debug-on-error elisp--eval-last-sexp-fake-value)) + (cons (elisp--eval-last-sexp eval-last-sexp-arg-internal) + debug-on-error)))) + (unless (eq (cdr value) elisp--eval-last-sexp-fake-value) + (setq debug-on-error (cdr value))) + (car value)))) + +(defun elisp--eval-defun-1 (form) + "Treat some expressions specially. +Reset the `defvar' and `defcustom' variables to the initial value. +\(For `defcustom', use the :set function if there is one.) +Reinitialize the face according to the `defface' specification." + ;; The code in edebug-defun should be consistent with this, but not + ;; the same, since this gets a macroexpanded form. + (cond ((not (listp form)) + form) + ((and (eq (car form) 'defvar) + (cdr-safe (cdr-safe form)) + (boundp (cadr form))) + ;; Force variable to be re-set. + `(progn (defvar ,(nth 1 form) nil ,@(nthcdr 3 form)) + (setq-default ,(nth 1 form) ,(nth 2 form)))) + ;; `defcustom' is now macroexpanded to + ;; `custom-declare-variable' with a quoted value arg. + ((and (eq (car form) 'custom-declare-variable) + (default-boundp (eval (nth 1 form) lexical-binding))) + ;; Force variable to be bound, using :set function if specified. + (let ((setfunc (memq :set form))) + (when setfunc + (setq setfunc (car-safe (cdr-safe setfunc))) + (or (functionp setfunc) (setq setfunc nil))) + (funcall (or setfunc 'set-default) + (eval (nth 1 form) lexical-binding) + ;; The second arg is an expression that evaluates to + ;; an expression. The second evaluation is the one + ;; normally performed not by normal execution but by + ;; custom-initialize-set (for example), which does not + ;; use lexical-binding. + (eval (eval (nth 2 form) lexical-binding)))) + form) + ;; `defface' is macroexpanded to `custom-declare-face'. + ((eq (car form) 'custom-declare-face) + ;; Reset the face. + (let ((face-symbol (eval (nth 1 form) lexical-binding))) + (setq face-new-frame-defaults + (assq-delete-all face-symbol face-new-frame-defaults)) + (put face-symbol 'face-defface-spec nil) + (put face-symbol 'face-override-spec nil)) + form) + ((eq (car form) 'progn) + (cons 'progn (mapcar #'elisp--eval-defun-1 (cdr form)))) + (t form))) + +(defun elisp--eval-defun () + "Evaluate defun that point is in or before. +The value is displayed in the echo area. +If the current defun is actually a call to `defvar', +then reset the variable using the initial value expression +even if the variable already has some other value. +\(Normally `defvar' does not change the variable's value +if it already has a value.\) + +Return the result of evaluation." + ;; FIXME: the print-length/level bindings should only be applied while + ;; printing, not while evaluating. + (let ((debug-on-error eval-expression-debug-on-error) + (print-length eval-expression-print-length) + (print-level eval-expression-print-level)) + (save-excursion + ;; Arrange for eval-region to "read" the (possibly) altered form. + ;; eval-region handles recording which file defines a function or + ;; variable. + (let ((standard-output t) + beg end form) + ;; Read the form from the buffer, and record where it ends. + (save-excursion + (end-of-defun) + (beginning-of-defun) + (setq beg (point)) + (setq form (read (current-buffer))) + (setq end (point))) + ;; Alter the form if necessary. + (let ((form (eval-sexp-add-defvars + (elisp--eval-defun-1 (macroexpand form))))) + (eval-region beg end standard-output + (lambda (_ignore) + ;; Skipping to the end of the specified region + ;; will make eval-region return. + (goto-char end) + form)))))) + (let ((str (eval-expression-print-format (car values)))) + (if str (princ str))) + ;; The result of evaluation has been put onto VALUES. So return it. + (car values)) + +(defun eval-defun (edebug-it) + "Evaluate the top-level form containing point, or after point. + +If the current defun is actually a call to `defvar' or `defcustom', +evaluating it this way resets the variable using its initial value +expression (using the defcustom's :set function if there is one), even +if the variable already has some other value. \(Normally `defvar' and +`defcustom' do not alter the value if there already is one.) In an +analogous way, evaluating a `defface' overrides any customizations of +the face, so that it becomes defined exactly as the `defface' expression +says. + +If `eval-expression-debug-on-error' is non-nil, which is the default, +this command arranges for all errors to enter the debugger. + +With a prefix argument, instrument the code for Edebug. + +If acting on a `defun' for FUNCTION, and the function was +instrumented, `Edebug: FUNCTION' is printed in the echo area. If not +instrumented, just FUNCTION is printed. + +If not acting on a `defun', the result of evaluation is displayed in +the echo area. This display is controlled by the variables +`eval-expression-print-length' and `eval-expression-print-level', +which see." + (interactive "P") + (cond (edebug-it + (require 'edebug) + (eval-defun (not edebug-all-defs))) + (t + (if (null eval-expression-debug-on-error) + (elisp--eval-defun) + (let (new-value value) + (let ((debug-on-error elisp--eval-last-sexp-fake-value)) + (setq value (elisp--eval-defun)) + (setq new-value debug-on-error)) + (unless (eq elisp--eval-last-sexp-fake-value new-value) + (setq debug-on-error new-value)) + value))))) + +;;; ElDoc Support + +(defvar elisp--eldoc-last-data (make-vector 3 nil) + "Bookkeeping; elements are as follows: + 0 - contains the last symbol read from the buffer. + 1 - contains the string last displayed in the echo area for variables, + or argument string for functions. + 2 - 'function if function args, 'variable if variable documentation.") + +(defun elisp-eldoc-documentation-function () + "`eldoc-documentation-function' (which see) for Emacs Lisp." + (let ((current-symbol (elisp--current-symbol)) + (current-fnsym (elisp--fnsym-in-current-sexp))) + (cond ((null current-fnsym) + nil) + ((eq current-symbol (car current-fnsym)) + (or (apply #'elisp--get-fnsym-args-string current-fnsym) + (elisp--get-var-docstring current-symbol))) + (t + (or (elisp--get-var-docstring current-symbol) + (apply #'elisp--get-fnsym-args-string current-fnsym)))))) + +(defun elisp--get-fnsym-args-string (sym &optional index) + "Return a string containing the parameter list of the function SYM. +If SYM is a subr and no arglist is obtainable from the docstring +or elsewhere, return a 1-line docstring." + (let ((argstring + (cond + ((not (and sym (symbolp sym) (fboundp sym))) nil) + ((and (eq sym (aref elisp--eldoc-last-data 0)) + (eq 'function (aref elisp--eldoc-last-data 2))) + (aref elisp--eldoc-last-data 1)) + (t + (let* ((advertised (gethash (indirect-function sym) + advertised-signature-table t)) + doc + (args + (cond + ((listp advertised) advertised) + ((setq doc (help-split-fundoc (documentation sym t) sym)) + (car doc)) + (t (help-function-arglist sym))))) + ;; Stringify, and store before highlighting, downcasing, etc. + ;; FIXME should truncate before storing. + (elisp--last-data-store sym (elisp--function-argstring args) + 'function)))))) + ;; Highlight, truncate. + (if argstring + (elisp--highlight-function-argument sym argstring index)))) + +(defun elisp--highlight-function-argument (sym args index) + "Highlight argument INDEX in ARGS list for function SYM. +In the absence of INDEX, just call `elisp--docstring-format-sym-doc'." + ;; FIXME: This should probably work on the list representation of `args' + ;; rather than its string representation. + ;; FIXME: This function is much too long, we need to split it up! + (let ((start nil) + (end 0) + (argument-face 'eldoc-highlight-function-argument) + (args-lst (mapcar (lambda (x) + (replace-regexp-in-string + "\\`[(]\\|[)]\\'" "" x)) + (split-string args)))) + ;; Find the current argument in the argument string. We need to + ;; handle `&rest' and informal `...' properly. + ;; + ;; FIXME: What to do with optional arguments, like in + ;; (defun NAME ARGLIST [DOCSTRING] BODY...) case? + ;; The problem is there is no robust way to determine if + ;; the current argument is indeed a docstring. + + ;; When `&key' is used finding position based on `index' + ;; would be wrong, so find the arg at point and determine + ;; position in ARGS based on this current arg. + (when (string-match "&key" args) + (let* (case-fold-search + key-have-value + (sym-name (symbol-name sym)) + (cur-w (current-word)) + (args-lst-ak (cdr (member "&key" args-lst))) + (limit (save-excursion + (when (re-search-backward sym-name nil t) + (match-end 0)))) + (cur-a (if (and cur-w (string-match ":\\([^ ()]*\\)" cur-w)) + (substring cur-w 1) + (save-excursion + (let (split) + (when (re-search-backward ":\\([^()\n]*\\)" limit t) + (setq split (split-string (match-string 1) " " t)) + (prog1 (car split) + (when (cdr split) + (setq key-have-value t)))))))) + ;; If `cur-a' is not one of `args-lst-ak' + ;; assume user is entering an unknown key + ;; referenced in last position in signature. + (other-key-arg (and (stringp cur-a) + args-lst-ak + (not (member (upcase cur-a) args-lst-ak)) + (upcase (car (last args-lst-ak)))))) + (unless (string= cur-w sym-name) + ;; The last keyword have already a value + ;; i.e :foo a b and cursor is at b. + ;; If signature have also `&rest' + ;; (assume it is after the `&key' section) + ;; go to the arg after `&rest'. + (if (and key-have-value + (save-excursion + (not (re-search-forward ":.*" (point-at-eol) t))) + (string-match "&rest \\([^ ()]*\\)" args)) + (setq index nil ; Skip next block based on positional args. + start (match-beginning 1) + end (match-end 1)) + ;; If `cur-a' is nil probably cursor is on a positional arg + ;; before `&key', in this case, exit this block and determine + ;; position with `index'. + (when (and cur-a ; A keyword arg (dot removed) or nil. + (or (string-match + (concat "\\_<" (upcase cur-a) "\\_>") args) + (string-match + (concat "\\_<" other-key-arg "\\_>") args))) + (setq index nil ; Skip next block based on positional args. + start (match-beginning 0) + end (match-end 0))))))) + ;; Handle now positional arguments. + (while (and index (>= index 1)) + (if (string-match "[^ ()]+" args end) + (progn + (setq start (match-beginning 0) + end (match-end 0)) + (let ((argument (match-string 0 args))) + (cond ((string= argument "&rest") + ;; All the rest arguments are the same. + (setq index 1)) + ((string= argument "&optional")) ; Skip. + ((string= argument "&allow-other-keys")) ; Skip. + ;; Back to index 0 in ARG1 ARG2 ARG2 ARG3 etc... + ;; like in `setq'. + ((or (and (string-match-p "\\.\\.\\.$" argument) + (string= argument (car (last args-lst)))) + (and (string-match-p "\\.\\.\\.$" + (substring args 1 (1- (length args)))) + (= (length (remove "..." args-lst)) 2) + (> index 1) (eq (logand index 1) 1))) + (setq index 0)) + (t + (setq index (1- index)))))) + (setq end (length args) + start (1- end) + argument-face 'font-lock-warning-face + index 0))) + (let ((doc args)) + (when start + (setq doc (copy-sequence args)) + (add-text-properties start end (list 'face argument-face) doc)) + (setq doc (elisp--docstring-format-sym-doc + sym doc (if (functionp sym) 'font-lock-function-name-face + 'font-lock-keyword-face))) + doc))) + +;; Return a string containing a brief (one-line) documentation string for +;; the variable. +(defun elisp--get-var-docstring (sym) + (cond ((not sym) nil) + ((and (eq sym (aref elisp--eldoc-last-data 0)) + (eq 'variable (aref elisp--eldoc-last-data 2))) + (aref elisp--eldoc-last-data 1)) + (t + (let ((doc (documentation-property sym 'variable-documentation t))) + (when doc + (let ((doc (elisp--docstring-format-sym-doc + sym (elisp--docstring-first-line doc) + 'font-lock-variable-name-face))) + (elisp--last-data-store sym doc 'variable))))))) + +(defun elisp--last-data-store (symbol doc type) + (aset elisp--eldoc-last-data 0 symbol) + (aset elisp--eldoc-last-data 1 doc) + (aset elisp--eldoc-last-data 2 type) + doc) + +;; Note that any leading `*' in the docstring (which indicates the variable +;; is a user option) is removed. +(defun elisp--docstring-first-line (doc) + (and (stringp doc) + (substitute-command-keys + (save-match-data + ;; Don't use "^" in the regexp below since it may match + ;; anywhere in the doc-string. + (let ((start (if (string-match "\\`\\*" doc) (match-end 0) 0))) + (cond ((string-match "\n" doc) + (substring doc start (match-beginning 0))) + ((zerop start) doc) + (t (substring doc start)))))))) + +(defvar eldoc-echo-area-use-multiline-p) + +;; If the entire line cannot fit in the echo area, the symbol name may be +;; truncated or eliminated entirely from the output to make room for the +;; description. +(defun elisp--docstring-format-sym-doc (sym doc face) + (save-match-data + (let* ((name (symbol-name sym)) + (ea-multi eldoc-echo-area-use-multiline-p) + ;; Subtract 1 from window width since emacs will not write + ;; any chars to the last column, or in later versions, will + ;; cause a wraparound and resize of the echo area. + (ea-width (1- (window-width (minibuffer-window)))) + (strip (- (+ (length name) (length ": ") (length doc)) ea-width))) + (cond ((or (<= strip 0) + (eq ea-multi t) + (and ea-multi (> (length doc) ea-width))) + (format "%s: %s" (propertize name 'face face) doc)) + ((> (length doc) ea-width) + (substring (format "%s" doc) 0 ea-width)) + ((>= strip (length name)) + (format "%s" doc)) + (t + ;; Show the end of the partial symbol name, rather + ;; than the beginning, since the former is more likely + ;; to be unique given package namespace conventions. + (setq name (substring name strip)) + (format "%s: %s" (propertize name 'face face) doc)))))) + + +;; Return a list of current function name and argument index. +(defun elisp--fnsym-in-current-sexp () + (save-excursion + (let ((argument-index (1- (elisp--beginning-of-sexp)))) + ;; If we are at the beginning of function name, this will be -1. + (when (< argument-index 0) + (setq argument-index 0)) + ;; Don't do anything if current word is inside a string. + (if (= (or (char-after (1- (point))) 0) ?\") + nil + (list (elisp--current-symbol) argument-index))))) + +;; Move to the beginning of current sexp. Return the number of nested +;; sexp the point was over or after. +(defun elisp--beginning-of-sexp () + (let ((parse-sexp-ignore-comments t) + (num-skipped-sexps 0)) + (condition-case _ + (progn + ;; First account for the case the point is directly over a + ;; beginning of a nested sexp. + (condition-case _ + (let ((p (point))) + (forward-sexp -1) + (forward-sexp 1) + (when (< (point) p) + (setq num-skipped-sexps 1))) + (error)) + (while + (let ((p (point))) + (forward-sexp -1) + (when (< (point) p) + (setq num-skipped-sexps (1+ num-skipped-sexps)))))) + (error)) + num-skipped-sexps)) + +;; returns nil unless current word is an interned symbol. +(defun elisp--current-symbol () + (let ((c (char-after (point)))) + (and c + (memq (char-syntax c) '(?w ?_)) + (intern-soft (current-word))))) + +(defun elisp--function-argstring (arglist) + "Return ARGLIST as a string enclosed by (). +ARGLIST is either a string, or a list of strings or symbols." + (let ((str (cond ((stringp arglist) arglist) + ((not (listp arglist)) nil) + (t (format "%S" (help-make-usage 'toto arglist)))))) + (if (and str (string-match "\\`([^ )]+ ?" str)) + (replace-match "(" t t str) + str))) + +(provide 'elisp-mode) +;;; elisp-mode.el ends here diff --git a/lisp/progmodes/etags.el b/lisp/progmodes/etags.el index b89b4cf0fe5..be0dabf17b2 100644 --- a/lisp/progmodes/etags.el +++ b/lisp/progmodes/etags.el @@ -28,6 +28,7 @@ (require 'ring) (require 'button) +(require 'xref) ;;;###autoload (defvar tags-file-name nil @@ -141,11 +142,8 @@ Otherwise, `find-tag-default' is used." :group 'etags :type '(choice (const nil) function)) -(defcustom find-tag-marker-ring-length 16 - "Length of marker rings `find-tag-marker-ring' and `tags-location-ring'." - :group 'etags - :type 'integer - :version "20.3") +(define-obsolete-variable-alias 'find-tag-marker-ring-length + 'xref-marker-ring-length "25.1") (defcustom tags-tag-face 'default "Face for tags in the output of `tags-apropos'." @@ -182,15 +180,18 @@ Example value: (sexp :tag "Tags to search"))) :version "21.1") -(defvar find-tag-marker-ring (make-ring find-tag-marker-ring-length) - "Ring of markers which are locations from which \\[find-tag] was invoked.") +(defvaralias 'find-tag-marker-ring 'xref--marker-ring) +(make-obsolete-variable + 'find-tag-marker-ring + "use `xref-push-marker-stack' or `xref-pop-marker-stack' instead." + "25.1") (defvar default-tags-table-function nil "If non-nil, a function to choose a default tags file for a buffer. This function receives no arguments and should return the default tags table file to use for the current buffer.") -(defvar tags-location-ring (make-ring find-tag-marker-ring-length) +(defvar tags-location-ring (make-ring xref-marker-ring-length) "Ring of markers which are locations visited by \\[find-tag]. Pop back to the last location with \\[negative-argument] \\[find-tag].") @@ -713,15 +714,13 @@ Returns t if it visits a tags table, or nil if there are no more in the list." (interactive) ;; Clear out the markers we are throwing away. (let ((i 0)) - (while (< i find-tag-marker-ring-length) + (while (< i xref-marker-ring-length) (if (aref (cddr tags-location-ring) i) (set-marker (aref (cddr tags-location-ring) i) nil)) - (if (aref (cddr find-tag-marker-ring) i) - (set-marker (aref (cddr find-tag-marker-ring) i) nil)) (setq i (1+ i)))) + (xref-clear-marker-stack) (setq tags-file-name nil - tags-location-ring (make-ring find-tag-marker-ring-length) - find-tag-marker-ring (make-ring find-tag-marker-ring-length) + tags-location-ring (make-ring xref-marker-ring-length) tags-table-list nil tags-table-computed-list nil tags-table-computed-list-for nil @@ -780,6 +779,7 @@ tags table and its (recursively) included tags tables." (quit (message "Tags completion table construction aborted.") (setq tags-completion-table nil))))) +;;;###autoload (defun tags-lazy-completion-table () (let ((buf (current-buffer))) (lambda (string pred action) @@ -898,7 +898,7 @@ See documentation of variable `tags-file-name'." ;; Run the user's hook. Do we really want to do this for pop? (run-hooks 'local-find-tag-hook)))) ;; Record whence we came. - (ring-insert find-tag-marker-ring (point-marker)) + (xref-push-marker-stack) (if (and next-p last-tag) ;; Find the same table we last used. (visit-tags-table-buffer 'same) @@ -954,7 +954,6 @@ See documentation of variable `tags-file-name'." (switch-to-buffer buf) (error (pop-to-buffer buf))) (goto-char pos))) -;;;###autoload (define-key esc-map "." 'find-tag) ;;;###autoload (defun find-tag-other-window (tagname &optional next-p regexp-p) @@ -976,6 +975,7 @@ onto a ring and may be popped back to with \\[pop-tag-mark]. Contrast this with the ring of marks gone to by the command. See documentation of variable `tags-file-name'." + (declare (obsolete xref-find-definitions-other-window "25.1")) (interactive (find-tag-interactive "Find tag other window: ")) ;; This hair is to deal with the case where the tag is found in the @@ -995,7 +995,6 @@ See documentation of variable `tags-file-name'." ;; the window's point from the buffer. (set-window-point (selected-window) tagpoint)) window-point))) -;;;###autoload (define-key ctl-x-4-map "." 'find-tag-other-window) ;;;###autoload (defun find-tag-other-frame (tagname &optional next-p) @@ -1017,10 +1016,10 @@ onto a ring and may be popped back to with \\[pop-tag-mark]. Contrast this with the ring of marks gone to by the command. See documentation of variable `tags-file-name'." + (declare (obsolete xref-find-definitions-other-frame "25.1")) (interactive (find-tag-interactive "Find tag other frame: ")) (let ((pop-up-frames t)) (find-tag-other-window tagname next-p))) -;;;###autoload (define-key ctl-x-5-map "." 'find-tag-other-frame) ;;;###autoload (defun find-tag-regexp (regexp &optional next-p other-window) @@ -1040,29 +1039,15 @@ onto a ring and may be popped back to with \\[pop-tag-mark]. Contrast this with the ring of marks gone to by the command. See documentation of variable `tags-file-name'." + (declare (obsolete xref-find-apropos "25.1")) (interactive (find-tag-interactive "Find tag regexp: " t)) ;; We go through find-tag-other-window to do all the display hair there. (funcall (if other-window 'find-tag-other-window 'find-tag) regexp next-p t)) -;;;###autoload (define-key esc-map [?\C-.] 'find-tag-regexp) - -;;;###autoload (define-key esc-map "*" 'pop-tag-mark) ;;;###autoload -(defun pop-tag-mark () - "Pop back to where \\[find-tag] was last invoked. +(defalias 'pop-tag-mark 'xref-pop-marker-stack) -This is distinct from invoking \\[find-tag] with a negative argument -since that pops a stack of markers at which tags were found, not from -where they were found." - (interactive) - (if (ring-empty-p find-tag-marker-ring) - (error "No previous locations for find-tag invocation")) - (let ((marker (ring-remove find-tag-marker-ring 0))) - (switch-to-buffer (or (marker-buffer marker) - (error "The marked buffer has been deleted"))) - (goto-char (marker-position marker)) - (set-marker marker nil nil))) (defvar tag-lines-already-matched nil "Matches remembered between calls.") ; Doc string: calls to what? @@ -1804,6 +1789,7 @@ Two variables control the processing we do on each file: the value of interesting (it returns non-nil if so) and `tags-loop-operate' is a form to evaluate to operate on an interesting file. If the latter evaluates to nil, we exit; otherwise we scan the next file." + (declare (obsolete "use `xref-find-definitions' interface instead." "25.1")) (interactive) (let (new ;; Non-nil means we have finished one file @@ -1859,7 +1845,6 @@ nil, we exit; otherwise we scan the next file." (and messaged (null tags-loop-operate) (message "Scanning file %s...found" buffer-file-name)))) -;;;###autoload (define-key esc-map "," 'tags-loop-continue) ;;;###autoload (defun tags-search (regexp &optional file-list-form) @@ -1948,6 +1933,7 @@ directory specification." ;;;###autoload (defun tags-apropos (regexp) "Display list of all tags in tags table REGEXP matches." + (declare (obsolete xref-find-apropos "25.1")) (interactive "sTags apropos (regexp): ") (with-output-to-temp-buffer "*Tags List*" (princ "Click mouse-2 to follow tags.\n\nTags matching regexp `") @@ -2077,6 +2063,54 @@ for \\[find-tag] (which see)." (completion-in-region (car comp-data) (cadr comp-data) (nth 2 comp-data) (plist-get (nthcdr 3 comp-data) :predicate))))) + + +;;; Xref backend + +;; Stop searching if we find more than xref-limit matches, as the xref +;; infrastructure is not designed to handle very long lists. +;; Switching to some kind of lazy list might be better, but hopefully +;; we hit the limit rarely. +(defconst etags--xref-limit 1000) + +;;;###autoload +(defun etags-xref-find (action id) + (pcase action + (`definitions (etags--xref-find-definitions id)) + (`apropos (etags--xref-find-definitions id t)))) + +(defun etags--xref-find-definitions (pattern &optional regexp?) + ;; This emulates the behaviour of `find-tag-in-order' but instead of + ;; returning one match at a time all matches are returned as list. + ;; NOTE: find-tag-tag-order is typically a buffer-local variable. + (let* ((xrefs '()) + (first-time t) + (search-fun (if regexp? #'re-search-forward #'search-forward)) + (marks (make-hash-table :test 'equal)) + (case-fold-search (if (memq tags-case-fold-search '(nil t)) + tags-case-fold-search + case-fold-search))) + (save-excursion + (while (visit-tags-table-buffer (not first-time)) + (setq first-time nil) + (dolist (order-fun (cond (regexp? find-tag-regexp-tag-order) + (t find-tag-tag-order))) + (goto-char (point-min)) + (while (and (funcall search-fun pattern nil t) + (< (hash-table-count marks) etags--xref-limit)) + (when (funcall order-fun pattern) + (beginning-of-line) + (cl-destructuring-bind (hint line &rest pos) (etags-snarf-tag) + (unless (eq hint t) ; hint==t if we are in a filename line + (let* ((file (file-of-tag)) + (mark-key (cons file line))) + (unless (gethash mark-key marks) + (let ((loc (xref-make-file-location + (expand-file-name file) line 0))) + (push (xref-make hint loc) xrefs) + (puthash mark-key t marks))))))))))) + (nreverse xrefs))) + (provide 'etags) diff --git a/lisp/progmodes/f90.el b/lisp/progmodes/f90.el index 215b8d8358e..c7f018f5f15 100644 --- a/lisp/progmodes/f90.el +++ b/lisp/progmodes/f90.el @@ -830,7 +830,7 @@ Can be overridden by the value of `font-lock-maximum-decoration'.") (font-lock-mode 1) (setq font-lock-keywords (symbol-value (intern-soft (format "f90-font-lock-keywords-%d" n)))) - (font-lock-fontify-buffer)) + (font-lock-flush)) (defun f90-font-lock-1 () "Set `font-lock-keywords' to `f90-font-lock-keywords-1'." diff --git a/lisp/progmodes/grep.el b/lisp/progmodes/grep.el index 99629450c1b..b0d4b5ac377 100644 --- a/lisp/progmodes/grep.el +++ b/lisp/progmodes/grep.el @@ -1,7 +1,6 @@ -;;; grep.el --- run `grep' and display the results +;;; grep.el --- run `grep' and display the results -*- lexical-binding:t -*- -;; Copyright (C) 1985-1987, 1993-1999, 2001-2014 Free Software -;; Foundation, Inc. +;; Copyright (C) 1985-1987, 1993-1999, 2001-2014 Free Software Foundation, Inc. ;; Author: Roland McGrath <roland@gnu.org> ;; Maintainer: emacs-devel@gnu.org @@ -77,11 +76,10 @@ in grep buffers, so if you have globally disabled font-lock-mode, you will not get highlighting. This option sets the environment variable GREP_COLORS to specify -markers for highlighting and GREP_OPTIONS to add the --color -option in front of any explicit grep options before starting -the grep. +markers for highlighting and adds the --color option in front of +any explicit grep options before starting the grep. -When this option is `auto', grep uses `--color=auto' to highlight +When this option is `auto', grep uses `--color' to highlight matches only when it outputs to a terminal (when `grep' is the last command in the pipe), thus avoiding the use of any potentially-harmful escape sequences when standard output goes to a file or pipe. @@ -97,7 +95,7 @@ To change the default value, use Customize or call the function :type '(choice (const :tag "Do not highlight matches with grep markers" nil) (const :tag "Highlight matches with grep markers" t) (const :tag "Use --color=always" always) - (const :tag "Use --color=auto" auto) + (const :tag "Use --color" auto) (other :tag "Not Set" auto-detect)) :set 'grep-apply-setting :version "22.1" @@ -345,16 +343,11 @@ Notice that using \\[next-error] or \\[compile-goto-error] modifies ;;;###autoload (defconst grep-regexp-alist '( - ;; Rule to match column numbers is commented out since no known grep - ;; produces them - ;; ("^\\(.+?\\)\\(:[ \t]*\\)\\([1-9][0-9]*\\)\\2\\(?:\\([1-9][0-9]*\\)\\(?:-\\([1-9][0-9]*\\)\\)?\\2\\)?" - ;; 1 3 (4 . 5)) - ;; 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. - ("^\\(.+?\\)\\(:[ \t]*\\)\\([1-9][0-9]*\\)\\2" - 1 3 + ;; Use a tight regexp to handle weird file names (with colons + ;; in them) as well as possible. E.g., use [1-9][0-9]* rather + ;; than [0-9]+ so as to accept ":034:" in file names. + ("^\\(.*?[^/\n]\\):[ \t]*\\([1-9][0-9]*\\)[ \t]*:" + 1 2 ;; Calculate column positions (col . end-col) of first grep match on a line ((lambda () (when grep-highlight-matches @@ -467,10 +460,6 @@ Set up `compilation-exit-message-function' and run `grep-setup-hook'." ;; `setenv' modifies `process-environment' let-bound in `compilation-start' ;; Any TERM except "dumb" allows GNU grep to use `--color=auto' (setenv "TERM" "emacs-grep") - (setenv "GREP_OPTIONS" - (concat (getenv "GREP_OPTIONS") - " --color=" (if (eq grep-highlight-matches 'always) - "always" "auto"))) ;; GREP_COLOR is used in GNU grep 2.5.1, but deprecated in later versions (setenv "GREP_COLOR" "01;31") ;; GREP_COLORS is used in GNU grep 2.5.2 and later versions @@ -567,10 +556,28 @@ This function is called from `compilation-filter-hook'." (looking-at (concat (regexp-quote hello-file) ":[0-9]+:English"))))))))) + + (when (eq grep-highlight-matches 'auto-detect) + (setq grep-highlight-matches + (with-temp-buffer + (and (grep-probe grep-program '(nil t nil "--help")) + (progn + (goto-char (point-min)) + (search-forward "--color" nil t)) + ;; Windows and DOS pipes fail `isatty' detection in Grep. + (if (memq system-type '(windows-nt ms-dos)) + 'always 'auto))))) + (unless (and grep-command grep-find-command grep-template grep-find-template) (let ((grep-options - (concat (if grep-use-null-device "-n" "-nH") + (concat (and grep-highlight-matches + (grep-probe grep-program + `(nil nil nil "--color" "x" ,null-device) + nil 1) + (if (eq grep-highlight-matches 'always) + "--color=always " "--color ")) + (if grep-use-null-device "-n" "-nH") (if (grep-probe grep-program `(nil nil nil "-e" "foo" ,null-device) nil 1) @@ -637,16 +644,6 @@ This function is called from `compilation-filter-hook'." (t (format "%s . <X> -type f <F> -print | \"%s\" %s" find-program xargs-program gcmd)))))))) - (when (eq grep-highlight-matches 'auto-detect) - (setq grep-highlight-matches - (with-temp-buffer - (and (grep-probe grep-program '(nil t nil "--help")) - (progn - (goto-char (point-min)) - (search-forward "--color" nil t)) - ;; Windows and DOS pipes fail `isatty' detection in Grep. - (if (memq system-type '(windows-nt ms-dos)) - 'always 'auto))))) ;; Save defaults for this host. (setq grep-host-defaults-alist @@ -805,16 +802,20 @@ substitution string. Note dynamic scoping of variables.") (defun grep-expand-template (template &optional regexp files dir excl) "Patch grep COMMAND string replacing <C>, <D>, <F>, <R>, and <X>." - (let ((command template) - (cf case-fold-search) - (case-fold-search nil)) + (let* ((command template) + (env `((cf . ,case-fold-search) + (excl . ,excl) + (dir . ,dir) + (files . ,files) + (regexp . ,regexp))) + (case-fold-search nil)) (dolist (kw grep-expand-keywords command) (if (string-match (car kw) command) (setq command (replace-match (or (if (symbolp (cdr kw)) - (symbol-value (cdr kw)) - (save-match-data (eval (cdr kw)))) + (eval (cdr kw) env) + (save-match-data (eval (cdr kw) env))) "") t t command)))))) @@ -901,7 +902,7 @@ This command shares argument histories with \\[rgrep] and \\[grep]." (confirm (equal current-prefix-arg '(4)))) (list regexp files dir confirm)))))) (when (and (stringp regexp) (> (length regexp) 0)) - (unless (and dir (file-directory-p dir) (file-readable-p dir)) + (unless (and dir (file-accessible-directory-p dir)) (setq dir default-directory)) (let ((command regexp)) (if (null files) @@ -982,7 +983,7 @@ to specify a command to run." (confirm (equal current-prefix-arg '(4)))) (list regexp files dir confirm)))))) (when (and (stringp regexp) (> (length regexp) 0)) - (unless (and dir (file-directory-p dir) (file-readable-p dir)) + (unless (and dir (file-accessible-directory-p dir)) (setq dir default-directory)) (if (null files) (if (not (string= regexp (if (consp grep-find-command) @@ -1055,7 +1056,7 @@ to specify a command to run." (setq default-directory dir))))))) ;;;###autoload -(defun zrgrep (regexp &optional files dir confirm grep-find-template) +(defun zrgrep (regexp &optional files dir confirm template) "Recursively grep for REGEXP in gzipped FILES in tree rooted at DIR. Like `rgrep' but uses `zgrep' for `grep-program', sets the default file name to `*.gz', and sets `grep-highlight-matches' to `always'." @@ -1090,10 +1091,8 @@ file name to `*.gz', and sets `grep-highlight-matches' to `always'." (list regexp files dir confirm grep-find-template))))))) ;; Set `grep-highlight-matches' to `always' ;; since `zgrep' puts filters in the grep output. - (let ((grep-highlight-matches 'always)) - ;; `rgrep' uses the dynamically bound value `grep-find-template' - ;; from the argument `grep-find-template' whose value is computed - ;; in the `interactive' spec. + (let ((grep-find-template template) + (grep-highlight-matches 'always)) (rgrep regexp files dir confirm))) ;;;###autoload diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el index 98912ca5acb..a12bdd99f23 100644 --- a/lisp/progmodes/gud.el +++ b/lisp/progmodes/gud.el @@ -34,7 +34,8 @@ ;; and added a menu. Brian D. Carlstrom <bdc@ai.mit.edu> combined the IRIX ;; kluge with the gud-xdb-directories hack producing gud-dbx-directories. ;; Derek L. Davies <ddavies@world.std.com> added support for jdb (Java -;; debugger.) +;; debugger.) Jan Nieuwenhuizen added support for the Guile REPL (Guile +;; debugger). ;;; Code: @@ -140,7 +141,7 @@ Used to gray out relevant toolbar icons.") (display-graphic-p) (fboundp 'x-show-tip)) :visible (memq gud-minor-mode - '(gdbmi dbx sdb xdb pdb)) + '(gdbmi guiler dbx sdb xdb pdb)) :button (:toggle . gud-tooltip-mode)) ([refresh] "Refresh" . gud-refresh) ([run] menu-item "Run" gud-run @@ -170,11 +171,11 @@ Used to gray out relevant toolbar icons.") ([up] menu-item "Up Stack" gud-up :enable (not gud-running) :visible (memq gud-minor-mode - '(gdbmi gdb dbx xdb jdb pdb))) + '(gdbmi gdb guiler dbx xdb jdb pdb))) ([down] menu-item "Down Stack" gud-down :enable (not gud-running) :visible (memq gud-minor-mode - '(gdbmi gdb dbx xdb jdb pdb))) + '(gdbmi gdb guiler dbx xdb jdb pdb))) ([pp] menu-item "Print S-expression" gud-pp :enable (and (not gud-running) (bound-and-true-p gdb-active-process)) @@ -195,7 +196,7 @@ Used to gray out relevant toolbar icons.") ([finish] menu-item "Finish Function" gud-finish :enable (not gud-running) :visible (memq gud-minor-mode - '(gdbmi gdb xdb jdb pdb))) + '(gdbmi gdb guiler xdb jdb pdb))) ([stepi] menu-item "Step Instruction" gud-stepi :enable (not gud-running) :visible (memq gud-minor-mode '(gdbmi gdb dbx))) @@ -255,9 +256,8 @@ Used to gray out relevant toolbar icons.") ([menu-bar file] . undefined)))) "Map used in visited files.") -(let ((m (assq 'gud-minor-mode minor-mode-map-alist))) - (if m (setcdr m gud-minor-mode-map) - (push (cons 'gud-minor-mode gud-minor-mode-map) minor-mode-map-alist))) +(setf (alist-get 'gud-minor-mode minor-mode-map-alist) + gud-minor-mode-map) (defvar gud-mode-map ;; Will inherit from comint-mode via define-derived-mode. @@ -803,8 +803,7 @@ directory and source-file directory for your debugger." "Completion table for GDB commands. COMMAND is the prefix for which we seek completion. CONTEXT is the text before COMMAND on the line." - (let* ((start (- (point) (field-beginning))) - (complete-list + (let* ((complete-list (gud-gdb-run-command-fetch-lines (concat "complete " context command) (current-buffer) ;; From string-match above. @@ -1699,6 +1698,83 @@ and source-file directory for your debugger." (run-hooks 'pdb-mode-hook)) ;; ====================================================================== +;; Guile REPL (guiler) functions + +;; History of argument lists passed to guiler. +(defvar gud-guiler-history nil) + +(defvar gud-guiler-lastfile nil) + +(defun gud-guiler-marker-filter (string) + (setq gud-marker-acc (if gud-marker-acc (concat gud-marker-acc string) string)) + + (let ((start 0)) + (while + (cond + ((string-match "^In \\(.*\\):" gud-marker-acc start) + (setq gud-guiler-lastfile (match-string 1 gud-marker-acc))) + ((string-match "^\\([^:\n]+\\):\\([0-9]+\\):\\([0-9]+\\):[^\n]*" + gud-marker-acc start) + (setq gud-guiler-lastfile (match-string 1 gud-marker-acc)) + (setq gud-last-frame + (cons gud-guiler-lastfile + (string-to-number (match-string 2 gud-marker-acc))))) + ((string-match "^[ ]*\\([0-9]+\\):\\([0-9]+\\) [^\n]*" + gud-marker-acc start) + (if gud-guiler-lastfile + (setq gud-last-frame + (cons gud-guiler-lastfile + (string-to-number (match-string 1 gud-marker-acc)))))) + ((string-match comint-prompt-regexp gud-marker-acc start) t) + ((string= (substring gud-marker-acc start) "") nil) + (t nil)) + (setq start (match-end 0))) + + ;; Search for the last incomplete line in this chunk + (while (string-match "\n" gud-marker-acc start) + (setq start (match-end 0))) + + ;; If we have an incomplete line, store it in gud-marker-acc. + (setq gud-marker-acc (substring gud-marker-acc (or start 0)))) + string) + + +(defcustom gud-guiler-command-name "guile" + "File name for executing the Guile debugger. +This should be an executable on your path, or an absolute file name." + :type 'string + :group 'gud) + +;;;###autoload +(defun guiler (command-line) + "Run guiler on program FILE in buffer `*gud-FILE*'. +The directory containing FILE becomes the initial working directory +and source-file directory for your debugger." + (interactive + (list (gud-query-cmdline 'guiler))) + + (gud-common-init command-line nil 'gud-guiler-marker-filter) + (setq-local gud-minor-mode 'guiler) + +;; FIXME: absolute file-names are not grokked yet by Guile's ,break-at-source +;; and relative file names only when relative to %load-path. +;; (gud-def gud-break ",break-at-source %d%f %l" "\C-b" "Set breakpoint at current line.") + (gud-def gud-break ",break-at-source %f %l" "\C-b" "Set breakpoint at current line.") +;; FIXME: remove breakpoint with file-line not yet supported by Guile +;; (gud-def gud-remove ",delete ---> %d%f:%l" "\C-d" "Remove breakpoint at current line") + (gud-def gud-step ",step" "\C-s" "Step one source line with display.") + (gud-def gud-next ",next" "\C-n" "Step one line (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-up ",up" "<" "Up one stack frame.") + (gud-def gud-down ",down" ">" "Down one stack frame.") + (gud-def gud-print "%e" "\C-p" "Evaluate Guile expression at point.") + + (setq comint-prompt-regexp "^scheme@([^>]+> ") + (setq paragraph-start comint-prompt-regexp) + (run-hooks 'guiler-mode-hook)) + +;; ====================================================================== ;; ;; JDB support. ;; @@ -3445,6 +3521,7 @@ With arg, dereference expr if ARG is positive, otherwise do not dereference." "Return a suitable command to print the expression EXPR." (pcase gud-minor-mode (`gdbmi (concat "-data-evaluate-expression \"" expr "\"")) + (`guiler expr) (`dbx (concat "print " expr)) ((or `xdb `pdb) (concat "p " expr)) (`sdb (concat expr "/")))) diff --git a/lisp/progmodes/hideif.el b/lisp/progmodes/hideif.el index 506f2c2364e..cda421fbc86 100644 --- a/lisp/progmodes/hideif.el +++ b/lisp/progmodes/hideif.el @@ -1,10 +1,10 @@ -;;; hideif.el --- hides selected code within ifdef +;;; hideif.el --- hides selected code within ifdef -*- lexical-binding:t -*- ;; Copyright (C) 1988, 1994, 2001-2014 Free Software Foundation, Inc. ;; Author: Brian Marick ;; Daniel LaLiberte <liberte@holonexus.org> -;; Maintainer: emacs-devel@gnu.org +;; Maintainer: Luke Lee <luke.yx.lee@gmail.com> ;; Keywords: c, outlines ;; This file is part of GNU Emacs. @@ -36,6 +36,8 @@ ;; ;; Hide-ifdef suppresses the display of code that the preprocessor wouldn't ;; pass through. Support complete C/C++ expression and precedence. +;; It will automatically scan for new #define symbols and macros on the way +;; parsing. ;; ;; The hidden code is marked by ellipses (...). Be ;; cautious when editing near ellipses, since the hidden text is @@ -97,11 +99,12 @@ ;; Extensively modified by Daniel LaLiberte (while at Gould). ;; ;; Extensively modified by Luke Lee in 2013 to support complete C expression -;; evaluation. +;; evaluation and argumented macro expansion. ;;; Code: (require 'cc-mode) +(require 'cl-lib) (defgroup hide-ifdef nil "Hide selected code within `ifdef'." @@ -133,6 +136,40 @@ :group 'hide-ifdef :version "23.1") +(defcustom hide-ifdef-exclude-define-regexp nil + "Ignore #define names if those names match this exclusion pattern." + :type 'string + :version "25.1") + +(defcustom hide-ifdef-expand-reinclusion-protection t + "Non-nil means don't hide an entire header file enclosed by #ifndef...#endif. +Most C/C++ headers are usually wrapped with ifdefs to prevent re-inclusion: + + ----- beginning of file ----- + #ifndef _XXX_HEADER_FILE_INCLUDED_ + #define _XXX_HEADER_FILE_INCLUDED_ + xxx + xxx + xxx... + #endif + ----- end of file ----- + +The first time we visit such a file, _XXX_HEADER_FILE_INCLUDED_ is +undefined, and so nothing is hidden. The next time we visit it, everything will +be hidden. + +This behavior is generally undesirable. If this option is non-nil, the outermost +#if is always visible." + :type 'boolean + :version "25.1") + +(defcustom hide-ifdef-header-regexp + "\\.h\\(h\\|xx\\|pp\\)?\\'" + "C/C++ header file name patterns to determine if current buffer is a header. +Effective only if `hide-ifdef-expand-reinclusion-protection' is t." + :type 'string + :group 'hide-ifdef + :version "25.1") (defvar hide-ifdef-mode-submap ;; Set up the submap that goes after the prefix key. @@ -146,6 +183,8 @@ (define-key map "s" 'show-ifdefs) (define-key map "\C-d" 'hide-ifdef-block) (define-key map "\C-s" 'show-ifdef-block) + (define-key map "e" 'hif-evaluate-macro) + (define-key map "C" 'hif-clear-all-ifdef-defined) (define-key map "\C-q" 'hide-ifdef-toggle-read-only) (define-key map "\C-w" 'hide-ifdef-toggle-shadowing) @@ -201,7 +240,7 @@ (cons '(hide-ifdef-hiding " Hiding") minor-mode-alist))) -;; fix c-mode syntax table so we can recognize whole symbols. +;; Fix c-mode syntax table so we can recognize whole symbols. (defvar hide-ifdef-syntax-table (let ((st (copy-syntax-table c-mode-syntax-table))) (modify-syntax-entry ?_ "w" st) @@ -213,6 +252,11 @@ (defvar hide-ifdef-env nil "An alist of defined symbols and their values.") +(defvar hide-ifdef-env-backup nil + "This variable is a backup of the previously cleared `hide-ifdef-env'. +This backup prevents any accidental clearance of `hide-fidef-env' by +`hif-clear-all-ifdef-defined'.") + (defvar hif-outside-read-only nil "Internal variable. Saves the value of `buffer-read-only' while hiding.") @@ -229,53 +273,75 @@ that the C preprocessor would eliminate may be hidden from view. Several variables affect how the hiding is done: `hide-ifdef-env' - An association list of defined and undefined symbols for the - current buffer. Initially, the global value of `hide-ifdef-env' - is used. + An association list of defined and undefined symbols for the + current project. Initially, the global value of `hide-ifdef-env' + is used. This variable was a buffer-local variable, which limits + hideif to parse only one C/C++ file at a time. We've extended + hideif to support parsing a C/C++ project containing multiple C/C++ + source files opened simultaneously in different buffers. Therefore + `hide-ifdef-env' can no longer be buffer local but must be global. `hide-ifdef-define-alist' - An association list of defined symbol lists. + An association list of defined symbol lists. Use `hide-ifdef-set-define-alist' to save the current `hide-ifdef-env' and `hide-ifdef-use-define-alist' to set the current `hide-ifdef-env' from one of the lists in `hide-ifdef-define-alist'. `hide-ifdef-lines' - Set to non-nil to not show #if, #ifdef, #ifndef, #else, and - #endif lines when hiding. + Set to non-nil to not show #if, #ifdef, #ifndef, #else, and + #endif lines when hiding. `hide-ifdef-initially' - Indicates whether `hide-ifdefs' should be called when Hide-Ifdef mode - is activated. + Indicates whether `hide-ifdefs' should be called when Hide-Ifdef mode + is activated. `hide-ifdef-read-only' - Set to non-nil if you want to make buffers read only while hiding. - After `show-ifdefs', read-only status is restored to previous value. + Set to non-nil if you want to make buffers read only while hiding. + After `show-ifdefs', read-only status is restored to previous value. \\{hide-ifdef-mode-map}" :group 'hide-ifdef :lighter " Ifdef" (if hide-ifdef-mode (progn - ;; inherit global values - (set (make-local-variable 'hide-ifdef-env) - (default-value 'hide-ifdef-env)) - (set (make-local-variable 'hide-ifdef-hiding) - (default-value 'hide-ifdef-hiding)) - (set (make-local-variable 'hif-outside-read-only) buffer-read-only) - (set (make-local-variable 'line-move-ignore-invisible) t) - (add-hook 'change-major-mode-hook - (lambda () (hide-ifdef-mode -1)) nil t) - - (add-to-invisibility-spec '(hide-ifdef . t)) - - (if hide-ifdef-initially - (hide-ifdefs) - (show-ifdefs))) + ;; inherit global values + + ;; `hide-ifdef-env' is now a global variable. + ;; We can still simulate the behavior of older hideif versions (i.e. + ;; `hide-ifdef-env' being buffer local) by clearing this variable + ;; (C-c @ C) everytime before hiding current buffer. +;; (set (make-local-variable 'hide-ifdef-env) +;; (default-value 'hide-ifdef-env)) + (set 'hide-ifdef-env (default-value 'hide-ifdef-env)) + ;; Some C/C++ headers might have other ways to prevent reinclusion and + ;; thus would like `hide-ifdef-expand-reinclusion-protection' to be nil. + (set (make-local-variable 'hide-ifdef-expand-reinclusion-protection) + (default-value 'hide-ifdef-expand-reinclusion-protection)) + (set (make-local-variable 'hide-ifdef-hiding) + (default-value 'hide-ifdef-hiding)) + (set (make-local-variable 'hif-outside-read-only) buffer-read-only) + (set (make-local-variable 'line-move-ignore-invisible) t) + (add-hook 'change-major-mode-hook + (lambda () (hide-ifdef-mode -1)) nil t) + + (add-to-invisibility-spec '(hide-ifdef . t)) + + (if hide-ifdef-initially + (hide-ifdefs) + (show-ifdefs))) ;; else end hide-ifdef-mode (kill-local-variable 'line-move-ignore-invisible) (remove-from-invisibility-spec '(hide-ifdef . t)) (when hide-ifdef-hiding (show-ifdefs)))) +(defun hif-clear-all-ifdef-defined () + "Clears all symbols defined in `hide-ifdef-env'. +It will backup this variable to `hide-ifdef-env-backup' before clearing to +prevent accidental clearance." + (interactive) + (when (y-or-n-p "Clear all #defined symbols? ") + (setq hide-ifdef-env-backup hide-ifdef-env) + (setq hide-ifdef-env nil))) (defun hif-show-all () "Show all of the text in the current buffer." @@ -295,16 +361,64 @@ Several variables affect how the hiding is done: (while (= (logand 1 (skip-chars-backward "\\\\")) 1) (end-of-line 2))) +(defun hif-merge-ifdef-region (start end) + "This function merges nearby ifdef regions to form a bigger overlay. +The region is defined by START and END. This will decrease the number of +overlays created." + ;; Generally there is no need to call itself recursively since there should + ;; originally exists no un-merged regions; however, if a part of the file is + ;; hidden with `hide-ifdef-lines' equals to nil while another part with 't, + ;; this case happens. + ;; TODO: Should we merge? or just create a container overlay? -- this can + ;; prevent `hideif-show-ifdef' expanding too many hidden contents since there + ;; is only a big overlay exists there without any smaller overlays. + (save-restriction + (widen) ; Otherwise `point-min' and `point-max' will be restricted and thus + ; fail to find neighbor overlays + (let ((begovrs (overlays-in + (max (- start 2) (point-min)) + (max (- start 1) (point-min)))) + (endovrs (overlays-in + (min (+ end 1) (point-max)) + (min (+ end 2) (point-max)))) + (ob nil) + (oe nil) + b e) + ;; Merge overlays before START + (dolist (o begovrs) + (when (overlay-get o 'hide-ifdef) + (setq b (min start (overlay-start o)) + e (max end (overlay-end o))) + (move-overlay o b e) + (hif-merge-ifdef-region b e) + (setq ob o))) + ;; Merge overlays after END + (dolist (o endovrs) + (when (overlay-get o 'hide-ifdef) + (setq b (min start (overlay-start o)) + e (max end (overlay-end o))) + (move-overlay o b e) + (hif-merge-ifdef-region b e) + (setf oe o))) + ;; If both START and END merging happens, merge into bigger one + (when (and ob oe) + (let ((b (min (overlay-start ob) (overlay-start oe))) + (e (max (overlay-end ob) (overlay-end oe)))) + (delete-overlay oe) + (move-overlay ob b e) + (hif-merge-ifdef-region b e))) + (or ob oe)))) + (defun hide-ifdef-region-internal (start end) - (remove-overlays start end 'hide-ifdef t) + (unless (hif-merge-ifdef-region start end) (let ((o (make-overlay start end))) (overlay-put o 'hide-ifdef t) (if hide-ifdef-shadow - (overlay-put o 'face 'hide-ifdef-shadow) - (overlay-put o 'invisible 'hide-ifdef)))) + (overlay-put o 'face 'hide-ifdef-shadow) + (overlay-put o 'invisible 'hide-ifdef))))) (defun hide-ifdef-region (start end) - "START is the start of a #if or #else form. END is the ending part. + "START is the start of a #if, #elif, or #else form. END is the ending part. Everything including these lines is made invisible." (save-excursion (goto-char start) (hif-end-of-line) (setq start (point)) @@ -313,7 +427,9 @@ Everything including these lines is made invisible." (defun hif-show-ifdef-region (start end) "Everything between START and END is made visible." - (remove-overlays start end 'hide-ifdef t)) + (let ((onum (length (overlays-in start end)))) + (remove-overlays start end 'hide-ifdef t) + (/= onum (length (overlays-in start end))))) ;;===%%SF%% evaluation (Start) === @@ -330,7 +446,7 @@ that form should be displayed.") (defun hif-set-var (var value) - "Prepend (var value) pair to `hide-ifdef-env'." + "Prepend (VAR VALUE) pair to `hide-ifdef-env'." (setq hide-ifdef-env (cons (cons var value) hide-ifdef-env))) (declare-function semantic-c-hideif-lookup "semantic/bovine/c" (var)) @@ -338,11 +454,11 @@ that form should be displayed.") (defun hif-lookup (var) (or (when (bound-and-true-p semantic-c-takeover-hideif) - (semantic-c-hideif-lookup var)) + (semantic-c-hideif-lookup var)) (let ((val (assoc var hide-ifdef-env))) - (if val - (cdr val) - hif-undefined-symbol)))) + (if val + (cdr val) + hif-undefined-symbol)))) (defun hif-defined (var) (cond @@ -358,25 +474,43 @@ that form should be displayed.") ;;===%%SF%% parsing (Start) === ;;; The code that understands what ifs and ifdef in files look like. -(defconst hif-cpp-prefix "\\(^\\|\r\\)[ \t]*#[ \t]*") -(defconst hif-ifndef-regexp (concat hif-cpp-prefix "ifndef")) -(defconst hif-ifx-regexp (concat hif-cpp-prefix "if\\(n?def\\)?[ \t]+")) -(defconst hif-else-regexp (concat hif-cpp-prefix "else")) -(defconst hif-endif-regexp (concat hif-cpp-prefix "endif")) +(defconst hif-cpp-prefix "\\(^\\|\r\\)[ \t]*#[ \t]*") +(defconst hif-ifxdef-regexp (concat hif-cpp-prefix "if\\(n\\)?def")) +(defconst hif-ifndef-regexp (concat hif-cpp-prefix "ifndef")) +(defconst hif-ifx-regexp (concat hif-cpp-prefix "if\\(n?def\\)?[ \t]+")) +(defconst hif-elif-regexp (concat hif-cpp-prefix "elif")) +(defconst hif-else-regexp (concat hif-cpp-prefix "else")) +(defconst hif-endif-regexp (concat hif-cpp-prefix "endif")) (defconst hif-ifx-else-endif-regexp - (concat hif-ifx-regexp "\\|" hif-else-regexp "\\|" hif-endif-regexp)) - -;; Used to store the current token and the whole token list during parsing. -;; Only bound dynamically. + (concat hif-ifx-regexp "\\|" hif-elif-regexp "\\|" hif-else-regexp "\\|" + hif-endif-regexp)) +(defconst hif-macro-expr-prefix-regexp + (concat hif-cpp-prefix "\\(if\\(n?def\\)?\\|elif\\|define\\)[ \t]+")) + +(defconst hif-white-regexp "[ \t]*") +(defconst hif-define-regexp (concat hif-cpp-prefix "\\(define\\|undef\\)")) +(defconst hif-id-regexp (concat "[[:alpha:]_][[:alnum:]_]*")) +(defconst hif-macroref-regexp + (concat hif-white-regexp "\\(" hif-id-regexp "\\)" hif-white-regexp + "\\(" + "(" hif-white-regexp + "\\(" hif-id-regexp "\\)?" hif-white-regexp + "\\(" "," hif-white-regexp hif-id-regexp hif-white-regexp "\\)*" + "\\(\\.\\.\\.\\)?" hif-white-regexp + ")" + "\\)?" )) + +;; Store the current token and the whole token list during parsing. +;; Bound dynamically. (defvar hif-token) (defvar hif-token-list) (defconst hif-token-alist '(("||" . hif-or) ("&&" . hif-and) - ("|" . hif-logior) + ("|" . hif-logior) ("^" . hif-logxor) - ("&" . hif-logand) + ("&" . hif-logand) ("<<" . hif-shiftleft) (">>" . hif-shiftright) ("==" . hif-equal) @@ -384,23 +518,28 @@ that form should be displayed.") ;; expression syntax, because they are still relevant for the tokenizer, ;; especially in conjunction with ##. ("=" . hif-assign) - ("!=" . hif-notequal) + ("!=" . hif-notequal) ("##" . hif-token-concat) ("!" . hif-not) ("~" . hif-lognot) ("(" . hif-lparen) (")" . hif-rparen) - (">" . hif-greater) - ("<" . hif-less) - (">=" . hif-greater-equal) - ("<=" . hif-less-equal) - ("+" . hif-plus) - ("-" . hif-minus) + (">" . hif-greater) + ("<" . hif-less) + (">=" . hif-greater-equal) + ("<=" . hif-less-equal) + ("+" . hif-plus) + ("-" . hif-minus) ("*" . hif-multiply) ("/" . hif-divide) ("%" . hif-modulo) - ("?" . hif-conditional) - (":" . hif-colon))) + ("?" . hif-conditional) + (":" . hif-colon) + ("," . hif-comma) + ("#" . hif-stringify) + ("..." . hif-etc))) + +(defconst hif-valid-token-list (mapcar 'cdr hif-token-alist)) (defconst hif-token-regexp (concat (regexp-opt (mapcar 'car hif-token-alist)) @@ -410,47 +549,71 @@ that form should be displayed.") (defconst hif-string-literal-regexp "\\(\"\\(?:[^\"\\]\\|\\\\.\\)*\"\\)") +(defun hif-string-to-number (string &optional base) + "Like `string-to-number', but it understands non-decimal floats." + (if (or (not base) (= base 10)) + (string-to-number string base) + (let* ((parts (split-string string "\\." t "[ \t]+")) + (frac (cadr parts)) + (fraclen (length frac)) + (quot (expt (if (zerop fraclen) + base + (* base 1.0)) fraclen))) + (/ (string-to-number (concat (car parts) frac) base) quot)))) + +;; The dynamic binding variable `hif-simple-token-only' is shared only by +;; `hif-tokenize' and `hif-find-define'. The purpose is to prevent `hif-tokenize' +;; from returning one more value to indicate a simple token is scanned. This help +;; speeding up macro evaluation on those very simple cases like integers or +;; literals. +;; Check the long comments before `hif-find-define' for more details. [lukelee] +(defvar hif-simple-token-only) (defun hif-tokenize (start end) "Separate string between START and END into a list of tokens." (let ((token-list nil)) + (setq hif-simple-token-only t) (with-syntax-table hide-ifdef-syntax-table (save-excursion - (goto-char start) - (while (progn (forward-comment (point-max)) (< (point) end)) - ;; (message "expr-start = %d" expr-start) (sit-for 1) - (cond - ((looking-at "\\\\\n") - (forward-char 2)) + (goto-char start) + (while (progn (forward-comment (point-max)) (< (point) end)) + ;; (message "expr-start = %d" expr-start) (sit-for 1) + (cond + ((looking-at "\\\\\n") + (forward-char 2)) ((looking-at hif-string-literal-regexp) (push (substring-no-properties (match-string 1)) token-list) (goto-char (match-end 0))) - ((looking-at hif-token-regexp) - (let ((token (buffer-substring (point) (match-end 0)))) - (goto-char (match-end 0)) - ;; (message "token: %s" token) (sit-for 1) - (push + + ((looking-at hif-token-regexp) + (let ((token (buffer-substring-no-properties + (point) (match-end 0)))) + (goto-char (match-end 0)) + ;; (message "token: %s" token) (sit-for 1) + (push (or (cdr (assoc token hif-token-alist)) (if (string-equal token "defined") 'hif-defined) ;; TODO: ;; 1. postfix 'l', 'll', 'ul' and 'ull' - ;; 2. floating number formats - ;; 3. hexadecimal/octal floats - ;; 4. 098 is interpreted as octal conversion error - ;; FIXME: string-to-number does not convert hex floats + ;; 2. floating number formats (like 1.23e4) + ;; 3. 098 is interpreted as octal conversion error (if (string-match "0x\\([0-9a-fA-F]+\\.?[0-9a-fA-F]*\\)" token) - (string-to-number (match-string 1 token) 16)) ;; hex - ;; FIXME: string-to-number does not convert octal floats + (hif-string-to-number (match-string 1 token) 16)) ;; hex (if (string-match "\\`0[0-9]+\\(\\.[0-9]+\\)?\\'" token) - (string-to-number token 8)) ;; octal + (hif-string-to-number token 8)) ;; octal (if (string-match "\\`[1-9][0-9]*\\(\\.[0-9]+\\)?\\'" token) (string-to-number token)) ;; decimal - (intern token)) + (prog1 (intern token) + (setq hif-simple-token-only nil))) token-list))) - (t (error "Bad #if expression: %s" (buffer-string))))))) + + ((looking-at "\r") ; Sometimes MS-Windows user will leave CR in + (forward-char 1)) ; the source code. Let's not get stuck here. + (t (error "Bad #if expression: %s" (buffer-string))))))) + (nreverse token-list))) ;;------------------------------------------------------------------------ @@ -485,9 +648,116 @@ that form should be displayed.") "Pop the next token from token-list into the let variable `hif-token'." (setq hif-token (pop hif-token-list))) -(defun hif-parse-if-exp (token-list) - "Parse the TOKEN-LIST. Return translated list in prefix form." - (let ((hif-token-list token-list)) +(defsubst hif-if-valid-identifier-p (id) + (not (or (numberp id) + (stringp id)))) + +(defun hif-define-operator (tokens) + "`Upgrade' hif-define xxx to '(hif-define xxx)' so it won't be substituted." + (let ((result nil) + (tok nil)) + (while (setq tok (pop tokens)) + (push + (if (eq tok 'hif-defined) + (progn + (setq tok (cadr tokens)) + (if (eq (car tokens) 'hif-lparen) + (if (and (hif-if-valid-identifier-p tok) + (eq (cl-caddr tokens) 'hif-rparen)) + (setq tokens (cl-cdddr tokens)) + (error "#define followed by non-identifier: %S" tok)) + (setq tok (car tokens) + tokens (cdr tokens)) + (unless (hif-if-valid-identifier-p tok) + (error "#define followed by non-identifier: %S" tok))) + (list 'hif-defined 'hif-lparen tok 'hif-rparen)) + tok) + result)) + (nreverse result))) + +(defun hif-flatten (l) + "Flatten a tree." + (apply #'nconc + (mapcar (lambda (x) (if (listp x) + (hif-flatten x) + (list x))) l))) + +(defun hif-expand-token-list (tokens &optional macroname expand_list) + "Perform expansion on TOKENS till everything expanded. +Self-reference (directly or indirectly) tokens are not expanded. +EXPAND_LIST is the list of macro names currently being expanded, used for +detecting self-reference." + (catch 'self-referencing + (let ((expanded nil) + (remains (hif-define-operator + (hif-token-concatenation + (hif-token-stringification tokens)))) + tok rep) + (if macroname + (setq expand_list (cons macroname expand_list))) + ;; Expanding all tokens till list exhausted + (while (setq tok (pop remains)) + (if (memq tok expand_list) + ;; For self-referencing tokens, don't expand it + (throw 'self-referencing tokens)) + (push + (cond + ((or (memq tok hif-valid-token-list) + (numberp tok) + (stringp tok)) + tok) + + ((setq rep (hif-lookup tok)) + (if (and (listp rep) + (eq (car rep) 'hif-define-macro)) ; A defined macro + ;; Recursively expand it + (if (cadr rep) ; Argument list is not nil + (if (not (eq (car remains) 'hif-lparen)) + ;; No argument, no invocation + tok + ;; Argumented macro, get arguments and invoke it. + ;; Dynamically bind hif-token-list and hif-token + ;; for hif-macro-supply-arguments + (let* ((hif-token-list (cdr remains)) + (hif-token nil) + (parmlist (mapcar #'hif-expand-token-list + (hif-get-argument-list))) + (result + (hif-expand-token-list + (hif-macro-supply-arguments tok parmlist) + tok expand_list))) + (setq remains (cons hif-token hif-token-list)) + result)) + ;; Argument list is nil, direct expansion + (setq rep (hif-expand-token-list + (cl-caddr rep) ; Macro's token list + tok expand_list)) + ;; Replace all remaining references immediately + (setq remains (cl-substitute tok rep remains)) + rep) + ;; Lookup tok returns an atom + rep)) + + ;;[2013-10-22 16:06:12 +0800] Must keep the token, removing + ;; this token might results in an incomplete expression that + ;; cannot be parsed further. + ;;((= 1 (hif-defined tok)) ; defined (hif-defined tok)=1, + ;; ;;but empty (hif-lookup tok)=nil, thus remove this token + ;; (setq remains (delete tok remains)) + ;; nil) + + (t ; Usual IDs + tok)) + + expanded)) + + (hif-flatten (nreverse expanded))))) + +(defun hif-parse-exp (token-list &optional macroname) + "Parse the TOKEN-LIST. +Return translated list in prefix form. MACRONAME is applied when invoking +macros to prevent self-reference." + (let ((hif-token-list (hif-expand-token-list token-list macroname))) (hif-nexttoken) (prog1 (and hif-token @@ -496,31 +766,31 @@ that form should be displayed.") (error "Error: unexpected token: %s" hif-token))))) (defun hif-exprlist () - "Parse an exprlist: expr { ',' expr}" + "Parse an exprlist: expr { ',' expr}." (let ((result (hif-expr))) (if (eq hif-token 'hif-comma) - (let ((temp (list result))) - (while - (progn - (hif-nexttoken) - (push (hif-expr) temp) - (eq hif-token 'hif-comma))) - (cons 'hif-comma (nreverse temp))) + (let ((temp (list result))) + (while + (progn + (hif-nexttoken) + (push (hif-expr) temp) + (eq hif-token 'hif-comma))) + (cons 'hif-comma (nreverse temp))) result))) (defun hif-expr () "Parse an expression as found in #if. - expr : or-expr | or-expr '?' expr ':' expr." +expr : or-expr | or-expr '?' expr ':' expr." (let ((result (hif-or-expr)) - middle) + middle) (while (eq hif-token 'hif-conditional) (hif-nexttoken) (setq middle (hif-expr)) (if (eq hif-token 'hif-colon) - (progn - (hif-nexttoken) - (setq result (list 'hif-conditional result middle (hif-expr)))) - (error "Error: unexpected token: %s" hif-token))) + (progn + (hif-nexttoken) + (setq result (list 'hif-conditional result middle (hif-expr)))) + (error "Error: unexpected token: %s" hif-token))) result)) (defun hif-or-expr () @@ -577,7 +847,8 @@ that form should be displayed.") "Parse a comp-expr : logshift | comp-expr `<'|`>'|`>='|`<=' logshift." (let ((result (hif-logshift-expr)) (comp-token nil)) - (while (memq hif-token '(hif-greater hif-less hif-greater-equal hif-less-equal)) + (while (memq hif-token '(hif-greater hif-less hif-greater-equal + hif-less-equal)) (setq comp-token hif-token) (hif-nexttoken) (setq result (list comp-token result (hif-logshift-expr)))) @@ -608,7 +879,7 @@ that form should be displayed.") "Parse an expression with *,/,%. muldiv : factor | muldiv '*|/|%' factor." (let ((result (hif-factor)) - (math-op nil)) + (math-op nil)) (while (memq hif-token '(hif-multiply hif-divide hif-modulo)) (setq math-op hif-token) (hif-nexttoken) @@ -616,7 +887,9 @@ that form should be displayed.") result)) (defun hif-factor () - "Parse a factor: '!' factor | '~' factor | '(' expr ')' | 'defined(' id ')' | 'id(parmlist)' | strings | id." + "Parse a factor. +factor : '!' factor | '~' factor | '(' expr ')' | 'defined(' id ')' | + 'id(parmlist)' | strings | id." (cond ((eq hif-token 'hif-not) (hif-nexttoken) @@ -630,36 +903,119 @@ that form should be displayed.") (hif-nexttoken) (let ((result (hif-exprlist))) (if (not (eq hif-token 'hif-rparen)) - (error "Bad token in parenthesized expression: %s" hif-token) - (hif-nexttoken) - result))) + (error "Bad token in parenthesized expression: %s" hif-token) + (hif-nexttoken) + result))) ((eq hif-token 'hif-defined) (hif-nexttoken) (let ((paren (when (eq hif-token 'hif-lparen) (hif-nexttoken) t)) - (ident hif-token)) + (ident hif-token)) (if (memq hif-token '(or and not hif-defined hif-lparen hif-rparen)) - (error "Error: unexpected token: %s" hif-token)) + (error "Error: unexpected token: %s" hif-token)) (when paren - (hif-nexttoken) + (hif-nexttoken) (unless (eq hif-token 'hif-rparen) - (error "Error: expected \")\" after identifier"))) + (error "Error: expected \")\" after identifier"))) (hif-nexttoken) `(hif-defined (quote ,ident)))) ((numberp hif-token) (prog1 hif-token (hif-nexttoken))) + ((stringp hif-token) + (hif-string-concatenation)) ;; Unary plus/minus. ((memq hif-token '(hif-minus hif-plus)) (list (prog1 hif-token (hif-nexttoken)) 0 (hif-factor))) - (t ; identifier + (t ; identifier (let ((ident hif-token)) - (if (memq ident '(or and)) - (error "Error: missing identifier")) (hif-nexttoken) - `(hif-lookup (quote ,ident)))))) + (if (eq hif-token 'hif-lparen) + (hif-place-macro-invocation ident) + `(hif-lookup (quote ,ident))))))) + +(defun hif-get-argument-list () + (let ((nest 0) + (parmlist nil) ; A "token" list of parameters, will later be parsed + (parm nil)) + + (while (or (not (eq (hif-nexttoken) 'hif-rparen)) + (/= nest 0)) + (if (eq (car (last parm)) 'hif-comma) + (setq parm nil)) + (cond + ((eq hif-token 'hif-lparen) + (setq nest (1+ nest))) + ((eq hif-token 'hif-rparen) + (setq nest (1- nest))) + ((and (eq hif-token 'hif-comma) + (= nest 0)) + (push (nreverse parm) parmlist) + (setq parm nil))) + (push hif-token parm)) + + (push (nreverse parm) parmlist) ; Okay even if PARM is nil + (hif-nexttoken) ; Drop the `hif-rparen', get next token + (nreverse parmlist))) + +(defun hif-place-macro-invocation (ident) + (let ((parmlist (hif-get-argument-list))) + `(hif-invoke (quote ,ident) (quote ,parmlist)))) + +(defun hif-string-concatenation () + "Parse concatenated strings: string | strings string." + (let ((result (substring-no-properties hif-token))) + (while (stringp (hif-nexttoken)) + (setq result (concat + (substring result 0 -1) ; remove trailing '"' + (substring hif-token 1)))) ; remove leading '"' + result)) + +(defun hif-define-macro (_parmlist _token-body) + "A marker for defined macro with arguments. +This macro cannot be evaluated alone without parameters input." + ;;TODO: input arguments at run time, use minibuffer to query all arguments + (error + "Argumented macro cannot be evaluated without passing any parameter")) + +(defun hif-stringify (a) + "Stringify a number, string or symbol." + (cond + ((numberp a) + (number-to-string a)) + ((atom a) + (symbol-name a)) + ((stringp a) + (concat "\"" a "\"")) + (t + (error "Invalid token to stringify")))) + +(defun intern-safe (str) + (if (stringp str) + (intern str))) + +(defun hif-token-concat (a b) + "Concatenate two tokens into a longer token. +Currently support only simple token concatenation. Also support weird (but +valid) token concatenation like '>' ## '>' becomes '>>'. Here we take care only +those that can be evaluated during preprocessing time and ignore all those that +can only be evaluated at C(++) runtime (like '++', '--' and '+='...)." + (if (or (memq a hif-valid-token-list) + (memq b hif-valid-token-list)) + (let* ((ra (car (rassq a hif-token-alist))) + (rb (car (rassq b hif-token-alist))) + (result (and ra rb + (cdr (assoc (concat ra rb) hif-token-alist))))) + (or result + ;;(error "Invalid token to concatenate") + (error "Concatenating \"%s\" and \"%s\" does not give a valid \ +preprocessing token" + (or ra (symbol-name a)) + (or rb (symbol-name b))))) + (intern-safe (concat (hif-stringify a) + (hif-stringify b))))) (defun hif-mathify (val) "Treat VAL as a number: if it's t or nil, use 1 or 0." @@ -715,30 +1071,159 @@ that form should be displayed.") (defun hif-comma (&rest expr) - "Evaluate a list of expr, return the result of the last item." + "Evaluate a list of EXPR, return the result of the last item." (let ((result nil)) (dolist (e expr) (ignore-errors (setq result (funcall hide-ifdef-evaluator e)))) result)) +(defun hif-token-stringification (l) + "Scan token list for `hif-stringify' ('#') token and stringify the next token." + (let (result) + (while l + (push (if (eq (car l) 'hif-stringify) + (prog1 + (if (cadr l) + (hif-stringify (cadr l)) + (error "No token to stringify")) + (setq l (cdr l))) + (car l)) + result) + (setq l (cdr l))) + (nreverse result))) + +(defun hif-token-concatenation (l) + "Scan token list for `hif-token-concat' ('##') token and concatenate two tokens." + (let ((prev nil) + result) + (while l + (while (eq (car l) 'hif-token-concat) + (unless prev + (error "No token before ## to concatenate")) + (unless (cdr l) + (error "No token after ## to concatenate")) + (setq prev (hif-token-concat prev (cadr l))) + (setq l (cddr l))) + (if prev + (setq result (append result (list prev)))) + (setq prev (car l) + l (cdr l))) + (if prev + (append result (list prev)) + result))) + +(defun hif-delimit (lis atom) + (nconc (cl-mapcan (lambda (l) (list l atom)) + (butlast lis)) + (last lis))) + +;; Perform token replacement: +(defun hif-macro-supply-arguments (macro-name actual-parms) + "Expand a macro call, replace ACTUAL-PARMS in the macro body." + (let* ((SA (assoc macro-name hide-ifdef-env)) + (macro (and SA + (cdr SA) + (eq (cadr SA) 'hif-define-macro) + (cddr SA))) + (formal-parms (and macro (car macro))) + (macro-body (and macro (cadr macro))) + actual-count + formal-count + formal + etc) + + (when (and actual-parms formal-parms macro-body) + ;; For each actual parameter, evaluate each one and associate it + ;; with an actual parameter, put it into local table and finally + ;; evaluate the macro body. + (if (setq etc (eq (car formal-parms) 'hif-etc)) + ;; Take care of `hif-etc' first. Prefix `hif-comma' back if needed. + (setq formal-parms (cdr formal-parms))) + (setq formal-count (length formal-parms) + actual-count (length actual-parms)) + + (if (> formal-count actual-count) + (error "Too few parameters for macro %S" macro-name) + (if (< formal-count actual-count) + (or etc + (error "Too many parameters for macro %S" macro-name)))) + + ;; Perform token replacement on the MACRO-BODY with the parameters + (while (setq formal (pop formal-parms)) + ;; Prevent repetitive substitution, thus cannot use `subst' + ;; for example: + ;; #define mac(a,b) (a+b) + ;; #define testmac mac(b,y) + ;; testmac should expand to (b+y): replace of argument a and b + ;; occurs simultaneously, not sequentially. If sequentially, + ;; according to the argument order, it will become: + ;; 1. formal parm #1 'a' replaced by actual parm 'b', thus (a+b) + ;; becomes (b+b) + ;; 2. formal parm #2 'b' replaced by actual parm 'y', thus (b+b) + ;; becomes (y+y). + (setq macro-body + ;; Unlike `subst', `substitute' replace only the top level + ;; instead of the whole tree; more importantly, it's not + ;; destructive. + (cl-substitute (if (and etc (null formal-parms)) + (hif-delimit actual-parms 'hif-comma) + (car actual-parms)) + formal macro-body)) + (setq actual-parms (cdr actual-parms))) + + ;; Replacement completed, flatten the whole token list + (setq macro-body (hif-flatten macro-body)) + + ;; Stringification and token concatenation happens here + (hif-token-concatenation (hif-token-stringification macro-body))))) + +(defun hif-invoke (macro-name actual-parms) + "Invoke a macro by expanding it, reparse macro-body and finally invoke it." + ;; Reparse the macro body and evaluate it + (funcall hide-ifdef-evaluator + (hif-parse-exp + (hif-macro-supply-arguments macro-name actual-parms) + macro-name))) ;;;----------- end of parser ----------------------- -(defun hif-canonicalize () - "When at beginning of #ifX, return a Lisp expression for its condition." +(defun hif-canonicalize-tokens (regexp) ; For debugging + "Return the expanded result of the scanned tokens." (save-excursion - (let ((negate (looking-at hif-ifndef-regexp))) - (re-search-forward hif-ifx-regexp) - (let* ((tokens (hif-tokenize (point) - (progn (hif-end-of-line) (point)))) - (expr (hif-parse-if-exp tokens))) - ;; (message "hif-canonicalized: %s" expr) - (if negate - (list 'hif-not expr) - expr))))) - + (re-search-forward regexp) + (let* ((curr-regexp (match-string 0)) + (defined (string-match hif-ifxdef-regexp curr-regexp)) + (negate (and defined + (string= (match-string 2 curr-regexp) "n"))) + (hif-simple-token-only nil) ;; Dynamic binding var for `hif-tokenize' + (tokens (hif-tokenize (point) + (progn (hif-end-of-line) (point))))) + (if defined + (setq tokens (list 'hif-defined tokens))) + (if negate + (setq tokens (list 'hif-not tokens))) + tokens))) + +(defun hif-canonicalize (regexp) + "Return a Lisp expression for its condition by scanning current buffer. +Do this when cursor is at the beginning of `regexp' (i.e. #ifX)." + (let ((case-fold-search nil)) + (save-excursion + (re-search-forward regexp) + (let* ((curr-regexp (match-string 0)) + (defined (string-match hif-ifxdef-regexp curr-regexp)) + (negate (and defined + (string= (match-string 2 curr-regexp) "n"))) + (hif-simple-token-only nil) ; Dynamic binding for `hif-tokenize' + (tokens (hif-tokenize (point) + (progn (hif-end-of-line) (point))))) + (if defined + (setq tokens (list 'hif-defined tokens))) + (if negate + (setq tokens (list 'hif-not tokens))) + (hif-parse-exp tokens))))) (defun hif-find-any-ifX () "Move to next #if..., or #ifndef, at point or after." @@ -749,10 +1234,10 @@ that form should be displayed.") (defun hif-find-next-relevant () - "Move to next #if..., #else, or #endif, after the current line." + "Move to next #if..., #elif..., #else, or #endif, after the current line." ;; (message "hif-find-next-relevant at %d" (point)) (end-of-line) - ;; avoid infinite recursion by only going to beginning of line if match found + ;; Avoid infinite recursion by only going to line-beginning if match found (if (re-search-forward hif-ifx-else-endif-regexp (point-max) t) (beginning-of-line))) @@ -760,33 +1245,37 @@ that form should be displayed.") "Move to previous #if..., #else, or #endif, before the current line." ;; (message "hif-find-previous-relevant at %d" (point)) (beginning-of-line) - ;; avoid infinite recursion by only going to beginning of line if match found + ;; Avoid infinite recursion by only going to line-beginning if match found (if (re-search-backward hif-ifx-else-endif-regexp (point-min) t) (beginning-of-line))) -(defun hif-looking-at-ifX () ;; Should eventually see #if - (looking-at hif-ifx-regexp)) +(defun hif-looking-at-ifX () + (looking-at hif-ifx-regexp)) ; Should eventually see #if (defun hif-looking-at-endif () (looking-at hif-endif-regexp)) (defun hif-looking-at-else () (looking-at hif-else-regexp)) +(defun hif-looking-at-elif () + (looking-at hif-elif-regexp)) (defun hif-ifdef-to-endif () - "If positioned at #ifX or #else form, skip to corresponding #endif." + "If positioned at #ifX, #elif, or #else form, skip to corresponding #endif." ;; (message "hif-ifdef-to-endif at %d" (point)) (sit-for 1) (hif-find-next-relevant) (cond ((hif-looking-at-ifX) - (hif-ifdef-to-endif) ; find endif of nested if - (hif-ifdef-to-endif)) ; find outer endif or else - ((hif-looking-at-else) - (hif-ifdef-to-endif)) ; find endif following else - ((hif-looking-at-endif) - 'done) - (t - (error "Mismatched #ifdef #endif pair")))) + (hif-ifdef-to-endif) ; Find endif of nested if + (hif-ifdef-to-endif)) ; Find outer endif or else + ((hif-looking-at-elif) + (hif-ifdef-to-endif)) + ((hif-looking-at-else) + (hif-ifdef-to-endif)) ; Find endif following else + ((hif-looking-at-endif) + 'done) + (t + (error "Mismatched #ifdef #endif pair")))) (defun hif-endif-to-ifdef () @@ -795,15 +1284,18 @@ that form should be displayed.") (let ((start (point))) (hif-find-previous-relevant) (if (= start (point)) - (error "Mismatched #ifdef #endif pair"))) + (error "Mismatched #ifdef #endif pair"))) (cond ((hif-looking-at-endif) - (hif-endif-to-ifdef) ; find beginning of nested if - (hif-endif-to-ifdef)) ; find beginning of outer if or else - ((hif-looking-at-else) - (hif-endif-to-ifdef)) - ((hif-looking-at-ifX) - 'done) - (t))) ; never gets here + (hif-endif-to-ifdef) ; Find beginning of nested if + (hif-endif-to-ifdef)) ; Find beginning of outer if or else + ((hif-looking-at-elif) + (hif-endif-to-ifdef)) + ((hif-looking-at-else) + (hif-endif-to-ifdef)) + ((hif-looking-at-ifX) + 'done) + (t + (error "Mismatched #endif")))) ; never gets here (defun forward-ifdef (&optional arg) @@ -897,26 +1389,25 @@ With argument, do this that many times." ;;===%%SF%% hide-ifdef-hiding (Start) === -;;; A range is a structure with four components: -;;; ELSE-P True if there was an else clause for the ifdef. -;;; START The start of the range. (beginning of line) -;;; ELSE The else marker (beginning of line) -;;; Only valid if ELSE-P is true. -;;; END The end of the range. (beginning of line) +;; A range is a structure with four components: +;; START The start of the range. (beginning of line) +;; ELSE The else marker (beginning of line) +;; END The end of the range. (beginning of line) +;; ELIF A sequence of #elif markers (beginning of line) -(defsubst hif-make-range (start end &optional else) - (list start else end)) +(defsubst hif-make-range (start end &optional else elif) + (list start else end elif)) (defsubst hif-range-start (range) (elt range 0)) (defsubst hif-range-else (range) (elt range 1)) (defsubst hif-range-end (range) (elt range 2)) +(defsubst hif-range-elif (range) (elt range 3)) - -;;; Find-Range -;;; The workhorse, it delimits the #if region. Reasonably simple: -;;; Skip until an #else or #endif is found, remembering positions. If -;;; an #else was found, skip some more, looking for the true #endif. +;; Find-Range +;; The workhorse, it delimits the #if region. Reasonably simple: +;; Skip until an #else or #endif is found, remembering positions. If +;; an #else was found, skip some more, looking for the true #endif. (defun hif-find-range () "Return a Range structure describing the current #if region. @@ -925,35 +1416,40 @@ Point is left unchanged." (save-excursion (beginning-of-line) (let ((start (point)) - (else nil) - (end nil)) - ;; Part one. Look for either #endif or #else. + (elif nil) + (else nil) + (end nil)) + ;; Part one. Look for either #elif, #else or #endif. ;; This loop-and-a-half dedicated to E. Dijkstra. - (while (progn - (hif-find-next-relevant) - (hif-looking-at-ifX)) ; Skip nested ifdef - (hif-ifdef-to-endif)) - ;; Found either a #else or an #endif. - (cond ((hif-looking-at-else) - (setq else (point))) - (t - (setq end (point)))) ; (line-end-position) + (while (and (not else) (not end)) + (while (progn + (hif-find-next-relevant) + (hif-looking-at-ifX)) ; Skip nested ifdef + (hif-ifdef-to-endif)) + ;; Found either a #else, #elif, or an #endif. + (cond ((hif-looking-at-elif) + (setq elif (nconc elif (list (point))))) + ((hif-looking-at-else) + (setq else (point))) + (t + (setq end (point))))) ;; If found #else, look for #endif. (when else - (while (progn - (hif-find-next-relevant) - (hif-looking-at-ifX)) ; Skip nested ifdef - (hif-ifdef-to-endif)) - (if (hif-looking-at-else) - (error "Found two elses in a row? Broken!")) - (setq end (point))) ; (line-end-position) - (hif-make-range start end else)))) + (while (progn + (hif-find-next-relevant) + (hif-looking-at-ifX)) ; Skip nested ifdef + (hif-ifdef-to-endif)) + (if (hif-looking-at-else) + (error "Found two elses in a row? Broken!")) + (setq end (point))) ; (line-end-position) + (hif-make-range start end else elif)))) -;;; A bit slimy. +;; A bit slimy. (defun hif-hide-line (point) - "Hide the line containing point. Does nothing if `hide-ifdef-lines' is nil." + "Hide the line containing point. +Does nothing if `hide-ifdef-lines' is nil." (when hide-ifdef-lines (save-excursion (goto-char point) @@ -961,80 +1457,323 @@ Point is left unchanged." (line-beginning-position) (progn (hif-end-of-line) (point)))))) -;;; Hif-Possibly-Hide -;;; There are four cases. The #ifX expression is "taken" if it -;;; the hide-ifdef-evaluator returns T. Presumably, this means the code -;;; inside the #ifdef would be included when the program was -;;; compiled. -;;; -;;; Case 1: #ifX taken, and there's an #else. -;;; The #else part must be hidden. The #if (then) part must be -;;; processed for nested #ifX's. -;;; Case 2: #ifX taken, and there's no #else. -;;; The #if part must be processed for nested #ifX's. -;;; Case 3: #ifX not taken, and there's an #else. -;;; The #if part must be hidden. The #else part must be processed -;;; for nested #ifs. -;;; Case 4: #ifX not taken, and there's no #else. -;;; The #ifX part must be hidden. -;;; -;;; Further processing is done by narrowing to the relevant region -;;; and just recursively calling hide-ifdef-guts. -;;; -;;; When hif-possibly-hide returns, point is at the end of the -;;; possibly-hidden range. - -(defun hif-recurse-on (start end) +;; Hif-Possibly-Hide +;; There are four cases. The #ifX expression is "taken" if it +;; the hide-ifdef-evaluator returns T. Presumably, this means the code +;; inside the #ifdef would be included when the program was +;; compiled. +;; +;; Case 1: #ifX taken, and there's an #else. +;; The #else part must be hidden. The #if (then) part must be +;; processed for nested #ifX's. +;; Case 2: #ifX taken, and there's no #else. +;; The #if part must be processed for nested #ifX's. +;; Case 3: #ifX not taken, and there's an #elif +;; The #if part must be hidden, and then evaluate +;; the #elif condition like a new #ifX. +;; Case 4: #ifX not taken, and there's just an #else. +;; The #if part must be hidden. The #else part must be processed +;; for nested #ifs. +;; Case 5: #ifX not taken, and there's no #else. +;; The #ifX part must be hidden. +;; +;; Further processing is done by narrowing to the relevant region +;; and just recursively calling hide-ifdef-guts. +;; +;; When hif-possibly-hide returns, point is at the end of the +;; possibly-hidden range. + +(defvar hif-recurse-level 0) + +(defun hif-recurse-on (start end &optional dont-go-eol) "Call `hide-ifdef-guts' after narrowing to end of START line and END line." (save-excursion (save-restriction (goto-char start) - (end-of-line) + (unless dont-go-eol + (end-of-line)) (narrow-to-region (point) end) - (hide-ifdef-guts)))) + (let ((hif-recurse-level (1+ hif-recurse-level))) + (hide-ifdef-guts))))) -(defun hif-possibly-hide () +(defun hif-possibly-hide (expand-reinclusion) "Called at #ifX expression, this hides those parts that should be hidden. -It uses the judgment of `hide-ifdef-evaluator'." +It uses the judgment of `hide-ifdef-evaluator'. EXPAND-REINCLUSION is a flag +indicating that we should expand the #ifdef even if it should be hidden. +Refer to `hide-ifdef-expand-reinclusion-protection' for more details." ;; (message "hif-possibly-hide") (sit-for 1) - (let ((test (hif-canonicalize)) - (range (hif-find-range))) + (let* ((case-fold-search nil) + (test (hif-canonicalize hif-ifx-regexp)) + (range (hif-find-range)) + (elifs (hif-range-elif range)) + (if-part t) ; Everytime we start from if-part + (complete nil)) ;; (message "test = %s" test) (sit-for 1) (hif-hide-line (hif-range-end range)) - (if (not (hif-not (funcall hide-ifdef-evaluator test))) - (cond ((hif-range-else range) ; case 1 - (hif-hide-line (hif-range-else range)) - (hide-ifdef-region (hif-range-else range) - (1- (hif-range-end range))) - (hif-recurse-on (hif-range-start range) - (hif-range-else range))) - (t ; case 2 - (hif-recurse-on (hif-range-start range) - (hif-range-end range)))) - (cond ((hif-range-else range) ; case 3 - (hif-hide-line (hif-range-else range)) - (hide-ifdef-region (hif-range-start range) - (1- (hif-range-else range))) - (hif-recurse-on (hif-range-else range) - (hif-range-end range))) - (t ; case 4 - (hide-ifdef-region (point) - (1- (hif-range-end range)))))) + (while (not complete) + (if (and (not (and expand-reinclusion if-part)) + (hif-not (funcall hide-ifdef-evaluator test))) + ;; ifX/elif is FALSE + (if elifs + ;; Case 3 - Hide the #ifX and eval #elif + (let ((newstart (car elifs))) + (hif-hide-line (hif-range-start range)) + (hide-ifdef-region (hif-range-start range) + (1- newstart)) + (setcar range newstart) + (goto-char newstart) + (setq elifs (cdr elifs)) + (setq test (hif-canonicalize hif-elif-regexp))) + + ;; Check for #else + (cond ((hif-range-else range) + ;; Case 4 - #else block visible + (hif-hide-line (hif-range-else range)) + (hide-ifdef-region (hif-range-start range) + (1- (hif-range-else range))) + (hif-recurse-on (hif-range-else range) + (hif-range-end range))) + (t + ;; Case 5 - No #else block, hide #ifX + (hide-ifdef-region (point) + (1- (hif-range-end range))))) + (setq complete t)) + + ;; ifX/elif is TRUE + (cond (elifs + ;; Luke fix: distinguish from #elif..#elif to #elif..#else + (let ((elif (car elifs))) + ;; hide all elifs + (hif-hide-line elif) + (hide-ifdef-region elif (1- (hif-range-end range))) + (hif-recurse-on (hif-range-start range) + elif))) + ((hif-range-else range) + ;; Case 1 - Hide #elif and #else blocks, recurse #ifX + (hif-hide-line (hif-range-else range)) + (hide-ifdef-region (hif-range-else range) + (1- (hif-range-end range))) + (hif-recurse-on (hif-range-start range) + (hif-range-else range))) + (t + ;; Case 2 - No #else, just recurse #ifX + (hif-recurse-on (hif-range-start range) + (hif-range-end range)))) + (setq complete t)) + (setq if-part nil)) + + ;; complete = t (hif-hide-line (hif-range-start range)) ; Always hide start. (goto-char (hif-range-end range)) (end-of-line))) +(defun hif-evaluate-region (start end) + (let* ((tokens (ignore-errors ; Prevent C statement things like + ; 'do { ... } while (0)' + (hif-tokenize start end))) + (expr (and tokens + (condition-case nil + (hif-parse-exp tokens) + (error + tokens)))) + (result (funcall hide-ifdef-evaluator expr))) + result)) +(defun hif-evaluate-macro (rstart rend) + "Evaluate the macro expansion result for a region. +If no region active, find the current #ifdefs and evaluate the result. +Currently it supports only math calculations, strings or argumented macros can +not be expanded." + (interactive "r") + (let ((case-fold-search nil)) + (save-excursion + (unless mark-active + (setq rstart nil rend nil) + (beginning-of-line) + (when (and (re-search-forward hif-macro-expr-prefix-regexp nil t) + (string= "define" (match-string 2))) + (re-search-forward hif-macroref-regexp nil t))) + (let* ((start (or rstart (point))) + (end (or rend (progn (hif-end-of-line) (point)))) + (defined nil) + (simple 't) + (tokens (ignore-errors ; Prevent C statement things like + ; 'do { ... } while (0)' + (hif-tokenize start end))) + (expr (or (and (<= (length tokens) 1) ; Simple token + (setq defined (assoc (car tokens) hide-ifdef-env)) + (setq simple (atom (hif-lookup (car tokens)))) + (hif-lookup (car tokens))) + (and tokens + (condition-case nil + (hif-parse-exp tokens) + (error + nil))))) + (result (funcall hide-ifdef-evaluator expr)) + (exprstring (replace-regexp-in-string + ;; Trim off leading/trailing whites + "^[ \t]*\\([^ \t]+\\)[ \t]*" "\\1" + (replace-regexp-in-string + "\\(//.*\\)" "" ; Trim off end-of-line comments + (buffer-substring-no-properties start end))))) + (cond + ((and (<= (length tokens) 1) simple) ; Simple token + (if defined + (message "%S <= `%s'" result exprstring) + (message "`%s' is not defined" exprstring))) + ((integerp result) + (if (or (= 0 result) (= 1 result)) + (message "%S <= `%s'" result exprstring) + (message "%S (0x%x) <= `%s'" result result exprstring))) + ((null result) (message "%S <= `%s'" 'false exprstring)) + ((eq t result) (message "%S <= `%s'" 'true exprstring)) + (t (message "%S <= `%s'" result exprstring))) + result)))) + +(defun hif-parse-macro-arglist (str) + "Parse argument list formatted as '( arg1 [ , argn] [...] )'. +The '...' is also included. Return a list of the arguments, if '...' exists the +first arg will be `hif-etc'." + (let* ((hif-simple-token-only nil) ; Dynamic binding var for `hif-tokenize' + (tokenlist + (cdr (hif-tokenize + (- (point) (length str)) (point)))) ; Remove `hif-lparen' + etc result token) + (while (not (eq (setq token (pop tokenlist)) 'hif-rparen)) + (cond + ((eq token 'hif-etc) + (setq etc t)) + ((eq token 'hif-comma) + t) + (t + (push token result)))) + (if etc + (cons 'hif-etc (nreverse result)) + (nreverse result)))) + +;; The original version of hideif evaluates the macro early and store the +;; final values for the defined macro into the symbol database (aka +;; `hide-ifdef-env'). The evaluation process is "strings -> tokens -> parsed +;; tree -> [value]". (The square bracket refers to what's stored in in our +;; `hide-ifdef-env'.) +;; +;; This forbids the evaluation of an argumented macro since the parameters +;; are applied at run time. In order to support argumented macro I then +;; postponed the evaluation process one stage and store the "parsed tree" +;; into symbol database. The evaluation process was then "strings -> tokens +;; -> [parsed tree] -> value". Hideif therefore run slower since it need to +;; evaluate the parsed tree everytime when trying to expand the symbol. These +;; temporarily code changes are obsolete and not in Emacs source repository. +;; +;; Furthermore, CPP did allow partial expression to be defined in several +;; macros and later got concatenated into a complete expression and then +;; evaluate it. In order to match this behavior I had to postpone one stage +;; further, otherwise those partial expression will be fail on parsing and +;; we'll miss all macros that reference it. The evaluation process thus +;; became "strings -> [tokens] -> parsed tree -> value." This degraded the +;; performance since we need to parse tokens and evaluate them everytime +;; when that symbol is referenced. +;; +;; In real cases I found a lot portion of macros are "simple macros" that +;; expand to literals like integers or other symbols. In order to enhance +;; the performance I use this `hif-simple-token-only' to notify my code and +;; save the final [value] into symbol database. [lukelee] + +(defun hif-find-define (&optional min max) + "Parse texts and retrieve all defines within the region MIN and MAX." + (interactive) + (and min (goto-char min)) + (and (re-search-forward hif-define-regexp max t) + (or + (let* ((defining (string= "define" (match-string 2))) + (name (and (re-search-forward hif-macroref-regexp max t) + (match-string 1))) + (parmlist (and (match-string 3) ; First arg id found + (hif-parse-macro-arglist (match-string 2))))) + (if defining + ;; Ignore name (still need to return 't), or define the name + (or (and hide-ifdef-exclude-define-regexp + (string-match hide-ifdef-exclude-define-regexp + name)) + + (let* ((start (point)) + (end (progn (hif-end-of-line) (point))) + (hif-simple-token-only nil) ; Dynamic binding + (tokens + (and name + ;; `hif-simple-token-only' is set/clear + ;; only in this block + (condition-case nil + ;; Prevent C statements like + ;; 'do { ... } while (0)' + (hif-tokenize start end) + (error + ;; We can't just return nil here since + ;; this will stop hideif from searching + ;; for more #defines. + (setq hif-simple-token-only t) + (buffer-substring-no-properties + start end))))) + ;; For simple tokens we save only the parsed result; + ;; otherwise we save the tokens and parse it after + ;; parameter replacement + (expr (and tokens + ;; `hif-simple-token-only' is checked only + ;; here. + (or (and hif-simple-token-only + (listp tokens) + (= (length tokens) 1) + (hif-parse-exp tokens)) + `(hif-define-macro ,parmlist + ,tokens)))) + (SA (and name + (assoc (intern name) hide-ifdef-env)))) + (and name + (if SA + (or (setcdr SA expr) t) + ;; Lazy evaluation, eval only if hif-lookup find it. + ;; Define it anyway, even if nil it's still in list + ;; and therefore considered defined. + (push (cons (intern name) expr) hide-ifdef-env))))) + ;; #undef + (and name + (hif-undefine-symbol (intern name)))))) + t)) + + +(defun hif-add-new-defines (&optional min max) + "Scan and add all #define macros between MIN and MAX." + (interactive) + (save-excursion + (save-restriction + ;; (mark-region min max) ;; for debugging + (while (hif-find-define min max) + (setf min (point))) + (if max (goto-char max) + (goto-char (point-max)))))) (defun hide-ifdef-guts () "Does most of the work of `hide-ifdefs'. It does not do the work that's pointless to redo on a recursive entry." ;; (message "hide-ifdef-guts") (save-excursion - (goto-char (point-min)) - (while (hif-find-any-ifX) - (hif-possibly-hide)))) + (let* ((case-fold-search t) ; Ignore case for `hide-ifdef-header-regexp' + (expand-header (and hide-ifdef-expand-reinclusion-protection + (string-match hide-ifdef-header-regexp + (buffer-file-name)) + (zerop hif-recurse-level))) + (case-fold-search nil) + min max) + (goto-char (point-min)) + (setf min (point)) + (cl-loop do + (setf max (hif-find-any-ifX)) + (hif-add-new-defines min max) + (if max + (hif-possibly-hide expand-header)) + (setf min (point)) + while max)))) ;;===%%SF%% hide-ifdef-hiding (End) === @@ -1048,7 +1787,8 @@ It does not do the work that's pointless to redo on a recursive entry." (message "Hide-Read-Only %s" (if hide-ifdef-read-only "ON" "OFF")) (if hide-ifdef-hiding - (setq buffer-read-only (or hide-ifdef-read-only hif-outside-read-only))) + (setq buffer-read-only (or hide-ifdef-read-only + hif-outside-read-only))) (force-mode-line-update)) (defun hide-ifdef-toggle-outside-read-only () @@ -1078,38 +1818,67 @@ It does not do the work that's pointless to redo on a recursive entry." (overlay-put overlay 'face nil) (overlay-put overlay 'invisible 'hide-ifdef)))))) -(defun hide-ifdef-define (var) - "Define a VAR so that #ifdef VAR would be included." - (interactive "SDefine what? ") - (hif-set-var var 1) +(defun hide-ifdef-define (var &optional val) + "Define a VAR to VAL (default 1) in `hide-ifdef-env'. +This allows #ifdef VAR to be hidden." + (interactive + (let* ((default (save-excursion + (beginning-of-line) + (cond ((looking-at hif-ifx-else-endif-regexp) + (forward-word 2) + (current-word 'strict)) + (t + nil)))) + (var (read-minibuffer "Define what? " default)) + (val (read-from-minibuffer (format "Set %s to? (default 1): " var) + nil nil t nil "1"))) + (list var val))) + (hif-set-var var (or val 1)) + (message "%s set to %s" var (or val 1)) + (sleep-for 1) (if hide-ifdef-hiding (hide-ifdefs))) -(defun hide-ifdef-undef (var) - "Undefine a VAR so that #ifdef VAR would not be included." - (interactive "SUndefine what? ") - (hif-set-var var nil) - (if hide-ifdef-hiding (hide-ifdefs))) +(defun hif-undefine-symbol (var) + (setq hide-ifdef-env + (delete (assoc var hide-ifdef-env) hide-ifdef-env))) +(defun hide-ifdef-undef (start end) + "Undefine a VAR so that #ifdef VAR would not be included." + (interactive "r") + (let* ((symstr + (or (and mark-active + (buffer-substring-no-properties start end)) + (read-string "Undefine what? " (current-word)))) + (sym (and symstr + (intern symstr)))) + (if (zerop (hif-defined sym)) + (message "`%s' not defined, no need to undefine it" symstr) + (hif-undefine-symbol sym) + (if hide-ifdef-hiding (hide-ifdefs)) + (message "`%S' undefined" sym)))) (defun hide-ifdefs (&optional nomsg) "Hide the contents of some #ifdefs. Assume that defined symbols have been added to `hide-ifdef-env'. The text hidden is the text that would not be included by the C preprocessor if it were given the file with those symbols defined. +With prefix command presents it will also hide the #ifdefs themselves. Turn off hiding by calling `show-ifdefs'." (interactive) - (message "Hiding...") - (setq hif-outside-read-only buffer-read-only) - (unless hide-ifdef-mode (hide-ifdef-mode 1)) ; turn on hide-ifdef-mode - (if hide-ifdef-hiding - (show-ifdefs)) ; Otherwise, deep confusion. - (setq hide-ifdef-hiding t) - (hide-ifdef-guts) - (setq buffer-read-only (or hide-ifdef-read-only hif-outside-read-only)) - (or nomsg - (message "Hiding done"))) + (let ((hide-ifdef-lines current-prefix-arg)) + (or nomsg + (message "Hiding...")) + (setq hif-outside-read-only buffer-read-only) + (unless hide-ifdef-mode (hide-ifdef-mode 1)) ; Turn on hide-ifdef-mode + (if hide-ifdef-hiding + (show-ifdefs)) ; Otherwise, deep confusion. + (setq hide-ifdef-hiding t) + (hide-ifdef-guts) + (setq buffer-read-only (or hide-ifdef-read-only hif-outside-read-only)) + (or nomsg + (message "Hiding done")))) (defun show-ifdefs () @@ -1125,46 +1894,74 @@ Turn off hiding by calling `show-ifdefs'." Return as (TOP . BOTTOM) the extent of ifdef block." (let (max-bottom) (cons (save-excursion - (beginning-of-line) - (unless (or (hif-looking-at-else) (hif-looking-at-ifX)) - (up-ifdef)) - (prog1 (point) - (hif-ifdef-to-endif) - (setq max-bottom (1- (point))))) - (save-excursion - (beginning-of-line) - (unless (hif-looking-at-endif) - (hif-find-next-relevant)) - (while (hif-looking-at-ifX) - (hif-ifdef-to-endif) - (hif-find-next-relevant)) - (min max-bottom (1- (point))))))) - - -(defun hide-ifdef-block () - "Hide the ifdef block (true or false part) enclosing or before the cursor." - (interactive) - (unless hide-ifdef-mode (hide-ifdef-mode 1)) - (let ((top-bottom (hif-find-ifdef-block))) - (hide-ifdef-region (car top-bottom) (cdr top-bottom)) - (when hide-ifdef-lines - (hif-hide-line (car top-bottom)) - (hif-hide-line (1+ (cdr top-bottom)))) - (setq hide-ifdef-hiding t)) - (setq buffer-read-only (or hide-ifdef-read-only hif-outside-read-only))) - -(defun show-ifdef-block () + (beginning-of-line) + (unless (or (hif-looking-at-else) (hif-looking-at-ifX)) + (up-ifdef)) + (prog1 (point) + (hif-ifdef-to-endif) + (setq max-bottom (1- (point))))) + (save-excursion + (beginning-of-line) + (unless (hif-looking-at-endif) + (hif-find-next-relevant)) + (while (hif-looking-at-ifX) + (hif-ifdef-to-endif) + (hif-find-next-relevant)) + (min max-bottom (1- (point))))))) + + +(defun hide-ifdef-block (&optional arg start end) + "Hide the ifdef block (true or false part) enclosing or before the cursor. +With optional prefix argument ARG, also hide the #ifdefs themselves." + (interactive "P\nr") + (let ((hide-ifdef-lines arg)) + (if mark-active + (let ((hif-recurse-level (1+ hif-recurse-level))) + (hif-recurse-on start end t) + (setq mark-active nil)) + (unless hide-ifdef-mode (hide-ifdef-mode 1)) + (let ((top-bottom (hif-find-ifdef-block))) + (hide-ifdef-region (car top-bottom) (cdr top-bottom)) + (when hide-ifdef-lines + (hif-hide-line (car top-bottom)) + (hif-hide-line (1+ (cdr top-bottom)))) + (setq hide-ifdef-hiding t)) + (setq buffer-read-only + (or hide-ifdef-read-only hif-outside-read-only))))) + +(defun show-ifdef-block (&optional start end) "Show the ifdef block (true or false part) enclosing or before the cursor." - (interactive) - (let ((top-bottom (hif-find-ifdef-block))) + (interactive "r") + (if mark-active + (progn + (dolist (o (overlays-in start end)) + (if (overlay-get o 'hide-ifdef) + (delete-overlay o))) + (setq mark-active nil)) + (let ((top-bottom (condition-case nil + (hif-find-ifdef-block) + (error + nil))) + (ovrs (overlays-in (max (point-min) (1- (point))) + (min (point-max) (1+ (point))))) + (del nil)) + (if top-bottom (if hide-ifdef-lines - (hif-show-ifdef-region - (save-excursion - (goto-char (car top-bottom)) (line-beginning-position)) - (save-excursion - (goto-char (1+ (cdr top-bottom))) - (hif-end-of-line) (point))) - (hif-show-ifdef-region (1- (car top-bottom)) (cdr top-bottom))))) + (hif-show-ifdef-region + (save-excursion + (goto-char (car top-bottom)) (line-beginning-position)) + (save-excursion + (goto-char (1+ (cdr top-bottom))) + (hif-end-of-line) (point))) + (setf del (hif-show-ifdef-region + (1- (car top-bottom)) (cdr top-bottom))))) + (if (not (and top-bottom + del)) + (dolist (o ovrs) + ;;(dolist (o (overlays-in (1- (point)) (1+ (point)))) + ;; (if (overlay-get o 'hide-ifdef) (message "%S" o))) + (if (overlay-get o 'hide-ifdef) + (delete-overlay o))))))) ;;; definition alist support diff --git a/lisp/progmodes/hideshow.el b/lisp/progmodes/hideshow.el index e9349b655b0..a016c3283eb 100644 --- a/lisp/progmodes/hideshow.el +++ b/lisp/progmodes/hideshow.el @@ -390,37 +390,31 @@ Use the command `hs-minor-mode' to toggle or set this variable.") :help "Do not hidden code or comment blocks when isearch matches inside them" :active t :style radio :selected (eq hs-isearch-open nil)]))) -(defvar hs-c-start-regexp nil +(defvar-local hs-c-start-regexp nil "Regexp for beginning of comments. Differs from mode-specific comment regexps in that surrounding whitespace is stripped.") -(make-variable-buffer-local 'hs-c-start-regexp) -(defvar hs-block-start-regexp nil +(defvar-local hs-block-start-regexp nil "Regexp for beginning of block.") -(make-variable-buffer-local 'hs-block-start-regexp) -(defvar hs-block-start-mdata-select nil +(defvar-local hs-block-start-mdata-select nil "Element in `hs-block-start-regexp' match data to consider as block start. The internal function `hs-forward-sexp' moves point to the beginning of this element (using `match-beginning') before calling `hs-forward-sexp-func'.") -(make-variable-buffer-local 'hs-block-start-mdata-select) -(defvar hs-block-end-regexp nil +(defvar-local hs-block-end-regexp nil "Regexp for end of block.") -(make-variable-buffer-local 'hs-block-end-regexp) - -(defvar hs-forward-sexp-func 'forward-sexp +(defvar-local hs-forward-sexp-func 'forward-sexp "Function used to do a `forward-sexp'. Should change for Algol-ish modes. For single-character block delimiters -- ie, the syntax table regexp for the character is either `(' or `)' -- `hs-forward-sexp-func' would just be `forward-sexp'. For other modes such as simula, a more specialized function is necessary.") -(make-variable-buffer-local 'hs-forward-sexp-func) -(defvar hs-adjust-block-beginning nil +(defvar-local hs-adjust-block-beginning nil "Function used to tweak the block beginning. The block is hidden from the position returned by this function, as opposed to hiding it from the position returned when searching @@ -439,7 +433,6 @@ It should return the position from where we should start hiding. It should not move the point. See `hs-c-like-adjust-block-beginning' for an example of using this.") -(make-variable-buffer-local 'hs-adjust-block-beginning) (defvar hs-headline nil "Text of the line where a hidden block begins, set during isearch. @@ -789,6 +782,7 @@ If `hs-hide-comments-when-hiding-all' is non-nil, also hide the comments." (unless hs-allow-nesting (hs-discard-overlays (point-min) (point-max))) (goto-char (point-min)) + (syntax-propertize (point-max)) (let ((spew (make-progress-reporter "Hiding all blocks..." (point-min) (point-max))) (re (concat "\\(" diff --git a/lisp/progmodes/idlw-help.el b/lisp/progmodes/idlw-help.el index cd17600182f..3d42fe231bd 100644 --- a/lisp/progmodes/idlw-help.el +++ b/lisp/progmodes/idlw-help.el @@ -1177,15 +1177,13 @@ Useful when source code is displayed as help. See the option (if (featurep 'font-lock) (let ((major-mode 'idlwave-mode) (font-lock-verbose - (if (called-interactively-p 'interactive) font-lock-verbose nil)) - (syntax-table (syntax-table))) - (unwind-protect - (progn - (set-syntax-table idlwave-mode-syntax-table) - (set (make-local-variable 'font-lock-defaults) - idlwave-font-lock-defaults) - (font-lock-fontify-buffer)) - (set-syntax-table syntax-table))))) + (if (called-interactively-p 'interactive) font-lock-verbose nil))) + (with-syntax-table idlwave-mode-syntax-table + (set (make-local-variable 'font-lock-defaults) + idlwave-font-lock-defaults) + (if (fboundp 'font-lock-ensure) + (font-lock-ensure) + (font-lock-fontify-buffer)))))) (defun idlwave-help-error (name type class keyword) diff --git a/lisp/progmodes/idlw-shell.el b/lisp/progmodes/idlw-shell.el index 5d43edc2fc8..876695b0809 100644 --- a/lisp/progmodes/idlw-shell.el +++ b/lisp/progmodes/idlw-shell.el @@ -590,27 +590,28 @@ TYPE is either 'pro' or 'rinfo', and `idlwave-shell-temp-pro-file' or (defun idlwave-shell-make-temp-file (prefix) "Create a temporary file." - ; Hard coded make-temp-file for Emacs<21 - (if (fboundp 'make-temp-file) + (if (featurep 'emacs) (make-temp-file prefix) - (let (file - (temp-file-dir (if (boundp 'temporary-file-directory) - temporary-file-directory - "/tmp"))) - (while (condition-case () - (progn - (setq file - (make-temp-name - (expand-file-name prefix temp-file-dir))) - (if (featurep 'xemacs) - (write-region "" nil file nil 'silent nil) - (write-region "" nil file nil 'silent nil 'excl)) - nil) - (file-already-exists t)) - ;; the file was somehow created by someone else between - ;; `make-temp-name' and `write-region', let's try again. - nil) - file))) + (if (fboundp 'make-temp-file) + (make-temp-file prefix) + (let (file + (temp-file-dir (if (boundp 'temporary-file-directory) + temporary-file-directory + "/tmp"))) + (while (condition-case () + (progn + (setq file + (make-temp-name + (expand-file-name prefix temp-file-dir))) + (if (featurep 'xemacs) + (write-region "" nil file nil 'silent nil) + (write-region "" nil file nil 'silent nil 'excl)) + nil) + (file-already-exists t)) + ;; the file was somehow created by someone else between + ;; `make-temp-name' and `write-region', let's try again. + nil) + file)))) (defvar idlwave-shell-dirstack-query "cd,current=___cur & print,___cur" diff --git a/lisp/progmodes/idlwave.el b/lisp/progmodes/idlwave.el index e66c9655df1..7502a491806 100644 --- a/lisp/progmodes/idlwave.el +++ b/lisp/progmodes/idlwave.el @@ -3713,7 +3713,7 @@ expression to enter. The lines containing S1 and S2 are reindented using `indent-region' unless the optional second argument NOINDENT is non-nil." (if (derived-mode-p 'idlwave-shell-mode) - ;; This is a gross hack to avoit template abbrev expansion + ;; This is a gross hack to avoid template abbrev expansion ;; in the shell. FIXME: This is a dirty hack. (if (and (eq this-command 'self-insert-command) (equal last-abbrev-location (point))) diff --git a/lisp/progmodes/inf-lisp.el b/lisp/progmodes/inf-lisp.el index 5419a6dbdb8..ba64ae31844 100644 --- a/lisp/progmodes/inf-lisp.el +++ b/lisp/progmodes/inf-lisp.el @@ -112,6 +112,8 @@ mode. Default is whitespace followed by 0 or 1 single-letter colon-keyword (define-key lisp-mode-map "\C-x\C-e" 'lisp-eval-last-sexp) ; Gnu convention (define-key lisp-mode-map "\C-c\C-e" 'lisp-eval-defun) (define-key lisp-mode-map "\C-c\C-r" 'lisp-eval-region) +(define-key lisp-mode-map "\C-c\C-n" 'lisp-eval-form-and-next) +(define-key lisp-mode-map "\C-c\C-p" 'lisp-eval-paragraph) (define-key lisp-mode-map "\C-c\C-c" 'lisp-compile-defun) (define-key lisp-mode-map "\C-c\C-z" 'switch-to-lisp) (define-key lisp-mode-map "\C-c\C-l" 'lisp-load-file) @@ -311,6 +313,14 @@ of `inferior-lisp-program'). Runs the hooks from ;;;###autoload (defalias 'run-lisp 'inferior-lisp) +(defun lisp-eval-paragraph (&optional and-go) + "Send the current paragraph to the inferior Lisp process. +Prefix argument means switch to the Lisp buffer afterwards." + (interactive "P") + (save-excursion + (mark-paragraph) + (lisp-eval-region (point) (mark) and-go))) + (defun lisp-eval-region (start end &optional and-go) "Send the current region to the inferior Lisp process. Prefix argument means switch to the Lisp buffer afterwards." @@ -361,6 +371,14 @@ Prefix argument means switch to the Lisp buffer afterwards." (interactive "P") (lisp-eval-region (save-excursion (backward-sexp) (point)) (point) and-go)) +(defun lisp-eval-form-and-next () + "Send the previous sexp to the inferior Lisp process and move to the next one." + (interactive "") + (while (not (zerop (car (syntax-ppss)))) + (up-list)) + (lisp-eval-last-sexp) + (forward-sexp)) + (defun lisp-compile-region (start end &optional and-go) "Compile the current region in the inferior Lisp process. Prefix argument means switch to the Lisp buffer afterwards." diff --git a/lisp/progmodes/js.el b/lisp/progmodes/js.el index 0d81a0a22ae..f6a9440610e 100644 --- a/lisp/progmodes/js.el +++ b/lisp/progmodes/js.el @@ -1637,12 +1637,29 @@ This performs fontification according to `js--class-styles'." js--font-lock-keywords-3) "Font lock keywords for `js-mode'. See `font-lock-keywords'.") +(defconst js--syntax-propertize-regexp-syntax-table + (let ((st (make-char-table 'syntax-table (string-to-syntax ".")))) + (modify-syntax-entry ?\[ "(]" st) + (modify-syntax-entry ?\] ")[" st) + (modify-syntax-entry ?\\ "\\" st) + st)) + (defun js-syntax-propertize-regexp (end) - (when (eq (nth 3 (syntax-ppss)) ?/) - ;; A /.../ regexp. - (when (re-search-forward "\\(?:\\=\\|[^\\]\\)\\(?:\\\\\\\\\\)*/" end 'move) - (put-text-property (1- (point)) (point) - 'syntax-table (string-to-syntax "\"/"))))) + (let ((ppss (syntax-ppss))) + (when (eq (nth 3 ppss) ?/) + ;; A /.../ regexp. + (while + (when (re-search-forward "\\(?:\\=\\|[^\\]\\)\\(?:\\\\\\\\\\)*/" + end 'move) + (if (nth 1 (with-syntax-table + js--syntax-propertize-regexp-syntax-table + (let ((parse-sexp-lookup-properties nil)) + (parse-partial-sexp (nth 8 ppss) (point))))) + ;; A / within a character class is not the end of a regexp. + t + (put-text-property (1- (point)) (point) + 'syntax-table (string-to-syntax "\"/")) + nil)))))) (defun js-syntax-propertize (start end) ;; Javascript allows immediate regular expression objects, written /.../. @@ -3479,6 +3496,10 @@ If one hasn't been set, or if it's stale, prompt for a new one." '(when (fboundp 'folding-add-to-marks-list) (folding-add-to-marks-list 'js-mode "// {{{" "// }}}" ))) +;;;###autoload +(dolist (name (list "node" "nodejs" "gjs" "rhino")) + (add-to-list 'interpreter-mode-alist (cons (purecopy name) 'js-mode))) + (provide 'js) ;; js.el ends here diff --git a/lisp/progmodes/m4-mode.el b/lisp/progmodes/m4-mode.el index b795b35a8ea..573acf4445d 100644 --- a/lisp/progmodes/m4-mode.el +++ b/lisp/progmodes/m4-mode.el @@ -65,14 +65,13 @@ If m4 is not in your PATH, set this to an absolute file name." (defvar m4-font-lock-keywords `( - ("\\(\\b\\(m4_\\)?dnl\\b\\|^\\#\\).*$" . font-lock-comment-face) -; ("\\(\\bdnl\\b\\|\\bm4_dnl\\b\\|^\\#\\).*$" . font-lock-comment-face) + ("\\(\\_<\\(m4_\\)?dnl\\_>\\).*$" . font-lock-comment-face) ("\\$[*#@0-9]" . font-lock-variable-name-face) ("\\\$\\\@" . font-lock-variable-name-face) ("\\\$\\\*" . font-lock-variable-name-face) ("\\b\\(builtin\\|change\\(com\\|quote\\|word\\)\\|d\\(e\\(bug\\(file\\|mode\\)\\|cr\\|f\\(ine\\|n\\)\\)\\|iv\\(ert\\|num\\)\\|nl\\|umpdef\\)\\|e\\(rrprint\\|syscmd\\|val\\)\\|f\\(ile\\|ormat\\)\\|gnu\\|i\\(f\\(def\\|else\\)\\|n\\(c\\(lude\\|r\\)\\|d\\(ex\\|ir\\)\\)\\)\\|l\\(en\\|ine\\)\\|m\\(4\\(exit\\|wrap\\)\\|aketemp\\)\\|p\\(atsubst\\|opdef\\|ushdef\\)\\|regexp\\|s\\(hift\\|include\\|ubstr\\|ys\\(cmd\\|val\\)\\)\\|tra\\(ceo\\(ff\\|n\\)\\|nslit\\)\\|un\\(d\\(efine\\|ivert\\)\\|ix\\)\\)\\b" . font-lock-keyword-face) ("\\b\\(m4_\\(builtin\\|change\\(com\\|quote\\|word\\)\\|d\\(e\\(bug\\(file\\|mode\\)\\|cr\\|f\\(ine\\|n\\)\\)\\|iv\\(ert\\|num\\)\\|nl\\|umpdef\\)\\|e\\(rrprint\\|syscmd\\|val\\)\\|f\\(ile\\|ormat\\)\\|i\\(f\\(def\\|else\\)\\|n\\(c\\(lude\\|r\\)\\|d\\(ex\\|ir\\)\\)\\)\\|l\\(en\\|ine\\)\\|m\\(4\\(_undefine\\|exit\\|wrap\\)\\|aketemp\\)\\|p\\(atsubst\\|opdef\\|ushdef\\)\\|regexp\\|s\\(hift\\|include\\|ubstr\\|ys\\(cmd\\|val\\)\\)\\|tra\\(ceo\\(ff\\|n\\)\\|nslit\\)\\|undivert\\)\\)\\b" . font-lock-keyword-face)) - "Default font-lock-keywords for `m4 mode'.") + "Default `font-lock-keywords' for M4 mode.") (defcustom m4-mode-hook nil "Hook called by `m4-mode'." @@ -86,19 +85,26 @@ If m4 is not in your PATH, set this to an absolute file name." (modify-syntax-entry ?' ")`" table) (modify-syntax-entry ?# "<\n" table) (modify-syntax-entry ?\n ">#" table) - (modify-syntax-entry ?{ "_" table) - (modify-syntax-entry ?} "_" table) - ;; FIXME: This symbol syntax for underscore looks OK on its own, but it's - ;; odd that it should have the same syntax as { and } are these really - ;; valid in m4 symbols? + (modify-syntax-entry ?{ "." table) + (modify-syntax-entry ?} "." table) (modify-syntax-entry ?_ "_" table) - ;; FIXME: These three chars with word syntax look wrong. - (modify-syntax-entry ?* "w" table) - (modify-syntax-entry ?\" "w" table) - (modify-syntax-entry ?\" "w" table) + (modify-syntax-entry ?* "." table) + (modify-syntax-entry ?\" "." table) table) "Syntax table used while in `m4-mode'.") +(defun m4--quoted-p (pos) + "Return non-nil if POS is inside a quoted string." + (let ((quoted nil)) + (dolist (o (nth 9 (save-excursion (syntax-ppss pos)))) + (if (eq (char-after o) ?\`) (setq quoted t))) + quoted)) + +(defconst m4-syntax-propertize + (syntax-propertize-rules + ("#" (0 (when (m4--quoted-p (match-beginning 0)) + (string-to-syntax ".")))))) + (defvar m4-mode-map (let ((map (make-sparse-keymap)) (menu-map (make-sparse-keymap))) @@ -148,7 +154,8 @@ If m4 is not in your PATH, set this to an absolute file name." (setq-local comment-start "#") (setq-local parse-sexp-ignore-comments t) (setq-local add-log-current-defun-function #'m4-current-defun-name) - (setq font-lock-defaults '(m4-font-lock-keywords nil))) + (setq-local syntax-propertize-function m4-syntax-propertize) + (setq-local font-lock-defaults '(m4-font-lock-keywords nil))) (provide 'm4-mode) ;;stuff to play with for debugging diff --git a/lisp/progmodes/octave.el b/lisp/progmodes/octave.el index 25b081545a3..7d963635bc0 100644 --- a/lisp/progmodes/octave.el +++ b/lisp/progmodes/octave.el @@ -45,13 +45,13 @@ (defun completion-table-with-cache (fun &optional ignore-case) ;; See eg bug#11906. (let* (last-arg last-result - (new-fun - (lambda (arg) - (if (and last-arg (string-prefix-p last-arg arg ignore-case)) - last-result - (prog1 - (setq last-result (funcall fun arg)) - (setq last-arg arg)))))) + (new-fun + (lambda (arg) + (if (and last-arg (string-prefix-p last-arg arg ignore-case)) + last-result + (prog1 + (setq last-result (funcall fun arg)) + (setq last-arg arg)))))) (completion-table-dynamic new-fun))))) (eval-when-compile (unless (fboundp 'setq-local) diff --git a/lisp/progmodes/opascal.el b/lisp/progmodes/opascal.el index fd8e249bbb9..2f3704be6fa 100644 --- a/lisp/progmodes/opascal.el +++ b/lisp/progmodes/opascal.el @@ -1397,7 +1397,7 @@ If before the indent, the point is moved to the indent." (when opascal-debug (opascal-ensure-buffer opascal-debug-buffer "*OPascal Debug Log*") (opascal-log-msg opascal-debug-buffer - (concat (format-time-string "%H:%M:%S " (current-time)) + (concat (format-time-string "%H:%M:%S ") (apply #'format (cons format-string args)) "\n")))) diff --git a/lisp/progmodes/perl-mode.el b/lisp/progmodes/perl-mode.el index ef372a34fdb..b4a96e741b7 100644 --- a/lisp/progmodes/perl-mode.el +++ b/lisp/progmodes/perl-mode.el @@ -66,22 +66,7 @@ ;; a rich language; writing a more suitable parser would be a big job): ;; 2) The globbing syntax <pattern> is not recognized, so special ;; characters in the pattern string must be backslashed. -;; 3) The << quoting operators are not recognized; see below. -;; 5) To make '$' work correctly, $' is not recognized as a variable. -;; Use "$'" or $POSTMATCH instead. ;; -;; If you don't use font-lock, additional problems will appear: -;; 1) Regular expression delimiters do not act as quotes, so special -;; characters such as `'"#:;[](){} may need to be backslashed -;; in regular expressions and in both parts of s/// and tr///. -;; 4) The q and qq quoting operators are not recognized; see below. -;; 5) To make variables such a $' and $#array work, perl-mode treats -;; $ just like backslash, so '$' is not treated correctly. -;; 6) Unfortunately, treating $ like \ makes ${var} be treated as an -;; unmatched }. See below. -;; 7) When ' (quote) is used as a package name separator, perl-mode -;; doesn't understand, and thinks it is seeing a quoted string. - ;; Here are some ugly tricks to bypass some of these problems: the perl ;; expression /`/ (that's a back-tick) usually evaluates harmlessly, ;; but will trick perl-mode into starting a quoted string, which @@ -218,6 +203,13 @@ (defvar perl-quote-like-pairs '((?\( . ?\)) (?\[ . ?\]) (?\{ . ?\}) (?\< . ?\>))) +(eval-and-compile + (defconst perl--syntax-exp-intro-regexp + (concat "\\(?:\\(?:^\\|[^$@&%[:word:]]\\)" + (regexp-opt '("split" "if" "unless" "until" "while" "print" + "grep" "map" "not" "or" "and" "for" "foreach")) + "\\|[-?:.,;|&+*=!~({[]\\|\\(^\\)\\)[ \t\n]*"))) + ;; FIXME: handle here-docs and regexps. ;; <<EOF <<"EOF" <<'EOF' (no space) ;; see `man perlop' @@ -262,7 +254,7 @@ (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:]]*(\\([^)]+\\))" + ("\\<sub\\(?:[\s\t\n]+\\(?:\\sw\\|\\s_\\)+\\)?[\s\t\n]*(\\([^)]+\\))" (1 ".")) ;; Turn __DATA__ trailer into a comment. ("^\\(_\\)_\\(?:DATA\\|END\\)__[ \t]*\\(?:\\(\n\\)#.-\\*-.*perl.*-\\*-\\|\n.*\\)" @@ -278,10 +270,7 @@ ;; *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" "for" "foreach")) - "\\|[-?:.,;|&+*=!~({[]\\|\\(^\\)\\)[ \t\n]*\\(/\\)") + ((concat perl--syntax-exp-intro-regexp "\\(/\\)") (2 (ignore (if (and (match-end 1) ; / at BOL. (save-excursion @@ -316,10 +305,15 @@ (string-to-syntax "\""))) (perl-syntax-propertize-special-constructs end))))) ;; Here documents. - ;; TODO: Handle <<WORD. These are trickier because you need to - ;; disambiguate with the shift operator. - ("<<[ \t]*\\('[^'\n]*'\\|\"[^\"\n]*\"\\|\\\\[[:alpha:]][[:alnum:]]*\\).*\\(\n\\)" - (2 (let* ((st (get-text-property (match-beginning 2) 'syntax-table)) + ((concat + "\\(?:" + ;; << "EOF", << 'EOF', or << \EOF + "<<[ \t]*\\('[^'\n]*'\\|\"[^\"\n]*\"\\|\\\\[[:alpha:]][[:alnum:]]*\\)" + ;; The <<EOF case which needs perl--syntax-exp-intro-regexp, to + ;; disambiguate with the left-bitshift operator. + "\\|" perl--syntax-exp-intro-regexp "<<\\(?1:\\sw+\\)\\)" + ".*\\(\n\\)") + (3 (let* ((st (get-text-property (match-beginning 3) 'syntax-table)) (name (match-string 1))) (goto-char (match-end 1)) (if (save-excursion (nth 8 (syntax-ppss (match-beginning 0)))) @@ -329,7 +323,8 @@ ;; Remember the names of heredocs found on this line. (cons (pcase (aref name 0) (`?\\ (substring name 1)) - (_ (substring name 1 -1))) + ((or `?\" `?\' `?\`) (substring name 1 -1)) + (_ name)) (cdr st))))))) ;; We don't call perl-syntax-propertize-special-constructs directly ;; from the << rule, because there might be other elements (between @@ -753,7 +748,7 @@ following list: (bof (perl-beginning-of-function)) (delta (progn (goto-char oldpnt) - (perl-indent-line "\f\\|;?#" bof)))) + (perl-indent-line "\f\\|;?#")))) (and perl-tab-to-comment (= oldpnt (point)) ; done if point moved (if (listp delta) ; if line starts in a quoted string @@ -791,28 +786,23 @@ following list: (ding t))))))))) (make-obsolete 'perl-indent-command 'indent-according-to-mode "24.4") -(defun perl-indent-line (&optional nochange parse-start) +(defun perl-indent-line (&optional nochange) "Indent current line as Perl code. Return the amount the indentation changed by, or (parse-state) if line starts in a quoted string." (let ((case-fold-search nil) (pos (- (point-max) (point))) - (bof (or parse-start (save-excursion - ;; Don't consider text on this line as a - ;; valid BOF from which to indent. - (goto-char (line-end-position 0)) - (perl-beginning-of-function)))) beg indent shift-amt) (beginning-of-line) (setq beg (point)) (setq shift-amt - (cond ((eq (char-after bof) ?=) 0) - ((listp (setq indent (perl-calculate-indent bof))) indent) + (cond ((eq 1 (nth 7 (syntax-ppss))) 0) ;For doc sections! + ((listp (setq indent (perl-calculate-indent))) indent) ((eq 'noindent indent) indent) ((looking-at (or nochange perl-nochange)) 0) (t (skip-chars-forward " \t\f") - (setq indent (perl-indent-new-calculate nil indent bof)) + (setq indent (perl-indent-new-calculate nil indent)) (- indent (current-column))))) (skip-chars-forward " \t\f") (if (and (numberp shift-amt) (/= 0 shift-amt)) @@ -824,23 +814,21 @@ changed by, or (parse-state) if line starts in a quoted string." (goto-char (- (point-max) pos))) shift-amt)) -(defun perl-continuation-line-p (limit) +(defun perl-continuation-line-p () "Move to end of previous line and return non-nil if continued." ;; Statement level. Is it a continuation or a new statement? ;; Find previous non-comment character. (perl-backward-to-noncomment) ;; Back up over label lines, since they don't ;; affect whether our line is a continuation. - (while (or (eq (preceding-char) ?\,) - (and (eq (preceding-char) ?:) - (memq (char-syntax (char-after (- (point) 2))) - '(?w ?_)))) - (if (eq (preceding-char) ?\,) - (perl-backward-to-start-of-continued-exp limit) - (beginning-of-line)) + (while (and (eq (preceding-char) ?:) + (memq (char-syntax (char-after (- (point) 2))) + '(?w ?_))) + (beginning-of-line) (perl-backward-to-noncomment)) ;; Now we get the answer. - (not (memq (preceding-char) '(?\; ?\} ?\{)))) + (unless (memq (preceding-char) '(?\; ?\} ?\{)) + (preceding-char))) (defun perl-hanging-paren-p () "Non-nil if we are right after a hanging parenthesis-like char." @@ -848,173 +836,151 @@ changed by, or (parse-state) if line starts in a quoted string." (save-excursion (skip-syntax-backward " (") (not (bolp))))) -(defun perl-indent-new-calculate (&optional virtual default parse-start) +(defun perl-indent-new-calculate (&optional virtual default) (or (and virtual (save-excursion (skip-chars-backward " \t") (bolp)) (current-column)) (and (looking-at "\\(\\w\\|\\s_\\)+:[^:]") - (max 1 (+ (or default (perl-calculate-indent parse-start)) + (max 1 (+ (or default (perl-calculate-indent)) perl-label-offset))) (and (= (char-syntax (following-char)) ?\)) (save-excursion (forward-char 1) (when (condition-case nil (progn (forward-sexp -1) t) (scan-error nil)) - (perl-indent-new-calculate - ;; Recalculate the parsing-start, since we may have jumped - ;; dangerously close (typically in the case of nested functions). - 'virtual nil (save-excursion (perl-beginning-of-function)))))) + (perl-indent-new-calculate 'virtual)))) (and (and (= (following-char) ?{) (save-excursion (forward-char) (perl-hanging-paren-p))) - (+ (or default (perl-calculate-indent parse-start)) + (+ (or default (perl-calculate-indent)) perl-brace-offset)) - (or default (perl-calculate-indent parse-start)))) + (or default (perl-calculate-indent)))) -(defun perl-calculate-indent (&optional parse-start) +(defun perl-calculate-indent () "Return appropriate indentation for current line as Perl code. In usual case returns an integer: the column to indent to. -Returns (parse-state) if line starts inside a string. -Optional argument PARSE-START should be the position of `beginning-of-defun'." +Returns (parse-state) if line starts inside a string." (save-excursion (let ((indent-point (point)) (case-fold-search nil) (colon-line-end 0) + prev-char state containing-sexp) - (if parse-start ;used to avoid searching - (goto-char parse-start) - (perl-beginning-of-function)) - ;; We might be now looking at a local function that has nothing to - ;; do with us because `indent-point' is past it. In this case - ;; look further back up for another `perl-beginning-of-function'. - (while (and (looking-at "{") - (save-excursion - (beginning-of-line) - (looking-at "\\s-+sub\\>")) - (> indent-point (save-excursion - (condition-case nil - (forward-sexp 1) - (scan-error nil)) - (point)))) - (perl-beginning-of-function)) - (while (< (point) indent-point) ;repeat until right sexp - (setq state (parse-partial-sexp (point) indent-point 0)) - ;; state = (depth_in_parens innermost_containing_list - ;; last_complete_sexp string_terminator_or_nil inside_commentp - ;; following_quotep minimum_paren-depth_this_scan) - ;; Parsing stops if depth in parentheses becomes equal to third arg. - (setq containing-sexp (nth 1 state))) + (setq containing-sexp (nth 1 (syntax-ppss indent-point))) (cond ;; Don't auto-indent in a quoted string or a here-document. ((or (nth 3 state) (eq 2 (nth 7 state))) 'noindent) - ((null containing-sexp) ; Line is at top level. - (skip-chars-forward " \t\f") - (if (memq (following-char) - (if perl-indent-parens-as-block '(?\{ ?\( ?\[) '(?\{))) - 0 ; move to beginning of line if it starts a function body - ;; indent a little if this is a continuation line - (perl-backward-to-noncomment) - (if (or (bobp) - (memq (preceding-char) '(?\; ?\}))) - 0 perl-continued-statement-offset))) - ((/= (char-after containing-sexp) ?{) - ;; line is expression, not statement: - ;; indent to just after the surrounding open. - (goto-char (1+ containing-sexp)) - (if (perl-hanging-paren-p) - ;; We're indenting an arg of a call like: - ;; $a = foobarlongnamefun ( - ;; arg1 - ;; arg2 - ;; ); - (progn - (skip-syntax-backward "(") - (condition-case nil - (while (save-excursion - (skip-syntax-backward " ") (not (bolp))) - (forward-sexp -1)) - (scan-error nil)) - (+ (current-column) perl-indent-level)) - (if perl-indent-continued-arguments - (+ perl-indent-continued-arguments (current-indentation)) - (skip-chars-forward " \t") - (current-column)))) - (t - ;; Statement level. Is it a continuation or a new statement? - (if (perl-continuation-line-p containing-sexp) - ;; This line is continuation of preceding line's statement; - ;; indent perl-continued-statement-offset more than the - ;; previous line of the statement. - (progn - (perl-backward-to-start-of-continued-exp containing-sexp) - (+ (if (save-excursion - (perl-continuation-line-p containing-sexp)) - ;; If the continued line is itself a continuation - ;; line, then align, otherwise add an offset. - 0 perl-continued-statement-offset) - (current-column) - (if (save-excursion (goto-char indent-point) - (looking-at - (if perl-indent-parens-as-block - "[ \t]*[{(\[]" "[ \t]*{"))) - perl-continued-brace-offset 0))) - ;; This line starts a new statement. - ;; Position at last unclosed open. - (goto-char containing-sexp) - (or - ;; Is line first statement after an open-brace? - ;; If no, find that first statement and indent like it. - (save-excursion - (forward-char 1) - ;; Skip over comments and labels following openbrace. - (while (progn - (skip-chars-forward " \t\f\n") - (cond ((looking-at ";?#") - (forward-line 1) t) - ((looking-at "\\(\\w\\|\\s_\\)+:[^:]") - (setq colon-line-end (line-end-position)) - (search-forward ":"))))) - ;; The first following code counts - ;; if it is before the line we want to indent. - (and (< (point) indent-point) - (if (> colon-line-end (point)) - (- (current-indentation) perl-label-offset) - (current-column)))) - ;; If no previous statement, - ;; indent it relative to line brace is on. - ;; For open paren in column zero, don't let statement - ;; start there too. If perl-indent-level is zero, - ;; use perl-brace-offset + perl-continued-statement-offset - ;; For open-braces not the first thing in a line, - ;; add in perl-brace-imaginary-offset. - (+ (if (and (bolp) (zerop perl-indent-level)) - (+ perl-brace-offset perl-continued-statement-offset) - perl-indent-level) - ;; Move back over whitespace before the openbrace. - ;; If openbrace is not first nonwhite thing on the line, - ;; add the perl-brace-imaginary-offset. - (progn (skip-chars-backward " \t") - (if (bolp) 0 perl-brace-imaginary-offset)) - ;; If the openbrace is preceded by a parenthesized exp, - ;; move to the beginning of that; - ;; possibly a different line - (progn - (if (eq (preceding-char) ?\)) - (forward-sexp -1)) - ;; Get initial indentation of the line we are on. - (current-indentation)))))))))) + ((null containing-sexp) ; Line is at top level. + (skip-chars-forward " \t\f") + (if (memq (following-char) + (if perl-indent-parens-as-block '(?\{ ?\( ?\[) '(?\{))) + 0 ; move to beginning of line if it starts a function body + ;; indent a little if this is a continuation line + (perl-backward-to-noncomment) + (if (or (bobp) + (memq (preceding-char) '(?\; ?\}))) + 0 perl-continued-statement-offset))) + ((/= (char-after containing-sexp) ?{) + ;; line is expression, not statement: + ;; indent to just after the surrounding open. + (goto-char (1+ containing-sexp)) + (if (perl-hanging-paren-p) + ;; We're indenting an arg of a call like: + ;; $a = foobarlongnamefun ( + ;; arg1 + ;; arg2 + ;; ); + (progn + (skip-syntax-backward "(") + (condition-case nil + (while (save-excursion + (skip-syntax-backward " ") (not (bolp))) + (forward-sexp -1)) + (scan-error nil)) + (+ (current-column) perl-indent-level)) + (if perl-indent-continued-arguments + (+ perl-indent-continued-arguments (current-indentation)) + (skip-chars-forward " \t") + (current-column)))) + ;; Statement level. Is it a continuation or a new statement? + ((setq prev-char (perl-continuation-line-p)) + ;; This line is continuation of preceding line's statement; + ;; indent perl-continued-statement-offset more than the + ;; previous line of the statement. + (perl-backward-to-start-of-continued-exp) + (+ (if (or (save-excursion + (perl-continuation-line-p)) + (and (eq prev-char ?\,) + (looking-at "[[:alnum:]_]+[ \t\n]*=>"))) + ;; If the continued line is itself a continuation + ;; line, then align, otherwise add an offset. + 0 perl-continued-statement-offset) + (current-column) + (if (save-excursion (goto-char indent-point) + (looking-at + (if perl-indent-parens-as-block + "[ \t]*[{(\[]" "[ \t]*{"))) + perl-continued-brace-offset 0))) + (t + ;; This line starts a new statement. + ;; Position at last unclosed open. + (goto-char containing-sexp) + (or + ;; Is line first statement after an open-brace? + ;; If no, find that first statement and indent like it. + (save-excursion + (forward-char 1) + ;; Skip over comments and labels following openbrace. + (while (progn + (skip-chars-forward " \t\f\n") + (cond ((looking-at ";?#") + (forward-line 1) t) + ((looking-at "\\(\\w\\|\\s_\\)+:[^:]") + (setq colon-line-end (line-end-position)) + (search-forward ":"))))) + ;; The first following code counts + ;; if it is before the line we want to indent. + (and (< (point) indent-point) + (if (> colon-line-end (point)) + (- (current-indentation) perl-label-offset) + (current-column)))) + ;; If no previous statement, + ;; indent it relative to line brace is on. + ;; For open paren in column zero, don't let statement + ;; start there too. If perl-indent-level is zero, + ;; use perl-brace-offset + perl-continued-statement-offset + ;; For open-braces not the first thing in a line, + ;; add in perl-brace-imaginary-offset. + (+ (if (and (bolp) (zerop perl-indent-level)) + (+ perl-brace-offset perl-continued-statement-offset) + perl-indent-level) + ;; Move back over whitespace before the openbrace. + ;; If openbrace is not first nonwhite thing on the line, + ;; add the perl-brace-imaginary-offset. + (progn (skip-chars-backward " \t") + (if (bolp) 0 perl-brace-imaginary-offset)) + ;; If the openbrace is preceded by a parenthesized exp, + ;; move to the beginning of that; + ;; possibly a different line + (progn + (if (eq (preceding-char) ?\)) + (forward-sexp -1)) + ;; Get initial indentation of the line we are on. + (current-indentation))))))))) (defun perl-backward-to-noncomment () "Move point backward to after the first non-white-space, skipping comments." - (interactive) (forward-comment (- (point-max)))) -(defun perl-backward-to-start-of-continued-exp (lim) - (if (= (preceding-char) ?\)) - (forward-sexp -1)) - (beginning-of-line) - (if (<= (point) lim) - (goto-char (1+ lim))) - (skip-chars-forward " \t\f")) +(defun perl-backward-to-start-of-continued-exp () + (while + (let ((c (preceding-char))) + (cond + ((memq c '(?\; ?\{ ?\[ ?\()) (forward-comment (point-max)) nil) + ((memq c '(?\) ?\] ?\} ?\")) + (forward-sexp -1) (forward-comment (- (point))) t) + ((eq ?w (char-syntax c)) + (forward-word -1) (forward-comment (- (point))) t) + (t (forward-char -1) (forward-comment (- (point))) t))))) ;; note: this may be slower than the c-mode version, but I can understand it. (defalias 'indent-perl-exp 'perl-indent-exp) @@ -1039,7 +1005,7 @@ Optional argument PARSE-START should be the position of `beginning-of-defun'." (setq lsexp-mark bof-mark) (beginning-of-line) (while (< (point) (marker-position last-mark)) - (setq delta (perl-indent-line nil (marker-position bof-mark))) + (setq delta (perl-indent-line nil)) (if (numberp delta) ; unquoted start-of-line? (progn (if (eolp) diff --git a/lisp/progmodes/prog-mode.el b/lisp/progmodes/prog-mode.el index e0e57462405..1cfe1568813 100644 --- a/lisp/progmodes/prog-mode.el +++ b/lisp/progmodes/prog-mode.el @@ -35,6 +35,13 @@ "Generic programming mode, from which others derive." :group 'languages) +(defcustom prog-mode-hook nil + "Normal hook run when entering programming modes." + :type 'hook + :options '(flyspell-prog-mode abbrev-mode flymake-mode linum-mode + prettify-symbols-mode) + :group 'prog-mode) + (defvar prog-mode-map (let ((map (make-sparse-keymap))) (define-key map [?\C-\M-q] 'prog-indent-sexp) @@ -118,7 +125,7 @@ support it." (font-lock-add-keywords nil prettify-symbols--keywords) (setq-local font-lock-extra-managed-props (cons 'composition font-lock-extra-managed-props)) - (font-lock-fontify-buffer)) + (font-lock-flush)) ;; Turn off (when prettify-symbols--keywords (font-lock-remove-keywords nil prettify-symbols--keywords) diff --git a/lisp/progmodes/prolog.el b/lisp/progmodes/prolog.el index 42904720d63..3f98708e2e3 100644 --- a/lisp/progmodes/prolog.el +++ b/lisp/progmodes/prolog.el @@ -3342,8 +3342,6 @@ PREFIX is the prefix of the search regexp." ["Mark clause" prolog-mark-clause t] ["Mark predicate" prolog-mark-predicate t] ["Mark paragraph" mark-paragraph t] - ;;"---" - ;;["Fontify buffer" font-lock-fontify-buffer t] )) (defun prolog-menu () diff --git a/lisp/progmodes/ps-mode.el b/lisp/progmodes/ps-mode.el index f7de331f73b..9d74c40525e 100644 --- a/lisp/progmodes/ps-mode.el +++ b/lisp/progmodes/ps-mode.el @@ -41,6 +41,7 @@ (require 'comint) (require 'easymenu) +(require 'smie) ;; Define core `PostScript' group. (defgroup PostScript nil @@ -60,10 +61,7 @@ ;; User variables. -(defcustom ps-mode-auto-indent t - "Should we use autoindent?" - :group 'PostScript-edit - :type 'boolean) +(make-obsolete-variable 'ps-mode-auto-indent 'electric-indent-mode "25.1") (defcustom ps-mode-tab 4 "Number of spaces to use when indenting." @@ -204,7 +202,7 @@ If nil, use `temporary-file-directory'." "bind" "null" "gsave" "grestore" "grestoreall" "showpage"))) - (concat "\\<" (regexp-opt ops t) "\\>")) + (concat "\\_<" (regexp-opt ops t) "\\_>")) "Regexp of PostScript operators that will be fontified.") ;; Level 1 font-lock: @@ -214,13 +212,9 @@ If nil, use `temporary-file-directory'." ;; - 8bit characters (warning face) ;; Multiline strings are not supported. Strings with nested brackets are. (defconst ps-mode-font-lock-keywords-1 - '(("\\`%!PS.*" . font-lock-constant-face) + '(("\\`%!PS.*" (0 font-lock-constant-face t)) ("^%%BoundingBox:[ \t]+-?[0-9]+[ \t]+-?[0-9]+[ \t]+-?[0-9]+[ \t]+-?[0-9]+[ \t]*$" - . font-lock-constant-face) - (ps-mode-match-string-or-comment - (1 font-lock-comment-face nil t) - (2 font-lock-string-face nil t)) - ("([^()\n%]*\\|[^()\n]*)" . font-lock-warning-face) + (0 font-lock-constant-face t)) ("[\200-\377]+" (0 font-lock-warning-face prepend nil))) "Subdued level highlighting for PostScript mode.") @@ -255,19 +249,17 @@ If nil, use `temporary-file-directory'." ;; Names are fontified before PostScript operators, allowing the use of ;; a more simple (efficient) regexp than the one used in level 2. (defconst ps-mode-font-lock-keywords-3 - (append - ps-mode-font-lock-keywords-1 - (list - '("//\\w+" . font-lock-type-face) - `(,(concat - "^\\(/\\w+\\)\\>" - "\\([[ \t]*\\(%.*\\)?\r?$" ; Nothing but `[' or comment after the name. - "\\|[ \t]*\\({\\|<<\\)" ; `{' or `<<' following the name. - "\\|[ \t]+[0-9]+[ \t]+dict\\>" ; `[0-9]+ dict' following the name. - "\\|.*\\<def\\>\\)") ; `def' somewhere on the same line. - . (1 font-lock-function-name-face)) - '("/\\w+" . font-lock-variable-name-face) - (cons ps-mode-operators 'font-lock-keyword-face))) + `(,@ps-mode-font-lock-keywords-1 + ("//\\(?:\\sw\\|\\s_\\)+" . font-lock-type-face) + (,(concat + "^\\(/\\(?:\\sw\\|\\s_\\)+\\)\\_>" + "\\([[ \t]*\\(%.*\\)?\r?$" ; Nothing but `[' or comment after the name. + "\\|[ \t]*\\({\\|<<\\)" ; `{' or `<<' following the name. + "\\|[ \t]+[0-9]+[ \t]+dict\\_>" ; `[0-9]+ dict' following the name. + "\\|.*\\_<def\\_>\\)") ; `def' somewhere on the same line. + . (1 font-lock-function-name-face)) + ("/\\(?:\\sw\\|\\s_\\)+" . font-lock-variable-name-face) + (,ps-mode-operators . font-lock-keyword-face)) "High level highlighting for PostScript mode.") (defconst ps-mode-font-lock-keywords ps-mode-font-lock-keywords-1 @@ -289,13 +281,68 @@ If nil, use `temporary-file-directory'." ;; Variables. -(defvar ps-mode-map nil +(defvar ps-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "\C-c\C-v" 'ps-run-boundingbox) + (define-key map "\C-c\C-u" 'ps-mode-uncomment-region) + (define-key map "\C-c\C-t" 'ps-mode-epsf-rich) + (define-key map "\C-c\C-s" 'ps-run-start) + (define-key map "\C-c\C-r" 'ps-run-region) + (define-key map "\C-c\C-q" 'ps-run-quit) + (define-key map "\C-c\C-p" 'ps-mode-print-buffer) + (define-key map "\C-c\C-o" 'ps-mode-comment-out-region) + (define-key map "\C-c\C-k" 'ps-run-kill) + (define-key map "\C-c\C-j" 'ps-mode-other-newline) + (define-key map "\C-c\C-l" 'ps-run-clear) + (define-key map "\C-c\C-b" 'ps-run-buffer) + ;; FIXME: Add `indent' to backward-delete-char-untabify-method instead? + (define-key map "\177" 'ps-mode-backward-delete-char) + map) "Local keymap to use in PostScript mode.") -(defvar ps-mode-syntax-table nil +(defvar ps-mode-syntax-table + (let ((st (make-syntax-table))) + + (modify-syntax-entry ?\% "< " st) + (modify-syntax-entry ?\n "> " st) + (modify-syntax-entry ?\r "> " st) + (modify-syntax-entry ?\f "> " st) + (modify-syntax-entry ?\< "(>" st) + (modify-syntax-entry ?\> ")<" st) + + (modify-syntax-entry ?\! "_ " st) + (modify-syntax-entry ?\" "_ " st) + (modify-syntax-entry ?\# "_ " st) + (modify-syntax-entry ?\$ "_ " st) + (modify-syntax-entry ?\& "_ " st) + (modify-syntax-entry ?\' "_ " st) + (modify-syntax-entry ?\* "_ " st) + (modify-syntax-entry ?\+ "_ " st) + (modify-syntax-entry ?\, "_ " st) + (modify-syntax-entry ?\- "_ " st) + (modify-syntax-entry ?\. "_ " st) + (modify-syntax-entry ?\: "_ " st) + (modify-syntax-entry ?\; "_ " st) + (modify-syntax-entry ?\= "_ " st) + (modify-syntax-entry ?\? "_ " st) + (modify-syntax-entry ?\@ "_ " st) + (modify-syntax-entry ?\\ "\\" st) + (modify-syntax-entry ?^ "_ " st) ; NOT: ?\^ + (modify-syntax-entry ?\_ "_ " st) + (modify-syntax-entry ?\` "_ " st) + (modify-syntax-entry ?\| "_ " st) + (modify-syntax-entry ?\~ "_ " st) + st) "Syntax table used while in PostScript mode.") -(defvar ps-run-mode-map nil +(defvar ps-run-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map comint-mode-map) + (define-key map "\C-c\C-q" 'ps-run-quit) + (define-key map "\C-c\C-k" 'ps-run-kill) + (define-key map "\C-c\C-e" 'ps-run-goto-error) + (define-key map [mouse-2] 'ps-run-mouse-goto-error) + map) "Local keymap to use in PostScript run mode.") (defvar ps-mode-tmp-file nil @@ -365,9 +412,6 @@ If nil, use `temporary-file-directory'." ["8-bit to Octal Buffer" ps-mode-octal-buffer t] ["8-bit to Octal Region" ps-mode-octal-region (mark t)] "---" - ["Auto Indent" (setq ps-mode-auto-indent (not ps-mode-auto-indent)) - :style toggle :selected ps-mode-auto-indent] - "---" ["Start PostScript" ps-run-start t] @@ -404,79 +448,7 @@ If nil, use `temporary-file-directory'." ps-mode-submit-bug-report t])) - -;; Mode maps for PostScript edit mode and PostScript interaction mode. - -(unless ps-mode-map - (setq ps-mode-map (make-sparse-keymap)) - (define-key ps-mode-map "\C-c\C-v" 'ps-run-boundingbox) - (define-key ps-mode-map "\C-c\C-u" 'ps-mode-uncomment-region) - (define-key ps-mode-map "\C-c\C-t" 'ps-mode-epsf-rich) - (define-key ps-mode-map "\C-c\C-s" 'ps-run-start) - (define-key ps-mode-map "\C-c\C-r" 'ps-run-region) - (define-key ps-mode-map "\C-c\C-q" 'ps-run-quit) - (define-key ps-mode-map "\C-c\C-p" 'ps-mode-print-buffer) - (define-key ps-mode-map "\C-c\C-o" 'ps-mode-comment-out-region) - (define-key ps-mode-map "\C-c\C-k" 'ps-run-kill) - (define-key ps-mode-map "\C-c\C-j" 'ps-mode-other-newline) - (define-key ps-mode-map "\C-c\C-l" 'ps-run-clear) - (define-key ps-mode-map "\C-c\C-b" 'ps-run-buffer) - (define-key ps-mode-map ">" 'ps-mode-r-gt) - (define-key ps-mode-map "]" 'ps-mode-r-angle) - (define-key ps-mode-map "}" 'ps-mode-r-brace) - (define-key ps-mode-map "\177" 'ps-mode-backward-delete-char) - (define-key ps-mode-map "\t" 'ps-mode-tabkey) - (define-key ps-mode-map "\r" 'ps-mode-newline) - (easy-menu-define ps-mode-main ps-mode-map "PostScript" ps-mode-menu-main)) - -(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)) - - -;; Syntax table. - -(unless ps-mode-syntax-table - (setq ps-mode-syntax-table (make-syntax-table)) - - (modify-syntax-entry ?\% "< " ps-mode-syntax-table) - (modify-syntax-entry ?\n "> " ps-mode-syntax-table) - (modify-syntax-entry ?\r "> " ps-mode-syntax-table) - (modify-syntax-entry ?\f "> " ps-mode-syntax-table) - (modify-syntax-entry ?\< "(>" ps-mode-syntax-table) - (modify-syntax-entry ?\> ")<" ps-mode-syntax-table) - - (modify-syntax-entry ?\! "w " ps-mode-syntax-table) - (modify-syntax-entry ?\" "w " ps-mode-syntax-table) - (modify-syntax-entry ?\# "w " ps-mode-syntax-table) - (modify-syntax-entry ?\$ "w " ps-mode-syntax-table) - (modify-syntax-entry ?\& "w " ps-mode-syntax-table) - (modify-syntax-entry ?\' "w " ps-mode-syntax-table) - (modify-syntax-entry ?\* "w " ps-mode-syntax-table) - (modify-syntax-entry ?\+ "w " ps-mode-syntax-table) - (modify-syntax-entry ?\, "w " ps-mode-syntax-table) - (modify-syntax-entry ?\- "w " ps-mode-syntax-table) - (modify-syntax-entry ?\. "w " ps-mode-syntax-table) - (modify-syntax-entry ?\: "w " ps-mode-syntax-table) - (modify-syntax-entry ?\; "w " ps-mode-syntax-table) - (modify-syntax-entry ?\= "w " ps-mode-syntax-table) - (modify-syntax-entry ?\? "w " ps-mode-syntax-table) - (modify-syntax-entry ?\@ "w " ps-mode-syntax-table) - (modify-syntax-entry ?\\ "w " ps-mode-syntax-table) - (modify-syntax-entry ?^ "w " ps-mode-syntax-table) ; NOT: ?\^ - (modify-syntax-entry ?\_ "w " ps-mode-syntax-table) - (modify-syntax-entry ?\` "w " ps-mode-syntax-table) - (modify-syntax-entry ?\| "w " ps-mode-syntax-table) - (modify-syntax-entry ?\~ "w " ps-mode-syntax-table) - - (let ((i 128)) - (while (< i 256) - (modify-syntax-entry i "w " ps-mode-syntax-table) - (setq i (1+ i))))) +(easy-menu-define ps-mode-main ps-mode-map "PostScript" ps-mode-menu-main) @@ -484,6 +456,13 @@ If nil, use `temporary-file-directory'." ;; PostScript mode. +(defun ps-mode-smie-rules (kind token) + (pcase (cons kind token) + (`(:after . "<") (when (smie-rule-next-p "<") 0)) + (`(:elem . basic) ps-mode-tab) + (`(:close-all . ">") t) + (`(:list-intro . ,_) t))) + ;;;###autoload (define-derived-mode ps-mode prog-mode "PostScript" "Major mode for editing PostScript with GNU Emacs. @@ -493,7 +472,6 @@ Entry to this mode calls `ps-mode-hook'. The following variables hold user options, and can be set through the `customize' command: - `ps-mode-auto-indent' `ps-mode-tab' `ps-mode-paper-size' `ps-mode-print-function' @@ -523,12 +501,16 @@ with a file position. Clicking mouse-2 on this number will bring point to the corresponding spot in the PostScript window, if input to the interpreter was sent from that window. Typing \\<ps-run-mode-map>\\[ps-run-goto-error] when the cursor is at the number has the same effect." + (setq-local syntax-propertize-function #'ps-mode-syntax-propertize) (set (make-local-variable 'font-lock-defaults) '((ps-mode-font-lock-keywords ps-mode-font-lock-keywords-1 ps-mode-font-lock-keywords-2 ps-mode-font-lock-keywords-3) - t)) + nil)) + (smie-setup nil #'ps-mode-smie-rules) + (setq-local electric-indent-chars + (append '(?> ?\] ?\}) electric-indent-chars)) (set (make-local-variable 'comment-start) "%") ;; NOTE: `\' has a special meaning in strings only (set (make-local-variable 'comment-start-skip) "%+[ \t]*") @@ -555,8 +537,7 @@ Typing \\<ps-run-mode-map>\\[ps-run-goto-error] when the cursor is at the number (reporter-submit-bug-report ps-mode-maintainer-address (format "ps-mode.el %s [%s]" ps-mode-version system-type) - '(ps-mode-auto-indent - ps-mode-tab + '(ps-mode-tab ps-mode-paper-size ps-mode-print-function ps-run-prompt @@ -570,53 +551,54 @@ Typing \\<ps-run-mode-map>\\[ps-run-goto-error] when the cursor is at the number ;; Helper functions for font-lock. -;; When this function is called, point is at an opening bracket. -;; This function should test if point is at the start of a string -;; with nested brackets. -;; If true: move point to end of string -;; set string to match data nr 2 -;; return new point -;; If false: return nil -(defun ps-mode-looking-at-nested (limit) - (let ((first (point)) - (level 1) - pos) - ;; Move past opening bracket. - (forward-char 1) - (setq pos (point)) - (while (and (> level 0) (< pos limit)) - ;; Search next bracket, stepping over escaped brackets. - (if (not (looking-at "\\([^()\\\n]\\|\\\\.\\)*\\([()]\\)")) - (setq level -1) - (setq level (+ level (if (string= "(" (match-string 2)) 1 -1))) - (goto-char (setq pos (match-end 0))))) - (if (not (= level 0)) - nil - ;; Found string with nested brackets, now set match data nr 2. - (set-match-data (list first pos nil nil first pos)) - pos))) - -;; This function should search for a string or comment -;; If comment, return as match data nr 1 -;; If string, return as match data nr 2 -(defun ps-mode-match-string-or-comment (limit) - ;; Find the first potential match. - (if (not (re-search-forward "[%(]" limit t)) - ;; Nothing found: return failure. - nil - (let ((end (match-end 0))) - (goto-char (match-beginning 0)) - (cond ((looking-at "\\(%.*\\)\\|\\((\\([^()\\\n]\\|\\\\.\\)*)\\)") - ;; It's a comment or string without nested, unescaped brackets. - (goto-char (match-end 0)) - (point)) - ((ps-mode-looking-at-nested limit) - ;; It's a string with nested brackets. - (point)) - (t - ;; Try next match. - (goto-char end) - (ps-mode-match-string-or-comment limit)))))) +(defconst ps-mode--string-syntax-table + (let ((st (make-syntax-table ps-mode-syntax-table))) + (modify-syntax-entry ?% "." st) + (modify-syntax-entry ?< "." st) + (modify-syntax-entry ?> "." st) + (modify-syntax-entry ?\{ "." st) + (modify-syntax-entry ?\} "." st) + (modify-syntax-entry ?\[ "." st) + (modify-syntax-entry ?\] "." st) + st)) + +(defun ps-mode--syntax-propertize-special (end) + (let ((ppss (syntax-ppss)) + char) + (cond + ((not (nth 3 ppss))) ;Not in (...), <~..base85..~>, or <..hex..>. + ((eq ?\( (setq char (char-after (nth 8 ppss)))) + (save-restriction + (narrow-to-region (point-min) end) + (goto-char (nth 8 ppss)) + (condition-case nil + (with-syntax-table ps-mode--string-syntax-table + (let ((parse-sexp-lookup-properties nil)) + (forward-sexp 1)) + (put-text-property (1- (point)) (point) + 'syntax-table (string-to-syntax "|"))) + (scan-error (goto-char end))))) + ((eq char ?<) + (when (re-search-forward (if (eq ?~ (char-after (1+ (nth 8 ppss)))) + "~>" ">") + end 'move) + (put-text-property (1- (point)) (point) + 'syntax-table (string-to-syntax "|"))))))) + +(defun ps-mode-syntax-propertize (start end) + (goto-char start) + (ps-mode--syntax-propertize-special end) + (funcall + (syntax-propertize-rules + ("\\(<\\)\\(?:~\\|[ \n\t]*[[:xdigit:]]\\)\\|\\(?1:(\\)" + (1 (unless (or (eq (char-after (match-beginning 0)) + (char-before (match-beginning 0))) ;Avoid "<<". + (nth 8 (save-excursion (syntax-ppss (match-beginning 1))))) + (put-text-property (match-beginning 1) (match-end 1) + 'syntax-table (string-to-syntax "|")) + (ps-mode--syntax-propertize-special end) + nil)))) + (point) end)) ;; Key-handlers. @@ -654,34 +636,12 @@ defines the beginning of a group. These tokens are: { [ <<" (setq target (+ target ps-mode-tab))) target))))) -(defun ps-mode-newline () - "Insert newline with proper indentation." - (interactive) - (delete-horizontal-space) - (insert "\n") - (if ps-mode-auto-indent - (indent-to (ps-mode-target-column)))) - -(defun ps-mode-tabkey () - "Indent/reindent current line, or insert tab." - (interactive) - (let ((column (current-column)) - target) - (if (or (not ps-mode-auto-indent) - (< ps-mode-tab 1) - (not (re-search-backward "^[ \t]*\\=" nil t))) - (insert "\t") - (setq target (ps-mode-target-column)) - (while (<= target column) - (setq target (+ target ps-mode-tab))) - (indent-line-to target)))) - (defun ps-mode-backward-delete-char () "Delete backward indentation, or delete backward character." (interactive) (let ((column (current-column)) target) - (if (or (not ps-mode-auto-indent) + (if (or (not electric-indent-mode) (< ps-mode-tab 1) (not (re-search-backward "^[ \t]+\\=" nil t))) (call-interactively 'delete-backward-char) @@ -694,32 +654,6 @@ defines the beginning of a group. These tokens are: { [ <<" (setq target 0)) (indent-line-to target)))) -(defun ps-mode-r-brace () - "Insert `}' and perform balance." - (interactive) - (insert "}") - (ps-mode-r-balance "}")) - -(defun ps-mode-r-angle () - "Insert `]' and perform balance." - (interactive) - (insert "]") - (ps-mode-r-balance "]")) - -(defun ps-mode-r-gt () - "Insert `>' and perform balance." - (interactive) - (insert ">") - (ps-mode-r-balance ">>")) - -(defun ps-mode-r-balance (right) - "Adjust indenting if point after RIGHT." - (if ps-mode-auto-indent - (save-excursion - (when (re-search-backward (concat "^[ \t]*" (regexp-quote right) "\\=") nil t) - (indent-line-to (ps-mode-target-column))))) - (blink-matching-open)) - (defun ps-mode-other-newline () "Perform newline in `*ps-run*' buffer." (interactive) diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index c16b26100a1..a1ef9a6fca2 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -31,9 +31,9 @@ ;; found in GNU/Emacs. ;; Implements Syntax highlighting, Indentation, Movement, Shell -;; interaction, Shell completion, Shell virtualenv support, Pdb -;; tracking, Symbol completion, Skeletons, FFAP, Code Check, Eldoc, -;; Imenu. +;; interaction, Shell completion, Shell virtualenv support, Shell +;; package support, Shell syntax highlighting, Pdb tracking, Symbol +;; completion, Skeletons, FFAP, Code Check, Eldoc, Imenu. ;; Syntax highlighting: Fontification of code is provided and supports ;; python's triple quoted strings properly. @@ -69,7 +69,7 @@ ;; Besides that only the standard CPython (2.x and 3.x) shell and ;; IPython are officially supported out of the box, the interaction ;; should support any other readline based Python shells as well -;; (e.g. Jython and Pypy have been reported to work). You can change +;; (e.g. Jython and PyPy have been reported to work). You can change ;; your default interpreter and commandline arguments by setting the ;; `python-shell-interpreter' and `python-shell-interpreter-args' ;; variables. This example enables IPython globally: @@ -119,18 +119,24 @@ ;; modify its behavior. ;; Shell completion: hitting tab will try to complete the current -;; word. Shell completion is implemented in such way that if you -;; change the `python-shell-interpreter' it should be possible to -;; integrate custom logic to calculate completions. To achieve this -;; you just need to set `python-shell-completion-setup-code' and -;; `python-shell-completion-string-code'. The default provided code, -;; enables autocompletion for both CPython and IPython (and ideally -;; any readline based Python shell). This code depends on the -;; readline module, so if you are using some Operating System that -;; bundles Python without it (like Windows), installing pyreadline -;; from URL `http://ipython.scipy.org/moin/PyReadline/Intro' should -;; suffice. To troubleshoot why you are not getting any completions -;; you can try the following in your Python shell: +;; word. The two built-in mechanisms depend on Python's readline +;; module: the "native" completion is tried first and is activated +;; when `python-shell-completion-native-enable' is non-nil, the +;; current `python-shell-interpreter' is not a member of the +;; `python-shell-completion-native-disabled-interpreters' variable and +;; `python-shell-completion-native-setup' succeeds; the "fallback" or +;; "legacy" mechanism works by executing Python code in the background +;; and enables auto-completion for shells that do not support +;; receiving escape sequences (with some limitations, i.e. completion +;; in blocks does not work). The code executed for the "fallback" +;; completion can be found in `python-shell-completion-setup-code' and +;; `python-shell-completion-string-code' variables. Their default +;; values enable completion for both CPython and IPython, and probably +;; any readline based shell (it's known to work with PyPy). If your +;; Python installation lacks readline (like CPython for Windows), +;; installing pyreadline (URL `http://ipython.org/pyreadline.html') +;; should suffice. To troubleshoot why you are not getting any +;; completions, you can try the following in your Python shell: ;; >>> import readline, rlcompleter @@ -158,18 +164,28 @@ ;; (python-shell-exec-path . ("/path/to/env/bin/")) ;; Since the above is cumbersome and can be programmatically -;; calculated, the variable `python-shell-virtualenv-path' is +;; calculated, the variable `python-shell-virtualenv-root' is ;; provided. When this variable is set with the path of the ;; virtualenv to use, `process-environment' and `exec-path' get proper ;; values in order to run shells inside the specified virtualenv. So ;; the following will achieve the same as the previous example: -;; (setq python-shell-virtualenv-path "/path/to/env/") +;; (setq python-shell-virtualenv-root "/path/to/env/") ;; Also the `python-shell-extra-pythonpaths' variable have been ;; introduced as simple way of adding paths to the PYTHONPATH without ;; affecting existing values. +;; Shell package support: you can enable a package in the current +;; shell so that relative imports work properly using the +;; `python-shell-package-enable' command. + +;; Shell syntax highlighting: when enabled current input in shell is +;; highlighted. The variable `python-shell-font-lock-enable' controls +;; activation of this feature globally when shells are started. +;; Activation/deactivation can be also controlled on the fly via the +;; `python-shell-font-lock-toggle' command. + ;; Pdb tracking: when you execute a block of code that contains some ;; call to pdb (or ipdb) it will prompt the block of code and will ;; follow the execution of pdb marking the current line with an arrow. @@ -178,15 +194,13 @@ ;; the shell completion in background so you should run ;; `python-shell-send-buffer' from time to time to get better results. -;; Skeletons: 6 skeletons are provided for simple inserting of class, -;; def, for, if, try and while. These skeletons are integrated with -;; abbrev. If you have `abbrev-mode' activated and +;; Skeletons: skeletons are provided for simple inserting of things like class, +;; def, for, import, if, try, and while. These skeletons are +;; integrated with abbrev. If you have `abbrev-mode' activated and ;; `python-skeleton-autoinsert' is set to t, then whenever you type ;; the name of any of those defined and hit SPC, they will be ;; automatically expanded. As an alternative you can use the defined -;; skeleton commands: `python-skeleton-class', `python-skeleton-def' -;; `python-skeleton-for', `python-skeleton-if', `python-skeleton-try' -;; and `python-skeleton-while'. +;; skeleton commands: `python-skeleton-<foo>'. ;; FFAP: You can find the filename for a given module when using ffap ;; out of the box. This feature needs an inferior python shell @@ -248,6 +262,7 @@ (defvar outline-heading-end-regexp) (autoload 'comint-mode "comint") +(autoload 'help-function-arglist "help-fns") ;;;###autoload (add-to-list 'auto-mode-alist (cons (purecopy "\\.py\\'") 'python-mode)) @@ -280,6 +295,7 @@ (define-key map "\C-c\C-td" 'python-skeleton-def) (define-key map "\C-c\C-tf" 'python-skeleton-for) (define-key map "\C-c\C-ti" 'python-skeleton-if) + (define-key map "\C-c\C-tm" 'python-skeleton-import) (define-key map "\C-c\C-tt" 'python-skeleton-try) (define-key map "\C-c\C-tw" 'python-skeleton-while) ;; Shell interaction @@ -461,6 +477,23 @@ The type returned can be `comment', `string' or `paren'." 'python-info-ppss-comment-or-string-p #'python-syntax-comment-or-string-p "24.3") +(defun python-docstring-at-p (pos) + "Check to see if there is a docstring at POS." + (save-excursion + (goto-char pos) + (if (looking-at-p "'''\\|\"\"\"") + (progn + (python-nav-backward-statement) + (looking-at "\\`\\|class \\|def ")) + nil))) + +(defun python-font-lock-syntactic-face-function (state) + (if (nth 3 state) + (if (python-docstring-at-p (nth 8 state)) + font-lock-doc-face + font-lock-string-face) + font-lock-comment-face)) + (defvar python-font-lock-keywords ;; Keywords `(,(rx symbol-start @@ -549,7 +582,7 @@ The type returned can be `comment', `string' or `paren'." (res nil)) (while (and (setq res (re-search-forward re limit t)) (or (python-syntax-context 'paren) - (equal (char-after (point-marker)) ?=)))) + (equal (char-after (point)) ?=)))) res)) (1 font-lock-variable-name-face nil nil)) ;; support for a, b, c = (1, 2, 3) @@ -674,7 +707,8 @@ It makes underscores and dots word constituent chars.") "Current indentation level `python-indent-line-function' is using.") (defvar python-indent-levels '(0) - "Levels of indentation available for `python-indent-line-function'.") + "Levels of indentation available for `python-indent-line-function'. +Can also be `noindent' if automatic indentation can't be used.") (defun python-indent-guess-indent-offset () "Guess and set `python-indent-offset' for the current buffer." @@ -795,7 +829,9 @@ START is the buffer position where the sexp starts." start)))) (defun python-indent-calculate-indentation () - "Calculate correct indentation offset for the current line." + "Calculate correct indentation offset for the current line. +Returns `noindent' if the indentation does not depend on Python syntax, +such as in strings." (let* ((indentation-context (python-indent-context)) (context-status (car indentation-context)) (context-start (cdr indentation-context))) @@ -845,9 +881,7 @@ START is the buffer position where the sexp starts." ;; When inside of a string, do nothing. just use the current ;; indentation. XXX: perhaps it would be a good idea to ;; invoke standard text indentation here - (`inside-string - (goto-char context-start) - (current-indentation)) + (`inside-string 'noindent) ;; After backslash we have several possibilities. (`after-backslash (cond @@ -973,14 +1007,17 @@ START is the buffer position where the sexp starts." ;; XXX: This asks for a refactor. Even if point is on a ;; dedenter statement, it could be multiline and in that case ;; the continuation lines should be indented with normal rules. - (let* ((indentation (python-indent-calculate-indentation)) - (remainder (% indentation python-indent-offset)) - (steps (/ (- indentation remainder) python-indent-offset))) - (setq python-indent-levels (list 0)) - (dotimes (step steps) - (push (* python-indent-offset (1+ step)) python-indent-levels)) - (when (not (eq 0 remainder)) - (push (+ (* python-indent-offset steps) remainder) python-indent-levels))) + (let* ((indentation (python-indent-calculate-indentation))) + (if (not (numberp indentation)) + (setq python-indent-levels indentation) + (let* ((remainder (% indentation python-indent-offset)) + (steps (/ (- indentation remainder) python-indent-offset))) + (setq python-indent-levels (list 0)) + (dotimes (step steps) + (push (* python-indent-offset (1+ step)) python-indent-levels)) + (when (not (eq 0 remainder)) + (push (+ (* python-indent-offset steps) remainder) + python-indent-levels))))) (setq python-indent-levels (or (mapcar (lambda (pos) @@ -989,8 +1026,9 @@ START is the buffer position where the sexp starts." (current-indentation))) (python-info-dedenter-opening-block-positions)) (list 0)))) - (setq python-indent-current-level (1- (length python-indent-levels)) - python-indent-levels (nreverse python-indent-levels))) + (when (listp python-indent-levels) + (setq python-indent-current-level (1- (length python-indent-levels)) + python-indent-levels (nreverse python-indent-levels)))) (defun python-indent-toggle-levels () "Toggle `python-indent-current-level' over `python-indent-levels'." @@ -1018,28 +1056,30 @@ in the variable `python-indent-levels'. Afterwards it sets the variable `python-indent-current-level' correctly so offset is equal to (nth python-indent-current-level python-indent-levels)" - (or - (and (or (and (memq this-command python-indent-trigger-commands) - (eq last-command this-command)) - force-toggle) - (not (equal python-indent-levels '(0))) - (or (python-indent-toggle-levels) t)) - (python-indent-calculate-levels)) - (let* ((starting-pos (point-marker)) - (indent-ending-position - (+ (line-beginning-position) (current-indentation))) - (follow-indentation-p - (or (bolp) - (and (<= (line-beginning-position) starting-pos) - (>= indent-ending-position starting-pos)))) - (next-indent (nth python-indent-current-level python-indent-levels))) - (unless (= next-indent (current-indentation)) - (beginning-of-line) - (delete-horizontal-space) - (indent-to next-indent) - (goto-char starting-pos)) - (and follow-indentation-p (back-to-indentation))) - (python-info-dedenter-opening-block-message)) + (if (and (or (and (memq this-command python-indent-trigger-commands) + (eq last-command this-command)) + force-toggle) + (not (equal python-indent-levels '(0)))) + (if (listp python-indent-levels) + (python-indent-toggle-levels)) + (python-indent-calculate-levels)) + (if (eq python-indent-levels 'noindent) + python-indent-levels + (let* ((starting-pos (point-marker)) + (indent-ending-position + (+ (line-beginning-position) (current-indentation))) + (follow-indentation-p + (or (bolp) + (and (<= (line-beginning-position) starting-pos) + (>= indent-ending-position starting-pos)))) + (next-indent (nth python-indent-current-level python-indent-levels))) + (unless (= next-indent (current-indentation)) + (beginning-of-line) + (delete-horizontal-space) + (indent-to next-indent) + (goto-char starting-pos)) + (and follow-indentation-p (back-to-indentation))) + (python-info-dedenter-opening-block-message))) (defun python-indent-line-function () "`indent-line-function' for Python mode. @@ -1050,9 +1090,9 @@ See `python-indent-line' for details." "De-indent current line." (interactive "*") (when (and (not (python-syntax-comment-or-string-p)) - (<= (point-marker) (save-excursion + (<= (point) (save-excursion (back-to-indentation) - (point-marker))) + (point))) (> (current-column) 0)) (python-indent-line t) t)) @@ -1129,12 +1169,10 @@ any lines in the region are indented less than COUNT columns." (while (< (point) end) (if (and (< (current-indentation) count) (not (looking-at "[ \t]*$"))) - (error "Can't shift all lines enough")) + (user-error "Can't shift all lines enough")) (forward-line)) (indent-rigidly start end (- count)))))) -(add-to-list 'debug-ignored-errors "^Can't shift all lines enough") - (defun python-indent-shift-right (start end &optional count) "Shift lines contained in region START END by COUNT columns to the right. COUNT defaults to `python-indent-offset'. If region isn't @@ -1176,7 +1214,7 @@ the line will be re-indented automatically if needed." (save-excursion (goto-char (line-beginning-position)) (let ((indentation (python-indent-calculate-indentation))) - (when (< (current-indentation) indentation) + (when (and (numberp indentation) (< (current-indentation) indentation)) (indent-line-to indentation))))) ;; Electric colon ((and (eq ?: last-command-event) @@ -1790,6 +1828,7 @@ position, else returns nil." (defcustom python-shell-prompt-input-regexps '(">>> " "\\.\\.\\. " ; Python "In \\[[0-9]+\\]: " ; IPython + " \\.\\.\\.: " ; IPython ;; Using ipdb outside IPython may fail to cleanup and leave static ;; IPython prompts activated, this adds some safeguard for that. "In : " "\\.\\.\\.: ") @@ -1825,7 +1864,10 @@ It should not contain a caret (^) at the beginning." It should not contain a caret (^) at the beginning." :type 'string) -(defcustom python-shell-enable-font-lock t +(define-obsolete-variable-alias + 'python-shell-enable-font-lock 'python-shell-font-lock-enable "25.1") + +(defcustom python-shell-font-lock-enable t "Should syntax highlighting be enabled in the Python shell buffer? Restart the Python shell after changing this variable for it to take effect." :type 'boolean @@ -1868,7 +1910,7 @@ default `exec-path'." :group 'python :safe 'listp) -(defcustom python-shell-virtualenv-path nil +(defcustom python-shell-virtualenv-root nil "Path to virtualenv root. This variable, when set to a string, makes the values stored in `python-shell-process-environment' and `python-shell-exec-path' @@ -1878,6 +1920,9 @@ virtualenv." :group 'python :safe 'stringp) +(define-obsolete-variable-alias + 'python-shell-virtualenv-path 'python-shell-virtualenv-root "25.1") + (defcustom python-shell-setup-codes '(python-shell-completion-setup-code python-ffap-setup-code python-eldoc-setup-code) @@ -1969,7 +2014,9 @@ detection and just returns nil." nil))) (when (and (not prompts) python-shell-prompt-detect-failure-warning) - (warn + (lwarn + '(python python-shell-prompt-regexp) + :warning (concat "Python shell prompts cannot be detected.\n" "If your emacs session hangs when starting python shells\n" @@ -2064,67 +2111,57 @@ and `python-shell-output-prompt-regexp' using the values from (defun python-shell-get-process-name (dedicated) "Calculate the appropriate process name for inferior Python process. -If DEDICATED is t and the variable `buffer-file-name' is non-nil -returns a string with the form -`python-shell-buffer-name'[variable `buffer-file-name'] else -returns the value of `python-shell-buffer-name'." - (let ((process-name - (if (and dedicated - buffer-file-name) - (format "%s[%s]" python-shell-buffer-name buffer-file-name) - (format "%s" python-shell-buffer-name)))) - process-name)) +If DEDICATED is t returns a string with the form +`python-shell-buffer-name'[`buffer-name'] else returns the value +of `python-shell-buffer-name'." + (if dedicated + (format "%s[%s]" python-shell-buffer-name (buffer-name)) + python-shell-buffer-name)) (defun python-shell-internal-get-process-name () "Calculate the appropriate process name for Internal Python process. The name is calculated from `python-shell-global-buffer-name' and -a hash of all relevant global shell settings in order to ensure -uniqueness for different types of configurations." - (format "%s [%s]" - python-shell-internal-buffer-name - (md5 - (concat - python-shell-interpreter - python-shell-interpreter-args - python-shell--prompt-calculated-input-regexp - python-shell--prompt-calculated-output-regexp - (mapconcat #'symbol-value python-shell-setup-codes "") - (mapconcat #'identity python-shell-process-environment "") - (mapconcat #'identity python-shell-extra-pythonpaths "") - (mapconcat #'identity python-shell-exec-path "") - (or python-shell-virtualenv-path "") - (mapconcat #'identity python-shell-exec-path ""))))) - -(defun python-shell-parse-command () ;FIXME: why name it "parse"? +the `buffer-name'." + (format "%s[%s]" python-shell-internal-buffer-name (buffer-name))) + +(defun python-shell-calculate-command () "Calculate the string used to execute the inferior Python process." - ;; FIXME: process-environment doesn't seem to be used anywhere within - ;; this let. - (let ((process-environment (python-shell-calculate-process-environment)) - (exec-path (python-shell-calculate-exec-path))) + (let ((exec-path (python-shell-calculate-exec-path))) + ;; `exec-path' gets tweaked so that virtualenv's specific + ;; `python-shell-interpreter' absolute path can be found by + ;; `executable-find'. (format "%s %s" ;; FIXME: Why executable-find? (shell-quote-argument (executable-find python-shell-interpreter)) python-shell-interpreter-args))) +(define-obsolete-function-alias + 'python-shell-parse-command + #'python-shell-calculate-command "25.1") + +(defun python-shell-calculate-pythonpath () + "Calculate the PYTHONPATH using `python-shell-extra-pythonpaths'." + (let ((pythonpath (getenv "PYTHONPATH")) + (extra (mapconcat 'identity + python-shell-extra-pythonpaths + path-separator))) + (if pythonpath + (concat extra path-separator pythonpath) + extra))) + (defun python-shell-calculate-process-environment () - "Calculate process environment given `python-shell-virtualenv-path'." + "Calculate process environment given `python-shell-virtualenv-root'." (let ((process-environment (append python-shell-process-environment process-environment nil)) - (virtualenv (if python-shell-virtualenv-path - (directory-file-name python-shell-virtualenv-path) + (virtualenv (if python-shell-virtualenv-root + (directory-file-name python-shell-virtualenv-root) nil))) (when python-shell-unbuffered (setenv "PYTHONUNBUFFERED" "1")) (when python-shell-extra-pythonpaths - (setenv "PYTHONPATH" - (format "%s%s%s" - (mapconcat 'identity - python-shell-extra-pythonpaths - path-separator) - path-separator - (or (getenv "PYTHONPATH") "")))) + (setenv "PYTHONPATH" (python-shell-calculate-pythonpath))) (if (not virtualenv) process-environment (setenv "PYTHONHOME" nil) @@ -2135,34 +2172,250 @@ uniqueness for different types of configurations." process-environment)) (defun python-shell-calculate-exec-path () - "Calculate exec path given `python-shell-virtualenv-path'." - (let ((path (append python-shell-exec-path - exec-path nil))) ;FIXME: Why nil? - (if (not python-shell-virtualenv-path) + "Calculate exec path given `python-shell-virtualenv-root'." + (let ((path (append + ;; Use nil as the tail so that the list is a full copy, + ;; this is a paranoid safeguard for side-effects. + python-shell-exec-path exec-path nil))) + (if (not python-shell-virtualenv-root) path - (cons (expand-file-name "bin" python-shell-virtualenv-path) + (cons (expand-file-name "bin" python-shell-virtualenv-root) path)))) -(defun python-comint-output-filter-function (output) - "Hook run after content is put into comint buffer. -OUTPUT is a string with the contents of the buffer." - (ansi-color-filter-apply output)) +(defvar python-shell--package-depth 10) + +(defun python-shell-package-enable (directory package) + "Add DIRECTORY parent to $PYTHONPATH and enable PACKAGE." + (interactive + (let* ((dir (expand-file-name + (read-directory-name + "Package root: " + (file-name-directory + (or (buffer-file-name) default-directory))))) + (name (completing-read + "Package: " + (python-util-list-packages + dir python-shell--package-depth)))) + (list dir name))) + (python-shell-send-string + (format + (concat + "import os.path;import sys;" + "sys.path.append(os.path.dirname(os.path.dirname('''%s''')));" + "__package__ = '''%s''';" + "import %s") + directory package package) + (python-shell-get-process))) + +(defun python-shell-accept-process-output (process &optional timeout regexp) + "Accept PROCESS output with TIMEOUT until REGEXP is found. +Optional argument TIMEOUT is the timeout argument to +`accept-process-output' calls. Optional argument REGEXP +overrides the regexp to match the end of output, defaults to +`comint-prompt-regexp.'. Returns non-nil when output was +properly captured. + +This utility is useful in situations where the output may be +received in chunks, since `accept-process-output' gives no +guarantees they will be grabbed in a single call. An example use +case for this would be the CPython shell start-up, where the +banner and the initial prompt are received separately." + (let ((regexp (or regexp comint-prompt-regexp))) + (catch 'found + (while t + (when (not (accept-process-output process timeout)) + (throw 'found nil)) + (when (looking-back regexp) + (throw 'found t)))))) + +(defun python-shell-comint-end-of-output-p (output) + "Return non-nil if OUTPUT is ends with input prompt." + (string-match + ;; XXX: It seems on OSX an extra carriage return is attached + ;; at the end of output, this handles that too. + (concat + "\r?\n?" + ;; Remove initial caret from calculated regexp + (replace-regexp-in-string + (rx string-start ?^) "" + python-shell--prompt-calculated-input-regexp) + (rx eos)) + output)) + +(define-obsolete-function-alias + 'python-comint-output-filter-function + 'ansi-color-filter-apply + "25.1") + +(defun python-comint-postoutput-scroll-to-bottom (output) + "Faster version of `comint-postoutput-scroll-to-bottom'. +Avoids `recenter' calls until OUTPUT is completely sent." + (when (and (not (string= "" output)) + (python-shell-comint-end-of-output-p + (ansi-color-filter-apply output))) + (comint-postoutput-scroll-to-bottom output)) + output) (defvar python-shell--parent-buffer nil) -(defvar python-shell-output-syntax-table - (let ((table (make-syntax-table python-dotty-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) - (modify-syntax-entry ?\] "." table) - (modify-syntax-entry ?\} "." table) - table) - "Syntax table for shell output. -It makes parens and quotes be treated as punctuation chars.") +(defmacro python-shell-with-shell-buffer (&rest body) + "Execute the forms in BODY with the shell buffer temporarily current. +Signals an error if no shell buffer is available for current buffer." + (declare (indent 0) (debug t)) + (let ((shell-process (make-symbol "shell-process"))) + `(let ((,shell-process (python-shell-get-process-or-error))) + (with-current-buffer (process-buffer ,shell-process) + ,@body)))) + +(defvar python-shell--font-lock-buffer nil) + +(defun python-shell-font-lock-get-or-create-buffer () + "Get or create a font-lock buffer for current inferior process." + (python-shell-with-shell-buffer + (if python-shell--font-lock-buffer + python-shell--font-lock-buffer + (let ((process-name + (process-name (get-buffer-process (current-buffer))))) + (generate-new-buffer + (format "*%s-font-lock*" process-name)))))) + +(defun python-shell-font-lock-kill-buffer () + "Kill the font-lock buffer safely." + (python-shell-with-shell-buffer + (when (and python-shell--font-lock-buffer + (buffer-live-p python-shell--font-lock-buffer)) + (kill-buffer python-shell--font-lock-buffer) + (when (derived-mode-p 'inferior-python-mode) + (setq python-shell--font-lock-buffer nil))))) + +(defmacro python-shell-font-lock-with-font-lock-buffer (&rest body) + "Execute the forms in BODY in the font-lock buffer. +The value returned is the value of the last form in BODY. See +also `with-current-buffer'." + (declare (indent 0) (debug t)) + `(python-shell-with-shell-buffer + (save-current-buffer + (when (not (and python-shell--font-lock-buffer + (get-buffer python-shell--font-lock-buffer))) + (setq python-shell--font-lock-buffer + (python-shell-font-lock-get-or-create-buffer))) + (set-buffer python-shell--font-lock-buffer) + (set (make-local-variable 'delay-mode-hooks) t) + (let ((python-indent-guess-indent-offset nil)) + (when (not (derived-mode-p 'python-mode)) + (python-mode)) + ,@body)))) + +(defun python-shell-font-lock-cleanup-buffer () + "Cleanup the font-lock buffer. +Provided as a command because this might be handy if something +goes wrong and syntax highlighting in the shell gets messed up." + (interactive) + (python-shell-with-shell-buffer + (python-shell-font-lock-with-font-lock-buffer + (delete-region (point-min) (point-max))))) + +(defun python-shell-font-lock-comint-output-filter-function (output) + "Clean up the font-lock buffer after any OUTPUT." + (when (and (not (string= "" output)) + ;; Is end of output and is not just a prompt. + (not (member + (python-shell-comint-end-of-output-p + (ansi-color-filter-apply output)) + '(nil 0)))) + ;; If output is other than an input prompt then "real" output has + ;; been received and the font-lock buffer must be cleaned up. + (python-shell-font-lock-cleanup-buffer)) + output) + +(defun python-shell-font-lock-post-command-hook () + "Fontifies current line in shell buffer." + (if (eq this-command 'comint-send-input) + ;; Add a newline when user sends input as this may be a block. + (python-shell-font-lock-with-font-lock-buffer + (goto-char (line-end-position)) + (newline)) + (when (and (python-util-comint-last-prompt) + (> (point) (cdr (python-util-comint-last-prompt)))) + (let ((input (buffer-substring-no-properties + (cdr (python-util-comint-last-prompt)) (point-max))) + (old-input (python-shell-font-lock-with-font-lock-buffer + (buffer-substring-no-properties + (line-beginning-position) (point-max)))) + (current-point (point)) + (buffer-undo-list t)) + ;; When input hasn't changed, do nothing. + (when (not (string= input old-input)) + (delete-region (cdr (python-util-comint-last-prompt)) (point-max)) + (insert + (python-shell-font-lock-with-font-lock-buffer + (delete-region (line-beginning-position) + (line-end-position)) + (insert input) + ;; Ensure buffer is fontified, keeping it + ;; compatible with Emacs < 24.4. + (if (fboundp 'font-lock-ensure) + (funcall 'font-lock-ensure) + (font-lock-default-fontify-buffer)) + ;; Replace FACE text properties with FONT-LOCK-FACE so + ;; they are not overwritten by comint buffer's font lock. + (python-util-text-properties-replace-name + 'face 'font-lock-face) + (buffer-substring (line-beginning-position) + (line-end-position)))) + (goto-char current-point)))))) + +(defun python-shell-font-lock-turn-on (&optional msg) + "Turn on shell font-lock. +With argument MSG show activation message." + (interactive "p") + (python-shell-with-shell-buffer + (python-shell-font-lock-kill-buffer) + (set (make-local-variable 'python-shell--font-lock-buffer) nil) + (add-hook 'post-command-hook + #'python-shell-font-lock-post-command-hook nil 'local) + (add-hook 'kill-buffer-hook + #'python-shell-font-lock-kill-buffer nil 'local) + (add-hook 'comint-output-filter-functions + #'python-shell-font-lock-comint-output-filter-function + 'append 'local) + (when msg + (message "Shell font-lock is enabled")))) + +(defun python-shell-font-lock-turn-off (&optional msg) + "Turn off shell font-lock. +With argument MSG show deactivation message." + (interactive "p") + (python-shell-with-shell-buffer + (python-shell-font-lock-kill-buffer) + (when (python-util-comint-last-prompt) + ;; Cleanup current fontification + (remove-text-properties + (cdr (python-util-comint-last-prompt)) + (line-end-position) + '(face nil font-lock-face nil))) + (set (make-local-variable 'python-shell--font-lock-buffer) nil) + (remove-hook 'post-command-hook + #'python-shell-font-lock-post-command-hook'local) + (remove-hook 'kill-buffer-hook + #'python-shell-font-lock-kill-buffer 'local) + (remove-hook 'comint-output-filter-functions + #'python-shell-font-lock-comint-output-filter-function + 'local) + (when msg + (message "Shell font-lock is disabled")))) + +(defun python-shell-font-lock-toggle (&optional msg) + "Toggle font-lock for shell. +With argument MSG show activation/deactivation message." + (interactive "p") + (python-shell-with-shell-buffer + (set (make-local-variable 'python-shell-font-lock-enable) + (not python-shell-font-lock-enable)) + (if python-shell-font-lock-enable + (python-shell-font-lock-turn-on msg) + (python-shell-font-lock-turn-off msg)) + python-shell-font-lock-enable)) (define-derived-mode inferior-python-mode comint-mode "Inferior Python" "Major mode for Python inferior process. @@ -2173,13 +2426,17 @@ interpreter is run. Variables `python-shell-prompt-regexp', `python-shell-prompt-output-regexp', `python-shell-prompt-block-regexp', -`python-shell-enable-font-lock', +`python-shell-font-lock-enable', `python-shell-completion-setup-code', `python-shell-completion-string-code', `python-eldoc-setup-code', `python-eldoc-string-code', `python-ffap-setup-code' and `python-ffap-string-code' can customize this mode for different Python interpreters. +This mode resets `comint-output-filter-functions' locally, so you +may want to re-add custom functions to it using the +`inferior-python-mode-hook'. + You can also add additional setup code to be run at initialization of the interpreter via `python-shell-setup-codes' variable. @@ -2198,56 +2455,33 @@ variable. (set (make-local-variable 'python-shell--prompt-calculated-output-regexp) nil) (python-shell-prompt-set-calculated-regexps) (setq comint-prompt-regexp python-shell--prompt-calculated-input-regexp) + (set (make-local-variable 'comint-prompt-read-only) t) (setq mode-line-process '(":%s")) - (make-local-variable 'comint-output-filter-functions) - (add-hook 'comint-output-filter-functions - 'python-comint-output-filter-function) - (add-hook 'comint-output-filter-functions - 'python-pdbtrack-comint-output-filter-function) + (set (make-local-variable 'comint-output-filter-functions) + '(ansi-color-process-output + python-pdbtrack-comint-output-filter-function + python-comint-postoutput-scroll-to-bottom)) (set (make-local-variable 'compilation-error-regexp-alist) python-shell-compilation-regexp-alist) - (define-key inferior-python-mode-map [remap complete-symbol] - 'completion-at-point) (add-hook 'completion-at-point-functions - #'python-shell-completion-complete-at-point nil 'local) - (add-hook 'comint-dynamic-complete-functions ;FIXME: really? - #'python-shell-completion-complete-at-point nil 'local) + #'python-shell-completion-at-point nil 'local) (define-key inferior-python-mode-map "\t" 'python-shell-completion-complete-or-indent) (make-local-variable 'python-pdbtrack-buffers-to-kill) (make-local-variable 'python-pdbtrack-tracked-buffer) (make-local-variable 'python-shell-internal-last-output) - (when python-shell-enable-font-lock - (set-syntax-table python-mode-syntax-table) - (set (make-local-variable 'font-lock-defaults) - '(python-font-lock-keywords nil nil nil nil)) - (set (make-local-variable 'syntax-propertize-function) - (eval - ;; XXX: Unfortunately eval is needed here to make use of the - ;; dynamic value of `comint-prompt-regexp'. - `(syntax-propertize-rules - (,comint-prompt-regexp - (0 (ignore - (put-text-property - comint-last-input-start end 'syntax-table - python-shell-output-syntax-table) - ;; XXX: This might look weird, but it is the easiest - ;; way to ensure font lock gets cleaned up before the - ;; current prompt, which is needed for unclosed - ;; strings to not mess up with current input. - (font-lock-unfontify-region comint-last-input-start end)))) - (,(python-rx string-delimiter) - (0 (ignore - (and (not (eq (get-text-property start 'field) 'output)) - (python-syntax-stringify))))))))) - (compilation-shell-minor-mode 1)) - -(defun python-shell-make-comint (cmd proc-name &optional pop internal) + (when python-shell-font-lock-enable + (python-shell-font-lock-turn-on)) + (compilation-shell-minor-mode 1) + (python-shell-accept-process-output + (get-buffer-process (current-buffer)))) + +(defun python-shell-make-comint (cmd proc-name &optional show internal) "Create a Python shell comint buffer. CMD is the Python command to be executed and PROC-NAME is the process name the comint buffer will get. After the comint buffer is created the `inferior-python-mode' is activated. When -optional argument POP is non-nil the buffer is shown. When +optional argument SHOW is non-nil the buffer is shown. When optional argument INTERNAL is non-nil this process is run on a buffer with a name that starts with a space, following the Emacs convention for temporary/internal buffers, and also makes sure @@ -2276,22 +2510,24 @@ killed." (mapconcat #'identity args " "))) (with-current-buffer buffer (inferior-python-mode)) - (accept-process-output process) - (and pop (pop-to-buffer buffer t)) + (when show (display-buffer buffer)) (and internal (set-process-query-on-exit-flag process nil)))) proc-buffer-name))) ;;;###autoload -(defun run-python (cmd &optional dedicated show) +(defun run-python (&optional cmd dedicated show) "Run an inferior Python process. -Input and output via buffer named after -`python-shell-buffer-name'. If there is a process already -running in that buffer, just switch to it. -With argument, allows you to define CMD so you can edit the -command used to call the interpreter and define DEDICATED, so a -dedicated process for the current buffer is open. When numeric -prefix arg is other than 0 or 4 do not SHOW. +Argument CMD defaults to `python-shell-calculate-command' return +value. When called interactively with `prefix-arg', it allows +the user to edit such value and choose whether the interpreter +should be DEDICATED for the current buffer. When numeric prefix +arg is other than 0 or 4 do not SHOW. + +For a given buffer and same values of DEDICATED, if a process is +already running for it, it will do nothing. This means that if +the current buffer is using a global process, the user is still +able to switch it to use a dedicated one. Runs the hook `inferior-python-mode-hook' after `comint-mode-hook' is run. (Type \\[describe-mode] in the @@ -2299,13 +2535,14 @@ process buffer for a list of commands.)" (interactive (if current-prefix-arg (list - (read-string "Run Python: " (python-shell-parse-command)) + (read-shell-command "Run Python: " (python-shell-calculate-command)) (y-or-n-p "Make dedicated process? ") (= (prefix-numeric-value current-prefix-arg) 4)) - (list (python-shell-parse-command) nil t))) - (python-shell-make-comint - cmd (python-shell-get-process-name dedicated) show) - dedicated) + (list (python-shell-calculate-command) nil t))) + (get-buffer-process + (python-shell-make-comint + (or cmd (python-shell-calculate-command)) + (python-shell-get-process-name dedicated) show))) (defun run-python-internal () "Run an inferior Internal Python process. @@ -2319,57 +2556,69 @@ difference with global or dedicated shells is that these ones are attached to a configuration, not a buffer. This means that can be used for example to retrieve the sys.path and other stuff, without messing with user shells. Note that -`python-shell-enable-font-lock' and `inferior-python-mode-hook' +`python-shell-font-lock-enable' and `inferior-python-mode-hook' are set to nil for these shells, so setup codes are not sent at startup." - (let ((python-shell-enable-font-lock nil) + (let ((python-shell-font-lock-enable nil) (inferior-python-mode-hook nil)) (get-buffer-process (python-shell-make-comint - (python-shell-parse-command) + (python-shell-calculate-command) (python-shell-internal-get-process-name) nil t)))) (defun python-shell-get-buffer () - "Return inferior Python buffer for current buffer." - (let* ((dedicated-proc-name (python-shell-get-process-name t)) - (dedicated-proc-buffer-name (format "*%s*" dedicated-proc-name)) - (global-proc-name (python-shell-get-process-name nil)) - (global-proc-buffer-name (format "*%s*" global-proc-name)) - (dedicated-running (comint-check-proc dedicated-proc-buffer-name)) - (global-running (comint-check-proc global-proc-buffer-name))) - ;; Always prefer dedicated - (or (and dedicated-running dedicated-proc-buffer-name) - (and global-running global-proc-buffer-name)))) + "Return inferior Python buffer for current buffer. +If current buffer is in `inferior-python-mode', return it." + (if (derived-mode-p 'inferior-python-mode) + (current-buffer) + (let* ((dedicated-proc-name (python-shell-get-process-name t)) + (dedicated-proc-buffer-name (format "*%s*" dedicated-proc-name)) + (global-proc-name (python-shell-get-process-name nil)) + (global-proc-buffer-name (format "*%s*" global-proc-name)) + (dedicated-running (comint-check-proc dedicated-proc-buffer-name)) + (global-running (comint-check-proc global-proc-buffer-name))) + ;; Always prefer dedicated + (or (and dedicated-running dedicated-proc-buffer-name) + (and global-running global-proc-buffer-name))))) (defun python-shell-get-process () "Return inferior Python process for current buffer." (get-buffer-process (python-shell-get-buffer))) +(defun python-shell-get-process-or-error (&optional interactivep) + "Return inferior Python process for current buffer or signal error. +When argument INTERACTIVEP is non-nil, use `user-error' instead +of `error' with a user-friendly message." + (or (python-shell-get-process) + (if interactivep + (user-error + "Start a Python process first with `M-x run-python' or `%s'." + ;; Get the binding. + (key-description + (where-is-internal + #'run-python overriding-local-map t))) + (error + "No inferior Python process running.")))) + (defun python-shell-get-or-create-process (&optional cmd dedicated show) "Get or create an inferior Python process for current buffer and return it. Arguments CMD, DEDICATED and SHOW are those of `run-python' and are used to start the shell. If those arguments are not provided, `run-python' is called interactively and the user will be asked for their values." - (let* ((dedicated-proc-name (python-shell-get-process-name t)) - (dedicated-proc-buffer-name (format "*%s*" dedicated-proc-name)) - (global-proc-name (python-shell-get-process-name nil)) - (global-proc-buffer-name (format "*%s*" global-proc-name)) - (dedicated-running (comint-check-proc dedicated-proc-buffer-name)) - (global-running (comint-check-proc global-proc-buffer-name)) - (current-prefix-arg 16)) - (when (and (not dedicated-running) (not global-running)) - (if (if (not cmd) - ;; XXX: Refactor code such that calling `run-python' - ;; interactively is not needed anymore. - (call-interactively 'run-python) - (run-python cmd dedicated show)) - (setq dedicated-running t) - (setq global-running t))) - ;; Always prefer dedicated - (get-buffer-process (if dedicated-running - dedicated-proc-buffer-name - global-proc-buffer-name)))) + (let ((shell-process (python-shell-get-process))) + (when (not shell-process) + (if (not cmd) + ;; XXX: Refactor code such that calling `run-python' + ;; interactively is not needed anymore. + (call-interactively 'run-python) + (run-python cmd dedicated show))) + (or shell-process (python-shell-get-process)))) + +(make-obsolete + #'python-shell-get-or-create-process + "Instead call `python-shell-get-process' and create one if returns nil." + "25.1") (defvar python-shell-internal-buffer nil "Current internal shell buffer for the current buffer. @@ -2383,18 +2632,10 @@ there for compatibility with CEDET.") (defun python-shell-internal-get-or-create-process () "Get or create an inferior Internal Python process." - (let* ((proc-name (python-shell-internal-get-process-name)) - (proc-buffer-name (format " *%s*" proc-name))) - (when (not (process-live-p proc-name)) - (run-python-internal) - (setq python-shell-internal-buffer proc-buffer-name) - ;; XXX: Why is this `sit-for' needed? - ;; `python-shell-make-comint' calls `accept-process-output' - ;; already but it is not helping to get proper output on - ;; 'gnu/linux when the internal shell process is not running and - ;; a call to `python-shell-internal-send-string' is issued. - (sit-for 0.1 t)) - (get-buffer-process proc-buffer-name))) + (let ((proc-name (python-shell-internal-get-process-name))) + (if (process-live-p proc-name) + (get-process proc-name) + (run-python-internal)))) (define-obsolete-function-alias 'python-proc 'python-shell-internal-get-or-create-process "24.3") @@ -2417,10 +2658,14 @@ there for compatibility with CEDET.") (delete-trailing-whitespace)) temp-file-name)) -(defun python-shell-send-string (string &optional process) - "Send STRING to inferior Python PROCESS." - (interactive "sPython command: ") - (let ((process (or process (python-shell-get-or-create-process)))) +(defun python-shell-send-string (string &optional process msg) + "Send STRING to inferior Python PROCESS. +When optional argument MSG is non-nil, forces display of a +user-friendly message if there's no process running; defaults to +t when called interactively." + (interactive + (list (read-string "Python command: ") nil t)) + (let ((process (or process (python-shell-get-process-or-error msg)))) (if (string-match ".\n+." string) ;Multiline. (let* ((temp-file-name (python-shell--save-temp-file string)) (file-name (or (buffer-file-name) temp-file-name))) @@ -2443,16 +2688,7 @@ detecting a prompt at the end of the buffer." string (ansi-color-filter-apply string) python-shell-output-filter-buffer (concat python-shell-output-filter-buffer string)) - (when (string-match - ;; XXX: It seems on OSX an extra carriage return is attached - ;; at the end of output, this handles that too. - (concat - "\r?\n" - ;; Remove initial caret from calculated regexp - (replace-regexp-in-string - (rx string-start ?^) "" - python-shell--prompt-calculated-input-regexp) - "$") + (when (python-shell-comint-end-of-output-p python-shell-output-filter-buffer) ;; Output ends when `python-shell-output-filter-buffer' contains ;; the prompt attached at the end of it. @@ -2472,7 +2708,7 @@ detecting a prompt at the end of the buffer." (defun python-shell-send-string-no-output (string &optional process) "Send STRING to PROCESS and inhibit output. Return the output." - (let ((process (or process (python-shell-get-or-create-process))) + (let ((process (or process (python-shell-get-process-or-error))) (comint-preoutput-filter-functions '(python-shell-output-filter)) (python-shell-output-filter-in-progress t) @@ -2576,35 +2812,43 @@ the python shell: (line-beginning-position) (line-end-position)))) (buffer-substring-no-properties (point-min) (point-max))))) -(defun python-shell-send-region (start end &optional send-main) +(defun python-shell-send-region (start end &optional send-main msg) "Send the region delimited by START and END to inferior Python process. When optional argument SEND-MAIN is non-nil, allow execution of code inside blocks delimited by \"if __name__== '__main__':\". When called interactively SEND-MAIN defaults to nil, unless it's -called with prefix argument." - (interactive "r\nP") +called with prefix argument. When optional argument MSG is +non-nil, forces display of a user-friendly message if there's no +process running; defaults to t when called interactively." + (interactive + (list (region-beginning) (region-end) current-prefix-arg t)) (let* ((string (python-shell-buffer-substring start end (not send-main))) - (process (python-shell-get-or-create-process)) + (process (python-shell-get-process-or-error msg)) (original-string (buffer-substring-no-properties start end)) (_ (string-match "\\`\n*\\(.*\\)" original-string))) (message "Sent: %s..." (match-string 1 original-string)) (python-shell-send-string string process))) -(defun python-shell-send-buffer (&optional send-main) +(defun python-shell-send-buffer (&optional send-main msg) "Send the entire buffer to inferior Python process. When optional argument SEND-MAIN is non-nil, allow execution of code inside blocks delimited by \"if __name__== '__main__':\". When called interactively SEND-MAIN defaults to nil, unless it's -called with prefix argument." - (interactive "P") +called with prefix argument. When optional argument MSG is +non-nil, forces display of a user-friendly message if there's no +process running; defaults to t when called interactively." + (interactive (list current-prefix-arg t)) (save-restriction (widen) - (python-shell-send-region (point-min) (point-max) send-main))) + (python-shell-send-region (point-min) (point-max) send-main msg))) -(defun python-shell-send-defun (arg) +(defun python-shell-send-defun (&optional arg msg) "Send the current defun to inferior Python process. -When argument ARG is non-nil do not include decorators." - (interactive "P") +When argument ARG is non-nil do not include decorators. When +optional argument MSG is non-nil, forces display of a +user-friendly message if there's no process running; defaults to +t when called interactively." + (interactive (list current-prefix-arg t)) (save-excursion (python-shell-send-region (progn @@ -2620,17 +2864,28 @@ When argument ARG is non-nil do not include decorators." (progn (or (python-nav-end-of-defun) (end-of-line 1)) - (point-marker))))) + (point-marker)) + nil ;; noop + msg))) (defun python-shell-send-file (file-name &optional process temp-file-name - delete) + delete msg) "Send FILE-NAME to inferior Python PROCESS. If TEMP-FILE-NAME is passed then that file is used for processing instead, while internally the shell will continue to use FILE-NAME. If TEMP-FILE-NAME and DELETE are non-nil, then -TEMP-FILE-NAME is deleted after evaluation is performed." - (interactive "fFile to send: ") - (let* ((process (or process (python-shell-get-or-create-process))) +TEMP-FILE-NAME is deleted after evaluation is performed. When +optional argument MSG is non-nil, forces display of a +user-friendly message if there's no process running; defaults to +t when called interactively." + (interactive + (list + (read-file-name "File to send: ") ; file-name + nil ; process + nil ; temp-file-name + nil ; delete + t)) ; msg + (let* ((process (or process (python-shell-get-process-or-error msg))) (encoding (with-temp-buffer (insert-file-contents (or temp-file-name file-name)) @@ -2655,21 +2910,31 @@ TEMP-FILE-NAME is deleted after evaluation is performed." (or temp-file-name file-name) encoding encoding file-name) process))) -(defun python-shell-switch-to-shell () - "Switch to inferior Python process buffer." - (interactive) - (pop-to-buffer (process-buffer (python-shell-get-or-create-process)) t)) +(defun python-shell-switch-to-shell (&optional msg) + "Switch to inferior Python process buffer. +When optional argument MSG is non-nil, forces display of a +user-friendly message if there's no process running; defaults to +t when called interactively." + (interactive "p") + (pop-to-buffer + (process-buffer (python-shell-get-process-or-error msg)) nil t)) (defun python-shell-send-setup-code () "Send all setup code for shell. This function takes the list of setup code to send from the `python-shell-setup-codes' list." - (let ((process (get-buffer-process (current-buffer)))) - (dolist (code python-shell-setup-codes) - (when code - (message "Sent %s" code) - (python-shell-send-string - (symbol-value code) process))))) + (let ((process (python-shell-get-process)) + (code (concat + (mapconcat + (lambda (elt) + (cond ((stringp elt) elt) + ((symbolp elt) (symbol-value elt)) + (t ""))) + python-shell-setup-codes + "\n\n") + "\n\nprint ('python.el: sent setup code')"))) + (python-shell-send-string code process) + (python-shell-accept-process-output process))) (add-hook 'inferior-python-mode-hook #'python-shell-send-setup-code) @@ -2733,85 +2998,272 @@ the full statement in the case of imports." "24.4" "Completion string code must also autocomplete modules.") -(defcustom python-shell-completion-pdb-string-code - "';'.join(globals().keys() + locals().keys())" - "Python code used to get completions separated by semicolons for [i]pdb." - :type 'string - :group 'python) +(define-obsolete-variable-alias + 'python-shell-completion-pdb-string-code + 'python-shell-completion-string-code + "25.1" + "Completion string code must work for (i)pdb.") + +(defcustom python-shell-completion-native-disabled-interpreters + ;; PyPy's readline cannot handle some escape sequences yet. + (list "pypy") + "List of disabled interpreters. +When a match is found, native completion is disabled." + :type '(repeat string)) + +(defcustom python-shell-completion-native-enable t + "Enable readline based native completion." + :type 'boolean) + +(defcustom python-shell-completion-native-output-timeout 0.01 + "Time in seconds to wait for completion output before giving up." + :type 'float) + +(defvar python-shell-completion-native-redirect-buffer + " *Python completions redirect*" + "Buffer to be used to redirect output of readline commands.") + +(defun python-shell-completion-native-interpreter-disabled-p () + "Return non-nil if interpreter has native completion disabled." + (when python-shell-completion-native-disabled-interpreters + (string-match + (regexp-opt python-shell-completion-native-disabled-interpreters) + (file-name-nondirectory python-shell-interpreter)))) + +(defun python-shell-completion-native-try () + "Return non-nil if can trigger native completion." + (let ((python-shell-completion-native-enable t)) + (python-shell-completion-native-get-completions + (get-buffer-process (current-buffer)) + nil "int"))) + +(defun python-shell-completion-native-setup () + "Try to setup native completion, return non-nil on success." + (let ((process (python-shell-get-process))) + (python-shell-send-string + (funcall + 'mapconcat + #'identity + (list + "try:" + " import readline, rlcompleter" + ;; Remove parens on callables as it breaks completion on + ;; arguments (e.g. str(Ari<tab>)). + " class Completer(rlcompleter.Completer):" + " def _callable_postfix(self, val, word):" + " return word" + " readline.set_completer(Completer().complete)" + " if readline.__doc__ and 'libedit' in readline.__doc__:" + " readline.parse_and_bind('bind ^I rl_complete')" + " else:" + " readline.parse_and_bind('tab: complete')" + " print ('python.el: readline is available')" + "except:" + " print ('python.el: readline not available')") + "\n") + process) + (python-shell-accept-process-output process) + (when (save-excursion + (re-search-backward + (regexp-quote "python.el: readline is available") nil t 1)) + (python-shell-completion-native-try)))) + +(defun python-shell-completion-native-turn-off (&optional msg) + "Turn off shell native completions. +With argument MSG show deactivation message." + (interactive "p") + (python-shell-with-shell-buffer + (set (make-local-variable 'python-shell-completion-native-enable) nil) + (when msg + (message "Shell native completion is disabled, using fallback")))) + +(defun python-shell-completion-native-turn-on (&optional msg) + "Turn on shell native completions. +With argument MSG show deactivation message." + (interactive "p") + (python-shell-with-shell-buffer + (set (make-local-variable 'python-shell-completion-native-enable) t) + (python-shell-completion-native-turn-on-maybe msg))) + +(defun python-shell-completion-native-turn-on-maybe (&optional msg) + "Turn on native completions if enabled and available. +With argument MSG show activation/deactivation message." + (interactive "p") + (python-shell-with-shell-buffer + (when python-shell-completion-native-enable + (cond + ((python-shell-completion-native-interpreter-disabled-p) + (python-shell-completion-native-turn-off msg)) + ((python-shell-completion-native-setup) + (when msg + (message "Shell native completion is enabled."))) + (t (lwarn + '(python python-shell-completion-native-turn-on-maybe) + :warning + (concat + "Your `python-shell-interpreter' doesn't seem to " + "support readline, yet `python-shell-completion-native' " + (format "was `t' and %S is not part of the " + (file-name-nondirectory python-shell-interpreter)) + "`python-shell-completion-native-disabled-interpreters' " + "list. Native completions have been disabled locally. ")) + (python-shell-completion-native-turn-off msg)))))) + +(defun python-shell-completion-native-turn-on-maybe-with-msg () + "Like `python-shell-completion-native-turn-on-maybe' but force messages." + (python-shell-completion-native-turn-on-maybe t)) -(defun python-shell-completion-get-completions (process line input) - "Do completion at point for PROCESS. -LINE is used to detect the context on how to complete given INPUT." +(add-hook 'inferior-python-mode-hook + #'python-shell-completion-native-turn-on-maybe-with-msg) + +(defun python-shell-completion-native-toggle (&optional msg) + "Toggle shell native completion. +With argument MSG show activation/deactivation message." + (interactive "p") + (python-shell-with-shell-buffer + (if python-shell-completion-native-enable + (python-shell-completion-native-turn-off msg) + (python-shell-completion-native-turn-on msg)) + python-shell-completion-native-enable)) + +(defun python-shell-completion-native-get-completions (process import input) + "Get completions using native readline for PROCESS. +When IMPORT is non-nil takes precedence over INPUT for +completion." + (when (and python-shell-completion-native-enable + (python-util-comint-last-prompt) + (>= (point) (cdr (python-util-comint-last-prompt)))) + (let* ((input (or import input)) + (original-filter-fn (process-filter process)) + (redirect-buffer (get-buffer-create + python-shell-completion-native-redirect-buffer)) + (separators (python-rx + (or whitespace open-paren close-paren))) + (trigger "\t\t\t") + (new-input (concat input trigger)) + (input-length + (save-excursion + (+ (- (point-max) (comint-bol)) (length new-input)))) + (delete-line-command (make-string input-length ?\b)) + (input-to-send (concat new-input delete-line-command))) + ;; Ensure restoring the process filter, even if the user quits + ;; or there's some other error. + (unwind-protect + (with-current-buffer redirect-buffer + ;; Cleanup the redirect buffer + (delete-region (point-min) (point-max)) + ;; Mimic `comint-redirect-send-command', unfortunately it + ;; can't be used here because it expects a newline in the + ;; command and that's exactly what we are trying to avoid. + (let ((comint-redirect-echo-input nil) + (comint-redirect-verbose nil) + (comint-redirect-perform-sanity-check nil) + (comint-redirect-insert-matching-regexp nil) + ;; Feed it some regex that will never match. + (comint-redirect-finished-regexp "^\\'$") + (comint-redirect-output-buffer redirect-buffer)) + ;; Compatibility with Emacs 24.x. Comint changed and + ;; now `comint-redirect-filter' gets 3 args. This + ;; checks which version of `comint-redirect-filter' is + ;; in use based on its args and uses `apply-partially' + ;; to make it up for the 3 args case. + (if (= (length + (help-function-arglist 'comint-redirect-filter)) 3) + (set-process-filter + process (apply-partially + #'comint-redirect-filter original-filter-fn)) + (set-process-filter process #'comint-redirect-filter)) + (process-send-string process input-to-send) + (accept-process-output + process + python-shell-completion-native-output-timeout) + ;; XXX: can't use `python-shell-accept-process-output' + ;; here because there are no guarantees on how output + ;; ends. The workaround here is to call + ;; `accept-process-output' until we don't find anything + ;; else to accept. + (while (accept-process-output + process + python-shell-completion-native-output-timeout)) + (cl-remove-duplicates + (split-string + (buffer-substring-no-properties + (point-min) (point-max)) + separators t)))) + (set-process-filter process original-filter-fn))))) + +(defun python-shell-completion-get-completions (process import input) + "Do completion at point using PROCESS for IMPORT or INPUT. +When IMPORT is non-nil takes precedence over INPUT for +completion." (with-current-buffer (process-buffer process) (let* ((prompt - ;; Get last prompt of the inferior process buffer (this - ;; intentionally avoids using `comint-last-prompt' because - ;; of incompatibilities with Emacs 24.x). - (save-excursion + (let ((prompt-boundaries (python-util-comint-last-prompt))) (buffer-substring-no-properties - (line-beginning-position) ;End of prompt. - (re-search-backward "^")))) + (car prompt-boundaries) (cdr prompt-boundaries)))) (completion-code ;; Check whether a prompt matches a pdb string, an import ;; statement or just the standard prompt and use the ;; correct python-shell-completion-*-code string - (cond ((and (> (length python-shell-completion-pdb-string-code) 0) - (string-match + (cond ((and (string-match (concat "^" python-shell-prompt-pdb-regexp) prompt)) - python-shell-completion-pdb-string-code) + ;; Since there are no guarantees the user will remain + ;; in the same context where completion code was sent + ;; (e.g. user steps into a function), safeguard + ;; resending completion setup continuously. + (concat python-shell-completion-setup-code + "\nprint (" python-shell-completion-string-code ")")) ((string-match python-shell--prompt-calculated-input-regexp prompt) python-shell-completion-string-code) (t nil))) - (input - (if (string-match - (python-rx line-start (* space) (or "from" "import") space) - line) - line - input))) + (subject (or import input))) (and completion-code (> (length input) 0) (let ((completions (python-util-strip-string (python-shell-send-string-no-output - (format completion-code input) process)))) + (format completion-code subject) process)))) (and (> (length completions) 2) (split-string completions "^'\\|^\"\\|;\\|'$\\|\"$" t))))))) -(defun python-shell-completion-complete-at-point (&optional process) - "Perform completion at point in inferior Python. +(defun python-shell-completion-at-point (&optional process) + "Function for `completion-at-point-functions' in `inferior-python-mode'. Optional argument PROCESS forces completions to be retrieved using that one instead of current buffer's process." (setq process (or process (get-buffer-process (current-buffer)))) - (let* ((start + (let* ((last-prompt-end (cdr (python-util-comint-last-prompt))) + (import-statement + (when (string-match-p + (rx (* space) word-start (or "from" "import") word-end space) + (buffer-substring-no-properties last-prompt-end (point))) + (buffer-substring-no-properties last-prompt-end (point)))) + (start (save-excursion - (with-syntax-table python-dotty-syntax-table - (let* ((paren-depth (car (syntax-ppss))) - (syntax-string "w_") - (syntax-list (string-to-syntax syntax-string))) - ;; Stop scanning for the beginning of the completion - ;; subject after the char before point matches a - ;; delimiter - (while (member - (car (syntax-after (1- (point)))) syntax-list) - (skip-syntax-backward syntax-string) - (when (or (equal (char-before) ?\)) - (equal (char-before) ?\")) - (forward-char -1)) - (while (or - ;; honor initial paren depth - (> (car (syntax-ppss)) paren-depth) - (python-syntax-context 'string)) - (forward-char -1))) - (point))))) - (end (point))) + (if (not (re-search-backward + (python-rx + (or whitespace open-paren close-paren string-delimiter)) + last-prompt-end + t 1)) + last-prompt-end + (forward-char (length (match-string-no-properties 0))) + (point)))) + (end (point)) + (completion-fn + (if python-shell-completion-native-enable + #'python-shell-completion-native-get-completions + #'python-shell-completion-get-completions))) (list start end (completion-table-dynamic (apply-partially - #'python-shell-completion-get-completions - process (buffer-substring-no-properties - (line-beginning-position) end)))))) + completion-fn + process import-statement))))) + +(define-obsolete-function-alias + 'python-shell-completion-complete-at-point + 'python-shell-completion-at-point + "25.1") (defun python-shell-completion-complete-or-indent () "Complete or indent depending on the context. @@ -2820,7 +3272,7 @@ If not try to complete." (interactive) (if (string-match "^[[:space:]]*$" (buffer-substring (comint-line-beginning-position) - (point-marker))) + (point))) (indent-for-tab-command) (completion-at-point))) @@ -2919,18 +3371,19 @@ Argument OUTPUT is a string with the output from the comint process." ;;; Symbol completion -(defun python-completion-complete-at-point () - "Complete current symbol at point. +(defun python-completion-at-point () + "Function for `completion-at-point-functions' in `python-mode'. For this to work as best as possible you should call `python-shell-send-buffer' from time to time so context in inferior Python process is updated properly." (let ((process (python-shell-get-process))) - (if (not process) - (error "Completion needs an inferior Python process running") - (python-shell-completion-complete-at-point process)))) + (when process + (python-shell-completion-at-point process)))) -(add-to-list 'debug-ignored-errors - "^Completion needs an inferior Python process running.") +(define-obsolete-function-alias + 'python-completion-complete-at-point + 'python-completion-at-point + "25.1") ;;; Fill paragraph @@ -3150,8 +3603,7 @@ JUSTIFY should be used (if applicable) as in `fill-paragraph'." (save-restriction (narrow-to-region (progn (while (python-syntax-context 'paren) - (goto-char (1- (point-marker)))) - (point-marker) + (goto-char (1- (point)))) (line-beginning-position)) (progn (when (not (python-syntax-context 'paren)) @@ -3160,8 +3612,8 @@ JUSTIFY should be used (if applicable) as in `fill-paragraph'." (skip-syntax-backward "^)"))) (while (and (python-syntax-context 'paren) (not (eobp))) - (goto-char (1+ (point-marker)))) - (point-marker))) + (goto-char (1+ (point)))) + (point))) (let ((paragraph-start "\f\\|[ \t]*$") (paragraph-separate ",") (fill-paragraph-function)) @@ -3270,6 +3722,12 @@ The skeleton will be bound to python-skeleton-NAME." > _ \n '(python-skeleton--else) | ^) +(python-skeleton-define import nil + "Import from module: " + "from " str & " " | -5 + "import " + ("Identifier: " str ", ") -2 \n _) + (python-skeleton-define try nil nil "try:" \n @@ -3296,7 +3754,7 @@ The skeleton will be bound to python-skeleton-NAME." "class " str "(" ("Inheritance, %s: " (unless (equal ?\( (char-before)) ", ") str) - & ")" | -2 + & ")" | -1 ":" \n "\"\"\"" - "\"\"\"" \n > _ \n) @@ -3401,7 +3859,11 @@ See `python-check-command' for the default." "def __PYDOC_get_help(obj): try: import inspect - if hasattr(obj, 'startswith'): + try: + str_type = basestring + except NameError: + str_type = str + if isinstance(obj, str_type): obj = eval(obj, globals()) doc = inspect.getdoc(obj) if not doc and callable(obj): @@ -3424,10 +3886,7 @@ See `python-check-command' for the default." doc = doc.splitlines()[0] except: doc = '' - try: - exec('print doc') - except SyntaxError: - print(doc)" + print (doc)" "Python code to setup documentation retrieval." :type 'string :group 'python) @@ -3444,8 +3903,7 @@ If not FORCE-INPUT is passed then what `python-info-current-symbol' returns will be used. If not FORCE-PROCESS is passed what `python-shell-get-process' returns is used." (let ((process (or force-process (python-shell-get-process)))) - (if (not process) - (error "Eldoc needs an inferior Python process running") + (when process (let ((input (or force-input (python-info-current-symbol t)))) (and input @@ -3475,9 +3933,6 @@ Interactively, prompt for symbol." nil nil symbol)))) (message (python-eldoc--get-doc-at-point symbol))) -(add-to-list 'debug-ignored-errors - "^Eldoc needs an inferior Python process running.") - ;;; Imenu @@ -3997,6 +4452,18 @@ to \"^python-\"." (cdr pair)))) (buffer-local-variables from-buffer))) +(defvar comint-last-prompt-overlay) ; Shut up, byte compiler. + +(defun python-util-comint-last-prompt () + "Return comint last prompt overlay start and end. +This is for compatibility with Emacs < 24.4." + (cond ((bound-and-true-p comint-last-prompt-overlay) + (cons (overlay-start comint-last-prompt-overlay) + (overlay-end comint-last-prompt-overlay))) + ((bound-and-true-p comint-last-prompt) + comint-last-prompt) + (t nil))) + (defun python-util-forward-comment (&optional direction) "Python mode specific version of `forward-comment'. Optional argument DIRECTION defines the direction to move to." @@ -4008,6 +4475,68 @@ Optional argument DIRECTION defines the direction to move to." (goto-char comment-start)) (forward-comment factor))) +(defun python-util-list-directories (directory &optional predicate max-depth) + "List DIRECTORY subdirs, filtered by PREDICATE and limited by MAX-DEPTH. +Argument PREDICATE defaults to `identity' and must be a function +that takes one argument (a full path) and returns non-nil for +allowed files. When optional argument MAX-DEPTH is non-nil, stop +searching when depth is reached, else don't limit." + (let* ((dir (expand-file-name directory)) + (dir-length (length dir)) + (predicate (or predicate #'identity)) + (to-scan (list dir)) + (tally nil)) + (while to-scan + (let ((current-dir (car to-scan))) + (when (funcall predicate current-dir) + (setq tally (cons current-dir tally))) + (setq to-scan (append (cdr to-scan) + (python-util-list-files + current-dir #'file-directory-p) + nil)) + (when (and max-depth + (<= max-depth + (length (split-string + (substring current-dir dir-length) + "/\\|\\\\" t)))) + (setq to-scan nil)))) + (nreverse tally))) + +(defun python-util-list-files (dir &optional predicate) + "List files in DIR, filtering with PREDICATE. +Argument PREDICATE defaults to `identity' and must be a function +that takes one argument (a full path) and returns non-nil for +allowed files." + (let ((dir-name (file-name-as-directory dir))) + (apply #'nconc + (mapcar (lambda (file-name) + (let ((full-file-name (expand-file-name file-name dir-name))) + (when (and + (not (member file-name '("." ".."))) + (funcall (or predicate #'identity) full-file-name)) + (list full-file-name)))) + (directory-files dir-name))))) + +(defun python-util-list-packages (dir &optional max-depth) + "List packages in DIR, limited by MAX-DEPTH. +When optional argument MAX-DEPTH is non-nil, stop searching when +depth is reached, else don't limit." + (let* ((dir (expand-file-name dir)) + (parent-dir (file-name-directory + (directory-file-name + (file-name-directory + (file-name-as-directory dir))))) + (subpath-length (length parent-dir))) + (mapcar + (lambda (file-name) + (replace-regexp-in-string + (rx (or ?\\ ?/)) "." (substring file-name subpath-length))) + (python-util-list-directories + (directory-file-name dir) + (lambda (dir) + (file-exists-p (expand-file-name "__init__.py" dir))) + max-depth)))) + (defun python-util-popn (lst n) "Return LST first N elements. N should be an integer, when negative its opposite is used. @@ -4024,6 +4553,23 @@ returned as is." n (1- n))) (reverse acc)))) +(defun python-util-text-properties-replace-name + (from to &optional start end) + "Replace properties named FROM to TO, keeping its value. +Arguments START and END narrow the buffer region to work on." + (save-excursion + (goto-char (or start (point-min))) + (while (not (eobp)) + (let ((plist (text-properties-at (point))) + (next-change (or (next-property-change (point) (current-buffer)) + (or end (point-max))))) + (when (plist-get plist from) + (let* ((face (plist-get plist from)) + (plist (plist-put plist from nil)) + (plist (plist-put plist to face))) + (set-text-properties (point) next-change plist (current-buffer)))) + (goto-char next-change))))) + (defun python-util-strip-string (string) "Strip STRING whitespace and newlines from end and beginning." (replace-regexp-in-string @@ -4067,7 +4613,10 @@ returned as is." 'python-nav-forward-sexp) (set (make-local-variable 'font-lock-defaults) - '(python-font-lock-keywords nil nil nil nil)) + '(python-font-lock-keywords + nil nil nil nil + (font-lock-syntactic-face-function + . python-font-lock-syntactic-face-function))) (set (make-local-variable 'syntax-propertize-function) python-syntax-propertize-function) @@ -4076,8 +4625,9 @@ returned as is." #'python-indent-line-function) (set (make-local-variable 'indent-region-function) #'python-indent-region) ;; Because indentation is not redundant, we cannot safely reindent code. - (setq-local electric-indent-inhibit t) - (setq-local electric-indent-chars (cons ?: electric-indent-chars)) + (set (make-local-variable 'electric-indent-inhibit) t) + (set (make-local-variable 'electric-indent-chars) + (cons ?: electric-indent-chars)) ;; Add """ ... """ pairing to electric-pair-mode. (add-hook 'post-self-insert-hook @@ -4093,7 +4643,7 @@ returned as is." #'python-nav-end-of-defun) (add-hook 'completion-at-point-functions - #'python-completion-complete-at-point nil 'local) + #'python-completion-at-point nil 'local) (add-hook 'post-self-insert-hook #'python-indent-post-self-insert-function 'append 'local) @@ -4118,7 +4668,8 @@ returned as is." (add-to-list 'hs-special-modes-alist `(python-mode "^\\s-*\\(?:def\\|class\\)\\>" nil "#" ,(lambda (_arg) - (python-nav-end-of-defun)) nil)) + (python-nav-end-of-defun)) + nil)) (set (make-local-variable 'outline-regexp) (python-rx (* space) block-start)) diff --git a/lisp/progmodes/ruby-mode.el b/lisp/progmodes/ruby-mode.el index 2f23e338f81..bf0884f3560 100644 --- a/lisp/progmodes/ruby-mode.el +++ b/lisp/progmodes/ruby-mode.el @@ -152,6 +152,7 @@ This should only be called after matching against `ruby-here-doc-beg-re'." (define-key map (kbd "M-C-p") 'ruby-beginning-of-block) (define-key map (kbd "M-C-n") 'ruby-end-of-block) (define-key map (kbd "C-c {") 'ruby-toggle-block) + (define-key map (kbd "C-c '") 'ruby-toggle-string-quotes) map) "Keymap used in Ruby mode.") @@ -164,6 +165,8 @@ This should only be called after matching against `ruby-here-doc-beg-re'." ["End of Block" ruby-end-of-block t] ["Toggle Block" ruby-toggle-block t] "--" + ["Toggle String Quotes" ruby-toggle-string-quotes t] + "--" ["Backward Sexp" ruby-backward-sexp :visible (not ruby-use-smie)] ["Backward Sexp" backward-sexp @@ -1763,6 +1766,43 @@ If the result is do-end block, it will always be multiline." (ruby-do-end-to-brace beg end))) (goto-char start)))) +(defun ruby--string-region () + "Return region for string at point." + (let ((state (syntax-ppss))) + (when (memq (nth 3 state) '(?' ?\")) + (save-excursion + (goto-char (nth 8 state)) + (forward-sexp) + (list (nth 8 state) (point)))))) + +(defun ruby-string-at-point-p () + "Check if cursor is at a string or not." + (ruby--string-region)) + +(defun ruby--inverse-string-quote (string-quote) + "Get the inverse string quoting for STRING-QUOTE." + (if (equal string-quote "\"") "'" "\"")) + +(defun ruby-toggle-string-quotes () + "Toggle string literal quoting between single and double." + (interactive) + (when (ruby-string-at-point-p) + (let* ((region (ruby--string-region)) + (min (nth 0 region)) + (max (nth 1 region)) + (string-quote (ruby--inverse-string-quote (buffer-substring-no-properties min (1+ min)))) + (content + (buffer-substring-no-properties (1+ min) (1- max)))) + (setq content + (if (equal string-quote "\"") + (replace-regexp-in-string "\\\\\"" "\"" (replace-regexp-in-string "\\([^\\\\]\\)'" "\\1\\\\'" content)) + (replace-regexp-in-string "\\\\\'" "'" (replace-regexp-in-string "\\([^\\\\]\\)\"" "\\1\\\\\"" content)))) + (let ((orig-point (point))) + (delete-region min max) + (insert + (format "%s%s%s" string-quote content string-quote)) + (goto-char orig-point))))) + (eval-and-compile (defconst ruby-percent-literal-beg-re "\\(%\\)[qQrswWxIi]?\\([[:punct:]]\\)" @@ -2206,9 +2246,10 @@ See `font-lock-syntax-table'.") (add-to-list 'auto-mode-alist (cons (purecopy (concat "\\(?:\\." "rb\\|ru\\|rake\\|thor" - "\\|jbuilder\\|gemspec\\|podspec" + "\\|jbuilder\\|rabl\\|gemspec\\|podspec" "\\|/" "\\(?:Gem\\|Rake\\|Cap\\|Thor" + "\\|Puppet\\|Berks" "\\|Vagrant\\|Guard\\|Pod\\)file" "\\)\\'")) 'ruby-mode)) diff --git a/lisp/progmodes/scheme.el b/lisp/progmodes/scheme.el index 5ad5633fa85..c47a3bd6fbe 100644 --- a/lisp/progmodes/scheme.el +++ b/lisp/progmodes/scheme.el @@ -1,4 +1,4 @@ -;;; scheme.el --- Scheme (and DSSSL) editing mode +;;; scheme.el --- Scheme (and DSSSL) editing mode -*- lexical-binding: t; -*- ;; Copyright (C) 1986-1988, 1997-1998, 2001-2014 Free Software ;; Foundation, Inc. @@ -280,7 +280,9 @@ See `run-hooks'." "\\|-module" "\\)\\)\\>" ;; Any whitespace and declared object. - "[ \t]*(?" + ;; The "(*" is for curried definitions, e.g., + ;; (define ((sum a) b) (+ a b)) + "[ \t]*(*" "\\(\\sw+\\)?") '(1 font-lock-keyword-face) '(6 (cond ((match-beginning 3) font-lock-function-name-face) @@ -491,20 +493,20 @@ indentation." ;;; Let is different in Scheme -(defun would-be-symbol (string) - (not (string-equal (substring string 0 1) "("))) +;; (defun scheme-would-be-symbol (string) +;; (not (string-equal (substring string 0 1) "("))) -(defun next-sexp-as-string () - ;; Assumes that it is protected by a save-excursion - (forward-sexp 1) - (let ((the-end (point))) - (backward-sexp 1) - (buffer-substring (point) the-end))) +;; (defun scheme-next-sexp-as-string () +;; ;; Assumes that it is protected by a save-excursion +;; (forward-sexp 1) +;; (let ((the-end (point))) +;; (backward-sexp 1) +;; (buffer-substring (point) the-end))) ;; This is correct but too slow. ;; The one below works almost always. ;;(defun scheme-let-indent (state indent-point) -;; (if (would-be-symbol (next-sexp-as-string)) +;; (if (scheme-would-be-symbol (scheme-next-sexp-as-string)) ;; (scheme-indent-specform 2 state indent-point) ;; (scheme-indent-specform 1 state indent-point))) diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el index 476c7961be7..904e9dfc289 100644 --- a/lisp/progmodes/sh-script.el +++ b/lisp/progmodes/sh-script.el @@ -237,6 +237,7 @@ (ksh88 . jsh) (oash . sh) (pdksh . ksh88) + (mksh . pdksh) (posix . sh) (tcsh . csh) (wksh . ksh88) @@ -262,6 +263,7 @@ sh Bourne Shell ksh Korn Shell '93 dtksh CDE Desktop Korn Shell pdksh Public Domain Korn Shell + mksh MirOS BSD Korn Shell wksh Window Korn Shell zsh Z Shell oash SCO OA (curses) Shell @@ -271,7 +273,6 @@ sh Bourne Shell :version "24.4" ; added dash :group 'sh-script) - (defcustom sh-alias-alist (append (if (eq system-type 'gnu/linux) '((csh . tcsh) @@ -279,11 +280,20 @@ sh Bourne Shell ;; for the time being '((ksh . ksh88) (bash2 . bash) - (sh5 . sh))) + (sh5 . sh) + ;; Android's system shell + ("^/system/bin/sh$" . mksh))) "Alist for transforming shell names to what they really are. -Use this where the name of the executable doesn't correspond to the type of -shell it really is." - :type '(repeat (cons symbol symbol)) +Use this where the name of the executable doesn't correspond to +the type of shell it really is. Keys are regular expressions +matched against the full path of the interpreter. (For backward +compatibility, keys may also be symbols, which are matched +against the interpreter's basename. The values are symbols +naming the shell." + :type '(repeat (cons (radio + (regexp :tag "Regular expression") + (symbol :tag "Basename")) + (symbol :tag "Shell"))) :group 'sh-script) @@ -387,15 +397,20 @@ the car and cdr are the same symbol.") "Non-nil if `sh-shell-variables' is initialized.") (defun sh-canonicalize-shell (shell) - "Convert a shell name SHELL to the one we should handle it as." - (if (string-match "\\.exe\\'" shell) - (setq shell (substring shell 0 (match-beginning 0)))) - (or (symbolp shell) - (setq shell (intern shell))) - (or (cdr (assq shell sh-alias-alist)) - shell)) - -(defvar sh-shell (sh-canonicalize-shell (file-name-nondirectory sh-shell-file)) + "Convert a shell name SHELL to the one we should handle it as. +SHELL is a full path to the shell interpreter; return a shell +name symbol." + (cl-loop + with shell = (cond ((string-match "\\.exe\\'" shell) + (substring shell 0 (match-beginning 0))) + (t shell)) + with shell-base = (intern (file-name-nondirectory shell)) + for (key . value) in sh-alias-alist + if (and (stringp key) (string-match key shell)) return value + if (eq key shell-base) return value + finally return shell-base)) + +(defvar sh-shell (sh-canonicalize-shell sh-shell-file) "The shell being programmed. This is set by \\[sh-set-shell].") ;;;###autoload(put 'sh-shell 'safe-local-variable 'symbolp) @@ -680,7 +695,7 @@ removed when closing the here document." "jobs" "kill" "let" "local" "popd" "printf" "pushd" "shopt" "source" "suspend" "typeset" "unalias" ;; bash4 - "mapfile" "readarray") + "mapfile" "readarray" "coproc") ;; The next entry is only used for defining the others (bourne sh-append shell @@ -895,7 +910,7 @@ See `sh-feature'.") (:foreground "tan1" )) (t (:weight bold))) - "Face to show a here-document" + "Face to show a here-document." :group 'sh-indentation) ;; These colors are probably icky. It's just a placeholder though. @@ -906,7 +921,7 @@ See `sh-feature'.") (:foreground "magenta")) (t (:weight bold))) - "Face to show quoted execs like ``" + "Face to show quoted execs like `blabla`." :group 'sh-indentation) (define-obsolete-face-alias 'sh-heredoc-face 'sh-heredoc "22.1") (defvar sh-heredoc-face 'sh-heredoc) @@ -1036,13 +1051,11 @@ Point is at the beginning of the next line." "Search for a subshell embedded in a string. Find all the unescaped \" characters within said subshell, remembering that 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 flaky. (when (eq ?\" (nth 3 (syntax-ppss))) ; Check we matched an opening quote. ;; bingo we have a $( or a ` inside a "" (let (;; `state' can be: double-quote, backquote, code. (state (if (eq (char-before) ?`) 'backquote 'code)) + (startpos (point)) ;; Stacked states in the context. (states '(double-quote))) (while (and state (progn (skip-chars-forward "^'\\\\\"`$()" limit) @@ -1073,7 +1086,12 @@ subshells can nest." (`double-quote nil) (_ (setq state (pop states))))) (_ (error "Internal error in sh-font-lock-quoted-subshell"))) - (forward-char 1))))) + (forward-char 1)) + (when (< startpos (line-beginning-position)) + (put-text-property startpos (point) 'syntax-multiline t) + (add-hook 'syntax-propertize-extend-region-functions + 'syntax-propertize-multiline nil t)) + ))) (defun sh-is-quoted-p (pos) @@ -1536,6 +1554,12 @@ When the region is active, send the region instead." ;; mode-command and utility functions +(defun sh-after-hack-local-variables () + (when (assq 'sh-shell file-local-variables-alist) + (sh-set-shell (if (symbolp sh-shell) + (symbol-name sh-shell) + sh-shell)))) + ;;;###autoload (define-derived-mode sh-mode prog-mode "Shell-script" "Major mode for editing shell scripts. @@ -1646,7 +1670,9 @@ with your script for an edit-interpret-debug cycle." ((string-match "[.]csh\\>" buffer-file-name) "csh") ((equal (file-name-nondirectory buffer-file-name) ".profile") "sh") (t sh-shell-file)) - nil nil)) + nil nil) + (add-hook 'hack-local-variables-hook + #'sh-after-hack-local-variables nil t)) ;;;###autoload (defalias 'shell-script-mode 'sh-mode) @@ -2300,9 +2326,7 @@ Calls the value of `sh-set-shell-hook' if set." t)) (if (string-match "\\.exe\\'" shell) (setq shell (substring shell 0 (match-beginning 0)))) - (setq sh-shell (intern (file-name-nondirectory shell)) - sh-shell (or (cdr (assq sh-shell sh-alias-alist)) - sh-shell)) + (setq sh-shell (sh-canonicalize-shell shell)) (if insert-flag (setq sh-shell-file (executable-set-magic shell (sh-feature sh-shell-arg) @@ -2354,7 +2378,7 @@ Calls the value of `sh-set-shell-hook' if set." (when font-lock-mode (setq font-lock-set-defaults nil) (font-lock-set-defaults) - (font-lock-fontify-buffer)) + (font-lock-flush)) (setq sh-shell-process nil) (run-hooks 'sh-set-shell-hook)) diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el index 13d4178116e..e8a95eccdd2 100644 --- a/lisp/progmodes/sql.el +++ b/lisp/progmodes/sql.el @@ -212,11 +212,11 @@ ;; Michael Mauger <michael@mauger.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 ;; Paul Sleigh <bat@flurf.net> -- MySQL keyword enhancement ;; Andrew Schein <andrew@andrewschein.com> -- sql-port bug -;; Ian Bjorhovde <idbjorh@dataproxy.com> -- db2 escape newlines +;; Ian Bjorhovde <idbjorh@dataproxy.com> -- db2 escape newlines ;; incorrectly enabled by default ;; Roman Scherer <roman.scherer@nugg.ad> -- Connection documentation ;; Mark Wilkinson <wilkinsonmr@gmail.com> -- file-local variables ignored @@ -282,6 +282,13 @@ file. Since that is a plaintext file, this could be dangerous." :group 'SQL :safe 'numberp) +(defcustom sql-default-directory nil + "Default directory for SQL processes." + :version "25.1" + :type '(choice (const nil) string) + :group 'SQL + :safe 'stringp) + ;; Login parameter type (define-widget 'sql-login-params 'lazy @@ -498,6 +505,18 @@ file. Since that is a plaintext file, this could be dangerous." :prompt-length 5 :syntax-alist ((?@ . "_")) :terminator ("^go" . "go")) + + (vertica + :name "Vertica" + :sqli-program sql-vertica-program + :sqli-options sql-vertica-options + :sqli-login sql-vertica-login-params + :sqli-comint-func sql-comint-vertica + :list-all ("\\d" . "\\dS") + :list-table "\\d %s" + :prompt-regexp "^\\w*=[#>] " + :prompt-length 5 + :prompt-cont-regexp "^\\w*[-(][#>] ") ) "An alist of product specific configuration settings. @@ -1221,7 +1240,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-n") 'sql-send-line-and-next) (define-key map (kbd "C-c C-i") 'sql-product-interactive) + (define-key map (kbd "C-c C-z") 'sql-show-sqli-buffer) (define-key map (kbd "C-c C-l a") 'sql-list-all) (define-key map (kbd "C-c C-l t") 'sql-list-table) (define-key map [remap beginning-of-defun] 'sql-beginning-of-statement) @@ -1556,8 +1577,6 @@ to add functions and PL/SQL keywords.") ;; Oracle SQL*Plus Commands ;; Only recognized in they start in column 1 and the ;; abbreviation is followed by a space or the end of line. - - "\\|" (list (concat "^" (sql-regexp-abbrev "rem~ark") "\\(?:\\s-.*\\)?$") 0 'font-lock-comment-face t) @@ -1605,6 +1624,11 @@ to add functions and PL/SQL keywords.") 0 'font-lock-doc-face t) '("&?&\\(?:\\sw\\|\\s_\\)+[.]?" 0 font-lock-preprocessor-face t) + ;; Oracle PL/SQL Attributes (Declare these first to match %TYPE correctly) + (sql-font-lock-keywords-builder 'font-lock-builtin-face '("%" . "\\b") +"bulk_exceptions" "bulk_rowcount" "found" "isopen" "notfound" +"rowcount" "rowtype" "type" +) ;; Oracle Functions (sql-font-lock-keywords-builder 'font-lock-builtin-face nil "abs" "acos" "add_months" "appendchildxml" "ascii" "asciistr" "asin" @@ -1634,7 +1658,7 @@ to add functions and PL/SQL keywords.") "prediction" "prediction_bounds" "prediction_cost" "prediction_details" "prediction_probability" "prediction_set" "presentnnv" "presentv" "previous" "rank" "ratio_to_report" "rawtohex" -"rawtonhex" "ref" "reftohex" "regexp_count" "regexp_instr" +"rawtonhex" "ref" "reftohex" "regexp_count" "regexp_instr" "regexp_like" "regexp_replace" "regexp_substr" "regr_avgx" "regr_avgy" "regr_count" "regr_intercept" "regr_r2" "regr_slope" "regr_sxx" "regr_sxy" "regr_syy" "remainder" "replace" "round" "rowidtochar" "rowidtonchar" @@ -1719,7 +1743,7 @@ to add functions and PL/SQL keywords.") "password_life_time" "password_lock_time" "password_reuse_max" "password_reuse_time" "password_verify_function" "pctfree" "pctincrease" "pctthreshold" "pctused" "pctversion" "percent" -"performance" "permanent" "pfile" "physical" "pipelined" "plan" +"performance" "permanent" "pfile" "physical" "pipelined" "pivot" "plan" "post_transaction" "pragma" "prebuilt" "preserve" "primary" "private" "private_sga" "privileges" "procedure" "profile" "protection" "public" "purge" "query" "quiesce" "quota" "range" "read" "reads" "rebuild" @@ -1742,7 +1766,7 @@ to add functions and PL/SQL keywords.") "temporary" "test" "than" "then" "thread" "through" "time_zone" "timeout" "to" "trace" "transaction" "trigger" "triggers" "truncate" "trust" "type" "types" "unarchived" "under" "under_path" "undo" -"uniform" "union" "unique" "unlimited" "unlock" "unquiesce" +"uniform" "union" "unique" "unlimited" "unlock" "unpivot" "unquiesce" "unrecoverable" "until" "unusable" "unused" "update" "upgrade" "usage" "use" "using" "validate" "validation" "value" "values" "variable" "varray" "version" "view" "wait" "when" "whenever" "where" "with" @@ -1757,12 +1781,6 @@ to add functions and PL/SQL keywords.") "time" "timestamp" "urowid" "varchar2" "with" "year" "zone" ) - ;; Oracle PL/SQL Attributes - (sql-font-lock-keywords-builder 'font-lock-builtin-face '("%" . "\\b") -"bulk_exceptions" "bulk_rowcount" "found" "isopen" "notfound" -"rowcount" "rowtype" "type" -) - ;; Oracle PL/SQL Functions (sql-font-lock-keywords-builder 'font-lock-builtin-face nil "delete" "trim" "extend" "exists" "first" "last" "count" "limit" @@ -3050,7 +3068,7 @@ 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) - (user-error "There is no suitable SQLi buffer") + (sql-product-interactive) (let ((new-buffer (read-buffer "New SQLi buffer: " default-buffer t))) (if (null (sql-buffer-live-p new-buffer)) (user-error "Buffer %s is not a working SQLi buffer" new-buffer) @@ -3059,21 +3077,20 @@ If you call it from anywhere else, it sets the global copy of (run-hooks 'sql-set-sqli-hook))))))) (defun sql-show-sqli-buffer () - "Show the name of current SQLi buffer. + "Display the current SQLi buffer. -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." +This is the buffer SQL strings are sent to. +It is stored in the variable `sql-buffer'. +I +See also `sql-help' on how to create such a buffer." (interactive) - (if (or (null sql-buffer) - (null (buffer-live-p (get-buffer sql-buffer)))) - (user-error "%s has no SQLi buffer set" (buffer-name (current-buffer))) - (if (null (get-buffer-process sql-buffer)) - (user-error "Buffer %s has no process" sql-buffer) - (user-error "Current SQLi buffer is %s" sql-buffer)))) + (unless (and sql-buffer (buffer-live-p (get-buffer sql-buffer)) + (get-buffer-process sql-buffer)) + (sql-set-sqli-buffer)) + (display-buffer 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'. @@ -3323,7 +3340,7 @@ to avoid deleting non-prompt output." (setq oline (replace-match "" nil nil oline) sql-output-newline-count (1- sql-output-newline-count) prompt-found t))) - + ;; If we've found all the expected prompts, stop looking (if (= sql-output-newline-count 0) (setq sql-output-newline-count nil @@ -3403,6 +3420,13 @@ to avoid deleting non-prompt output." (interactive) (sql-send-region (point-min) (point-max))) +(defun sql-send-line-and-next () + "Send the current line to the SQL process and go to the next line." + (interactive) + (sql-send-region (line-beginning-position 1) (line-beginning-position 2)) + (beginning-of-line 2) + (while (forward-comment 1))) ; skip all comments and whitespace + (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) @@ -3480,45 +3504,51 @@ list of SQLi command strings." (message "Executing SQL command...done")))) (defun sql-redirect-one (sqlbuf command outbuf save-prior) - (with-current-buffer sqlbuf - (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 - (setq-local view-no-disable-on-exit t) - (read-only-mode -1) - (unless save-prior - (erase-buffer)) - (goto-char (point-max)) - (unless (zerop (buffer-size)) - (insert "\n")) - (setq start (point))) - - (when sql-debug-redirect - (message ">>SQL> %S" command)) - - ;; Run the command - (comint-redirect-send-command-to-process command buf proc nil t) - (while (null comint-redirect-completed) - (accept-process-output nil 1)) - - ;; 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))) - ;; Remove Ctrl-Ms - (goto-char start) - (while (re-search-forward "\r+$" nil t) - (replace-match "" t t)) - (goto-char start))))) + (when command + (with-current-buffer sqlbuf + (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 + (setq-local view-no-disable-on-exit t) + (read-only-mode -1) + (unless save-prior + (erase-buffer)) + (goto-char (point-max)) + (unless (zerop (buffer-size)) + (insert "\n")) + (setq start (point))) + + (when sql-debug-redirect + (message ">>SQL> %S" command)) + + ;; Run the command + (let ((inhibit-quit t) + comint-preoutput-filter-functions) + (with-local-quit + (comint-redirect-send-command-to-process command buf proc nil t) + (while (or quit-flag (null comint-redirect-completed)) + (accept-process-output nil 1))) + + (if quit-flag + (comint-redirect-cleanup) + ;; 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))) + ;; Remove Ctrl-Ms + (goto-char start) + (while (re-search-forward "\r+$" nil t) + (replace-match "" t t)) + (goto-char start)))))))) (defun sql-redirect-value (sqlbuf command regexp &optional regexp-groups) "Execute the SQL command and return part of result. @@ -3589,7 +3619,7 @@ buffer is popped into a view window." (apply c sqlbuf outbuf enhanced arg nil)) (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) @@ -3597,7 +3627,11 @@ buffer is popped into a view window." (get-lru-window)))) (with-current-buffer outbuf (set-buffer-modified-p nil) - (read-only-mode +1)) + (setq-local revert-buffer-function + (lambda (_ignore-auto _noconfirm) + (sql-execute sqlbuf (buffer-name outbuf) + command enhanced arg))) + (special-mode)) (pop-to-buffer outbuf) (when one-win (shrink-window-if-larger-than-buffer))))) @@ -3755,7 +3789,9 @@ must tell Emacs. Here's how to do that in your init file: \(add-hook 'sql-mode-hook (lambda () (modify-syntax-entry ?\\\\ \".\" sql-mode-syntax-table)))" + :group 'SQL :abbrev-table sql-mode-abbrev-table + (if sql-mode-menu (easy-menu-add sql-mode-menu)); XEmacs @@ -3786,6 +3822,7 @@ must tell Emacs. Here's how to do that in your init file: ;;; SQL interactive mode (put 'sql-interactive-mode 'mode-class 'special) +(put 'sql-interactive-mode 'custom-mode-group 'SQL) (defun sql-interactive-mode () "Major mode to use a SQL interpreter interactively. @@ -3928,11 +3965,10 @@ you entered, right above the output it created. ;; People wanting a different history file for each ;; buffer/process/client/whatever can change separator and file-name ;; on the sql-interactive-mode-hook. - (setq-local comint-input-ring-separator sql-input-ring-separator) - (setq comint-input-ring-file-name sql-input-ring-file-name) - ;; Calling the hook before calling comint-read-input-ring allows users - ;; to set comint-input-ring-file-name in sql-interactive-mode-hook. - (comint-read-input-ring t)) + (let + ((comint-input-ring-separator sql-input-ring-separator) + (comint-input-ring-file-name sql-input-ring-file-name)) + (comint-read-input-ring t))) (defun sql-stop (process event) "Called when the SQL process is stopped. @@ -3942,11 +3978,15 @@ Writes the input history to a history file using This function is a sentinel watching the SQL interpreter process. Sentinels will always get the two parameters PROCESS and EVENT." - (comint-write-input-ring) - (if (and (eq (current-buffer) sql-buffer) - (not buffer-read-only)) - (insert (format "\nProcess %s %s\n" process event)) - (message "Process %s %s" process event))) + (with-current-buffer (process-buffer process) + (let + ((comint-input-ring-separator sql-input-ring-separator) + (comint-input-ring-file-name sql-input-ring-file-name)) + (comint-write-input-ring)) + + (if (not buffer-read-only) + (insert (format "\nProcess %s %s\n" process event)) + (message "Process %s %s" process event)))) @@ -4164,7 +4204,9 @@ the call to \\[sql-product-interactive] with (sql-password (default-value 'sql-password)) (sql-server (default-value 'sql-server)) (sql-database (default-value 'sql-database)) - (sql-port (default-value 'sql-port))) + (sql-port (default-value 'sql-port)) + (default-directory (or sql-default-directory + default-directory))) (funcall (sql-get-product-feature product :sqli-comint-func) product (sql-get-product-feature product :sqli-options))) @@ -5039,6 +5081,46 @@ buffer. +(defcustom sql-vertica-program "vsql" + "Command to start the Vertica client." + :version "25.1" + :type 'file + :group 'SQL) + +(defcustom sql-vertica-options '("-P" "pager=off") + "List of additional options for `sql-vertica-program'. +The default value disables the internal pager." + :version "25.1" + :type '(repeat string) + :group 'SQL) + +(defcustom sql-vertica-login-params '(user password database server) + "List of login parameters needed to connect to Vertica." + :version "25.1" + :type 'sql-login-params + :group 'SQL) + +(defun sql-comint-vertica (product options) + "Create comint buffer and connect to Vertica." + (sql-comint product + (nconc + (and (not (string= "" sql-server)) + (list "-h" sql-server)) + (and (not (string= "" sql-database)) + (list "-d" sql-database)) + (and (not (string= "" sql-password)) + (list "-w" sql-password)) + (and (not (string= "" sql-user)) + (list "-U" sql-user)) + options))) + +;;;###autoload +(defun sql-vertica (&optional buffer) + "Run vsql as an inferior process." + (interactive "P") + (sql-product-interactive 'vertica buffer)) + + (provide 'sql) ;;; sql.el ends here diff --git a/lisp/progmodes/subword.el b/lisp/progmodes/subword.el index f9efa3732c7..e49037e41e7 100644 --- a/lisp/progmodes/subword.el +++ b/lisp/progmodes/subword.el @@ -1,4 +1,4 @@ -;;; subword.el --- Handling capitalized subwords in a nomenclature +;;; subword.el --- Handling capitalized subwords in a nomenclature -*- lexical-binding: t -*- ;; Copyright (C) 2004-2014 Free Software Foundation, Inc. @@ -21,13 +21,10 @@ ;;; Commentary: -;; This package was cc-submode.el before it was recognized being -;; useful in general and not tied to C and c-mode at all. - -;; This package provides `subword' oriented commands and a minor mode -;; (`subword-mode') that substitutes the common word handling -;; functions with them. It also provides the `superword-mode' minor -;; mode that treats symbols as words, the opposite of `subword-mode'. +;; This package provides the `subword' minor mode, which merges the +;; old remap-based subword.el (derived from cc-mode code) and +;; cap-words.el, which takes advantage of core Emacs +;; word-motion-customization functionality. ;; In spite of GNU Coding Standards, it is popular to name a symbol by ;; mixing uppercase and lowercase letters, e.g. "GtkWidget", @@ -47,25 +44,6 @@ ;; words. You also get a mode to treat symbols as words instead, ;; called `superword-mode' (the opposite of `subword-mode'). -;; In the minor mode, all common key bindings for word oriented -;; commands are overridden by the subword oriented commands: - -;; Key Word oriented command Subword oriented command (also superword) -;; ============================================================ -;; M-f `forward-word' `subword-forward' -;; M-b `backward-word' `subword-backward' -;; M-@ `mark-word' `subword-mark' -;; M-d `kill-word' `subword-kill' -;; M-DEL `backward-kill-word' `subword-backward-kill' -;; M-t `transpose-words' `subword-transpose' -;; M-c `capitalize-word' `subword-capitalize' -;; M-u `upcase-word' `subword-upcase' -;; M-l `downcase-word' `subword-downcase' -;; -;; Note: If you have changed the key bindings for the word oriented -;; commands in your .emacs or a similar place, the keys you've changed -;; to are also used for the corresponding subword oriented commands. - ;; To make the mode turn on automatically, put the following code in ;; your .emacs: ;; @@ -102,27 +80,25 @@ "Regexp used by `subword-backward-internal'.") (defvar subword-mode-map - (let ((map (make-sparse-keymap))) - (dolist (cmd '(forward-word backward-word mark-word kill-word - backward-kill-word transpose-words - capitalize-word upcase-word downcase-word - left-word right-word)) - (let ((othercmd (let ((name (symbol-name cmd))) - (string-match "\\([[:alpha:]-]+\\)-word[s]?" name) - (intern (concat "subword-" (match-string 1 name)))))) - (define-key map (vector 'remap cmd) othercmd))) - map) + ;; We originally remapped motion keys here, but now use Emacs core + ;; hooks. Leave this keymap around so that user additions to it + ;; keep working. + (make-sparse-keymap) "Keymap used in `subword-mode' minor mode.") ;;;###autoload +(define-obsolete-function-alias + 'capitalized-words-mode 'subword-mode "25.1") + +;;;###autoload (define-minor-mode subword-mode "Toggle subword movement and editing (Subword mode). With a prefix argument ARG, enable Subword mode if ARG is positive, and disable it otherwise. If called from Lisp, enable the mode if ARG is omitted or nil. -Subword mode is a buffer-local minor mode. Enabling it remaps -word-based editing commands to subword-based commands that handle +Subword mode is a buffer-local minor mode. Enabling it changes +the definition of a word so that word-based commands stop inside symbols with mixed uppercase and lowercase letters, e.g. \"GtkWidget\", \"EmacsFrameClass\", \"NSGraphicsContext\". @@ -136,13 +112,13 @@ called a `subword'. Here are some examples: EmacsFrameClass => \"Emacs\", \"Frame\" and \"Class\" NSGraphicsContext => \"NS\", \"Graphics\" and \"Context\" -The subword oriented commands activated in this minor mode recognize -subwords in a nomenclature to move between subwords and to edit them -as words. +This mode changes the definition of a word so that word commands +treat nomenclature boundaries as word boundaries. \\{subword-mode-map}" :lighter " ," - (when subword-mode (superword-mode -1))) + (when subword-mode (superword-mode -1)) + (subword-setup-buffer)) (define-obsolete-function-alias 'c-subword-mode 'subword-mode "23.2") @@ -151,6 +127,13 @@ as words. (lambda () (subword-mode 1)) :group 'convenience) +;; N.B. These commands aren't used unless explicitly invoked; they're +;; here for compatibility. Today, subword-mode leaves motion commands +;; alone and uses `find-word-boundary-function-table' to change how +;; `forward-word' and other low-level commands detect word boundaries. +;; This way, all word-related activities, not just the images we +;; imagine here, get subword treatment. + (defun subword-forward (&optional arg) "Do the same as `forward-word' but on subwords. See the command `subword-mode' for a description of subwords. @@ -159,10 +142,10 @@ Optional argument ARG is the same as for `forward-word'." (unless arg (setq arg 1)) (cond ((< 0 arg) - (dotimes (i arg (point)) + (dotimes (_i arg (point)) (funcall subword-forward-function))) ((> 0 arg) - (dotimes (i (- arg) (point)) + (dotimes (_i (- arg) (point)) (funcall subword-backward-function))) (t (point)))) @@ -262,7 +245,7 @@ Optional argument ARG is the same as for `capitalize-word'." (start (point)) (advance (>= arg 0))) - (dotimes (i count) + (dotimes (_i count) (if advance (progn (re-search-forward "[[:alpha:]]") @@ -290,17 +273,15 @@ With a prefix argument ARG, enable Superword mode if ARG is positive, and disable it otherwise. If called from Lisp, enable the mode if ARG is omitted or nil. -Superword mode is a buffer-local minor mode. Enabling it remaps -word-based editing commands to superword-based commands that -treat symbols as words, e.g. \"this_is_a_symbol\". - -The superword oriented commands activated in this minor mode -recognize symbols as superwords to move between superwords and to -edit them as words. +Superword mode is a buffer-local minor mode. Enabling it changes +the definition of words such that symbols characters are treated +as parts of words: e.g., in `superword-mode', +\"this_is_a_symbol\" counts as one word. \\{superword-mode-map}" :lighter " ²" - (when superword-mode (subword-mode -1))) + (when superword-mode (subword-mode -1)) + (subword-setup-buffer)) ;;;###autoload (define-global-minor-mode global-superword-mode superword-mode @@ -347,9 +328,45 @@ edit them as words. (1+ (match-beginning 0))))) (backward-word 1)))) +(defconst subword-find-word-boundary-function-table + (let ((tab (make-char-table nil))) + (set-char-table-range tab t #'subword-find-word-boundary) + tab) + "Assigned to `find-word-boundary-function-table' in +`subword-mode' and `superword-mode'; defers to +`subword-find-word-boundary'.") + +(defconst subword-empty-char-table + (make-char-table nil) + "Assigned to `find-word-boundary-function-table' while we're +searching subwords in order to avoid unwanted reentrancy.") + +(defun subword-setup-buffer () + (set (make-local-variable 'find-word-boundary-function-table) + (if (or subword-mode superword-mode) + subword-find-word-boundary-function-table + subword-empty-char-table))) + +(defun subword-find-word-boundary (pos limit) + "Catch-all handler in `subword-find-word-boundary-function-table'." + (let ((find-word-boundary-function-table subword-empty-char-table)) + (save-match-data + (save-excursion + (save-restriction + (if (< pos limit) + (progn + (goto-char pos) + (narrow-to-region (point-min) limit) + (funcall subword-forward-function)) + (goto-char (1+ pos)) + (narrow-to-region limit (point-max)) + (funcall subword-backward-function)) + (point)))))) + (provide 'subword) (provide 'superword) +(provide 'cap-words) ; Obsolete alias ;;; subword.el ends here diff --git a/lisp/progmodes/vera-mode.el b/lisp/progmodes/vera-mode.el index 069e7119b90..6a88c6ff0ab 100644 --- a/lisp/progmodes/vera-mode.el +++ b/lisp/progmodes/vera-mode.el @@ -138,7 +138,6 @@ If nil, TAB always indents current line." (define-key map "\C-c\t" 'indent-according-to-mode) (define-key map "\M-\C-\\" 'vera-indent-region) (define-key map "\C-c\C-c" 'vera-comment-uncomment-region) - (define-key map "\C-c\C-f" 'vera-fontify-buffer) (define-key map "\C-c\C-v" 'vera-version) (define-key map "\M-\t" 'tab-to-tab-stop) ;; Electric key bindings. @@ -172,8 +171,6 @@ If nil, TAB always indents current line." ["Indent Region" vera-indent-region (mark)] ["Indent Buffer" vera-indent-buffer t] "--" - ["Fontify Buffer" vera-fontify-buffer t] - "--" ["Documentation" describe-mode] ["Version" vera-version t] ["Bug Report..." vera-submit-bug-report t] @@ -686,7 +683,8 @@ Adapted from `font-lock-match-c-style-declaration-item-and-skip-to-next'." "Font lock mode face used to highlight interface names." :group 'font-lock-highlighting-faces) -(defalias 'vera-fontify-buffer 'font-lock-fontify-buffer) +(define-obsolete-function-alias 'vera-fontify-buffer + 'font-lock-fontify-buffer "25.1") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Indentation diff --git a/lisp/progmodes/verilog-mode.el b/lisp/progmodes/verilog-mode.el index 84d7c15f76c..e7fcf223bc1 100644 --- a/lisp/progmodes/verilog-mode.el +++ b/lisp/progmodes/verilog-mode.el @@ -123,7 +123,7 @@ ;;; Code: ;; This variable will always hold the version number of the mode -(defconst verilog-mode-version "2013-11-05-78e66ba-vpo" +(defconst verilog-mode-version "2014-11-12-aa4b777-vpo" "Version of this Verilog mode.") (defconst verilog-mode-release-emacs t "If non-nil, this version of Verilog mode was released with Emacs itself.") @@ -1020,6 +1020,20 @@ SystemVerilog designs." :type 'string) (put 'verilog-assignment-delay 'safe-local-variable 'stringp) +(defcustom verilog-auto-arg-format 'packed + "Formatting to use for AUTOARG signal names. +If 'packed', then as many inputs and outputs that fit within +`fill-column' will be put onto one line. + +If 'single', then a single input or output will be put onto each +line." + :version "25.1" + :type '(radio (const :tag "Line up Assignments and Declarations" packed) + (const :tag "Line up Assignment statements" single)) + :group 'verilog-mode-auto) +(put 'verilog-auto-arg-format 'safe-local-variable + '(lambda (x) (memq x '(packed single)))) + (defcustom verilog-auto-arg-sort nil "Non-nil means AUTOARG signal names will be sorted, not in declaration order. Declaration order is advantageous with order based instantiations @@ -1460,6 +1474,8 @@ If set will become buffer local.") :help "Help on AUTOINPUT - adding inputs from cells"] ["AUTOINSERTLISP" (describe-function 'verilog-auto-insert-lisp) :help "Help on AUTOINSERTLISP - insert text from a lisp function"] + ["AUTOINSERTLAST" (describe-function 'verilog-auto-insert-last) + :help "Help on AUTOINSERTLISPLAST - insert text from a lisp function"] ["AUTOINST" (describe-function 'verilog-auto-inst) :help "Help on AUTOINST - adding pins for cells"] ["AUTOINST (.*)" (describe-function 'verilog-auto-star) @@ -1634,7 +1650,7 @@ will break, as the o's continuously replace. xa -> x works ok though." string)) (defsubst verilog-re-search-forward (REGEXP BOUND NOERROR) - ; checkdoc-params: (REGEXP BOUND NOERROR) + ;; checkdoc-params: (REGEXP BOUND NOERROR) "Like `re-search-forward', but skips over match in comments or strings." (let ((mdata '(nil nil))) ;; So match-end will return nil if no matches found (while (and @@ -1650,7 +1666,7 @@ will break, as the o's continuously replace. xa -> x works ok though." (match-end 0))) (defsubst verilog-re-search-backward (REGEXP BOUND NOERROR) - ; checkdoc-params: (REGEXP BOUND NOERROR) + ;; checkdoc-params: (REGEXP BOUND NOERROR) "Like `re-search-backward', but skips over match in comments or strings." (let ((mdata '(nil nil))) ;; So match-end will return nil if no matches found (while (and @@ -1679,7 +1695,7 @@ so there may be a large up front penalty for the first search." pt)) (defsubst verilog-re-search-backward-quick (regexp bound noerror) - ; checkdoc-params: (REGEXP BOUND NOERROR) + ;; checkdoc-params: (REGEXP BOUND NOERROR) "Like `verilog-re-search-backward', including use of REGEXP BOUND and NOERROR, but trashes match data and is faster for REGEXP that doesn't match often. This uses `verilog-scan' and text properties to ignore comments, @@ -1748,6 +1764,7 @@ To call on \\[verilog-auto], set `verilog-auto-delete-trailing-whitespace'." (unless (bolp) (insert "\n")))) (defvar compile-command) +(defvar create-lockfiles) ;; Emacs 24 ;; compilation program (defun verilog-set-compile-command () @@ -2250,7 +2267,11 @@ find the errors." ;; "\\(assert\\|assume\\|cover\\)\\s-+property\\>" (defconst verilog-no-indent-begin-re - "\\<\\(if\\|else\\|while\\|for\\|repeat\\|always\\|always_comb\\|always_ff\\|always_latch\\)\\>") + (eval-when-compile + (verilog-regexp-words + '("always" "always_comb" "always_ff" "always_latch" "initial" "final" ;; procedural blocks + "if" "else" ;; conditional statements + "while" "for" "foreach" "repeat" "do" "forever" )))) ;; loop statements (defconst verilog-ends-re ;; Parenthesis indicate type of keyword found @@ -2308,6 +2329,7 @@ find the errors." "endinterface" "endpackage" "endsequence" + "endproperty" "endspecify" "endtable" "endtask" @@ -2340,6 +2362,7 @@ find the errors." "\\(program\\)\\|" ; 13 "\\(sequence\\)\\|" ; 14 "\\(clocking\\)\\|" ; 15 + "\\(property\\)\\|" ; 16 "\\)\\>\\)")) (defconst verilog-end-block-re (eval-when-compile @@ -2404,7 +2427,7 @@ find the errors." "\\(\\<package\\>\\)\\|" "\\(\\<final\\>\\)\\|" "\\(@\\)\\|" - "\\(\\<while\\>\\)\\|" + "\\(\\<while\\>\\)\\|\\(\\<do\\>\\)\\|" "\\(\\<for\\(ever\\|each\\)?\\>\\)\\|" "\\(\\<repeat\\>\\)\\|\\(\\<wait\\>\\)\\|" "#")) @@ -2498,15 +2521,20 @@ find the errors." "join" "join_any" "join_none" "end" "endcase" - "endconfig" + "endchecker" "endclass" "endclocking" + "endconfig" "endfunction" "endgenerate" + "endgroup" "endmodule" "endprimitive" "endinterface" "endpackage" + "endprogram" + "endproperty" + "endsequence" "endspecify" "endtable" "endtask" ) @@ -2704,9 +2732,9 @@ find the errors." (defconst verilog-disable-fork-re "\\(disable\\|wait\\)\\s-+fork\\>") (defconst verilog-extended-case-re "\\(\\(unique0?\\s-+\\|priority\\s-+\\)?case[xz]?\\)") (defconst verilog-extended-complete-re - (concat "\\(\\(\\<extern\\s-+\\|\\<\\(\\<pure\\>\\s-+\\)?virtual\\s-+\\|\\<protected\\s-+\\)*\\(\\<function\\>\\|\\<task\\>\\)\\)" + (concat "\\(\\(\\<extern\\s-+\\|\\<\\(\\<\\(pure\\|context\\)\\>\\s-+\\)?virtual\\s-+\\|\\<protected\\s-+\\)*\\(\\<function\\>\\|\\<task\\>\\)\\)" "\\|\\(\\(\\<typedef\\>\\s-+\\)*\\(\\<struct\\>\\|\\<union\\>\\|\\<class\\>\\)\\)" - "\\|\\(\\(\\<import\\>\\s-+\\)?\\(\"DPI-C\"\\s-+\\)?\\(\\<pure\\>\\s-+\\)?\\(function\\>\\|task\\>\\)\\)" + "\\|\\(\\(\\<import\\>\\s-+\\)?\\(\"DPI-C\"\\s-+\\)?\\(\\<\\(pure\\|context\\)\\>\\s-+\\)?\\([A-Za-z_][A-Za-z0-9_]*\\s-+=\\s-+\\)?\\(function\\>\\|task\\>\\)\\)" "\\|" verilog-extended-case-re )) (defconst verilog-basic-complete-re (eval-when-compile @@ -2736,10 +2764,45 @@ find the errors." "String used to mark end of excluded text.") (defconst verilog-preprocessor-re (eval-when-compile - (verilog-regexp-words - `( - "`define" "`include" "`ifdef" "`ifndef" "`if" "`endif" "`else" - )))) + (concat + ;; single words + "\\(?:" + (verilog-regexp-words + `("`__FILE__" + "`__LINE__" + "`celldefine" + "`else" + "`end_keywords" + "`endcelldefine" + "`endif" + "`nounconnected_drive" + "`resetall" + "`unconnected_drive" + "`undefineall")) + "\\)\\|\\(?:" + ;; two words: i.e. `ifdef DEFINE + "\\<\\(`elsif\\|`ifn?def\\|`undef\\|`default_nettype\\|`begin_keywords\\)\\>\\s-" + "\\)\\|\\(?:" + ;; `line number "filename" level + "\\<\\(`line\\)\\>\\s-+[0-9]+\\s-+\"[^\"]+\"\\s-+[012]" + "\\)\\|\\(?:" + ;;`include "file" or `include <file> + "\\<\\(`include\\)\\>\\s-+\\(?:\"[^\"]+\"\\|<[^>]+>\\)" + "\\)\\|\\(?:" + ;; `pragma <stuff> (no mention in IEEE 1800-2012 that pragma can span multiple lines + "\\<\\(`pragma\\)\\>\\s-+.+$" + "\\)\\|\\(?:" + ;; `timescale time_unit / time_precision + "\\<\\(`timescale\\)\\>\\s-+10\\{0,2\\}\\s-*[munpf]?s\\s-*\\/\\s-*10\\{0,2\\}\\s-*[munpf]?s" + "\\)\\|\\(?:" + ;; `define and `if can span multiple lines if line ends in '\'. NOTE: `if is not IEEE 1800-2012 + ;; from http://www.emacswiki.org/emacs/MultilineRegexp + (concat "\\<\\(`define\\|`if\\)\\>" ;; directive + "\\s-+" ;; separator + "\\(.*\\(?:\n.*\\)*?\\)" ;; definition: to tend of line, the maybe more lines (excludes any trailing \n) + "\\(?:\n\\s-*\n\\|\\'\\)") ;; blank line or EOF + "\\)" + ))) (defconst verilog-keywords '( "`case" "`default" "`define" "`else" "`endfor" "`endif" @@ -2788,8 +2851,8 @@ find the errors." "sync_reject_on" "unique0" "until" "until_with" "untyped" "weak" ;; 1800-2012 "implements" "interconnect" "nettype" "soft" - ) - "List of Verilog keywords.") + ) + "List of Verilog keywords.") (defconst verilog-comment-start-regexp "//\\|/\\*" "Dual comment value for `comment-start-regexp'.") @@ -2906,7 +2969,7 @@ See also `verilog-font-lock-extra-types'.") '( "and" "bit" "buf" "bufif0" "bufif1" "cmos" "defparam" "event" "genvar" "inout" "input" "integer" "localparam" - "logic" "mailbox" "nand" "nmos" "not" "notif0" "notif1" "or" + "logic" "mailbox" "nand" "nmos" "nor" "not" "notif0" "notif1" "or" "output" "parameter" "pmos" "pull0" "pull1" "pulldown" "pullup" "rcmos" "real" "realtime" "reg" "rnmos" "rpmos" "rtran" "rtranif0" "rtranif1" "semaphore" "signed" "struct" "supply" @@ -3332,9 +3395,9 @@ Use filename, if current buffer being edited shorten to just buffer name." (verilog-re-search-backward reg nil 'move)) (cond ((match-end 1) ; matched verilog-end-block-re - ; try to leap back to matching outward block by striding across - ; indent level changing tokens then immediately - ; previous line governs indentation. + ;; try to leap back to matching outward block by striding across + ;; indent level changing tokens then immediately + ;; previous line governs indentation. (verilog-leap-to-head)) ((match-end 2) ; else, we're in deep (setq elsec (1+ elsec))) @@ -3992,7 +4055,7 @@ This puts the mark at the end, and point at the beginning." (mark-defun))) (defun verilog-comment-region (start end) - ; checkdoc-params: (start end) + ;; checkdoc-params: (start end) "Put the region into a Verilog comment. The comments that are in this area are \"deformed\": `*)' becomes `!(*' and `}' becomes `!{'. @@ -4106,9 +4169,7 @@ Uses `verilog-scan' cache." (while (and (> (marker-position e) (point)) (verilog-re-search-forward - (concat - "\\<end\\(\\(function\\)\\|\\(task\\)\\|\\(module\\)\\|\\(primitive\\)\\|\\(interface\\)\\|\\(package\\)\\|\\(case\\)\\)?\\>" - "\\|\\(`endif\\)\\|\\(`else\\)") + verilog-auto-end-comment-lines-re nil 'move)) (goto-char (match-beginning 0)) (let ((indent-str (verilog-indent-line))) @@ -4137,45 +4198,47 @@ Uses `verilog-scan' cache." ;; or the token before us unambiguously ends a statement, ;; then move back a token and test again. (not (or - ;; stop if beginning of buffer - (bolp) - ;; stop if we find a ; + ;; stop if beginning of buffer + (bobp) + ;; stop if we find a ; (= (preceding-char) ?\;) - ;; stop if we see a named coverpoint + ;; stop if we see a named coverpoint (looking-at "\\w+\\W*:\\W*\\(coverpoint\\|cross\\|constraint\\)") - ;; keep going if we are in the middle of a word + ;; keep going if we are in the middle of a word (not (or (looking-at "\\<") (forward-word -1))) - ;; stop if we see an assertion (perhaps labeled) + ;; stop if we see an assertion (perhaps labeled) (and (looking-at "\\(\\<\\(assert\\|assume\\|cover\\)\\>\\s-+\\<property\\>\\)\\|\\(\\<assert\\>\\)") (progn - (setq h (point)) - (save-excursion - (verilog-backward-token) - (if (looking-at verilog-label-re) - (setq h (point)))) - (goto-char h))) - ;; stop if we see an extended complete reg, perhaps a complete one + (setq h (point)) + (save-excursion + (verilog-backward-token) + (if (looking-at verilog-label-re) + (setq h (point)))) + (goto-char h))) + ;; stop if we see an extended complete reg, perhaps a complete one (and - (looking-at verilog-complete-reg) - (let* ((p (point))) - (while (and (looking-at verilog-extended-complete-re) - (progn (setq p (point)) - (verilog-backward-token) - (/= p (point))))) - (goto-char p))) - ;; stop if we see a complete reg (previous found extended ones) + (looking-at verilog-complete-reg) + (let* ((p (point))) + (while (and (looking-at verilog-extended-complete-re) + (progn (setq p (point)) + (verilog-backward-token) + (/= p (point))))) + (goto-char p))) + ;; stop if we see a complete reg (previous found extended ones) (looking-at verilog-basic-complete-re) - ;; stop if previous token is an ender + ;; stop if previous token is an ender (save-excursion - (verilog-backward-token) - (or - (looking-at verilog-end-block-re) - (looking-at verilog-preprocessor-re))))) ;; end of test - (verilog-backward-syntactic-ws) - (verilog-backward-token)) + (verilog-backward-token) + (looking-at verilog-end-block-re)))) + (verilog-backward-syntactic-ws) + (verilog-backward-token)) ;; Now point is where the previous line ended. - (verilog-forward-syntactic-ws))) + (verilog-forward-syntactic-ws) + ;; Skip forward over any preprocessor directives, as they have wacky indentation + (if (looking-at verilog-preprocessor-re) + (progn (goto-char (match-end 0)) + (verilog-forward-syntactic-ws))))) (defun verilog-beg-of-statement-1 () "Move backward to beginning of statement." @@ -4189,13 +4252,12 @@ Uses `verilog-scan' cache." (verilog-backward-syntactic-ws) (if (or (bolp) (= (preceding-char) ?\;) - (save-excursion + (progn (verilog-backward-token) (looking-at verilog-ends-re))) (progn (goto-char pt) - (throw 'done t)) - (verilog-backward-token)))) + (throw 'done t))))) (verilog-forward-syntactic-ws))) ; ; (while (and @@ -4223,7 +4285,7 @@ Uses `verilog-scan' cache." ((equal (char-after) ?\}) (forward-char)) - ;; Skip to end of statement + ;; Skip to end of statement ((condition-case nil (setq pos (catch 'found @@ -4285,7 +4347,7 @@ More specifically, point @ in the line foo : @ begin" (setq nest (1+ nest))) ((match-end 2) (if (= nest 1) - (throw 'found 1)) + (throw 'found 1)) (setq nest (1- nest))) (t (throw 'found (= nest 0))))))) @@ -4430,6 +4492,7 @@ Limit search to point LIM." "\\(`ifdef\\>\\)\\|" "\\(`ifndef\\>\\)\\|" "\\(`elsif\\>\\)")) + (defun verilog-set-auto-endcomments (indent-str kill-existing-comment) "Add ending comment with given INDENT-STR. With KILL-EXISTING-COMMENT, remove what was there before. @@ -4752,10 +4815,10 @@ primitive or interface named NAME." (cond ((match-end 5) ;; of verilog-end-block-ordered-re (setq reg "\\(\\<function\\>\\)\\|\\(\\<\\(endfunction\\|task\\|\\(macro\\)?module\\|primitive\\)\\>\\)") - (setq name-re "\\w+\\s-*(")) + (setq name-re "\\w+\\(?:\n\\|\\s-\\)*[(;]")) ((match-end 6) ;; of verilog-end-block-ordered-re (setq reg "\\(\\<task\\>\\)\\|\\(\\<\\(endtask\\|function\\|\\(macro\\)?module\\|primitive\\)\\>\\)") - (setq name-re "\\w+\\s-*(")) + (setq name-re "\\w+\\(?:\n\\|\\s-\\)*[(;]")) ((match-end 7) ;; of verilog-end-block-ordered-re (setq reg "\\(\\<\\(macro\\)?module\\>\\)\\|\\<endmodule\\>")) ((match-end 8) ;; of verilog-end-block-ordered-re @@ -4774,6 +4837,8 @@ primitive or interface named NAME." (setq reg "\\(\\<\\(rand\\)?sequence\\>\\)\\|\\(\\<\\(endsequence\\|primitive\\|interface\\|\\(macro\\)?module\\)\\>\\)")) ((match-end 15) ;; of verilog-end-block-ordered-re (setq reg "\\(\\<clocking\\>\\)\\|\\<endclocking\\>")) + ((match-end 16) ;; of verilog-end-block-ordered-re + (setq reg "\\(\\<property\\>\\)\\|\\<endproperty\\>")) (t (error "Problem in verilog-set-auto-endcomments"))) (let (b e) @@ -5078,13 +5143,13 @@ FILENAME to find directory to run in, or defaults to `buffer-file-name`." (list (let ((default (verilog-expand-command verilog-preprocessor))) (set (make-local-variable `verilog-preprocessor) - (read-from-minibuffer "Run Preprocessor (like this): " - default nil nil - 'verilog-preprocess-history default))))) + (read-from-minibuffer "Run Preprocessor (like this): " + default nil nil + 'verilog-preprocess-history default))))) (unless command (setq command (verilog-expand-command verilog-preprocessor))) (let* ((fontlocked (and (boundp 'font-lock-mode) font-lock-mode)) - (dir (file-name-directory (or filename buffer-file-name))) - (cmd (concat "cd " dir "; " command))) + (dir (file-name-directory (or filename buffer-file-name))) + (cmd (concat "cd " dir "; " command))) (with-output-to-temp-buffer "*Verilog-Preprocessed*" (with-current-buffer (get-buffer "*Verilog-Preprocessed*") (insert (concat "// " cmd "\n")) @@ -5092,7 +5157,11 @@ FILENAME to find directory to run in, or defaults to `buffer-file-name`." (verilog-mode) ;; Without this force, it takes a few idle seconds ;; to get the color, which is very jarring - (when fontlocked (font-lock-fontify-buffer)))))) + (unless (fboundp 'font-lock-ensure) + ;; We should use font-lock-ensure in preference to + ;; font-lock-fontify-buffer, but IIUC the problem this is supposed to + ;; solve only appears in Emacsen older than font-lock-ensure anyway. + (when fontlocked (font-lock-fontify-buffer))))))) ;; @@ -5138,23 +5207,29 @@ Save the result unless optional NO-SAVE is t." ;; Make sure any sub-files we read get proper mode (setq-default major-mode 'verilog-mode) ;; Ditto files already read in - (mapc (lambda (buf) - (when (buffer-file-name buf) - (with-current-buffer buf - (verilog-mode)))) - (buffer-list)) - ;; Process the files - (mapcar (lambda (buf) + ;; Remember buffer list, so don't later pickup any verilog-getopt files + (let ((orig-buffer-list (buffer-list))) + (mapc (lambda (buf) (when (buffer-file-name buf) - (save-excursion - (if (not (file-exists-p (buffer-file-name buf))) - (error - (concat "File not found: " (buffer-file-name buf)))) - (message (concat "Processing " (buffer-file-name buf))) - (set-buffer buf) - (funcall funref) - (unless no-save (save-buffer))))) - (buffer-list)))) + (with-current-buffer buf + (verilog-mode) + (verilog-auto-reeval-locals) + (verilog-getopt-flags)))) + orig-buffer-list) + ;; Process the files + (mapcar (lambda (buf) + (when (buffer-file-name buf) + (save-excursion + (if (not (file-exists-p (buffer-file-name buf))) + (error + (concat "File not found: " (buffer-file-name buf)))) + (message (concat "Processing " (buffer-file-name buf))) + (set-buffer buf) + (funcall funref) + (when (and (not no-save) + (buffer-modified-p)) ;; Avoid "no changes to be saved" + (save-buffer))))) + orig-buffer-list)))) (defun verilog-batch-auto () "For use with --batch, perform automatic expansions as a stand-alone tool. @@ -5271,7 +5346,7 @@ Return a list of two elements: (INDENT-TYPE INDENT-LEVEL)." (if (save-excursion (beginning-of-line) (and (looking-at verilog-directive-re-1) (not (or (looking-at "[ \t]*`[ou]vm_") - (looking-at "[ \t]*`vmm_"))))) + (looking-at "[ \t]*`vmm_"))))) (throw 'nesting 'directive)) ;; indent structs as if there were module level (setq structres (verilog-in-struct-nested-p)) @@ -5510,10 +5585,10 @@ Return a list of two elements: (INDENT-TYPE INDENT-LEVEL)." ; endfunction (verilog-beg-of-statement) (if (looking-at verilog-beg-block-re-ordered) - (throw 'nesting 'block) - (throw 'nesting 'defun))) + (throw 'nesting 'block) + (throw 'nesting 'defun))) - ;; + ;; ((looking-at "\\<property\\>") ; *sigh* ; {assert|assume|cover} property (); are complete @@ -5704,7 +5779,7 @@ Jump from end to matching begin, from endcase to matching case, and so on." (setq sreg reg) (setq reg "\\(\\<fork\\>\\)\\|\\(\\<join\\(_any\\|_none\\)?\\>\\)" )) ))) - ;no nesting + ;; no nesting (if (and (verilog-re-search-backward reg nil 'move) (match-end 1)) ; task -> could be virtual and/or protected @@ -5818,7 +5893,9 @@ Set point to where line starts." (;-- any of begin|initial|while are complete statements; 'begin : foo' is also complete t (forward-word -1) - (while (= (preceding-char) ?\_) + (while (or (= (preceding-char) ?\_) + (= (preceding-char) ?\@) + (= (preceding-char) ?\.)) (forward-word -1)) (cond ((looking-at "\\<else\\>") @@ -6072,14 +6149,18 @@ Return >0 for nested struct." (defun verilog-at-constraint-p () "If at the { of a constraint or coverpoint definition, return true, moving point to constraint." (if (save-excursion + (let ((p (point))) (and (equal (char-after) ?\{) (forward-list) (progn (backward-char 1) (verilog-backward-ws&directives) + (and (or (equal (char-before) ?\{) ;; empty case (equal (char-before) ?\;) - (equal (char-before) ?\}))))) + (equal (char-before) ?\})) + ;; skip what looks like bus repetition operator {#{ + (not (string-match "^{\\s-*[0-9]+\\s-*{" (buffer-substring p (point))))))))) (progn (let ( (pt (point)) (pass 0)) (verilog-backward-ws&directives) @@ -6398,6 +6479,9 @@ Only look at a few lines to determine indent level." (looking-at verilog-declaration-re)) (verilog-indent-declaration ind)) + (;-- form feeds - ignored as bug in indent-line-to in < 24.5 + (looking-at "\f")) + (;-- Everything else t (let ((val (eval (cdr (assoc type verilog-indent-alist))))) @@ -6547,10 +6631,9 @@ Be verbose about progress unless optional QUIET set." endpos (set-marker (make-marker) end) base-ind (progn (goto-char start) - (forward-char 1) - (skip-chars-forward " \t") - (current-column)) - ) + (forward-char 1) + (skip-chars-forward " \t") + (current-column))) ;; in a declaration block (not in argument list) (setq start (progn @@ -8065,7 +8148,7 @@ Optional NUM-PARAM and MAX-PARAM check for a specific number of parameters." Return an array of [outputs inouts inputs wire reg assign const]." (let ((end-mod-point (or (verilog-get-end-of-defun) (point-max))) (functask 0) (paren 0) (sig-paren 0) (v2kargs-ok t) - in-modport in-clocking ptype ign-prop + in-modport in-clocking in-ign-to-semi ptype ign-prop sigs-in sigs-out sigs-inout sigs-var sigs-assign sigs-const sigs-gparam sigs-intf sigs-modports vec expect-signal keywd newsig rvalue enum io signed typedefed multidim @@ -8097,19 +8180,24 @@ Return an array of [outputs inouts inputs wire reg assign const]." (or (re-search-forward "[^\\]\"" nil t) ;; don't forward-char first, since we look for a non backslash first (error "%s: Unmatched quotes, at char %d" (verilog-point-text) (point)))) ((eq ?\; (following-char)) - (when (and in-modport (not (eq in-modport t))) ;; end of a modport declaration - (verilog-modport-decls-set - in-modport - (verilog-decls-new sigs-out sigs-inout sigs-in - nil nil nil nil nil nil)) - ;; Pop from varstack to restore state to pre-clocking - (setq tmp (car varstack) - varstack (cdr varstack) - sigs-out (aref tmp 0) - sigs-inout (aref tmp 1) - sigs-in (aref tmp 2))) - (setq vec nil io nil expect-signal nil newsig nil paren 0 rvalue nil - v2kargs-ok nil in-modport nil ign-prop nil) + (cond (in-ign-to-semi ;; Such as inside a "import ...;" in a module header + (setq in-ign-to-semi nil)) + ((and in-modport (not (eq in-modport t))) ;; end of a modport declaration + (verilog-modport-decls-set + in-modport + (verilog-decls-new sigs-out sigs-inout sigs-in + nil nil nil nil nil nil)) + ;; Pop from varstack to restore state to pre-clocking + (setq tmp (car varstack) + varstack (cdr varstack) + sigs-out (aref tmp 0) + sigs-inout (aref tmp 1) + sigs-in (aref tmp 2)) + (setq vec nil io nil expect-signal nil newsig nil paren 0 rvalue nil + v2kargs-ok nil in-modport nil ign-prop nil)) + (t + (setq vec nil io nil expect-signal nil newsig nil paren 0 rvalue nil + v2kargs-ok nil in-modport nil ign-prop nil))) (forward-char 1)) ((eq ?= (following-char)) (setq rvalue t newsig nil) @@ -8212,8 +8300,12 @@ Return an array of [outputs inouts inputs wire reg assign const]." (setq in-modport t)) ((equal keywd "clocking") (setq in-clocking t)) + ((equal keywd "import") + (if v2kargs-ok ;; import in module header, not a modport import + (setq in-ign-to-semi t rvalue t))) ((equal keywd "type") (setq ptype t)) + ((equal keywd "var")) ;; Ifdef? Ignore name of define ((member keywd '("`ifdef" "`ifndef" "`elsif")) (setq rvalue t)) @@ -8224,7 +8316,8 @@ Return an array of [outputs inouts inputs wire reg assign const]." (setq typedefed (if typedefed (concat typedefed " " keywd) keywd))) (t (setq vec nil enum nil rvalue nil signed nil - typedefed nil multidim nil sig-paren paren + typedefed keywd ; Have a type + multidim nil sig-paren paren expect-signal 'sigs-var modport nil)))) ;; Interface with optional modport in v2k arglist? ;; Skip over parsing modport, and take the interface name as the type @@ -8285,6 +8378,7 @@ Return an array of [outputs inouts inputs wire reg assign const]." (eq functask 0) (not (member keywd verilog-keywords))) ;; Add new signal to expect-signal's variable + ;;(if dbg (setq dbg (concat dbg (format "Pt %s New sig %s'\n" (point) keywd)))) (setq newsig (verilog-sig-new keywd vec nil nil enum signed typedefed multidim modport)) (set expect-signal (cons newsig (symbol-value expect-signal)))))) @@ -8853,7 +8947,6 @@ IGNORE-NEXT is true to ignore next token, fake from inside case statement." (save-excursion (let* (;;(dbg "") sigs-out-d sigs-out-i sigs-out-unk sigs-temp sigs-in) - (search-forward ")") (verilog-read-always-signals-recurse nil nil nil) (setq sigs-out-i (append sigs-out-i sigs-out-unk) sigs-out-unk nil) @@ -9138,7 +9231,7 @@ foo.v (an include file): `define _FOO_V ... contents of file `endif // _FOO_V" -;;slow: (verilog-read-defines nil t)) + ;;slow: (verilog-read-defines nil t) (save-excursion (verilog-getopt-flags) (goto-char (point-min)) @@ -9527,7 +9620,7 @@ variables to build the path. With optional CHECK-EXT also check (setq outlist (cons (expand-file-name fn (file-name-directory current)) outlist))) - (setq chkexts (cdr chkexts))) + (setq chkexts (cdr chkexts))) (setq chkdirs (cdr chkdirs))) (setq outlist (nreverse outlist)) (setq verilog-dir-cache-lib-filenames @@ -9624,7 +9717,7 @@ Return modi if successful, else print message unless IGNORE-ERROR is true." allow-cache (setq modi (gethash module verilog-modi-lookup-cache)) (equal verilog-modi-lookup-last-current current) - ;; Iff hit is in current buffer, then tick must match + ;; If hit is in current buffer, then tick must match (or (equal verilog-modi-lookup-last-tick (buffer-chars-modified-tick)) (not (equal current (verilog-modi-file-or-buffer modi))))) ;;(message "verilog-modi-lookup: HIT %S" modi) @@ -10602,7 +10695,7 @@ If FORCE, always reread it." ;; (defun verilog-auto-arg-ports (sigs message indent-pt) - "Print a list of ports for an AUTOINST. + "Print a list of ports for AUTOARG. Takes SIGS list, adds MESSAGE to front and inserts each at INDENT-PT." (when sigs (when verilog-auto-arg-sort @@ -10614,13 +10707,20 @@ Takes SIGS list, adds MESSAGE to front and inserts each at INDENT-PT." (let ((space "")) (indent-to indent-pt) (while sigs - (cond ((> (+ 2 (current-column) (length (verilog-sig-name (car sigs)))) fill-column) + (cond ((equal verilog-auto-arg-format 'single) + (insert space) + (indent-to indent-pt) + (setq space "\n")) + ;; verilog-auto-arg-format 'packed + ((> (+ 2 (current-column) (length (verilog-sig-name (car sigs)))) fill-column) (insert "\n") - (indent-to indent-pt)) - (t (insert space))) + (indent-to indent-pt) + (setq space " ")) + (t + (insert space) + (setq space " "))) (insert (verilog-sig-name (car sigs)) ",") - (setq sigs (cdr sigs) - space " "))))) + (setq sigs (cdr sigs)))))) (defun verilog-auto-arg () "Expand AUTOARG statements. @@ -10655,9 +10755,11 @@ Typing \\[verilog-auto] will make this into: output o; endmodule -The argument declarations may be printed in declaration order to best suit -order based instantiations, or alphabetically, based on the -`verilog-auto-arg-sort' variable. +The argument declarations may be printed in declaration order to +best suit order based instantiations, or alphabetically, based on +the `verilog-auto-arg-sort' variable. + +Formatting is controlled with `verilog-auto-arg-format' variable. Any ports declared between the ( and /*AUTOARG*/ are presumed to be predeclared and are not redeclared by AUTOARG. AUTOARG will make a @@ -11681,6 +11783,9 @@ Limitations: Typedefs must match `verilog-typedef-regexp', which is disabled by default. + Types are added to declarations if an AUTOLOGIC or + `verilog-auto-wire-type' is set to logic. + Signals matching `verilog-auto-output-ignore-regexp' are not included. An example (see `verilog-auto-inst' for what else is going on here): @@ -11773,10 +11878,18 @@ Typing \\[verilog-auto] will make this into: wire tempa = i; wire tempb = tempa; wire o = tempb; - endmodule" + endmodule + +You may also provide an optional regular expression, in which case only +signals matching the regular expression will be included. For example the +same expansion will result from only extracting outputs starting with ov: + + /*AUTOOUTPUTEVERY(\"^ov\")*/" (save-excursion ;;Point must be at insertion point (let* ((indent-pt (current-indentation)) + (params (verilog-read-auto-params 0 1)) + (regexp (nth 0 params)) (v2k (verilog-in-paren-quick)) (modi (verilog-modi-current)) (moddecls (verilog-modi-get-decls modi)) @@ -11784,6 +11897,11 @@ Typing \\[verilog-auto] will make this into: (verilog-signals-not-in (verilog-decls-get-signals moddecls) (verilog-decls-get-ports moddecls))))) + (when regexp + (setq sig-list (verilog-signals-matching-regexp + sig-list regexp))) + (setq sig-list (verilog-signals-not-matching-regexp + sig-list verilog-auto-output-ignore-regexp)) (verilog-forward-or-insert-line) (when v2k (verilog-repair-open-comma)) (when sig-list @@ -11809,6 +11927,9 @@ Limitations: Typedefs must match `verilog-typedef-regexp', which is disabled by default. + Types are added to declarations if an AUTOLOGIC or + `verilog-auto-wire-type' is set to logic. + Signals matching `verilog-auto-input-ignore-regexp' are not included. An example (see `verilog-auto-inst' for what else is going on here): @@ -11889,6 +12010,9 @@ Limitations: Typedefs must match `verilog-typedef-regexp', which is disabled by default. + Types are added to declarations if an AUTOLOGIC or + `verilog-auto-wire-type' is set to logic. + Signals matching `verilog-auto-inout-ignore-regexp' are not included. An example (see `verilog-auto-inst' for what else is going on here): @@ -12005,13 +12129,14 @@ same expansion will result from only extracting signals starting with i: /*AUTOINOUTMODULE(\"ExampMain\",\"^i\")*/ -You may also provide an optional second regular expression, in -which case only signals which have that pin direction and data -type will be included. This matches against everything before -the signal name in the declaration, for example against -\"input\" (single bit), \"output logic\" (direction and type) or -\"output [1:0]\" (direction and implicit type). You also -probably want to skip spaces in your regexp. +You may also provide an optional third argument regular +expression, in which case only signals which have that pin +direction and data type matching that regular expression will be +included. This matches against everything before the signal name +in the declaration, for example against \"input\" (single bit), +\"output logic\" (direction and type) or \"output +[1:0]\" (direction and implicit type). You also probably want to +skip spaces in your regexp. For example, the below will result in matching the output \"o\" against the previous example's module: @@ -12071,7 +12196,7 @@ against the previous example's module: (verilog-signals-matching-regexp sig-list-if regexp) "interface" direction-re)) (when v2k (verilog-repair-open-comma)) - (when (or sig-list-i sig-list-o sig-list-io) + (when (or sig-list-i sig-list-o sig-list-io sig-list-if) (verilog-insert-indent "// Beginning of automatic in/out/inouts (from specific module)\n") ;; Don't sort them so an upper AUTOINST will match the main module (verilog-insert-definition modi sig-list-o "output" indent-pt v2k t) @@ -12130,7 +12255,21 @@ You may also provide an optional regular expression, in which case only signals matching the regular expression will be included. For example the same expansion will result from only extracting signals starting with i: - /*AUTOINOUTCOMP(\"ExampMain\",\"^i\")*/" + /*AUTOINOUTCOMP(\"ExampMain\",\"^i\")*/ + +You may also provide an optional third argument regular +expression, in which case only signals which have that pin +direction and data type matching that regular expression will be +included. This matches against everything before the signal name +in the declaration, for example against \"input\" (single bit), +\"output logic\" (direction and type) or \"output +[1:0]\" (direction and implicit type). You also probably want to +skip spaces in your regexp. + +For example, the below will result in matching the output \"o\" +against the previous example's module: + + /*AUTOINOUTCOMP(\"ExampMain\",\"\",\"^output.*\")*/" (verilog-auto-inout-module t nil)) (defun verilog-auto-inout-in () @@ -12181,7 +12320,7 @@ You may also provide an optional regular expression, in which case only signals matching the regular expression will be included. For example the same expansion will result from only extracting signals starting with i: - /*AUTOINOUTCOMP(\"ExampMain\",\"^i\")*/" + /*AUTOINOUTIN(\"ExampMain\",\"^i\")*/" (verilog-auto-inout-module nil t)) (defun verilog-auto-inout-param () @@ -12374,9 +12513,13 @@ driver/monitor using AUTOINST in the testbench." (defun verilog-auto-insert-lisp () "Expand AUTOINSERTLISP statements, as part of \\[verilog-auto]. -The Lisp code provided is called, and the Lisp code calls -`insert` to insert text into the current file beginning on the -line after the AUTOINSERTLISP. +The Lisp code provided is called before other AUTOS are expanded, +and the Lisp code generally will call `insert` to insert text +into the current file beginning on the line after the +AUTOINSERTLISP. + +See also AUTOINSERTLAST and `verilog-auto-insert-last' which +executes after (as opposed to before) other AUTOs. See also AUTO_LISP, which takes a Lisp expression and evaluates it during `verilog-auto-inst' but does not insert any text. @@ -12433,9 +12576,25 @@ text: (setq verilog-scan-cache-tick nil) ;; Clear cache; inserted unknown text (verilog-delete-empty-auto-pair)))) +(defun verilog-auto-insert-last () + "Expand AUTOINSERTLAST statements, as part of \\[verilog-auto]. +The Lisp code provided is called after all other AUTOS have been +expanded, and the Lisp code generally will call `insert` to +insert text into the current file beginning on the line after the +AUTOINSERTLAST. + +Other than when called (after AUTOs are expanded), the functionality +is otherwise identical to AUTOINSERTLISP and `verilog-auto-insert-lisp' which +executes before (as opposed to after) other AUTOs. + +See `verilog-auto-insert-lisp' for examples." + (verilog-auto-insert-lisp)) + (defun verilog-auto-sense-sigs (moddecls presense-sigs) "Return list of signals for current AUTOSENSE block." - (let* ((sigss (verilog-read-always-signals)) + (let* ((sigss (save-excursion + (search-forward ")") + (verilog-read-always-signals))) (sig-list (verilog-signals-not-params (verilog-signals-not-in (verilog-alw-get-inputs sigss) (append (and (not verilog-auto-sense-include-inputs) @@ -12625,11 +12784,12 @@ Typing \\[verilog-auto] will make this into: (save-excursion (verilog-read-signals (save-excursion - (verilog-re-search-backward-quick "\\(@\\|\\<begin\\>\\|\\<if\\>\\|\\<case\\>\\)" nil t) + (verilog-re-search-backward-quick + "\\(@\\|\\<\\(begin\\|if\\|case\\|always\\(_latch\\|_ff\\|_comb\\)?\\)\\>\\)" nil t) (point)) (point))))) (save-excursion - (verilog-re-search-backward-quick "@" nil t) + (verilog-re-search-backward-quick "\\(@\\|\\<\\(always\\(_latch\\|_ff\\|_comb\\)?\\)\\>\\)" nil t) (setq sigss (verilog-read-always-signals))) (setq dly-list (verilog-alw-get-outputs-delayed sigss)) (setq sig-list (verilog-signals-not-in (append @@ -13159,6 +13319,7 @@ Using \\[describe-function], see also: `verilog-auto-inout-param' for AUTOINOUTPARAM copying params from elsewhere `verilog-auto-input' for AUTOINPUT making hierarchy inputs `verilog-auto-insert-lisp' for AUTOINSERTLISP insert code from lisp function + `verilog-auto-insert-last' for AUTOINSERTLAST insert code from lisp function `verilog-auto-inst' for AUTOINST instantiation pins `verilog-auto-star' for AUTOINST .* SystemVerilog pins `verilog-auto-inst-param' for AUTOINSTPARAM instantiation params @@ -13235,7 +13396,6 @@ Wilson Snyder (wsnyder@wsnyder.org)." (verilog-inject-arg)) ;; ;; Do user inserts first, so their code can insert AUTOs - ;; We may provide an AUTOINSERTLISPLAST if another cleanup pass is needed (verilog-auto-re-search-do "/\\*AUTOINSERTLISP(.*?)\\*/" 'verilog-auto-insert-lisp) ;; Expand instances before need the signals the instances input/output @@ -13269,11 +13429,13 @@ Wilson Snyder (wsnyder@wsnyder.org)." (verilog-auto-re-search-do "/\\*AUTOREG\\*/" 'verilog-auto-reg) (verilog-auto-re-search-do "/\\*AUTOREGINPUT\\*/" 'verilog-auto-reg-input) ;; outputevery needs AUTOOUTPUTs done first - (verilog-auto-re-search-do "/\\*AUTOOUTPUTEVERY\\*/" 'verilog-auto-output-every) + (verilog-auto-re-search-do "/\\*AUTOOUTPUTEVERY\\((.*?)\\)?\\*/" 'verilog-auto-output-every) ;; After we've created all new variables (verilog-auto-re-search-do "/\\*AUTOUNUSED\\*/" 'verilog-auto-unused) ;; Must be after all inputs outputs are generated (verilog-auto-re-search-do "/\\*AUTOARG\\*/" 'verilog-auto-arg) + ;; User inserts + (verilog-auto-re-search-do "/\\*AUTOINSERTLAST(.*?)\\*/" 'verilog-auto-insert-last) ;; Fix line numbers (comments only) (when verilog-auto-inst-template-numbers (verilog-auto-templated-rel)) @@ -13442,7 +13604,7 @@ See also `verilog-header' for an alternative format." > "`ovm_object_utils_begin(" name ")" \n > (- verilog-indent-level) " `ovm_object_utils_end" \n > _ \n - > "function new(name=\"" name "\");" \n + > "function new(string name=\"" name "\");" \n > "super.new(name);" \n > (- verilog-indent-level) "endfunction" \n > _ \n @@ -13456,7 +13618,7 @@ See also `verilog-header' for an alternative format." > "`uvm_object_utils_begin(" name ")" \n > (- verilog-indent-level) "`uvm_object_utils_end" \n > _ \n - > "function new(name=\"" name "\");" \n + > "function new(string name=\"" name "\");" \n > "super.new(name);" \n > (- verilog-indent-level) "endfunction" \n > _ \n @@ -13470,7 +13632,7 @@ See also `verilog-header' for an alternative format." > "`uvm_component_utils_begin(" name ")" \n > (- verilog-indent-level) "`uvm_component_utils_end" \n > _ \n - > "function new(name=\"\", uvm_component parent);" \n + > "function new(string name=\"\", uvm_component parent);" \n > "super.new(name, parent);" \n > (- verilog-indent-level) "endfunction" \n > _ \n @@ -13538,8 +13700,7 @@ for sensitivity list." () > "begin" '(verilog-sk-prompt-name) \n > _ \n - > (- verilog-indent-level-behavioral) "end" -) + > (- verilog-indent-level-behavioral) "end" ) (define-skeleton verilog-sk-fork "Insert a fork join block." diff --git a/lisp/progmodes/vhdl-mode.el b/lisp/progmodes/vhdl-mode.el index c52c4169f40..4d6b3b23978 100644 --- a/lisp/progmodes/vhdl-mode.el +++ b/lisp/progmodes/vhdl-mode.el @@ -13,10 +13,10 @@ ;; filed in the Emacs bug reporting system against this file, a copy ;; of the bug report be sent to the maintainer's email address. -(defconst vhdl-version "3.34.2" +(defconst vhdl-version "3.36.1" "VHDL Mode version number.") -(defconst vhdl-time-stamp "2012-11-21" +(defconst vhdl-time-stamp "2014-11-27" "VHDL Mode time stamp for last update.") ;; This file is part of GNU Emacs. @@ -72,12 +72,12 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Emacs Versions -;; this updated version was only tested on: GNU Emacs 20.4 +;; this updated version was only tested on: GNU Emacs 24.1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Installation -;; Prerequisites: GNU Emacs 20.X/21.X/22.X/23.X, XEmacs 20.X/21.X. +;; Prerequisites: GNU Emacs 20/21/22/23/24, XEmacs 20/21. ;; Put `vhdl-mode.el' into the `site-lisp' directory of your Emacs installation ;; or into an arbitrary directory that is added to the load path by the @@ -215,20 +215,20 @@ Overrides local variable `indent-tabs-mode'." ;; [Error] Assignment error: variable is illegal target of signal assignment ("ADVance MS" "vacom" "-work \\1" "make" "-f \\1" nil "valib \\1; vamap \\2 \\1" "./" "work/" "Makefile" "adms" - ("^\\s-+\\([0-9]+\\):\\s-+" nil 1 nil) ("Compiling file \\(.+\\)" 1) + ("^\\s-+\\([0-9]+\\):\\s-+" nil 1 nil) ("^Compiling file \\(.+\\)" 1) ("ENTI/\\1.vif" "ARCH/\\1-\\2.vif" "CONF/\\1.vif" "PACK/\\1.vif" "BODY/\\1.vif" upcase)) ;; Aldec ;; COMP96 ERROR COMP96_0018: "Identifier expected." "test.vhd" 66 3 ("Aldec" "vcom" "-work \\1" "make" "-f \\1" nil "vlib \\1; vmap \\2 \\1" "./" "work/" "Makefile" "aldec" - (".* ERROR [^:]+: \".*\" \"\\([^ \\t\\n]+\\)\" \\([0-9]+\\) \\([0-9]+\\)" 1 2 3) ("" 0) + ("^.* ERROR [^:]+: \".*\" \"\\([^ \t\n]+\\)\" \\([0-9]+\\) \\([0-9]+\\)" 1 2 3) ("" 0) nil) ;; Cadence Leapfrog: cv -file test.vhd ;; duluth: *E,430 (test.vhd,13): identifier (POSITIV) is not declared ("Cadence Leapfrog" "cv" "-work \\1 -file" "make" "-f \\1" nil "mkdir \\1" "./" "work/" "Makefile" "leapfrog" - ("duluth: \\*E,[0-9]+ (\\([^ \\t\\n]+\\),\\([0-9]+\\)):" 1 2 nil) ("" 0) + ("^duluth: \\*E,[0-9]+ (\\([^ \t\n]+\\),\\([0-9]+\\)):" 1 2 nil) ("" 0) ("\\1/entity" "\\2/\\1" "\\1/configuration" "\\1/package" "\\1/body" downcase)) ;; Cadence Affirma NC vhdl: ncvhdl test.vhd @@ -236,27 +236,29 @@ Overrides local variable `indent-tabs-mode'." ;; (PLL_400X_TOP) is not declared [10.3]. ("Cadence NC" "ncvhdl" "-work \\1" "make" "-f \\1" nil "mkdir \\1" "./" "work/" "Makefile" "ncvhdl" - ("ncvhdl_p: \\*E,\\w+ (\\([^ \\t\\n]+\\),\\([0-9]+\\)|\\([0-9]+\\)):" 1 2 3) ("" 0) + ("^ncvhdl_p: \\*E,\\w+ (\\([^ \t\n]+\\),\\([0-9]+\\)|\\([0-9]+\\)):" 1 2 3) ("" 0) ("\\1/entity/pc.db" "\\2/\\1/pc.db" "\\1/configuration/pc.db" "\\1/package/pc.db" "\\1/body/pc.db" downcase)) - ;; ghdl vhdl: ghdl test.vhd + ;; ghdl vhdl + ;; ghdl -a bad_counter.vhdl + ;; bad_counter.vhdl:13:14: operator "=" is overloaded ("GHDL" "ghdl" "-i --workdir=\\1 --ieee=synopsys -fexplicit " "make" "-f \\1" nil "mkdir \\1" "./" "work/" "Makefile" "ghdl" - ("ghdl_p: \\*E,\\w+ (\\([^ \\t\\n]+\\),\\([0-9]+\\)|\\([0-9]+\\)):" 1 2 3) ("" 0) + ("^ghdl_p: \\*E,\\w+ (\\([^ \t\n]+\\),\\([0-9]+\\)|\\([0-9]+\\)):" 1 2 3) ("" 0) ("\\1/entity" "\\2/\\1" "\\1/configuration" "\\1/package" "\\1/body" downcase)) ;; IBM Compiler ;; 00 COACHDL* | [CCHDL-1]: File: adder.vhd, line.column: 120.6 ("IBM Compiler" "g2tvc" "-src" "precomp" "\\1" nil "mkdir \\1" "./" "work/" "Makefile" "ibm" - ("[0-9]+ COACHDL.*: File: \\([^ \\t\\n]+\\), line.column: \\([0-9]+\\).\\([0-9]+\\)" 1 2 3) (" " 0) + ("^[0-9]+ COACHDL.*: File: \\([^ \t\n]+\\), *line.column: \\([0-9]+\\).\\([0-9]+\\)" 1 2 3) (" " 0) nil) ;; Ikos Voyager: analyze test.vhd ;; analyze test.vhd ;; E L4/C5: this library unit is inaccessible ("Ikos" "analyze" "-l \\1" "make" "-f \\1" nil "mkdir \\1" "./" "work/" "Makefile" "ikos" - ("E L\\([0-9]+\\)/C\\([0-9]+\\):" nil 1 2) + ("^E L\\([0-9]+\\)/C\\([0-9]+\\):" nil 1 2) ("^analyze +\\(.+ +\\)*\\(.+\\)$" 2) nil) ;; ModelSim, Model Technology: vcom test.vhd @@ -266,14 +268,14 @@ Overrides local variable `indent-tabs-mode'." ;; ** Error: adder.vhd(190): Unknown identifier: ctl_numb ("ModelSim" "vcom" "-93 -work \\1" "make" "-f \\1" nil "vlib \\1; vmap \\2 \\1" "./" "work/" "Makefile" "modelsim" - ("\\(ERROR\\|WARNING\\|\\*\\* Error\\|\\*\\* Warning\\)[^:]*:\\( *\[[0-9]+\]\\)? \\([^ \\t\\n]+\\)(\\([0-9]+\\)):" 3 4 nil) ("" 0) + ("^\\(ERROR\\|WARNING\\|\\*\\* Error\\|\\*\\* Warning\\)[^:]*:\\( *\[[0-9]+\]\\)? \\([^ \t\n]+\\)(\\([0-9]+\\)):" 3 4 nil) ("" 0) ("\\1/_primary.dat" "\\2/\\1.dat" "\\1/_primary.dat" "\\1/_primary.dat" "\\1/body.dat" downcase)) ;; ProVHDL, Synopsys LEDA: provhdl -w work -f test.vhd ;; test.vhd:34: error message ("LEDA ProVHDL" "provhdl" "-w \\1 -f" "make" "-f \\1" nil "mkdir \\1" "./" "work/" "Makefile" "provhdl" - ("\\([^ \\t\\n]+\\):\\([0-9]+\\): " 1 2 nil) ("" 0) + ("^\\([^ \t\n:]+\\):\\([0-9]+\\): " 1 2 nil) ("" 0) ("ENTI/\\1.vif" "ARCH/\\1-\\2.vif" "CONF/\\1.vif" "PACK/\\1.vif" "BODY/BODY-\\1.vif" upcase)) ;; Quartus compiler @@ -284,21 +286,21 @@ Overrides local variable `indent-tabs-mode'." ;; Warning: VHDL Process Statement warning at dvi2sdi_tst.vhd(172): ... ("Quartus" "make" "-work \\1" "make" "-f \\1" nil "mkdir \\1" "./" "work/" "Makefile" "quartus" - ("\\(Error\\|Warning\\): .* \\([^ \\t\\n]+\\)(\\([0-9]+\\))" 2 3 nil) ("" 0) + ("^\\(Error\\|Warning\\): .* \\([^ \t\n]+\\)(\\([0-9]+\\))" 2 3 nil) ("" 0) nil) ;; QuickHDL, Mentor Graphics: qvhcom test.vhd ;; ERROR: test.vhd(24): near "dnd": expecting: END ;; WARNING[4]: test.vhd(30): A space is required between ... ("QuickHDL" "qvhcom" "-work \\1" "make" "-f \\1" nil "mkdir \\1" "./" "work/" "Makefile" "quickhdl" - ("\\(ERROR\\|WARNING\\)[^:]*: \\([^ \\t\\n]+\\)(\\([0-9]+\\)):" 2 3 nil) ("" 0) + ("^\\(ERROR\\|WARNING\\)[^:]*: \\([^ \t\n]+\\)(\\([0-9]+\\)):" 2 3 nil) ("" 0) ("\\1/_primary.dat" "\\2/\\1.dat" "\\1/_primary.dat" "\\1/_primary.dat" "\\1/body.dat" downcase)) ;; Savant: scram -publish-cc test.vhd ;; test.vhd:87: _set_passed_through_out_port(IIR_Boolean) not defined for ("Savant" "scram" "-publish-cc -design-library-name \\1" "make" "-f \\1" nil "mkdir \\1" "./" "work._savant_lib/" "Makefile" "savant" - ("\\([^ \\t\\n]+\\):\\([0-9]+\\): " 1 2 nil) ("" 0) + ("^\\([^ \t\n:]+\\):\\([0-9]+\\): " 1 2 nil) ("" 0) ("\\1_entity.vhdl" "\\2_secondary_units._savant_lib/\\2_\\1.vhdl" "\\1_config.vhdl" "\\1_package.vhdl" "\\1_secondary_units._savant_lib/\\1_package_body.vhdl" downcase)) @@ -306,39 +308,39 @@ Overrides local variable `indent-tabs-mode'." ;; Error: CSVHDL0002: test.vhd: (line 97): Invalid prefix ("Simili" "vhdlp" "-work \\1" "make" "-f \\1" nil "mkdir \\1" "./" "work/" "Makefile" "simili" - ("\\(Error\\|Warning\\): \\w+: \\([^ \\t\\n]+\\): (line \\([0-9]+\\)): " 2 3 nil) ("" 0) + ("^\\(Error\\|Warning\\): \\w+: \\([^ \t\n]+\\): (line \\([0-9]+\\)): " 2 3 nil) ("" 0) ("\\1/prim.var" "\\2/_\\1.var" "\\1/prim.var" "\\1/prim.var" "\\1/_body.var" downcase)) ;; Speedwave (Innoveda): analyze -libfile vsslib.ini -src test.vhd ;; ERROR[11]::File test.vhd Line 100: Use of undeclared identifier ("Speedwave" "analyze" "-libfile vsslib.ini -src" "make" "-f \\1" nil "mkdir \\1" "./" "work/" "Makefile" "speedwave" - ("^ *ERROR\[[0-9]+\]::File \\([^ \\t\\n]+\\) Line \\([0-9]+\\):" 1 2 nil) ("" 0) + ("^ *ERROR\[[0-9]+\]::File \\([^ \t\n]+\\) Line \\([0-9]+\\):" 1 2 nil) ("" 0) nil) ;; Synopsys, VHDL Analyzer (sim): vhdlan -nc test.vhd ;; **Error: vhdlan,703 test.vhd(22): OTHERS is not legal in this context. ("Synopsys" "vhdlan" "-nc -work \\1" "make" "-f \\1" nil "mkdir \\1" "./" "work/" "Makefile" "synopsys" - ("\\*\\*Error: vhdlan,[0-9]+ \\([^ \\t\\n]+\\)(\\([0-9]+\\)):" 1 2 nil) ("" 0) + ("^\\*\\*Error: vhdlan,[0-9]+ \\([^ \t\n]+\\)(\\([0-9]+\\)):" 1 2 nil) ("" 0) ("\\1.sim" "\\2__\\1.sim" "\\1.sim" "\\1.sim" "\\1__.sim" upcase)) ;; Synopsys, VHDL Analyzer (syn): vhdlan -nc -spc test.vhd ;; **Error: vhdlan,703 test.vhd(22): OTHERS is not legal in this context. ("Synopsys Design Compiler" "vhdlan" "-nc -spc -work \\1" "make" "-f \\1" nil "mkdir \\1" "./" "work/" "Makefile" "synopsys_dc" - ("\\*\\*Error: vhdlan,[0-9]+ \\([^ \\t\\n]+\\)(\\([0-9]+\\)):" 1 2 nil) ("" 0) + ("^\\*\\*Error: vhdlan,[0-9]+ \\([^ \t\n]+\\)(\\([0-9]+\\)):" 1 2 nil) ("" 0) ("\\1.syn" "\\2__\\1.syn" "\\1.syn" "\\1.syn" "\\1__.syn" upcase)) ;; Synplify: ;; @W:"test.vhd":57:8:57:9|Optimizing register bit count_x(5) to a constant 0 ("Synplify" "n/a" "n/a" "make" "-f \\1" nil "mkdir \\1" "./" "work/" "Makefile" "synplify" - ("@[EWN]:\"\\([^ \\t\\n]+\\)\":\\([0-9]+\\):\\([0-9]+\\):" 1 2 3) ("" 0) + ("^@[EWN]:\"\\([^ \t\n]+\\)\":\\([0-9]+\\):\\([0-9]+\\):" 1 2 3) ("" 0) nil) ;; Vantage: analyze -libfile vsslib.ini -src test.vhd ;; Compiling "test.vhd" line 1... ;; **Error: LINE 49 *** No aggregate value is valid in this context. ("Vantage" "analyze" "-libfile vsslib.ini -src" "make" "-f \\1" nil "mkdir \\1" "./" "work/" "Makefile" "vantage" - ("\\*\\*Error: LINE \\([0-9]+\\) \\*\\*\\*" nil 1 nil) + ("^\\*\\*Error: LINE \\([0-9]+\\) \\*\\*\\*" nil 1 nil) ("^ *Compiling \"\\(.+\\)\" " 1) nil) ;; VeriBest: vc vhdl test.vhd @@ -355,14 +357,14 @@ Overrides local variable `indent-tabs-mode'." ;; **Error: LINE 49 *** No aggregate value is valid in this context. ("Viewlogic" "analyze" "-libfile vsslib.ini -src" "make" "-f \\1" nil "mkdir \\1" "./" "work/" "Makefile" "viewlogic" - ("\\*\\*Error: LINE \\([0-9]+\\) \\*\\*\\*" nil 1 nil) + ("^\\*\\*Error: LINE \\([0-9]+\\) \\*\\*\\*" nil 1 nil) ("^ *Compiling \"\\(.+\\)\" " 1) nil) ;; Xilinx XST: ;; ERROR:HDLParsers:164 - "test.vhd" Line 3. parse error ("Xilinx XST" "xflow" "" "make" "-f \\1" nil "mkdir \\1" "./" "work/" "Makefile" "xilinx" - ("^ERROR:HDLParsers:[0-9]+ - \"\\([^ \\t\\n]+\\)\" Line \\([0-9]+\\)\." 1 2 nil) ("" 0) + ("^ERROR:HDLParsers:[0-9]+ - \"\\([^ \t\n]+\\)\" Line \\([0-9]+\\)\." 1 2 nil) ("" 0) nil) ) "List of available VHDL compilers and their properties. @@ -392,7 +394,8 @@ File message: Unit-to-file name mapping: mapping of library unit names to names of files generated by the compiler (used for Makefile generation) To string : string a name is mapped to (\"\\1\" inserts the unit name, - \"\\2\" inserts the entity name for architectures) + \"\\2\" inserts the entity name for architectures, + \"\\3\" inserts the library name) Case adjustment : adjust case of inserted unit names \(*) The regular expression must match the error message starting from the @@ -486,7 +489,7 @@ Select a compiler name from the ones defined in option `vhdl-compiler-alist'." (append '(choice) (nreverse list))) :group 'vhdl-compile) -(defcustom vhdl-compile-use-local-error-regexp t +(defcustom vhdl-compile-use-local-error-regexp nil "Non-nil means use buffer-local `compilation-error-regexp-alist'. In this case, only error message regexps for VHDL compilers are active if compilation is started from a VHDL buffer. Otherwise, the error message @@ -495,6 +498,7 @@ active all the time. Note that by doing that, the predefined global regexps might result in erroneous parsing of error messages for some VHDL compilers. NOTE: Activate the new setting by restarting Emacs." + :version "25.1" ; t -> nil :type 'boolean :group 'vhdl-compile) @@ -1069,7 +1073,7 @@ NOTE: Activate the new setting in a VHDL buffer by using the menu entry "Customizations for sequential processes." :group 'vhdl-template) -(defcustom vhdl-reset-kind 'async +(defcustom vhdl-reset-kind 'async "Specifies which kind of reset to use in sequential processes." :type '(choice (const :tag "None" none) (const :tag "Synchronous" sync) @@ -2125,7 +2129,6 @@ your style, only those that are different from the default.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; mandatory -(require 'assoc) (require 'compile) ; XEmacs (require 'easymenu) (require 'hippie-exp) @@ -2137,6 +2140,36 @@ your style, only those that are different from the default.") (require 'ps-print) (require 'speedbar))) ; for speedbar-with-writable +(defun vhdl-aput (alist-symbol key &optional value) + "Insert a key-value pair into an alist. +The alist is referenced by ALIST-SYMBOL. The key-value pair is made +from KEY and VALUE. If the key-value pair referenced by KEY can be +found in the alist, the value of KEY will be set to VALUE. If the +key-value pair cannot be found in the alist, it will be inserted into +the head of the alist." + (let* ((alist (symbol-value alist-symbol)) + (elem (assoc key alist))) + (if elem + (setcdr elem value) + (set alist-symbol (cons (cons key value) alist))))) + +(defun vhdl-adelete (alist-symbol key) + "Delete a key-value pair from the alist. +Alist is referenced by ALIST-SYMBOL and the key-value pair to remove +is pair matching KEY." + (let ((alist (symbol-value alist-symbol)) alist-cdr) + (while (equal key (caar alist)) + (setq alist (cdr alist)) + (set alist-symbol alist)) + (while (setq alist-cdr (cdr alist)) + (if (equal key (caar alist-cdr)) + (setcdr alist (cdr alist-cdr)) + (setq alist alist-cdr))))) + +(defun vhdl-aget (alist key) + "Return the value in ALIST that is associated with KEY. If KEY is +not found, then nil is returned." + (cdr (assoc key alist))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Compatibility @@ -2256,7 +2289,6 @@ Ignore byte-compiler warnings you might see." "Wait until idle, then run FUNCTION." (if (fboundp 'start-itimer) (start-itimer "vhdl-mode" function secs repeat t) -; (run-with-idle-timer secs repeat function))) ;; explicitly activate timer (necessary when Emacs is already idle) (aset (run-with-idle-timer secs repeat function) 0 nil))) @@ -2429,7 +2461,7 @@ specified." current buffer if no project is defined." (if (vhdl-project-p) (expand-file-name (vhdl-resolve-env-variable - (nth 1 (aget vhdl-project-alist vhdl-project)))) + (nth 1 (vhdl-aget vhdl-project-alist vhdl-project)))) default-directory)) (defmacro vhdl-prepare-search-1 (&rest body) @@ -2537,11 +2569,11 @@ conversion." (setq file-list (cdr file-list))) dir-list)) -(defun vhdl-aput (alist-symbol key &optional value) +(defun vhdl-aput-delete-if-nil (alist-symbol key &optional value) "As `aput', but delete key-value pair if VALUE is nil." (if value - (aput alist-symbol key value) - (adelete alist-symbol key))) + (vhdl-aput alist-symbol key value) + (vhdl-adelete alist-symbol key))) (defun vhdl-delete (elt list) "Delete by side effect the first occurrence of ELT as a member of LIST." @@ -2596,11 +2628,6 @@ conversion." (set-buffer (marker-buffer marker))) (goto-char marker)) -(defun vhdl-goto-line (line) - "Use this instead of calling user level function `goto-line'." - (goto-char (point-min)) - (forward-line (1- line))) - (defun vhdl-menu-split (list title) "Split menu LIST into several submenus, if number of elements > `vhdl-menu-max-size'." @@ -2975,7 +3002,7 @@ STRING are replaced by `-' and substrings are converted to lower case." (make-variable-buffer-local 'vhdl-syntactic-context) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Abbrev ook bindings +;; Abbrev hook bindings (defvar vhdl-mode-abbrev-table nil "Abbrev table to use in `vhdl-mode' buffers.") @@ -2985,8 +3012,10 @@ STRING are replaced by `-' and substrings are converted to lower case." (define-abbrev-table 'vhdl-mode-abbrev-table (append (when (memq 'vhdl vhdl-electric-keywords) - ;; VHDL'93 keywords - (mapcar (lambda (x) (list (car x) "" (cdr x) 0 'system)) + ;; VHDL'02 keywords + (mapcar (if (featurep 'xemacs) + (lambda (x) (list (car x) "" (cdr x) 0)) + (lambda (x) (list (car x) "" (cdr x) 0 'system))) '( ("--" . vhdl-template-display-comment-hook) ("abs" . vhdl-template-default-hook) @@ -3102,7 +3131,9 @@ STRING are replaced by `-' and substrings are converted to lower case." ))) ;; VHDL-AMS keywords (when (and (memq 'vhdl vhdl-electric-keywords) (vhdl-standard-p 'ams)) - (mapcar (lambda (x) (list (car x) "" (cdr x) 0 'system)) + (mapcar (if (featurep 'xemacs) + (lambda (x) (list (car x) "" (cdr x) 0)) + (lambda (x) (list (car x) "" (cdr x) 0 'system))) '( ("across" . vhdl-template-default-hook) ("break" . vhdl-template-break-hook) @@ -4822,7 +4853,7 @@ Key bindings: ;; set local variables (set (make-local-variable 'paragraph-start) - "\\s-*\\(--+\\s-*$\\|[^ -]\\|$\\)") + "\\s-*\\(--+\\s-*$\\|$\\)") (set (make-local-variable 'paragraph-separate) paragraph-start) (set (make-local-variable 'paragraph-ignore-fill-prefix) t) (set (make-local-variable 'parse-sexp-ignore-comments) t) @@ -4860,9 +4891,7 @@ Key bindings: (set (make-local-variable 'font-lock-support-mode) 'lazy-lock-mode) (set (make-local-variable 'lazy-lock-defer-contextually) nil) (set (make-local-variable 'lazy-lock-defer-on-the-fly) t) -; (set (make-local-variable 'lazy-lock-defer-time) 0.1) (set (make-local-variable 'lazy-lock-defer-on-scrolling) t)) -; (turn-on-font-lock) ;; variables for source file compilation (when vhdl-compile-use-local-error-regexp @@ -7566,7 +7595,6 @@ indentation is done before aligning." (setq end (point-marker)) (goto-char begin) (setq bol (setq begin (progn (beginning-of-line) (point)))) -; (untabify bol end) (when indent (indent-region bol end nil)))) (let ((copy (copy-alist alignment-list))) @@ -7962,7 +7990,6 @@ end of line, do nothing in comments and strings." (and (looking-at "\\s-+") (re-search-forward "\\s-+" end t) (progn (replace-match " " nil nil) t)) (and (looking-at "-") (re-search-forward "-" end t)) -; (re-search-forward "[^ \t-]+" end t)))) (re-search-forward "[^ \t\"-]+" end t)))) (unless no-message (message "Fixing up whitespace...done"))) @@ -8080,7 +8107,7 @@ Currently supported keywords: 'begin', 'if'." (while (re-search-forward "\\<\\(for\\|if\\)\\>" end t) (goto-char (match-end 1)) (setq point (point-marker)) - ;; exception: in literal or preceded by `end' or label + ;; exception: in literal or preceded by `end', `wait' or label (when (and (not (save-excursion (goto-char (match-beginning 1)) (vhdl-in-literal))) (save-excursion @@ -8089,7 +8116,7 @@ Currently supported keywords: 'begin', 'if'." (and (re-search-forward "^\\s-*\\([^ \t\n].*\\)" (match-beginning 1) t) (not (string-match - "\\(\\<end\\>\\|\\<wait\\>\\|\\w+\\s-*:\\)\\s-*$" + "\\(\\<end\\>\\|\\<wait .*\\|\\w+\\s-*:\\)\\s-*$" (match-string 1))))))) (goto-char (match-beginning 1)) (insert "\n") @@ -8138,10 +8165,12 @@ case fixing to a region. Calls functions `vhdl-indent-buffer', (when (nth 0 vhdl-beautify-options) (vhdl-fixup-whitespace-region beg end t)) (when (nth 1 vhdl-beautify-options) (vhdl-fix-statement-region beg end)) (when (nth 2 vhdl-beautify-options) (vhdl-indent-region beg end)) - (let ((vhdl-align-groups t)) - (when (nth 3 vhdl-beautify-options) (vhdl-align-region beg end))) + (when (nth 3 vhdl-beautify-options) + (let ((vhdl-align-groups t)) (vhdl-align-region beg end))) (when (nth 4 vhdl-beautify-options) (vhdl-fix-case-region beg end)) - (when (nth 0 vhdl-beautify-options) (vhdl-remove-trailing-spaces-region beg end))) + (when (nth 0 vhdl-beautify-options) + (vhdl-remove-trailing-spaces-region beg end) + (if vhdl-indent-tabs-mode (tabify beg end) (untabify beg end)))) (defun vhdl-beautify-buffer () "Beautify buffer by applying indentation, whitespace fixup, alignment, and @@ -8447,11 +8476,11 @@ buffer." (setq beg (point)))))) ;; search for signals declared in surrounding block declarative parts (save-excursion - (while (and (progn (while (and (setq beg (re-search-backward "^\\s-*\\(\\w+\\s-*:\\s-*block\\|\\(end\\)\\s-+block\\)\\>" nil t)) - (match-string 2)) - (goto-char (match-end 2)) + (while (and (progn (while (and (setq beg (re-search-backward "^\\s-*\\(\\w+\\s-*:\\s-*\\(block\\|\\(for\\|if\\).*\\<generate\\>\\)\\|\\(end\\)\\s-+block\\)\\>" nil t)) + (match-string 4)) + (goto-char (match-end 4)) (vhdl-backward-sexp) - (re-search-backward "^\\s-*\\w+\\s-*:\\s-*block\\>" nil t)) + (re-search-backward "^\\s-*\\w+\\s-*:\\s-*\\(block\\|generate\\)\\>" nil t)) beg) (setq end (re-search-forward "^\\s-*begin\\>" nil t))) ;; scan for all declared signal names @@ -8548,7 +8577,8 @@ Used for undoing after template abortion.") "Return the working library name of the current project or \"work\" if no project is defined." (vhdl-resolve-env-variable - (or (nth 6 (aget vhdl-project-alist vhdl-project)) vhdl-default-library))) + (or (nth 6 (vhdl-aget vhdl-project-alist vhdl-project)) + vhdl-default-library))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Enabling/disabling @@ -8966,8 +8996,6 @@ since these are almost equivalent)." (interactive) (when (vhdl-template-field "target signal") (insert " <= ") -; (if (not (equal (vhdl-template-field "[GUARDED] [TRANSPORT]") "")) -; (insert " ")) (let ((margin (current-column)) (start (point)) position) @@ -9903,7 +9931,7 @@ otherwise." (defun vhdl-template-record (kind &optional name secondary) "Insert a record type declaration." (interactive) - (let ((margin (current-column)) + (let ((margin (current-indentation)) (start (point)) (first t)) (vhdl-insert-keyword "RECORD\n") @@ -9965,7 +9993,6 @@ otherwise." (insert "\n") (indent-to (+ margin vhdl-basic-offset)) (vhdl-template-field "target signal" " <= ") -; (vhdl-template-field "[GUARDED] [TRANSPORT]") (insert "\n") (indent-to (+ margin vhdl-basic-offset)) (vhdl-template-field "waveform") @@ -10466,8 +10493,10 @@ specification, if not already there." (defun vhdl-template-replace-header-keywords (beg end &optional file-title is-model) "Replace keywords in header and footer." - (let ((project-title (or (nth 0 (aget vhdl-project-alist vhdl-project)) "")) - (project-desc (or (nth 9 (aget vhdl-project-alist vhdl-project)) "")) + (let ((project-title (or (nth 0 (vhdl-aget vhdl-project-alist vhdl-project)) + "")) + (project-desc (or (nth 9 (vhdl-aget vhdl-project-alist vhdl-project)) + "")) pos) (vhdl-prepare-search-2 (save-excursion @@ -10525,9 +10554,9 @@ specification, if not already there." (replace-match file-title t t)) (goto-char beg)) (let (string) - (while - (re-search-forward "<\\(\\(\\w\\|\\s_\\)*\\) string>" end t) - (setq string (read-string (concat (match-string 1) ": "))) + (while (re-search-forward "<\\(\\(\\w\\|\\s_\\)*\\) string>" end t) + (save-match-data + (setq string (read-string (concat (match-string 1) ": ")))) (replace-match string t t))) (goto-char beg) (when (and (not is-model) (search-forward "<cursor>" end t)) @@ -10635,14 +10664,7 @@ 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-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)))))) (defun vhdl-comment-block () "Insert comment for code block." @@ -10882,8 +10904,6 @@ Point is left between them." (defun vhdl-template-generate-body (margin label) "Insert body for generate template." (vhdl-insert-keyword " GENERATE") -; (if (not (vhdl-standard-p '87)) -; (vhdl-template-begin-end "GENERATE" label margin) (insert "\n\n") (indent-to margin) (vhdl-insert-keyword "END GENERATE ") @@ -11670,7 +11690,6 @@ reflected in a subsequent paste operation." comment group-comment)))) ;; parse group comment and spacing (setq group-comment (vhdl-parse-group-comment)))) -; (vhdl-parse-string "end\\>") ;; parse context clause (setq context-clause (vhdl-scan-context-clause)) ; ;; add surrounding package to context clause @@ -12622,7 +12641,6 @@ reflected in a subsequent paste operation." (while (and he-expand-list (or (not (stringp (car he-expand-list))) (he-string-member (car he-expand-list) he-tried-table t))) -; (equal (car he-expand-list) he-search-string))) (unless (stringp (car he-expand-list)) (setq vhdl-expand-upper-case (car he-expand-list))) (setq he-expand-list (cdr he-expand-list))) @@ -12908,8 +12926,8 @@ File statistics: \"%s\"\n\ ";; project name\n" "(setq vhdl-project \"" vhdl-project "\")\n\n" ";; project setup\n" - "(aput 'vhdl-project-alist vhdl-project\n'") - (pp (aget vhdl-project-alist vhdl-project) (current-buffer)) + "(vhdl-aput 'vhdl-project-alist vhdl-project\n'") + (pp (vhdl-aget vhdl-project-alist vhdl-project) (current-buffer)) (insert ")\n") (save-buffer) (kill-buffer (current-buffer)) @@ -12929,16 +12947,18 @@ File statistics: \"%s\"\n\ (condition-case () (let ((current-project vhdl-project)) (load-file file-name) - (when (/= (length (aget vhdl-project-alist vhdl-project t)) 10) - (adelete 'vhdl-project-alist vhdl-project) + (when (/= (length (vhdl-aget vhdl-project-alist vhdl-project)) 10) + (vhdl-adelete 'vhdl-project-alist vhdl-project) (error "")) - (when not-make-current - (setq vhdl-project current-project)) + (if not-make-current + (setq vhdl-project current-project) + (setq vhdl-compiler + (caar (nth 4 (vhdl-aget vhdl-project-alist vhdl-project))))) (vhdl-update-mode-menu) (vhdl-speedbar-refresh) (unless not-make-current - (message "Current VHDL project: \"%s\"%s" - vhdl-project (if auto " (auto-loaded)" "")))) + (message "Current VHDL project: \"%s\"; compiler: \"%s\"%s" + vhdl-project vhdl-compiler (if auto " (auto-loaded)" "")))) (error (vhdl-warning (format "ERROR: Invalid project setup file: \"%s\"" file-name)))))) @@ -12946,7 +12966,7 @@ File statistics: \"%s\"\n\ "Duplicate setup of current project." (interactive) (let ((new-name (read-from-minibuffer "New project name: ")) - (project-entry (aget vhdl-project-alist vhdl-project t))) + (project-entry (vhdl-aget vhdl-project-alist vhdl-project))) (setq vhdl-project-alist (append vhdl-project-alist (list (cons new-name project-entry)))) @@ -13275,7 +13295,6 @@ This does highlighting of keywords and standard identifiers.") (skip-syntax-backward " ") (skip-syntax-backward "w_") (skip-syntax-backward " "))) -; (skip-chars-backward "^-(\n\";") (goto-char (match-end 1)) (1 font-lock-variable-name-face))) ;; highlight formal parameters in component instantiations and subprogram @@ -13676,8 +13695,6 @@ hierarchy otherwise.") non-final) "Scan contents of VHDL files in directory or file pattern NAME." (string-match "\\(.*[/\\]\\)\\(.*\\)" name) -; (unless (file-directory-p (match-string 1 name)) -; (message "No such directory: \"%s\"" (match-string 1 name))) (let* ((dir-name (match-string 1 name)) (file-pattern (match-string 2 name)) (is-directory (= 0 (length file-pattern))) @@ -13690,18 +13707,18 @@ hierarchy otherwise.") dir-name t (wildcard-to-regexp file-pattern))))) (key (or project dir-name)) (file-exclude-regexp - (or (nth 3 (aget vhdl-project-alist project)) "")) + (or (nth 3 (vhdl-aget vhdl-project-alist project)) "")) (limit-design-file-size (nth 0 vhdl-speedbar-scan-limit)) (limit-hier-file-size (nth 0 (nth 1 vhdl-speedbar-scan-limit))) (limit-hier-inst-no (nth 1 (nth 1 vhdl-speedbar-scan-limit))) ent-alist conf-alist pack-alist ent-inst-list file-alist tmp-list tmp-entry no-files files-exist big-files) (when (or project update) - (setq ent-alist (aget vhdl-entity-alist key t) - conf-alist (aget vhdl-config-alist key t) - pack-alist (aget vhdl-package-alist key t) - ent-inst-list (car (aget vhdl-ent-inst-alist key t)) - file-alist (aget vhdl-file-alist key t))) + (setq ent-alist (vhdl-aget vhdl-entity-alist key) + conf-alist (vhdl-aget vhdl-config-alist key) + pack-alist (vhdl-aget vhdl-package-alist key) + ent-inst-list (car (vhdl-aget vhdl-ent-inst-alist key)) + file-alist (vhdl-aget vhdl-file-alist key))) (when (and (not is-directory) (null file-list)) (message "No such file: \"%s\"" name)) (setq files-exist file-list) @@ -13743,7 +13760,7 @@ hierarchy otherwise.") (while (re-search-forward "^[ \t]*entity[ \t\n\r\f]+\\(\\w+\\)[ \t\n\r\f]+is\\>" nil t) (let* ((ent-name (match-string-no-properties 1)) (ent-key (downcase ent-name)) - (ent-entry (aget ent-alist ent-key t)) + (ent-entry (vhdl-aget ent-alist ent-key)) (lib-alist (vhdl-scan-context-clause))) (if (nth 1 ent-entry) (vhdl-warning-when-idle @@ -13751,10 +13768,10 @@ hierarchy otherwise.") ent-name (nth 1 ent-entry) (nth 2 ent-entry) file-name (vhdl-current-line)) (push ent-key ent-list) - (aput 'ent-alist ent-key - (list ent-name file-name (vhdl-current-line) - (nth 3 ent-entry) (nth 4 ent-entry) - lib-alist))))) + (vhdl-aput 'ent-alist ent-key + (list ent-name file-name (vhdl-current-line) + (nth 3 ent-entry) (nth 4 ent-entry) + lib-alist))))) ;; scan for architectures (goto-char (point-min)) (while (re-search-forward "^[ \t]*architecture[ \t\n\r\f]+\\(\\w+\\)[ \t\n\r\f]+of[ \t\n\r\f]+\\(\\w+\\)[ \t\n\r\f]+is\\>" nil t) @@ -13762,9 +13779,9 @@ hierarchy otherwise.") (arch-key (downcase arch-name)) (ent-name (match-string-no-properties 2)) (ent-key (downcase ent-name)) - (ent-entry (aget ent-alist ent-key t)) + (ent-entry (vhdl-aget ent-alist ent-key)) (arch-alist (nth 3 ent-entry)) - (arch-entry (aget arch-alist arch-key t)) + (arch-entry (vhdl-aget arch-alist arch-key)) (lib-arch-alist (vhdl-scan-context-clause))) (if arch-entry (vhdl-warning-when-idle @@ -13773,20 +13790,20 @@ hierarchy otherwise.") (nth 2 arch-entry) file-name (vhdl-current-line)) (setq arch-list (cons arch-key arch-list) arch-ent-list (cons ent-key arch-ent-list)) - (aput 'arch-alist arch-key - (list arch-name file-name (vhdl-current-line) nil - lib-arch-alist)) - (aput 'ent-alist ent-key - (list (or (nth 0 ent-entry) ent-name) - (nth 1 ent-entry) (nth 2 ent-entry) - (vhdl-sort-alist arch-alist) - arch-key (nth 5 ent-entry)))))) + (vhdl-aput 'arch-alist arch-key + (list arch-name file-name (vhdl-current-line) + nil lib-arch-alist)) + (vhdl-aput 'ent-alist ent-key + (list (or (nth 0 ent-entry) ent-name) + (nth 1 ent-entry) (nth 2 ent-entry) + (vhdl-sort-alist arch-alist) + arch-key (nth 5 ent-entry)))))) ;; scan for configurations (goto-char (point-min)) (while (re-search-forward "^[ \t]*configuration[ \t\n\r\f]+\\(\\w+\\)[ \t\n\r\f]+of[ \t\n\r\f]+\\(\\w+\\)[ \t\n\r\f]+is\\>" nil t) (let* ((conf-name (match-string-no-properties 1)) (conf-key (downcase conf-name)) - (conf-entry (aget conf-alist conf-key t)) + (conf-entry (vhdl-aget conf-alist conf-key)) (ent-name (match-string-no-properties 2)) (ent-key (downcase ent-name)) (lib-alist (vhdl-scan-context-clause)) @@ -13827,16 +13844,16 @@ hierarchy otherwise.") inst-lib-key) comp-conf-list)) (setq inst-key-list (cdr inst-key-list))))) - (aput 'conf-alist conf-key - (list conf-name file-name conf-line ent-key - arch-key comp-conf-list lib-alist))))) + (vhdl-aput 'conf-alist conf-key + (list conf-name file-name conf-line ent-key + arch-key comp-conf-list lib-alist))))) ;; scan for packages (goto-char (point-min)) (while (re-search-forward "^[ \t]*package[ \t\n\r\f]+\\(body[ \t\n\r\f]+\\)?\\(\\w+\\)[ \t\n\r\f]+is\\>" nil t) (let* ((pack-name (match-string-no-properties 2)) (pack-key (downcase pack-name)) (is-body (match-string-no-properties 1)) - (pack-entry (aget pack-alist pack-key t)) + (pack-entry (vhdl-aget pack-alist pack-key)) (pack-line (vhdl-current-line)) (end-of-unit (vhdl-get-end-of-unit)) comp-name func-name comp-alist func-alist lib-alist) @@ -13867,7 +13884,7 @@ hierarchy otherwise.") (if is-body (push pack-key pack-body-list) (push pack-key pack-list)) - (aput + (vhdl-aput 'pack-alist pack-key (if is-body (list (or (nth 0 pack-entry) pack-name) @@ -13891,9 +13908,9 @@ hierarchy otherwise.") (ent-key (downcase ent-name)) (arch-name (match-string-no-properties 1)) (arch-key (downcase arch-name)) - (ent-entry (aget ent-alist ent-key t)) + (ent-entry (vhdl-aget ent-alist ent-key)) (arch-alist (nth 3 ent-entry)) - (arch-entry (aget arch-alist arch-key t)) + (arch-entry (vhdl-aget arch-alist arch-key)) (beg-of-unit (point)) (end-of-unit (vhdl-get-end-of-unit)) (inst-no 0) @@ -13907,7 +13924,10 @@ hierarchy otherwise.") "\\(\\(for\\|if\\)\\>[^;:]+\\<generate\\>\\|block\\>\\)\\)\\|" "\\(^[ \t]*end[ \t\n\r\f]+\\(generate\\|block\\)\\>\\)") end-of-unit t) (or (not limit-hier-inst-no) - (<= (setq inst-no (1+ inst-no)) + (<= (if (or (match-string 14) + (match-string 16)) + inst-no + (setq inst-no (1+ inst-no))) limit-hier-inst-no))) (cond ;; block/generate beginning found @@ -13988,23 +14008,25 @@ hierarchy otherwise.") (setcar tmp-inst-alist inst-entry)) (setq tmp-inst-alist (cdr tmp-inst-alist))))) ;; save in cache - (aput 'arch-alist arch-key - (list (nth 0 arch-entry) (nth 1 arch-entry) - (nth 2 arch-entry) inst-alist - (nth 4 arch-entry))) - (aput 'ent-alist ent-key - (list (nth 0 ent-entry) (nth 1 ent-entry) - (nth 2 ent-entry) (vhdl-sort-alist arch-alist) - (nth 4 ent-entry) (nth 5 ent-entry))) + (vhdl-aput 'arch-alist arch-key + (list (nth 0 arch-entry) (nth 1 arch-entry) + (nth 2 arch-entry) inst-alist + (nth 4 arch-entry))) + (vhdl-aput 'ent-alist ent-key + (list (nth 0 ent-entry) (nth 1 ent-entry) + (nth 2 ent-entry) + (vhdl-sort-alist arch-alist) + (nth 4 ent-entry) (nth 5 ent-entry))) (when (and limit-hier-inst-no (> inst-no limit-hier-inst-no)) (message "WARNING: Scan limit (hierarchy: instances per architecture) reached in file:\n \"%s\"" file-name) (setq big-files t)) (goto-char end-of-unit)))) ;; remember design units for this file - (aput 'file-alist file-name - (list ent-list arch-list arch-ent-list conf-list - pack-list pack-body-list inst-list inst-ent-list)) + (vhdl-aput 'file-alist file-name + (list ent-list arch-list arch-ent-list conf-list + pack-list pack-body-list + inst-list inst-ent-list)) (setq ent-inst-list (append inst-ent-list ent-inst-list)))))) (setq file-list (cdr file-list)))) (when (or (and (not project) files-exist) @@ -14023,8 +14045,8 @@ hierarchy otherwise.") ;; check whether configuration has a corresponding entity/architecture (setq tmp-list conf-alist) (while tmp-list - (if (setq tmp-entry (aget ent-alist (nth 4 (car tmp-list)) t)) - (unless (aget (nth 3 tmp-entry) (nth 5 (car tmp-list)) t) + (if (setq tmp-entry (vhdl-aget ent-alist (nth 4 (car tmp-list)))) + (unless (vhdl-aget (nth 3 tmp-entry) (nth 5 (car tmp-list))) (setq tmp-entry (car tmp-list)) (vhdl-warning-when-idle "Configuration of non-existing architecture: \"%s\" of \"%s(%s)\"\n in \"%s\" (line %d)" @@ -14053,17 +14075,17 @@ hierarchy otherwise.") (add-to-list 'vhdl-updated-project-list (or project dir-name))) ;; clear directory alists (unless project - (adelete 'vhdl-entity-alist key) - (adelete 'vhdl-config-alist key) - (adelete 'vhdl-package-alist key) - (adelete 'vhdl-ent-inst-alist key) - (adelete 'vhdl-file-alist key)) + (vhdl-adelete 'vhdl-entity-alist key) + (vhdl-adelete 'vhdl-config-alist key) + (vhdl-adelete 'vhdl-package-alist key) + (vhdl-adelete 'vhdl-ent-inst-alist key) + (vhdl-adelete 'vhdl-file-alist key)) ;; put directory contents into cache - (aput 'vhdl-entity-alist key ent-alist) - (aput 'vhdl-config-alist key conf-alist) - (aput 'vhdl-package-alist key pack-alist) - (aput 'vhdl-ent-inst-alist key (list ent-inst-list)) - (aput 'vhdl-file-alist key file-alist) + (vhdl-aput 'vhdl-entity-alist key ent-alist) + (vhdl-aput 'vhdl-config-alist key conf-alist) + (vhdl-aput 'vhdl-package-alist key pack-alist) + (vhdl-aput 'vhdl-ent-inst-alist key (list ent-inst-list)) + (vhdl-aput 'vhdl-file-alist key file-alist) ;; final messages (message "Scanning %s %s\"%s\"...done" (if is-directory "directory" "files") (or num-string "") name) @@ -14079,18 +14101,18 @@ hierarchy otherwise.") (defun vhdl-scan-project-contents (project) "Scan the contents of all VHDL files found in the directories and files of PROJECT." - (let ((dir-list (or (nth 2 (aget vhdl-project-alist project)) '(""))) + (let ((dir-list (or (nth 2 (vhdl-aget vhdl-project-alist project)) '(""))) (default-dir (vhdl-resolve-env-variable - (nth 1 (aget vhdl-project-alist project)))) + (nth 1 (vhdl-aget vhdl-project-alist project)))) (file-exclude-regexp - (or (nth 3 (aget vhdl-project-alist project)) "")) + (or (nth 3 (vhdl-aget vhdl-project-alist project)) "")) dir-list-tmp dir dir-name num-dir act-dir recursive) ;; clear project alists - (adelete 'vhdl-entity-alist project) - (adelete 'vhdl-config-alist project) - (adelete 'vhdl-package-alist project) - (adelete 'vhdl-ent-inst-alist project) - (adelete 'vhdl-file-alist project) + (vhdl-adelete 'vhdl-entity-alist project) + (vhdl-adelete 'vhdl-config-alist project) + (vhdl-adelete 'vhdl-package-alist project) + (vhdl-adelete 'vhdl-ent-inst-alist project) + (vhdl-adelete 'vhdl-file-alist project) ;; expand directory names by default-directory (message "Collecting source files...") (while dir-list @@ -14137,7 +14159,7 @@ of PROJECT." (add-to-list 'dir-list-tmp (file-name-directory dir-name)) (setq dir-list (cdr dir-list) act-dir (1+ act-dir))) - (aput 'vhdl-directory-alist project (list (nreverse dir-list-tmp))) + (vhdl-aput 'vhdl-directory-alist project (list (nreverse dir-list-tmp))) (message "Scanning project \"%s\"...done" project))) (defun vhdl-update-file-contents (file-name) @@ -14150,13 +14172,16 @@ of PROJECT." (when (member dir-name (nth 1 (car directory-alist))) (let* ((vhdl-project (nth 0 (car directory-alist))) (project (vhdl-project-p)) - (ent-alist (aget vhdl-entity-alist (or project dir-name) t)) - (conf-alist (aget vhdl-config-alist (or project dir-name) t)) - (pack-alist (aget vhdl-package-alist (or project dir-name) t)) - (ent-inst-list (car (aget vhdl-ent-inst-alist - (or project dir-name) t))) - (file-alist (aget vhdl-file-alist (or project dir-name) t)) - (file-entry (aget file-alist file-name t)) + (ent-alist (vhdl-aget vhdl-entity-alist + (or project dir-name))) + (conf-alist (vhdl-aget vhdl-config-alist + (or project dir-name))) + (pack-alist (vhdl-aget vhdl-package-alist + (or project dir-name))) + (ent-inst-list (car (vhdl-aget vhdl-ent-inst-alist + (or project dir-name)))) + (file-alist (vhdl-aget vhdl-file-alist (or project dir-name))) + (file-entry (vhdl-aget file-alist file-name)) (ent-list (nth 0 file-entry)) (arch-list (nth 1 file-entry)) (arch-ent-list (nth 2 file-entry)) @@ -14170,57 +14195,57 @@ of PROJECT." ;; entities (while ent-list (setq key (car ent-list) - entry (aget ent-alist key t)) + entry (vhdl-aget ent-alist key)) (when (equal file-name (nth 1 entry)) (if (nth 3 entry) - (aput 'ent-alist key - (list (nth 0 entry) nil nil (nth 3 entry) nil)) - (adelete 'ent-alist key))) + (vhdl-aput 'ent-alist key + (list (nth 0 entry) nil nil (nth 3 entry) nil)) + (vhdl-adelete 'ent-alist key))) (setq ent-list (cdr ent-list))) ;; architectures (while arch-list (setq key (car arch-list) ent-key (car arch-ent-list) - entry (aget ent-alist ent-key t) + entry (vhdl-aget ent-alist ent-key) arch-alist (nth 3 entry)) - (when (equal file-name (nth 1 (aget arch-alist key t))) - (adelete 'arch-alist key) + (when (equal file-name (nth 1 (vhdl-aget arch-alist key))) + (vhdl-adelete 'arch-alist key) (if (or (nth 1 entry) arch-alist) - (aput 'ent-alist ent-key - (list (nth 0 entry) (nth 1 entry) (nth 2 entry) - arch-alist (nth 4 entry) (nth 5 entry))) - (adelete 'ent-alist ent-key))) + (vhdl-aput 'ent-alist ent-key + (list (nth 0 entry) (nth 1 entry) (nth 2 entry) + arch-alist (nth 4 entry) (nth 5 entry))) + (vhdl-adelete 'ent-alist ent-key))) (setq arch-list (cdr arch-list) arch-ent-list (cdr arch-ent-list))) ;; configurations (while conf-list (setq key (car conf-list)) - (when (equal file-name (nth 1 (aget conf-alist key t))) - (adelete 'conf-alist key)) + (when (equal file-name (nth 1 (vhdl-aget conf-alist key))) + (vhdl-adelete 'conf-alist key)) (setq conf-list (cdr conf-list))) ;; package declarations (while pack-list (setq key (car pack-list) - entry (aget pack-alist key t)) + entry (vhdl-aget pack-alist key)) (when (equal file-name (nth 1 entry)) (if (nth 6 entry) - (aput 'pack-alist key - (list (nth 0 entry) nil nil nil nil nil - (nth 6 entry) (nth 7 entry) (nth 8 entry) - (nth 9 entry))) - (adelete 'pack-alist key))) + (vhdl-aput 'pack-alist key + (list (nth 0 entry) nil nil nil nil nil + (nth 6 entry) (nth 7 entry) (nth 8 entry) + (nth 9 entry))) + (vhdl-adelete 'pack-alist key))) (setq pack-list (cdr pack-list))) ;; package bodies (while pack-body-list (setq key (car pack-body-list) - entry (aget pack-alist key t)) + entry (vhdl-aget pack-alist key)) (when (equal file-name (nth 6 entry)) (if (nth 1 entry) - (aput 'pack-alist key - (list (nth 0 entry) (nth 1 entry) (nth 2 entry) - (nth 3 entry) (nth 4 entry) (nth 5 entry) - nil nil nil nil)) - (adelete 'pack-alist key))) + (vhdl-aput 'pack-alist key + (list (nth 0 entry) (nth 1 entry) (nth 2 entry) + (nth 3 entry) (nth 4 entry) (nth 5 entry) + nil nil nil nil)) + (vhdl-adelete 'pack-alist key))) (setq pack-body-list (cdr pack-body-list))) ;; instantiated entities (while inst-ent-list @@ -14228,10 +14253,10 @@ of PROJECT." (vhdl-delete (car inst-ent-list) ent-inst-list)) (setq inst-ent-list (cdr inst-ent-list))) ;; update caches - (vhdl-aput 'vhdl-entity-alist cache-key ent-alist) - (vhdl-aput 'vhdl-config-alist cache-key conf-alist) - (vhdl-aput 'vhdl-package-alist cache-key pack-alist) - (vhdl-aput 'vhdl-ent-inst-alist cache-key (list ent-inst-list)) + (vhdl-aput-delete-if-nil 'vhdl-entity-alist cache-key ent-alist) + (vhdl-aput-delete-if-nil 'vhdl-config-alist cache-key conf-alist) + (vhdl-aput-delete-if-nil 'vhdl-package-alist cache-key pack-alist) + (vhdl-aput-delete-if-nil 'vhdl-ent-inst-alist cache-key (list ent-inst-list)) ;; scan file (vhdl-scan-directory-contents file-name project t) (when (or (and vhdl-speedbar-show-projects project) @@ -14264,8 +14289,8 @@ of PROJECT." &optional include-top ent-hier) "Get instantiation hierarchy beginning in architecture ARCH-KEY of entity ENT-KEY." - (let* ((ent-entry (aget ent-alist ent-key t)) - (arch-entry (if arch-key (aget (nth 3 ent-entry) arch-key t) + (let* ((ent-entry (vhdl-aget ent-alist ent-key)) + (arch-entry (if arch-key (vhdl-aget (nth 3 ent-entry) arch-key) (cdar (last (nth 3 ent-entry))))) (inst-alist (nth 3 arch-entry)) inst-entry inst-ent-entry inst-arch-entry inst-conf-entry comp-entry @@ -14276,9 +14301,6 @@ entity ENT-KEY." (setq level (1+ level))) (when (member ent-key ent-hier) (error "ERROR: Instantiation loop detected, component instantiates itself: \"%s\"" ent-key)) - ;; check configured architecture (already checked during scanning) -; (unless (or (null conf-inst-alist) (assoc arch-key (nth 3 ent-entry))) -; (vhdl-warning-when-idle "Configuration for non-existing architecture used: \"%s\"" conf-key)) ;; process all instances (while inst-alist (setq inst-entry (car inst-alist) @@ -14294,27 +14316,27 @@ entity ENT-KEY." (downcase (or inst-comp-name "")))))) (setq tmp-list (cdr tmp-list))) (setq inst-conf-key (or (nth 4 (car tmp-list)) inst-conf-key)) - (setq inst-conf-entry (aget conf-alist inst-conf-key t)) + (setq inst-conf-entry (vhdl-aget conf-alist inst-conf-key)) (when (and inst-conf-key (not inst-conf-entry)) (vhdl-warning-when-idle "Configuration not found: \"%s\"" inst-conf-key)) ;; determine entity (setq inst-ent-key (or (nth 2 (car tmp-list)) ; from configuration (nth 3 inst-conf-entry) ; from subconfiguration - (nth 3 (aget conf-alist (nth 7 inst-entry) t)) + (nth 3 (vhdl-aget conf-alist (nth 7 inst-entry))) ; from configuration spec. (nth 5 inst-entry))) ; from direct instantiation - (setq inst-ent-entry (aget ent-alist inst-ent-key t)) + (setq inst-ent-entry (vhdl-aget ent-alist inst-ent-key)) ;; determine architecture (setq inst-arch-key (or (nth 3 (car tmp-list)) ; from configuration (nth 4 inst-conf-entry) ; from subconfiguration (nth 6 inst-entry) ; from direct instantiation - (nth 4 (aget conf-alist (nth 7 inst-entry))) + (nth 4 (vhdl-aget conf-alist (nth 7 inst-entry))) ; from configuration spec. (nth 4 inst-ent-entry) ; MRA (caar (nth 3 inst-ent-entry)))) ; first alphabetically - (setq inst-arch-entry (aget (nth 3 inst-ent-entry) inst-arch-key t)) + (setq inst-arch-entry (vhdl-aget (nth 3 inst-ent-entry) inst-arch-key)) ;; set library (setq inst-lib-key (or (nth 5 (car tmp-list)) ; from configuration @@ -14353,7 +14375,8 @@ entity ENT-KEY." (defun vhdl-get-instantiations (ent-key indent) "Get all instantiations of entity ENT-KEY." - (let ((ent-alist (aget vhdl-entity-alist (vhdl-speedbar-line-key indent) t)) + (let ((ent-alist (vhdl-aget vhdl-entity-alist + (vhdl-speedbar-line-key indent))) arch-alist inst-alist ent-inst-list ent-entry arch-entry inst-entry) (while ent-alist @@ -14439,29 +14462,29 @@ entity ENT-KEY." (insert ")\n") (when (member 'hierarchy vhdl-speedbar-save-cache) (insert "\n;; entity and architecture cache\n" - "(aput 'vhdl-entity-alist " key " '") - (print (aget vhdl-entity-alist cache-key t) (current-buffer)) + "(vhdl-aput 'vhdl-entity-alist " key " '") + (print (vhdl-aget vhdl-entity-alist cache-key) (current-buffer)) (insert ")\n\n;; configuration cache\n" - "(aput 'vhdl-config-alist " key " '") - (print (aget vhdl-config-alist cache-key t) (current-buffer)) + "(vhdl-aput 'vhdl-config-alist " key " '") + (print (vhdl-aget vhdl-config-alist cache-key) (current-buffer)) (insert ")\n\n;; package cache\n" - "(aput 'vhdl-package-alist " key " '") - (print (aget vhdl-package-alist cache-key t) (current-buffer)) + "(vhdl-aput 'vhdl-package-alist " key " '") + (print (vhdl-aget vhdl-package-alist cache-key) (current-buffer)) (insert ")\n\n;; instantiated entities cache\n" - "(aput 'vhdl-ent-inst-alist " key " '") - (print (aget vhdl-ent-inst-alist cache-key t) (current-buffer)) + "(vhdl-aput 'vhdl-ent-inst-alist " key " '") + (print (vhdl-aget vhdl-ent-inst-alist cache-key) (current-buffer)) (insert ")\n\n;; design units per file cache\n" - "(aput 'vhdl-file-alist " key " '") - (print (aget vhdl-file-alist cache-key t) (current-buffer)) + "(vhdl-aput 'vhdl-file-alist " key " '") + (print (vhdl-aget vhdl-file-alist cache-key) (current-buffer)) (when project (insert ")\n\n;; source directories in project cache\n" - "(aput 'vhdl-directory-alist " key " '") - (print (aget vhdl-directory-alist cache-key t) (current-buffer))) + "(vhdl-aput 'vhdl-directory-alist " key " '") + (print (vhdl-aget vhdl-directory-alist cache-key) (current-buffer))) (insert ")\n")) (when (member 'display vhdl-speedbar-save-cache) (insert "\n;; shown design units cache\n" - "(aput 'vhdl-speedbar-shown-unit-alist " key " '") - (print (aget vhdl-speedbar-shown-unit-alist cache-key t) + "(vhdl-aput 'vhdl-speedbar-shown-unit-alist " key " '") + (print (vhdl-aget vhdl-speedbar-shown-unit-alist cache-key) (current-buffer)) (insert ")\n")) (setq vhdl-updated-project-list @@ -14528,7 +14551,6 @@ if required." (defun vhdl-speedbar-initialize () "Initialize speedbar." ;; general settings -; (set (make-local-variable 'speedbar-tag-hierarchy-method) nil) ;; VHDL file extensions (extracted from `auto-mode-alist') (let ((mode-alist auto-mode-alist)) (while mode-alist @@ -14626,11 +14648,7 @@ if required." (append '(("vhdl directory" vhdl-speedbar-update-current-unit) ("vhdl project" vhdl-speedbar-update-current-project - vhdl-speedbar-update-current-unit) -; ("files" (lambda () (setq speedbar-ignored-path-regexp -; (speedbar-extension-list-to-regex -; speedbar-ignored-path-expressions)))) - ) + vhdl-speedbar-update-current-unit)) speedbar-stealthy-function-list)) (when (eq vhdl-speedbar-display-mode 'directory) (setq speedbar-initial-expansion-list-name "vhdl directory")) @@ -14724,10 +14742,7 @@ if required." (concat "^\\([0-9]+:\\s-*<\\)[+]>\\s-+" (caar project-alist) "$") nil t) (goto-char (match-end 1)) (speedbar-do-function-pointer))) - (setq project-alist (cdr project-alist)))) -; (vhdl-speedbar-update-current-project) -; (vhdl-speedbar-update-current-unit nil t) - ) + (setq project-alist (cdr project-alist))))) (defun vhdl-speedbar-insert-project-hierarchy (project indent &optional rescan) "Insert hierarchy of PROJECT. Rescan directories if RESCAN is non-nil, @@ -14737,10 +14752,10 @@ otherwise use cached data." (vhdl-scan-project-contents project)) ;; insert design hierarchy (vhdl-speedbar-insert-hierarchy - (aget vhdl-entity-alist project t) - (aget vhdl-config-alist project t) - (aget vhdl-package-alist project t) - (car (aget vhdl-ent-inst-alist project t)) indent) + (vhdl-aget vhdl-entity-alist project) + (vhdl-aget vhdl-config-alist project) + (vhdl-aget vhdl-package-alist project) + (car (vhdl-aget vhdl-ent-inst-alist project)) indent) (insert (int-to-string indent) ":\n") (put-text-property (- (point) 3) (1- (point)) 'invisible t) (put-text-property (1- (point)) (point) 'invisible nil) @@ -14755,13 +14770,13 @@ otherwise use cached data." (vhdl-scan-directory-contents directory)) ;; insert design hierarchy (vhdl-speedbar-insert-hierarchy - (aget vhdl-entity-alist directory t) - (aget vhdl-config-alist directory t) - (aget vhdl-package-alist directory t) - (car (aget vhdl-ent-inst-alist directory t)) depth) + (vhdl-aget vhdl-entity-alist directory) + (vhdl-aget vhdl-config-alist directory) + (vhdl-aget vhdl-package-alist directory) + (car (vhdl-aget vhdl-ent-inst-alist directory)) depth) ;; expand design units (vhdl-speedbar-expand-units directory) - (aput 'vhdl-directory-alist directory (list (list directory)))) + (vhdl-aput 'vhdl-directory-alist directory (list (list directory)))) (defun vhdl-speedbar-insert-hierarchy (ent-alist conf-alist pack-alist ent-inst-list depth) @@ -14849,10 +14864,10 @@ otherwise use cached data." (defun vhdl-speedbar-expand-units (key) "Expand design units in directory/project KEY according to `vhdl-speedbar-shown-unit-alist'." - (let ((unit-alist (aget vhdl-speedbar-shown-unit-alist key t)) + (let ((unit-alist (vhdl-aget vhdl-speedbar-shown-unit-alist key)) (vhdl-speedbar-update-current-unit nil) vhdl-updated-project-list) - (adelete 'vhdl-speedbar-shown-unit-alist key) + (vhdl-adelete 'vhdl-speedbar-shown-unit-alist key) (vhdl-prepare-search-1 (while unit-alist ; expand units (vhdl-speedbar-goto-this-unit key (caar unit-alist)) @@ -14902,7 +14917,7 @@ otherwise use cached data." (progn (setq vhdl-speedbar-shown-project-list nil) (vhdl-speedbar-refresh)) (let ((key (vhdl-speedbar-line-key))) - (adelete 'vhdl-speedbar-shown-unit-alist key) + (vhdl-adelete 'vhdl-speedbar-shown-unit-alist key) (vhdl-speedbar-refresh (and vhdl-speedbar-show-projects key)) (when (memq 'display vhdl-speedbar-save-cache) (add-to-list 'vhdl-updated-project-list key))))) @@ -14911,9 +14926,9 @@ otherwise use cached data." "Expand all design units in current directory/project." (interactive) (let* ((key (vhdl-speedbar-line-key)) - (ent-alist (aget vhdl-entity-alist key t)) - (conf-alist (aget vhdl-config-alist key t)) - (pack-alist (aget vhdl-package-alist key t)) + (ent-alist (vhdl-aget vhdl-entity-alist key)) + (conf-alist (vhdl-aget vhdl-config-alist key)) + (pack-alist (vhdl-aget vhdl-package-alist key)) arch-alist unit-alist subunit-alist) (add-to-list 'vhdl-speedbar-shown-project-list key) (while ent-alist @@ -14930,7 +14945,7 @@ otherwise use cached data." (while pack-alist (push (list (caar pack-alist)) unit-alist) (setq pack-alist (cdr pack-alist))) - (aput 'vhdl-speedbar-shown-unit-alist key unit-alist) + (vhdl-aput 'vhdl-speedbar-shown-unit-alist key unit-alist) (vhdl-speedbar-refresh) (when (memq 'display vhdl-speedbar-save-cache) (add-to-list 'vhdl-updated-project-list key)))) @@ -14965,8 +14980,8 @@ otherwise use cached data." (cond ((string-match "+" text) ; expand entity (let* ((key (vhdl-speedbar-line-key indent)) - (ent-alist (aget vhdl-entity-alist key t)) - (ent-entry (aget ent-alist token t)) + (ent-alist (vhdl-aget vhdl-entity-alist key)) + (ent-entry (vhdl-aget ent-alist token)) (arch-alist (nth 3 ent-entry)) (inst-alist (vhdl-get-instantiations token indent)) (subpack-alist (nth 5 ent-entry)) @@ -14976,9 +14991,9 @@ otherwise use cached data." (speedbar-change-expand-button-char ??) (speedbar-change-expand-button-char ?-) ;; add entity to `vhdl-speedbar-shown-unit-alist' - (let* ((unit-alist (aget vhdl-speedbar-shown-unit-alist key t))) - (aput 'unit-alist token nil) - (aput 'vhdl-speedbar-shown-unit-alist key unit-alist)) + (let* ((unit-alist (vhdl-aget vhdl-speedbar-shown-unit-alist key))) + (vhdl-aput 'unit-alist token nil) + (vhdl-aput 'vhdl-speedbar-shown-unit-alist key unit-alist)) (speedbar-with-writable (save-excursion (end-of-line) (forward-char 1) @@ -15017,11 +15032,11 @@ otherwise use cached data." (speedbar-change-expand-button-char ?+) ;; remove entity from `vhdl-speedbar-shown-unit-alist' (let* ((key (vhdl-speedbar-line-key indent)) - (unit-alist (aget vhdl-speedbar-shown-unit-alist key t))) - (adelete 'unit-alist token) + (unit-alist (vhdl-aget vhdl-speedbar-shown-unit-alist key))) + (vhdl-adelete 'unit-alist token) (if unit-alist - (aput 'vhdl-speedbar-shown-unit-alist key unit-alist) - (adelete 'vhdl-speedbar-shown-unit-alist key)) + (vhdl-aput 'vhdl-speedbar-shown-unit-alist key unit-alist) + (vhdl-adelete 'vhdl-speedbar-shown-unit-alist key)) (speedbar-delete-subblock indent) (when (memq 'display vhdl-speedbar-save-cache) (add-to-list 'vhdl-updated-project-list key)))) @@ -15034,23 +15049,24 @@ otherwise use cached data." (cond ((string-match "+" text) ; expand architecture (let* ((key (vhdl-speedbar-line-key (1- indent))) - (ent-alist (aget vhdl-entity-alist key t)) - (conf-alist (aget vhdl-config-alist key t)) + (ent-alist (vhdl-aget vhdl-entity-alist key)) + (conf-alist (vhdl-aget vhdl-config-alist key)) (hier-alist (vhdl-get-hierarchy ent-alist conf-alist (car token) (cdr token) nil nil 0 (1- indent))) - (ent-entry (aget ent-alist (car token) t)) - (arch-entry (aget (nth 3 ent-entry) (cdr token) t)) + (ent-entry (vhdl-aget ent-alist (car token))) + (arch-entry (vhdl-aget (nth 3 ent-entry) (cdr token))) (subpack-alist (nth 4 arch-entry)) entry) (if (not (or hier-alist subpack-alist)) (speedbar-change-expand-button-char ??) (speedbar-change-expand-button-char ?-) ;; add architecture to `vhdl-speedbar-shown-unit-alist' - (let* ((unit-alist (aget vhdl-speedbar-shown-unit-alist key t)) - (arch-alist (nth 0 (aget unit-alist (car token) t)))) - (aput 'unit-alist (car token) (list (cons (cdr token) arch-alist))) - (aput 'vhdl-speedbar-shown-unit-alist key unit-alist)) + (let* ((unit-alist (vhdl-aget vhdl-speedbar-shown-unit-alist key)) + (arch-alist (nth 0 (vhdl-aget unit-alist (car token))))) + (vhdl-aput 'unit-alist (car token) + (list (cons (cdr token) arch-alist))) + (vhdl-aput 'vhdl-speedbar-shown-unit-alist key unit-alist)) (speedbar-with-writable (save-excursion (end-of-line) (forward-char 1) @@ -15077,10 +15093,10 @@ otherwise use cached data." (speedbar-change-expand-button-char ?+) ;; remove architecture from `vhdl-speedbar-shown-unit-alist' (let* ((key (vhdl-speedbar-line-key (1- indent))) - (unit-alist (aget vhdl-speedbar-shown-unit-alist key t)) - (arch-alist (nth 0 (aget unit-alist (car token) t)))) - (aput 'unit-alist (car token) (list (delete (cdr token) arch-alist))) - (aput 'vhdl-speedbar-shown-unit-alist key unit-alist) + (unit-alist (vhdl-aget vhdl-speedbar-shown-unit-alist key)) + (arch-alist (nth 0 (vhdl-aget unit-alist (car token))))) + (vhdl-aput 'unit-alist (car token) (list (delete (cdr token) arch-alist))) + (vhdl-aput 'vhdl-speedbar-shown-unit-alist key unit-alist) (speedbar-delete-subblock indent) (when (memq 'display vhdl-speedbar-save-cache) (add-to-list 'vhdl-updated-project-list key)))) @@ -15093,9 +15109,9 @@ otherwise use cached data." (cond ((string-match "+" text) ; expand configuration (let* ((key (vhdl-speedbar-line-key indent)) - (conf-alist (aget vhdl-config-alist key t)) - (conf-entry (aget conf-alist token)) - (ent-alist (aget vhdl-entity-alist key t)) + (conf-alist (vhdl-aget vhdl-config-alist key)) + (conf-entry (vhdl-aget conf-alist token)) + (ent-alist (vhdl-aget vhdl-entity-alist key)) (hier-alist (vhdl-get-hierarchy ent-alist conf-alist (nth 3 conf-entry) (nth 4 conf-entry) token (nth 5 conf-entry) @@ -15106,9 +15122,9 @@ otherwise use cached data." (speedbar-change-expand-button-char ??) (speedbar-change-expand-button-char ?-) ;; add configuration to `vhdl-speedbar-shown-unit-alist' - (let* ((unit-alist (aget vhdl-speedbar-shown-unit-alist key t))) - (aput 'unit-alist token nil) - (aput 'vhdl-speedbar-shown-unit-alist key unit-alist)) + (let* ((unit-alist (vhdl-aget vhdl-speedbar-shown-unit-alist key))) + (vhdl-aput 'unit-alist token nil) + (vhdl-aput 'vhdl-speedbar-shown-unit-alist key unit-alist)) (speedbar-with-writable (save-excursion (end-of-line) (forward-char 1) @@ -15134,11 +15150,11 @@ otherwise use cached data." (speedbar-change-expand-button-char ?+) ;; remove configuration from `vhdl-speedbar-shown-unit-alist' (let* ((key (vhdl-speedbar-line-key indent)) - (unit-alist (aget vhdl-speedbar-shown-unit-alist key t))) - (adelete 'unit-alist token) + (unit-alist (vhdl-aget vhdl-speedbar-shown-unit-alist key))) + (vhdl-adelete 'unit-alist token) (if unit-alist - (aput 'vhdl-speedbar-shown-unit-alist key unit-alist) - (adelete 'vhdl-speedbar-shown-unit-alist key)) + (vhdl-aput 'vhdl-speedbar-shown-unit-alist key unit-alist) + (vhdl-adelete 'vhdl-speedbar-shown-unit-alist key)) (speedbar-delete-subblock indent) (when (memq 'display vhdl-speedbar-save-cache) (add-to-list 'vhdl-updated-project-list key)))) @@ -15151,8 +15167,8 @@ otherwise use cached data." (cond ((string-match "+" text) ; expand package (let* ((key (vhdl-speedbar-line-key indent)) - (pack-alist (aget vhdl-package-alist key t)) - (pack-entry (aget pack-alist token t)) + (pack-alist (vhdl-aget vhdl-package-alist key)) + (pack-entry (vhdl-aget pack-alist token)) (comp-alist (nth 3 pack-entry)) (func-alist (nth 4 pack-entry)) (func-body-alist (nth 8 pack-entry)) @@ -15162,9 +15178,9 @@ otherwise use cached data." (speedbar-change-expand-button-char ??) (speedbar-change-expand-button-char ?-) ;; add package to `vhdl-speedbar-shown-unit-alist' - (let* ((unit-alist (aget vhdl-speedbar-shown-unit-alist key t))) - (aput 'unit-alist token nil) - (aput 'vhdl-speedbar-shown-unit-alist key unit-alist)) + (let* ((unit-alist (vhdl-aget vhdl-speedbar-shown-unit-alist key))) + (vhdl-aput 'unit-alist token nil) + (vhdl-aput 'vhdl-speedbar-shown-unit-alist key unit-alist)) (speedbar-with-writable (save-excursion (end-of-line) (forward-char 1) @@ -15185,7 +15201,8 @@ otherwise use cached data." (vhdl-speedbar-make-title-line "Subprograms:" (1+ indent))) (while func-alist (setq func-entry (car func-alist) - func-body-entry (aget func-body-alist (car func-entry) t)) + func-body-entry (vhdl-aget func-body-alist + (car func-entry))) (when (nth 2 func-entry) (vhdl-speedbar-make-subprogram-line (nth 1 func-entry) @@ -15203,11 +15220,11 @@ otherwise use cached data." (speedbar-change-expand-button-char ?+) ;; remove package from `vhdl-speedbar-shown-unit-alist' (let* ((key (vhdl-speedbar-line-key indent)) - (unit-alist (aget vhdl-speedbar-shown-unit-alist key t))) - (adelete 'unit-alist token) + (unit-alist (vhdl-aget vhdl-speedbar-shown-unit-alist key))) + (vhdl-adelete 'unit-alist token) (if unit-alist - (aput 'vhdl-speedbar-shown-unit-alist key unit-alist) - (adelete 'vhdl-speedbar-shown-unit-alist key)) + (vhdl-aput 'vhdl-speedbar-shown-unit-alist key unit-alist) + (vhdl-adelete 'vhdl-speedbar-shown-unit-alist key)) (speedbar-delete-subblock indent) (when (memq 'display vhdl-speedbar-save-cache) (add-to-list 'vhdl-updated-project-list key)))) @@ -15217,15 +15234,15 @@ otherwise use cached data." (defun vhdl-speedbar-insert-subpackages (subpack-alist indent dir-indent) "Insert required packages." - (let* ((pack-alist (aget vhdl-package-alist - (vhdl-speedbar-line-key dir-indent) t)) + (let* ((pack-alist (vhdl-aget vhdl-package-alist + (vhdl-speedbar-line-key dir-indent))) pack-key lib-name pack-entry) (when subpack-alist (vhdl-speedbar-make-title-line "Packages Used:" indent)) (while subpack-alist (setq pack-key (cdar subpack-alist) lib-name (caar subpack-alist)) - (setq pack-entry (aget pack-alist pack-key t)) + (setq pack-entry (vhdl-aget pack-alist pack-key)) (vhdl-speedbar-make-subpack-line (or (nth 0 pack-entry) pack-key) lib-name (cons (nth 1 pack-entry) (nth 2 pack-entry)) @@ -15283,18 +15300,21 @@ NO-POSITION non-nil means do not re-position cursor." (or always (not (equal file-name speedbar-last-selected-file)))) (if vhdl-speedbar-show-projects (while project-list - (setq file-alist (append file-alist (aget vhdl-file-alist - (car project-list) t))) + (setq file-alist (append file-alist + (vhdl-aget vhdl-file-alist + (car project-list)))) (setq project-list (cdr project-list))) - (setq file-alist (aget vhdl-file-alist - (abbreviate-file-name default-directory) t))) + (setq file-alist + (vhdl-aget vhdl-file-alist + (abbreviate-file-name default-directory)))) (select-frame speedbar-frame) (set-buffer speedbar-buffer) (speedbar-with-writable (vhdl-prepare-search-1 (save-excursion ;; unhighlight last units - (let* ((file-entry (aget file-alist speedbar-last-selected-file t))) + (let* ((file-entry (vhdl-aget file-alist + speedbar-last-selected-file))) (vhdl-speedbar-update-units "\\[.\\] " (nth 0 file-entry) speedbar-last-selected-file 'vhdl-speedbar-entity-face) @@ -15314,7 +15334,7 @@ NO-POSITION non-nil means do not re-position cursor." "> " (nth 6 file-entry) speedbar-last-selected-file 'vhdl-speedbar-instantiation-face)) ;; highlight current units - (let* ((file-entry (aget file-alist file-name t))) + (let* ((file-entry (vhdl-aget file-alist file-name))) (setq pos (vhdl-speedbar-update-units "\\[.\\] " (nth 0 file-entry) @@ -15747,7 +15767,8 @@ is already shown in a buffer." (let ((buffer (get-file-buffer (car token)))) (speedbar-find-file-in-frame (car token)) (when (or vhdl-speedbar-jump-to-unit buffer) - (vhdl-goto-line (cdr token)) + (goto-char (point-min)) + (forward-line (1- (cdr token))) (recenter)) (vhdl-speedbar-update-current-unit t t) (speedbar-set-timer dframe-update-speed) @@ -15765,7 +15786,8 @@ is already shown in a buffer." (let ((token (get-text-property (match-beginning 3) 'speedbar-token))) (vhdl-visit-file (car token) t - (progn (vhdl-goto-line (cdr token)) + (progn (goto-char (point-min)) + (forward-line (1- (cdr token))) (end-of-line) (if is-entity (vhdl-port-copy) @@ -15805,9 +15827,11 @@ is already shown in a buffer." (error "ERROR: No architecture under cursor") (let* ((arch-key (downcase (vhdl-speedbar-line-text))) (ent-key (downcase (vhdl-speedbar-higher-text))) - (ent-alist (aget vhdl-entity-alist - (or (vhdl-project-p) default-directory) t)) - (ent-entry (aget ent-alist ent-key t))) + (ent-alist (vhdl-aget + vhdl-entity-alist + (or (vhdl-project-p) + (abbreviate-file-name default-directory)))) + (ent-entry (vhdl-aget ent-alist ent-key))) (setcar (cddr (cddr ent-entry)) arch-key) ; (nth 4 ent-entry) (speedbar-refresh)))) @@ -15946,15 +15970,14 @@ expansion function)." ;; add speedbar (when (fboundp 'speedbar) - (condition-case () - (when (and vhdl-speedbar-auto-open - (not (and (boundp 'speedbar-frame) - (frame-live-p speedbar-frame)))) - (speedbar-frame-mode 1) - (if (fboundp 'speedbar-select-attached-frame) - (speedbar-select-attached-frame) - (select-frame speedbar-attached-frame))) - (error (vhdl-warning-when-idle "ERROR: An error occurred while opening speedbar")))) + (let ((current-frame (selected-frame))) + (condition-case () + (when (and vhdl-speedbar-auto-open + (not (and (boundp 'speedbar-frame) + (frame-live-p speedbar-frame)))) + (speedbar-frame-mode 1)) + (error (vhdl-warning-when-idle "ERROR: An error occurred while opening speedbar"))) + (select-frame current-frame))) ;; initialize speedbar (if (not (boundp 'speedbar-frame)) @@ -16217,7 +16240,7 @@ component instantiation." (setq constant-entry (cons constant-name (if (match-string 1) - (or (aget generic-alist (match-string 2) t) + (or (vhdl-aget generic-alist (match-string 2)) (error "ERROR: Formal generic \"%s\" mismatch for instance \"%s\"" (match-string 2) inst-name)) (cdar generic-alist)))) (push constant-entry constant-alist) @@ -16235,11 +16258,12 @@ component instantiation." (vhdl-forward-syntactic-ws) (while (vhdl-parse-string "\\(\\(\\w+\\)[ \t\n\r\f]*=>[ \t\n\r\f]*\\)?\\(\\w+\\),?" t) (setq signal-name (match-string-no-properties 3)) - (setq signal-entry (cons signal-name - (if (match-string 1) - (or (aget port-alist (match-string 2) t) - (error "ERROR: Formal port \"%s\" mismatch for instance \"%s\"" (match-string 2) inst-name)) - (cdar port-alist)))) + (setq signal-entry + (cons signal-name + (if (match-string 1) + (or (vhdl-aget port-alist (match-string 2)) + (error "ERROR: Formal port \"%s\" mismatch for instance \"%s\"" (match-string 2) inst-name)) + (cdar port-alist)))) (push signal-entry signal-alist) (setq signal-name (downcase signal-name)) (if (equal (upcase (nth 2 signal-entry)) "IN") @@ -16478,8 +16502,9 @@ current project/directory." (pack-file-name (concat (vhdl-replace-string vhdl-package-file-name pack-name t) "." (file-name-extension (buffer-file-name)))) - (ent-alist (aget vhdl-entity-alist - (or project default-directory) t)) + (ent-alist (vhdl-aget vhdl-entity-alist + (or project + (abbreviate-file-name default-directory)))) (lazy-lock-minimum-size 0) clause-pos component-pos) (message "Generating components package \"%s\"..." pack-name) @@ -16519,7 +16544,8 @@ current project/directory." ;; insert component declarations (while ent-alist (vhdl-visit-file (nth 2 (car ent-alist)) nil - (progn (vhdl-goto-line (nth 3 (car ent-alist))) + (progn (goto-char (point-min)) + (forward-line (1- (nth 3 (car ent-alist)))) (end-of-line) (vhdl-port-copy))) (goto-char component-pos) @@ -16581,7 +16607,7 @@ current project/directory." (when (equal (nth 5 inst-entry) (nth 4 (car tmp-alist))) (setq conf-key (nth 0 (car tmp-alist)))) (setq tmp-alist (cdr tmp-alist))) - (setq conf-entry (aget conf-alist conf-key t)) + (setq conf-entry (vhdl-aget conf-alist conf-key)) ;; insert binding indication ... ;; ... with subconfiguration (if exists) (if (and vhdl-compose-configuration-use-subconfiguration conf-entry) @@ -16591,7 +16617,7 @@ current project/directory." (insert (vhdl-work-library) "." (nth 0 conf-entry)) (insert ";\n")) ;; ... with entity (if exists) - (setq ent-entry (aget ent-alist (nth 5 inst-entry) t)) + (setq ent-entry (vhdl-aget ent-alist (nth 5 inst-entry))) (when ent-entry (indent-to (+ margin vhdl-basic-offset)) (vhdl-insert-keyword "USE ENTITY ") @@ -16601,9 +16627,9 @@ current project/directory." (setq arch-name ;; choose architecture name a) from configuration, ;; b) from mra, or c) from first architecture - (or (nth 0 (aget (nth 3 ent-entry) - (or (nth 6 inst-entry) - (nth 4 ent-entry)) t)) + (or (nth 0 (vhdl-aget (nth 3 ent-entry) + (or (nth 6 inst-entry) + (nth 4 ent-entry)))) (nth 1 (car (nth 3 ent-entry))))) (insert "(" arch-name ")")) (insert ";\n") @@ -16613,7 +16639,7 @@ current project/directory." (indent-to (+ margin vhdl-basic-offset)) (vhdl-compose-configuration-architecture (nth 0 ent-entry) arch-name ent-alist conf-alist - (nth 3 (aget (nth 3 ent-entry) (downcase arch-name) t)))))) + (nth 3 (vhdl-aget (nth 3 ent-entry) (downcase arch-name))))))) ;; insert component configuration end (indent-to margin) (vhdl-insert-keyword "END FOR;\n") @@ -16635,10 +16661,12 @@ current project/directory." "Generate configuration declaration." (interactive) (vhdl-require-hierarchy-info) - (let ((ent-alist (aget vhdl-entity-alist - (or (vhdl-project-p) default-directory) t)) - (conf-alist (aget vhdl-config-alist - (or (vhdl-project-p) default-directory) t)) + (let ((ent-alist (vhdl-aget vhdl-entity-alist + (or (vhdl-project-p) + (abbreviate-file-name default-directory)))) + (conf-alist (vhdl-aget vhdl-config-alist + (or (vhdl-project-p) + (abbreviate-file-name default-directory)))) (from-speedbar ent-name) inst-alist conf-name conf-file-name pos) (vhdl-prepare-search-2 @@ -16654,8 +16682,8 @@ current project/directory." vhdl-compose-configuration-name (concat ent-name " " arch-name))) (setq inst-alist - (nth 3 (aget (nth 3 (aget ent-alist (downcase ent-name) t)) - (downcase arch-name) t)))) + (nth 3 (vhdl-aget (nth 3 (vhdl-aget ent-alist (downcase ent-name))) + (downcase arch-name))))) (message "Generating configuration \"%s\"..." conf-name) (if vhdl-compose-configuration-create-file ;; open configuration file @@ -16721,8 +16749,8 @@ current project/directory." (defun vhdl-makefile-name () "Return the Makefile name of the current project or the current compiler if no project is defined." - (let ((project-alist (aget vhdl-project-alist vhdl-project)) - (compiler-alist (aget vhdl-compiler-alist vhdl-compiler))) + (let ((project-alist (vhdl-aget vhdl-project-alist vhdl-project)) + (compiler-alist (vhdl-aget vhdl-compiler-alist vhdl-compiler))) (vhdl-replace-string (cons "\\(.*\\)\n\\(.*\\)" (or (nth 8 project-alist) (nth 8 compiler-alist))) @@ -16730,8 +16758,8 @@ no project is defined." (defun vhdl-compile-directory () "Return the directory where compilation/make should be run." - (let* ((project (aget vhdl-project-alist (vhdl-project-p t))) - (compiler (aget vhdl-compiler-alist vhdl-compiler)) + (let* ((project (vhdl-aget vhdl-project-alist (vhdl-project-p t))) + (compiler (vhdl-aget vhdl-compiler-alist vhdl-compiler)) (directory (vhdl-resolve-env-variable (if project (vhdl-replace-string @@ -16765,9 +16793,10 @@ no project is defined." (defun vhdl-compile-init () "Initialize for compilation." - (when (or (null compilation-error-regexp-alist) - (not (assoc (car (nth 11 (car vhdl-compiler-alist))) - compilation-error-regexp-alist))) + (when (and (not vhdl-emacs-22) + (or (null compilation-error-regexp-alist) + (not (assoc (car (nth 11 (car vhdl-compiler-alist))) + compilation-error-regexp-alist)))) ;; `compilation-error-regexp-alist' (let ((commands-alist vhdl-compiler-alist) regexp-alist sublist) @@ -16810,7 +16839,7 @@ do not print any file names." &optional file-options-only) "Get compiler options. Returning nil means do not compile this file." (let* ((compiler-options (nth 1 compiler)) - (project-entry (aget (nth 4 project) vhdl-compiler)) + (project-entry (vhdl-aget (nth 4 project) vhdl-compiler)) (project-options (nth 0 project-entry)) (exception-list (and file-name (nth 2 project-entry))) (work-library (vhdl-work-library)) @@ -16847,7 +16876,7 @@ do not print any file names." (defun vhdl-get-make-options (project compiler) "Get make options." (let* ((compiler-options (nth 3 compiler)) - (project-entry (aget (nth 4 project) vhdl-compiler)) + (project-entry (vhdl-aget (nth 4 project) vhdl-compiler)) (project-options (nth 1 project-entry)) (makefile-name (vhdl-makefile-name))) ;; insert Makefile name in compiler-specific options @@ -16868,8 +16897,8 @@ do not print any file names." `vhdl-compiler'." (interactive) (vhdl-compile-init) - (let* ((project (aget vhdl-project-alist vhdl-project)) - (compiler (or (aget vhdl-compiler-alist vhdl-compiler nil) + (let* ((project (vhdl-aget vhdl-project-alist vhdl-project)) + (compiler (or (vhdl-aget vhdl-compiler-alist vhdl-compiler) (error "ERROR: No such compiler: \"%s\"" vhdl-compiler))) (command (nth 0 compiler)) (default-directory (vhdl-compile-directory)) @@ -16910,8 +16939,8 @@ specified by a target." (or target (read-from-minibuffer "Target: " vhdl-make-target vhdl-minibuffer-local-map))) (vhdl-compile-init) - (let* ((project (aget vhdl-project-alist vhdl-project)) - (compiler (or (aget vhdl-compiler-alist vhdl-compiler) + (let* ((project (vhdl-aget vhdl-project-alist vhdl-project)) + (compiler (or (vhdl-aget vhdl-compiler-alist vhdl-compiler) (error "ERROR: No such compiler: \"%s\"" vhdl-compiler))) (command (nth 2 compiler)) (options (vhdl-get-make-options project compiler)) @@ -16928,17 +16957,20 @@ specified by a target." (let ((compiler-alist vhdl-compiler-alist) (error-regexp-alist '((vhdl-directory "^ *Compiling \"\\(.+\\)\"" 1)))) (while compiler-alist - ;; add error message regexps - (setq error-regexp-alist - (cons (append (list (make-symbol (concat "vhdl-" (subst-char-in-string ? ?- (downcase (nth 0 (car compiler-alist))))))) - (nth 11 (car compiler-alist))) - error-regexp-alist)) - ;; add filename regexps - (when (/= 0 (nth 1 (nth 12 (car compiler-alist)))) + ;; only add regexps for currently selected compiler + (when (or (not vhdl-compile-use-local-error-regexp) + (equal vhdl-compiler (nth 0 (car compiler-alist)))) + ;; add error message regexps (setq error-regexp-alist - (cons (append (list (make-symbol (concat "vhdl-" (subst-char-in-string ? ?- (downcase (nth 0 (car compiler-alist)))) "-file"))) - (nth 12 (car compiler-alist))) - error-regexp-alist))) + (cons (append (list (make-symbol (concat "vhdl-" (subst-char-in-string ? ?- (downcase (nth 0 (car compiler-alist))))))) + (nth 11 (car compiler-alist))) + error-regexp-alist)) + ;; add filename regexps + (when (/= 0 (nth 1 (nth 12 (car compiler-alist)))) + (setq error-regexp-alist + (cons (append (list (make-symbol (concat "vhdl-" (subst-char-in-string ? ?- (downcase (nth 0 (car compiler-alist)))) "-file"))) + (nth 12 (car compiler-alist))) + error-regexp-alist)))) (setq compiler-alist (cdr compiler-alist))) error-regexp-alist) "List of regexps for VHDL compilers. For Emacs 22+.") @@ -16949,6 +16981,10 @@ specified by a target." (interactive) (when (and (boundp 'compilation-error-regexp-alist-alist) (not (assoc 'vhdl-modelsim compilation-error-regexp-alist-alist))) + ;; remove all other compilers + (when vhdl-compile-use-local-error-regexp + (setq compilation-error-regexp-alist nil)) + ;; add VHDL compilers (mapcar (lambda (item) (push (car item) compilation-error-regexp-alist) @@ -16964,7 +17000,7 @@ specified by a target." (defun vhdl-generate-makefile () "Generate `Makefile'." (interactive) - (let* ((compiler (or (aget vhdl-compiler-alist vhdl-compiler) + (let* ((compiler (or (vhdl-aget vhdl-compiler-alist vhdl-compiler) (error "ERROR: No such compiler: \"%s\"" vhdl-compiler))) (command (nth 4 compiler))) ;; generate makefile @@ -16997,15 +17033,19 @@ specified by a target." (vhdl-scan-directory-contents directory)))) (let* ((directory (abbreviate-file-name (vhdl-default-directory))) (project (vhdl-project-p)) - (ent-alist (aget vhdl-entity-alist (or project directory) t)) - (conf-alist (aget vhdl-config-alist (or project directory) t)) - (pack-alist (aget vhdl-package-alist (or project directory) t)) - (regexp-list (nth 12 (aget vhdl-compiler-alist vhdl-compiler))) - (ent-regexp (cons "\\(.*\\)" (nth 0 regexp-list))) - (arch-regexp (cons "\\(.*\\) \\(.*\\)" (nth 1 regexp-list))) - (conf-regexp (cons "\\(.*\\)" (nth 2 regexp-list))) - (pack-regexp (cons "\\(.*\\)" (nth 3 regexp-list))) - (pack-body-regexp (cons "\\(.*\\)" (nth 4 regexp-list))) + (ent-alist (vhdl-aget vhdl-entity-alist (or project directory))) + (conf-alist (vhdl-aget vhdl-config-alist (or project directory))) + (pack-alist (vhdl-aget vhdl-package-alist (or project directory))) + (regexp-list (or (nth 12 (vhdl-aget vhdl-compiler-alist vhdl-compiler)) + '("\\1.vhd" "\\2_\\1.vhd" "\\1.vhd" + "\\1.vhd" "\\1_body.vhd" identity))) + (mapping-exist + (if (nth 12 (vhdl-aget vhdl-compiler-alist vhdl-compiler)) t nil)) + (ent-regexp (cons "\\(.*\\) \\(.*\\) \\(.*\\)" (nth 0 regexp-list))) + (arch-regexp (cons "\\(.*\\) \\(.*\\) \\(.*\\)" (nth 1 regexp-list))) + (conf-regexp (cons "\\(.*\\) \\(.*\\) \\(.*\\)" (nth 2 regexp-list))) + (pack-regexp (cons "\\(.*\\) \\(.*\\) \\(.*\\)" (nth 3 regexp-list))) + (pack-body-regexp (cons "\\(.*\\) \\(.*\\) \\(.*\\)" (nth 4 regexp-list))) (adjust-case (nth 5 regexp-list)) (work-library (downcase (vhdl-work-library))) (compile-directory (expand-file-name (vhdl-compile-directory) @@ -17022,9 +17062,10 @@ specified by a target." ;; check prerequisites (unless (file-exists-p compile-directory) (make-directory compile-directory t)) - (unless regexp-list - (error "Please contact the VHDL Mode maintainer for support of \"%s\"" - vhdl-compiler)) + (unless mapping-exist + (vhdl-warning + (format "No unit-to-file name mapping found for compiler \"%s\".\n Directory of dummy files is created instead (to be used as dependencies).\n Please contact the VHDL Mode maintainer for full support of \"%s\"" + vhdl-compiler vhdl-compiler) t)) (message "Generating makefile \"%s\"..." makefile-name) ;; rules for all entities (setq tmp-list ent-alist) @@ -17038,13 +17079,15 @@ specified by a target." compile-directory)) arch-alist (nth 4 ent-entry) lib-alist (nth 6 ent-entry) - rule (aget rule-alist ent-file-name) + rule (vhdl-aget rule-alist ent-file-name) target-list (nth 0 rule) depend-list (nth 1 rule) second-list nil subcomp-list nil) (setq tmp-key (vhdl-replace-string - ent-regexp (funcall adjust-case ent-key))) + ent-regexp + (funcall adjust-case + (concat ent-key " " work-library)))) (push (cons ent-key tmp-key) unit-list) ;; rule target for this entity (push ent-key target-list) @@ -17053,7 +17096,7 @@ specified by a target." (setq depend-list (append depend-list pack-list)) (setq all-pack-list pack-list) ;; add rule - (aput 'rule-alist ent-file-name (list target-list depend-list)) + (vhdl-aput 'rule-alist ent-file-name (list target-list depend-list)) ;; rules for all corresponding architectures (while arch-alist (setq arch-entry (car arch-alist) @@ -17065,12 +17108,14 @@ specified by a target." compile-directory)) inst-alist (nth 4 arch-entry) lib-alist (nth 5 arch-entry) - rule (aget rule-alist arch-file-name) + rule (vhdl-aget rule-alist arch-file-name) target-list (nth 0 rule) depend-list (nth 1 rule)) (setq tmp-key (vhdl-replace-string arch-regexp - (funcall adjust-case (concat arch-key " " ent-key)))) + (funcall adjust-case + (concat arch-key " " ent-key " " + work-library)))) (setq unit-list (cons (cons ent-arch-key tmp-key) unit-list)) (push ent-arch-key second-list) @@ -17093,7 +17138,7 @@ specified by a target." (setq depend-list (append depend-list pack-list)) (setq all-pack-list (append all-pack-list pack-list)) ;; add rule - (aput 'rule-alist arch-file-name (list target-list depend-list)) + (vhdl-aput 'rule-alist arch-file-name (list target-list depend-list)) (setq arch-alist (cdr arch-alist))) (push (list ent-key second-list (append subcomp-list all-pack-list)) prim-list)) @@ -17112,12 +17157,14 @@ specified by a target." arch-key (nth 5 conf-entry) inst-alist (nth 6 conf-entry) lib-alist (nth 7 conf-entry) - rule (aget rule-alist conf-file-name) + rule (vhdl-aget rule-alist conf-file-name) target-list (nth 0 rule) depend-list (nth 1 rule) subcomp-list (list ent-key)) (setq tmp-key (vhdl-replace-string - conf-regexp (funcall adjust-case conf-key))) + conf-regexp + (funcall adjust-case + (concat conf-key " " work-library)))) (push (cons conf-key tmp-key) unit-list) ;; rule target for this configuration (push conf-key target-list) @@ -17131,20 +17178,17 @@ specified by a target." (while inst-alist (setq inst-entry (car inst-alist)) (setq inst-ent-key (nth 2 inst-entry) -; comp-arch-key (nth 2 inst-entry)) inst-conf-key (nth 4 inst-entry)) (when (equal (downcase (nth 5 inst-entry)) work-library) (when inst-ent-key (setq depend-list (cons inst-ent-key depend-list) subcomp-list (cons inst-ent-key subcomp-list))) -; (when comp-arch-key -; (push (concat comp-ent-key "-" comp-arch-key) depend-list)) (when inst-conf-key (setq depend-list (cons inst-conf-key depend-list) subcomp-list (cons inst-conf-key subcomp-list)))) (setq inst-alist (cdr inst-alist))) ;; add rule - (aput 'rule-alist conf-file-name (list target-list depend-list)) + (vhdl-aput 'rule-alist conf-file-name (list target-list depend-list)) (push (list conf-key nil (append subcomp-list pack-list)) prim-list) (setq conf-alist (cdr conf-alist))) (setq conf-alist tmp-list) @@ -17160,10 +17204,12 @@ specified by a target." (file-relative-name (nth 2 pack-entry) compile-directory)) lib-alist (nth 6 pack-entry) lib-body-alist (nth 10 pack-entry) - rule (aget rule-alist pack-file-name) + rule (vhdl-aget rule-alist pack-file-name) target-list (nth 0 rule) depend-list (nth 1 rule)) (setq tmp-key (vhdl-replace-string - pack-regexp (funcall adjust-case pack-key))) + pack-regexp + (funcall adjust-case + (concat pack-key " " work-library)))) (push (cons pack-key tmp-key) unit-list) ;; rule target for this package (push pack-key target-list) @@ -17172,7 +17218,7 @@ specified by a target." (setq depend-list (append depend-list pack-list)) (setq all-pack-list pack-list) ;; add rule - (aput 'rule-alist pack-file-name (list target-list depend-list)) + (vhdl-aput 'rule-alist pack-file-name (list target-list depend-list)) ;; rules for this package's body (when (nth 7 pack-entry) (setq pack-body-key (concat pack-key "-body") @@ -17180,11 +17226,13 @@ specified by a target." (nth 7 pack-entry) (file-relative-name (nth 7 pack-entry) compile-directory)) - rule (aget rule-alist pack-body-file-name) + rule (vhdl-aget rule-alist pack-body-file-name) target-list (nth 0 rule) depend-list (nth 1 rule)) (setq tmp-key (vhdl-replace-string - pack-body-regexp (funcall adjust-case pack-key))) + pack-body-regexp + (funcall adjust-case + (concat pack-key " " work-library)))) (setq unit-list (cons (cons pack-body-key tmp-key) unit-list)) ;; rule target for this package's body @@ -17196,8 +17244,8 @@ specified by a target." (setq depend-list (append depend-list pack-list)) (setq all-pack-list (append all-pack-list pack-list)) ;; add rule - (aput 'rule-alist pack-body-file-name - (list target-list depend-list))) + (vhdl-aput 'rule-alist pack-body-file-name + (list target-list depend-list))) (setq prim-list (cons (list pack-key (when pack-body-key (list pack-body-key)) all-pack-list) @@ -17205,8 +17253,8 @@ specified by a target." (setq pack-alist (cdr pack-alist))) (setq pack-alist tmp-list) ;; generate Makefile - (let* ((project (aget vhdl-project-alist project)) - (compiler (aget vhdl-compiler-alist vhdl-compiler)) + (let* ((project (vhdl-aget vhdl-project-alist project)) + (compiler (vhdl-aget vhdl-compiler-alist vhdl-compiler)) (compiler-id (nth 9 compiler)) (library-directory (vhdl-resolve-env-variable @@ -17259,12 +17307,16 @@ specified by a target." compile-directory)))) (insert "\n\n# Define library paths\n" "\nLIBRARY-" work-library " = " library-directory "\n") + (unless mapping-exist + (insert "LIBRARY-" work-library "-make = " "$(LIBRARY-" work-library + ")/make" "\n")) ;; insert variable definitions for all library unit files (insert "\n\n# Define library unit files\n") (setq tmp-list unit-list) (while unit-list (insert "\nUNIT-" work-library "-" (caar unit-list) - " = \\\n\t$(LIBRARY-" work-library ")/" (cdar unit-list)) + " = \\\n\t$(LIBRARY-" work-library + (if mapping-exist "" "-make") ")/" (cdar unit-list)) (setq unit-list (cdr unit-list))) ;; insert variable definition for list of all library unit files (insert "\n\n\n# Define list of all library unit files\n" @@ -17287,13 +17339,20 @@ specified by a target." ;; insert `make library' rule (insert "\n\n# Rule for creating library directory\n" "\n" (nth 2 vhdl-makefile-default-targets) " :" - " \\\n\t\t$(LIBRARY-" work-library ")\n" + " \\\n\t\t$(LIBRARY-" work-library ")" + (if mapping-exist "" + (concat " \\\n\t\t$(LIBRARY-" work-library "-make)\n")) + "\n" "\n$(LIBRARY-" work-library ") :" "\n\t" (vhdl-replace-string (cons "\\(.*\\)\n\\(.*\\)" (nth 5 compiler)) (concat "$(LIBRARY-" work-library ")\n" (vhdl-work-library))) "\n") + (unless mapping-exist + (insert "\n$(LIBRARY-" work-library "-make) :" + "\n\t" + "mkdir -p $(LIBRARY-" work-library "-make)\n")) ;; insert '.PHONY' declaration (insert "\n\n.PHONY : " (nth 0 vhdl-makefile-default-targets) " " @@ -17306,9 +17365,9 @@ specified by a target." (setq subcomp-list (sort (vhdl-uniquify (nth 2 (car prim-list))) 'string<)) (setq unit-key (caar prim-list) - unit-name (or (nth 0 (aget ent-alist unit-key t)) - (nth 0 (aget conf-alist unit-key t)) - (nth 0 (aget pack-alist unit-key t)))) + unit-name (or (nth 0 (vhdl-aget ent-alist unit-key)) + (nth 0 (vhdl-aget conf-alist unit-key)) + (nth 0 (vhdl-aget pack-alist unit-key)))) (insert "\n" unit-key) (unless (equal unit-key unit-name) (insert " \\\n" unit-name)) @@ -17358,13 +17417,15 @@ specified by a target." (nth 0 rule) (if (equal vhdl-compile-post-command "") "" " $(POST-COMPILE)") "\n") + (insert "\n")) + (unless (and options mapping-exist) (setq tmp-list target-list) (while target-list - (insert "\n\t@touch $(UNIT-" work-library "-" (car target-list) ")" - (if (cdr target-list) " \\" "\n")) + (insert "\t@touch $(UNIT-" work-library "-" (car target-list) ")\n") (setq target-list (cdr target-list))) (setq target-list tmp-list)) (setq rule-alist (cdr rule-alist))) + (insert "\n\n### " makefile-name " ends here\n") ;; run Makefile generation hook (run-hooks 'vhdl-makefile-generation-hook) @@ -17374,7 +17435,8 @@ specified by a target." (progn (save-buffer) (kill-buffer (current-buffer)) (set-buffer orig-buffer) - (add-to-history 'file-name-history makefile-path-name)) + (when (fboundp 'add-to-history) + (add-to-history 'file-name-history makefile-path-name))) (vhdl-warning-when-idle (format "File not writable: \"%s\"" (abbreviate-file-name makefile-path-name))) diff --git a/lisp/progmodes/which-func.el b/lisp/progmodes/which-func.el index aa68f9fcc1a..e62ad271089 100644 --- a/lisp/progmodes/which-func.el +++ b/lisp/progmodes/which-func.el @@ -187,21 +187,20 @@ and you want to simplify them for the mode line which-func-unknown)))) ;;;###autoload (put 'which-func-current 'risky-local-variable t) -(defvar which-func-mode nil +(defvar-local which-func-mode nil "Non-nil means display current function name in mode line. This makes a difference only if `which-function-mode' is non-nil.") -(make-variable-buffer-local 'which-func-mode) -;;(put 'which-func-mode 'permanent-local t) (add-hook 'find-file-hook 'which-func-ff-hook t) (defun which-func-ff-hook () "File find hook for Which Function mode. It creates the Imenu index for the buffer, if necessary." - (setq which-func-mode - (and which-function-mode - (or (eq which-func-modes t) - (member major-mode which-func-modes)))) + (unless (local-variable-p 'which-func-mode) + (setq which-func-mode + (and which-function-mode + (or (eq which-func-modes t) + (member major-mode which-func-modes))))) (condition-case err (if (and which-func-mode @@ -259,15 +258,13 @@ in certain major modes." ;;Turn it on (progn (setq which-func-update-timer - (run-with-idle-timer idle-update-delay t 'which-func-update)) + (run-with-idle-timer idle-update-delay t #'which-func-update)) (dolist (buf (buffer-list)) (with-current-buffer buf - (setq which-func-mode - (or (eq which-func-modes t) - (member major-mode which-func-modes)))))) - ;; Turn it off - (dolist (buf (buffer-list)) - (with-current-buffer buf (setq which-func-mode nil))))) + (unless (local-variable-p 'which-func-mode) + (setq which-func-mode + (or (eq which-func-modes t) + (member major-mode which-func-modes))))))))) (defvar which-function-imenu-failed nil "Locally t in a buffer if `imenu--make-index-alist' found nothing there.") @@ -347,10 +344,11 @@ If no function name is found, return nil." (defvar ediff-window-B) (defvar ediff-window-C) +;; FIXME: Why does ediff require special support? (defun which-func-update-ediff-windows () "Update Which-Function mode display for Ediff windows. This function is meant to be called from `ediff-select-hook'." - (when (eq major-mode 'ediff-mode) + (when (and (derived-mode-p 'ediff-mode) which-function-mode) (when ediff-window-A (which-func-update-1 ediff-window-A)) (when ediff-window-B diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el new file mode 100644 index 00000000000..f3dc4bd4cfd --- /dev/null +++ b/lisp/progmodes/xref.el @@ -0,0 +1,525 @@ +;; xref.el --- Cross-referencing commands -*-lexical-binding:t-*- + +;; Copyright (C) 2014 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 file provides a somewhat generic infrastructure for cross +;; referencing commands, in particular "find-definition". +;; +;; Some part of the functionality must be implemented in a language +;; dependent way and that's done by defining `xref-find-function', +;; `xref-identifier-at-point-function' and +;; `xref-identifier-completion-table-function', which see. +;; +;; A major mode should make these variables buffer-local first. +;; +;; `xref-find-function' can be called in several ways, see its +;; description. It has to operate with "xref" and "location" values. +;; +;; One would usually call `make-xref' and `xref-make-file-location', +;; `xref-make-buffer-location' or `xref-make-bogus-location' to create +;; them. +;; +;; Each identifier must be represented as a string. Implementers can +;; use string properties to store additional information about the +;; identifier, but they should keep in mind that values returned from +;; `xref-identifier-completion-table-function' should still be +;; distinct, because the user can't see the properties when making the +;; choice. +;; +;; See the functions `etags-xref-find' and `elisp-xref-find' for full +;; examples. + +;;; Code: + +(require 'cl-lib) +(require 'eieio) +(require 'ring) + +(defgroup xref nil "Cross-referencing commands" + :group 'tools) + + +;;; Locations + +(defclass xref-location () () + :documentation "A location represents a position in a file or buffer.") + +;; If a backend decides to subclass xref-location it can provide +;; methods for some of the following functions: +(defgeneric xref-location-marker (location) + "Return the marker for LOCATION.") + +(defgeneric xref-location-group (location) + "Return a string used to group a set of locations. +This is typically the filename.") + +;;;; Commonly needed location classes are defined here: + +;; FIXME: might be useful to have an optional "hint" i.e. a string to +;; search for in case the line number is sightly out of date. +(defclass xref-file-location (xref-location) + ((file :type string :initarg :file) + (line :type fixnum :initarg :line) + (column :type fixnum :initarg :column)) + :documentation "A file location is a file/line/column triple. +Line numbers start from 1 and columns from 0.") + +(defun xref-make-file-location (file line column) + "Create and return a new xref-file-location." + (make-instance 'xref-file-location :file file :line line :column column)) + +(defmethod xref-location-marker ((l xref-file-location)) + (with-slots (file line column) l + (with-current-buffer + (or (get-file-buffer file) + (let ((find-file-suppress-same-file-warnings t)) + (find-file-noselect file))) + (save-restriction + (widen) + (save-excursion + (goto-char (point-min)) + (beginning-of-line line) + (move-to-column column) + (point-marker)))))) + +(defmethod xref-location-group ((l xref-file-location)) + (oref l :file)) + +(defclass xref-buffer-location (xref-location) + ((buffer :type buffer :initarg :buffer) + (position :type fixnum :initarg :position))) + +(defun xref-make-buffer-location (buffer position) + "Create and return a new xref-buffer-location." + (make-instance 'xref-buffer-location :buffer buffer :position position)) + +(defmethod xref-location-marker ((l xref-buffer-location)) + (with-slots (buffer position) l + (let ((m (make-marker))) + (move-marker m position buffer)))) + +(defmethod xref-location-group ((l xref-buffer-location)) + (with-slots (buffer) l + (or (buffer-file-name buffer) + (format "(buffer %s)" (buffer-name buffer))))) + +(defclass xref-bogus-location (xref-location) + ((message :type string :initarg :message + :reader xref-bogus-location-message)) + :documentation "Bogus locations are sometimes useful to +indicate errors, e.g. when we know that a function exists but the +actual location is not known.") + +(defun xref-make-bogus-location (message) + "Create and return a new xref-bogus-location." + (make-instance 'xref-bogus-location :message message)) + +(defmethod xref-location-marker ((l xref-bogus-location)) + (user-error "%s" (oref l :message))) + +(defmethod xref-location-group ((_ xref-bogus-location)) "(No location)") + +;; This should be in elisp-mode.el, but it's preloaded, and we can't +;; preload defclass and defmethod (at least, not yet). +(defclass xref-elisp-location (xref-location) + ((symbol :type symbol :initarg :symbol) + (type :type symbol :initarg :type) + (file :type string :initarg :file + :reader xref-location-group)) + :documentation "Location of an Emacs Lisp symbol definition.") + +(defun xref-make-elisp-location (symbol type file) + (make-instance 'xref-elisp-location :symbol symbol :type type :file file)) + +(defmethod xref-location-marker ((l xref-elisp-location)) + (with-slots (symbol type file) l + (let ((buffer-point + (pcase type + (`defun (find-function-search-for-symbol symbol nil file)) + ((or `defvar `defface) + (find-function-search-for-symbol symbol type file)) + (`feature + (cons (find-file-noselect file) 1))))) + (with-current-buffer (car buffer-point) + (goto-char (or (cdr buffer-point) (point-min))) + (point-marker))))) + + +;;; Cross-reference + +(defclass xref--xref () + ((description :type string :initarg :description + :reader xref--xref-description) + (location :type xref-location :initarg :location + :reader xref--xref-location)) + :comment "An xref is used to display and locate constructs like +variables or functions.") + +(defun xref-make (description location) + "Create and return a new xref. +DESCRIPTION is a short string to describe the xref. +LOCATION is an `xref-location'." + (make-instance 'xref--xref :description description :location location)) + + +;;; API + +(declare-function etags-xref-find "etags" (action id)) +(declare-function tags-lazy-completion-table "etags" ()) + +;; For now, make the etags backend the default. +(defvar xref-find-function #'etags-xref-find + "Function to look for cross-references. +It can be called in several ways: + + (definitions IDENTIFIER): Find definitions of IDENTIFIER. The +result must be a list of xref objects. If no definitions can be +found, return nil. + + (references IDENTIFIER): Find references of IDENTIFIER. The +result must be a list of xref objects. If no references can be +found, return nil. + + (apropos PATTERN): Find all symbols that match PATTERN. PATTERN +is a regexp. + +IDENTIFIER can be any string returned by +`xref-identifier-at-point-function', or from the table returned +by `xref-identifier-completion-table-function'. + +To create an xref object, call `xref-make'.") + +(defvar xref-identifier-at-point-function #'xref-default-identifier-at-point + "Function to get the relevant identifier at point. + +The return value must be a string or nil. nil means no +identifier at point found. + +If it's hard to determine the identifier precisely (e.g., because +it's a method call on unknown type), the implementation can +return a simple string (such as symbol at point) marked with a +special text property which `xref-find-function' would recognize +and then delegate the work to an external process.") + +(defvar xref-identifier-completion-table-function #'tags-lazy-completion-table + "Function that returns the completion table for identifiers.") + +(defun xref-default-identifier-at-point () + (let ((thing (thing-at-point 'symbol))) + (and thing (substring-no-properties thing)))) + + +;;; misc utilities +(defun xref--alistify (list key test) + "Partition the elements of LIST into an alist. +KEY extracts the key from an element and TEST is used to compare +keys." + (let ((alist '())) + (dolist (e list) + (let* ((k (funcall key e)) + (probe (cl-assoc k alist :test test))) + (if probe + (setcdr probe (cons e (cdr probe))) + (push (cons k (list e)) alist)))) + ;; Put them back in order. + (cl-loop for (key . value) in (reverse alist) + collect (cons key (reverse value))))) + +(defun xref--insert-propertized (props &rest strings) + "Insert STRINGS with text properties PROPS." + (let ((start (point))) + (apply #'insert strings) + (add-text-properties start (point) props))) + +(defun xref--search-property (property &optional backward) + "Search the next text range where text property PROPERTY is non-nil. +Return the value of PROPERTY. If BACKWARD is non-nil, search +backward." + (let ((next (if backward + #'previous-single-char-property-change + #'next-single-char-property-change)) + (start (point)) + (value nil)) + (while (progn + (goto-char (funcall next (point) property)) + (not (or (setq value (get-text-property (point) property)) + (eobp) + (bobp))))) + (cond (value) + (t (goto-char start) nil)))) + + +;;; Marker stack (M-. pushes, M-, pops) + +(defcustom xref-marker-ring-length 16 + "Length of the xref marker ring." + :type 'integer + :version "25.1") + +(defvar xref--marker-ring (make-ring xref-marker-ring-length) + "Ring of markers to implement the marker stack.") + +(defun xref-push-marker-stack () + "Add point to the marker stack." + (ring-insert xref--marker-ring (point-marker))) + +;;;###autoload +(defun xref-pop-marker-stack () + "Pop back to where \\[xref-find-definitions] was last invoked." + (interactive) + (let ((ring xref--marker-ring)) + (when (ring-empty-p ring) + (error "Marker stack is empty")) + (let ((marker (ring-remove ring 0))) + (switch-to-buffer (or (marker-buffer marker) + (error "The marked buffer has been deleted"))) + (goto-char (marker-position marker)) + (set-marker marker nil nil)))) + +;; etags.el needs this +(defun xref-clear-marker-stack () + "Discard all markers from the marker stack." + (let ((ring xref--marker-ring)) + (while (not (ring-empty-p ring)) + (let ((marker (ring-remove ring))) + (set-marker marker nil nil))))) + + +(defun xref--goto-location (location) + "Set buffer and point according to xref-location LOCATION." + (let ((marker (xref-location-marker location))) + (set-buffer (marker-buffer marker)) + (cond ((and (<= (point-min) marker) (<= marker (point-max)))) + (widen-automatically (widen)) + (t (error "Location is outside accessible part of buffer"))) + (goto-char marker))) + +(defun xref--pop-to-location (location &optional window) + "Goto xref-location LOCATION and display the buffer. +WINDOW controls how the buffer is displayed: + nil -- switch-to-buffer + 'window -- pop-to-buffer (other window) + 'frame -- pop-to-buffer (other frame)" + (xref--goto-location location) + (cl-ecase window + ((nil) (switch-to-buffer (current-buffer))) + (window (pop-to-buffer (current-buffer) t)) + (frame (let ((pop-up-frames t)) (pop-to-buffer (current-buffer) t))))) + + +;;; XREF buffer (part of the UI) + +;; The xref buffer is used to display a set of xrefs. + +(defun xref--display-position (pos other-window recenter-arg) + ;; show the location, but don't hijack focus. + (with-selected-window (display-buffer (current-buffer) other-window) + (goto-char pos) + (recenter recenter-arg))) + +(defun xref--show-location (location) + (condition-case err + (progn + (xref--goto-location location) + (xref--display-position (point) t 1)) + (user-error (message (error-message-string err))))) + +(defun xref--next-line (backward) + (let ((loc (xref--search-property 'xref-location backward))) + (when loc + (save-window-excursion + (xref--show-location loc) + (sit-for most-positive-fixnum))))) + +(defun xref-next-line () + "Move to the next xref and display its source in the other window." + (interactive) + (xref--next-line nil)) + +(defun xref-prev-line () + "Move to the previous xref and display its source in the other window." + (interactive) + (xref--next-line t)) + +(defun xref--location-at-point () + (or (get-text-property (point) 'xref-location) + (error "No reference at point"))) + +(defvar-local xref--window nil) + +(defun xref-goto-xref () + "Jump to the xref at point and bury the xref buffer." + (interactive) + (let ((loc (xref--location-at-point)) + (window xref--window)) + (quit-window) + (xref--pop-to-location loc window))) + +(define-derived-mode xref--xref-buffer-mode fundamental-mode "XREF" + "Mode for displaying cross-references." + (setq buffer-read-only t)) + +(let ((map xref--xref-buffer-mode-map)) + (define-key map (kbd "q") #'quit-window) + (define-key map [remap next-line] #'xref-next-line) + (define-key map [remap previous-line] #'xref-prev-line) + (define-key map (kbd "RET") #'xref-goto-xref) + + ;; suggested by Johan Claesson "to further reduce finger movement": + (define-key map (kbd ".") #'xref-next-line) + (define-key map (kbd ",") #'xref-prev-line)) + +(defconst xref-buffer-name "*xref*" + "The name of the buffer to show xrefs.") + +(defun xref--insert-xrefs (xref-alist) + "Insert XREF-ALIST in the current-buffer. +XREF-ALIST is of the form ((GROUP . (XREF ...)) ...). Where +GROUP is a string for decoration purposes and XREF is an +`xref--xref' object." + (cl-loop for ((group . xrefs) . more1) on xref-alist do + (xref--insert-propertized '(face bold) group "\n") + (cl-loop for (xref . more2) on xrefs do + (insert " ") + (with-slots (description location) xref + (xref--insert-propertized + (list 'xref-location location + 'face 'font-lock-keyword-face) + description)) + (when (or more1 more2) + (insert "\n"))))) + +(defun xref--analyze (xrefs) + "Find common filenames in XREFS. +Return an alist of the form ((FILENAME . (XREF ...)) ...)." + (xref--alistify xrefs + (lambda (x) + (xref-location-group (xref--xref-location x))) + #'equal)) + +(defun xref--show-xref-buffer (xrefs window) + (let ((xref-alist (xref--analyze xrefs))) + (with-current-buffer (get-buffer-create xref-buffer-name) + (let ((inhibit-read-only t)) + (erase-buffer) + (xref--insert-xrefs xref-alist) + (xref--xref-buffer-mode) + (pop-to-buffer (current-buffer)) + (goto-char (point-min)) + (setq xref--window window) + (current-buffer))))) + + +;; This part of the UI seems fairly uncontroversial: it reads the +;; identifier and deals with the single definition case. +;; +;; The controversial multiple definitions case is handed off to +;; xref-show-xrefs-function. + +(defvar xref-show-xrefs-function 'xref--show-xref-buffer + "Function to display a list of xrefs.") + +(defun xref--show-xrefs (id kind xrefs window) + (cond + ((null xrefs) + (user-error "No known %s for: %s" kind id)) + ((not (cdr xrefs)) + (xref-push-marker-stack) + (xref--pop-to-location (xref--xref-location (car xrefs)) window)) + (t + (xref-push-marker-stack) + (funcall xref-show-xrefs-function xrefs window)))) + +(defun xref--read-identifier (prompt) + "Return the identifier at point or read it from the minibuffer." + (let ((id (funcall xref-identifier-at-point-function))) + (cond ((or current-prefix-arg (not id)) + (completing-read prompt + (funcall xref-identifier-completion-table-function) + nil t id)) + (t id)))) + + +;;; Commands + +(defun xref--find-definitions (id window) + (xref--show-xrefs id "definitions" + (funcall xref-find-function 'definitions id) + window)) + +;;;###autoload +(defun xref-find-definitions (identifier) + "Find the definition of the identifier at point. +With prefix argument or when there's no identifier at point, +prompt for it." + (interactive (list (xref--read-identifier "Find definitions of: "))) + (xref--find-definitions identifier nil)) + +;;;###autoload +(defun xref-find-definitions-other-window (identifier) + "Like `xref-find-definitions' but switch to the other window." + (interactive (list (xref--read-identifier "Find definitions of: "))) + (xref--find-definitions identifier 'window)) + +;;;###autoload +(defun xref-find-definitions-other-frame (identifier) + "Like `xref-find-definitions' but switch to the other frame." + (interactive (list (xref--read-identifier "Find definitions of: "))) + (xref--find-definitions identifier 'frame)) + +;;;###autoload +(defun xref-find-references (identifier) + "Find references to the identifier at point. +With prefix argument, prompt for the identifier." + (interactive (list (xref--read-identifier "Find references of: "))) + (xref--show-xrefs identifier "references" + (funcall xref-find-function 'references identifier) + nil)) + +;;;###autoload +(defun xref-find-apropos (pattern) + "Find all meaningful symbols that match PATTERN. +The argument has the same meaning as in `apropos'." + (interactive (list (read-from-minibuffer + "Search for pattern (word list or regexp): "))) + (require 'apropos) + (xref--show-xrefs pattern "apropos" + (funcall xref-find-function 'apropos + (apropos-parse-pattern + (if (string-equal (regexp-quote pattern) pattern) + ;; Split into words + (or (split-string pattern "[ \t]+" t) + (user-error "No word list given")) + pattern))) + nil)) + + +;;; Key bindings + +;;;###autoload (define-key esc-map "." #'xref-find-definitions) +;;;###autoload (define-key esc-map "," #'xref-pop-marker-stack) +;;;###autoload (define-key esc-map [?\C-.] #'xref-find-apropos) +;;;###autoload (define-key ctl-x-4-map "." #'xref-find-definitions-other-window) +;;;###autoload (define-key ctl-x-5-map "." #'xref-find-definitions-other-frame) + + +(provide 'xref) + +;;; xref.el ends here diff --git a/lisp/progmodes/xscheme.el b/lisp/progmodes/xscheme.el index e22581445e5..4ab882b71fb 100644 --- a/lisp/progmodes/xscheme.el +++ b/lisp/progmodes/xscheme.el @@ -1,4 +1,4 @@ -;;; xscheme.el --- run MIT Scheme under Emacs +;;; xscheme.el --- run MIT Scheme under Emacs -*- lexical-binding: t; -*- ;; Copyright (C) 1986-1987, 1989-1990, 2001-2014 Free Software ;; Foundation, Inc. @@ -49,13 +49,13 @@ (defvar xscheme-expressions-ring-max 30 "Maximum length of Scheme expressions ring.") -(defvar xscheme-expressions-ring nil +(defvar-local xscheme-expressions-ring nil "List of expressions recently transmitted to the Scheme process.") -(defvar xscheme-expressions-ring-yank-pointer nil +(defvar-local xscheme-expressions-ring-yank-pointer nil "The tail of the Scheme expressions ring whose car is the last thing yanked.") -(defvar xscheme-running-p nil +(defvar-local xscheme-running-p nil "This variable, if nil, indicates that the scheme process is waiting for input. Otherwise, it is busy evaluating something.") @@ -64,7 +64,7 @@ waiting for input. Otherwise, it is busy evaluating something.") control-g interrupts were signaled. Do not allow more control-g's to be signaled until the scheme process acknowledges receipt.") -(defvar xscheme-control-g-disabled-p nil +(defvar-local xscheme-control-g-disabled-p nil "This variable, if non-nil, indicates that a control-g is being processed by the scheme process, so additional control-g's are to be ignored.") @@ -78,37 +78,26 @@ by the scheme process, so additional control-g's are to be ignored.") (defvar xscheme-runlight "") (defvar xscheme-runlight-string nil) -(defvar xscheme-process-filter-state 'idle +(defvar-local xscheme-process-filter-state 'idle "State of scheme process escape reader state machine: idle waiting for an escape sequence reading-type received an altmode but nothing else reading-string reading prompt string") -(defvar xscheme-allow-output-p t +(defvar-local xscheme-allow-output-p t "This variable, if nil, prevents output from the scheme process from being inserted into the process-buffer.") -(defvar xscheme-prompt "" +(defvar-local xscheme-prompt "" "The current scheme prompt string.") -(defvar xscheme-string-accumulator "" +(defvar-local xscheme-string-accumulator "" "Accumulator for the string being received from the scheme process.") -(defvar xscheme-mode-string nil) -(setq-default scheme-mode-line-process - '("" xscheme-runlight)) - -(mapc 'make-variable-buffer-local - '(xscheme-expressions-ring - xscheme-expressions-ring-yank-pointer - xscheme-process-filter-state - xscheme-running-p - xscheme-control-g-disabled-p - xscheme-allow-output-p - xscheme-prompt - xscheme-string-accumulator - xscheme-mode-string - scheme-mode-line-process)) +(defvar-local xscheme-mode-string nil) +(setq-default scheme-mode-line-process '("" xscheme-runlight)) +(make-variable-buffer-local 'scheme-mode-line-process) + (defgroup xscheme nil "Major mode for editing Scheme and interacting with MIT's C-Scheme." |