diff options
Diffstat (limited to 'lisp/progmodes')
76 files changed, 6978 insertions, 5570 deletions
diff --git a/lisp/progmodes/antlr-mode.el b/lisp/progmodes/antlr-mode.el index e5b9ac0a537..2a4b3482831 100644 --- a/lisp/progmodes/antlr-mode.el +++ b/lisp/progmodes/antlr-mode.el @@ -1,4 +1,4 @@ -;;; antlr-mode.el --- major mode for ANTLR grammar files +;;; antlr-mode.el --- major mode for ANTLR grammar files -*- lexical-binding: t; -*- ;; Copyright (C) 1999-2021 Free Software Foundation, Inc. @@ -33,7 +33,7 @@ ;; the manual style, follow all commands mentioned in the documentation of ;; `antlr-mode'. ANTLR is a LL(k)-based recognition tool which generates ;; lexers, parsers and tree transformers in Java, C++ or Sather and can be -;; found at <http://www.antlr.org/>. +;; found at <https://www.antlr.org/>. ;; Bug fixes, bug reports, improvements, and suggestions for the newest version ;; are strongly appreciated. @@ -84,98 +84,17 @@ (eval-when-compile (require 'cl-lib)) -(require 'easymenu) +(when (< emacs-major-version 28) ; preloaded in Emacs 28 + (require 'easymenu)) (require 'cc-mode) -;; Just to get the rid of the byte compiler warning. The code for -;; this function and its friends are too complex for their own good. -(declare-function cond-emacs-xemacs-macfn "antlr-mode" (args &optional msg)) - -;; General Emacs/XEmacs-compatibility compile-time macros -(eval-when-compile - (defmacro cond-emacs-xemacs (&rest args) - (cond-emacs-xemacs-macfn - args "`cond-emacs-xemacs' must return exactly one element")) - (defun cond-emacs-xemacs-macfn (args &optional msg) - (if (atom args) args - (and (eq (car args) :@) (null msg) ; (:@ ...spliced...) - (setq args (cdr args) - msg "(:@ ....) must return exactly one element")) - (let ((ignore (if (featurep 'xemacs) :EMACS :XEMACS)) - (mode :BOTH) code) - (while (consp args) - (if (memq (car args) '(:EMACS :XEMACS :BOTH)) (setq mode (pop args))) - (if (atom args) - (or args (error "Used selector %s without elements" mode)) - (or (eq ignore mode) - (push (cond-emacs-xemacs-macfn (car args)) code)) - (pop args))) - (cond (msg (if (or args (cdr code)) (error msg) (car code))) - ((or (null args) (eq ignore mode)) (nreverse code)) - (t (nconc (nreverse code) args)))))) - ;; Emacs/XEmacs-compatibility `defun': remove interactive "_" for Emacs, use - ;; existing functions when they are `fboundp', provide shortcuts if they are - ;; known to be defined in a specific Emacs branch (for short .elc) - (defmacro defunx (name arglist &rest definition) - (let ((xemacsp (featurep 'xemacs)) reuses) - (while (memq (car definition) - '(:try :emacs-and-try :xemacs-and-try)) - (if (eq (pop definition) (if xemacsp :xemacs-and-try :emacs-and-try)) - (setq reuses (car definition) - definition nil) - (push (pop definition) reuses))) - (if (and reuses (symbolp reuses)) - `(defalias ',name ',reuses) - (let* ((docstring (if (stringp (car definition)) (pop definition))) - (spec (and (not xemacsp) - (eq (car-safe (car definition)) 'interactive) - (null (cddar definition)) - (cadar definition)))) - (if (and (stringp spec) - (not (string-equal spec "")) - (eq (aref spec 0) ?_)) - (setq definition - (cons (if (string-equal spec "_") - '(interactive) - `(interactive ,(substring spec 1))) - (cdr definition)))) - (if (null reuses) - `(defun ,name ,arglist ,docstring - ,@(cond-emacs-xemacs-macfn definition)) - ;; no dynamic docstring in this case - `(eval-and-compile ; no warnings in Emacs - (defalias ',name - (cond ,@(mapcar (lambda (func) `((fboundp ',func) ',func)) - (nreverse reuses)) - (t ,(if definition - `(lambda ,arglist ,docstring - ,@(cond-emacs-xemacs-macfn definition)) - 'ignore)))))))))) - (defmacro ignore-errors-x (&rest body) - (let ((specials '((scan-sexps . 4) (scan-lists . 5))) - spec nils) - (if (and (featurep 'xemacs) - (null (cdr body)) (consp (car body)) - (setq spec (assq (caar body) specials)) - (>= (setq nils (- (cdr spec) (length (car body)))) 0)) - `(,@(car body) ,@(make-list nils nil) t) - `(ignore-errors ,@body))))) - ;; More compile-time-macros (eval-when-compile (defmacro save-buffer-state-x (&rest body) ; similar to EMACS/lazy-lock.el - (let ((modified (with-no-warnings (gensym "save-buffer-state-x-modified-")))) - `(let ((,modified (buffer-modified-p))) - (unwind-protect - (let ((buffer-undo-list t) (inhibit-read-only t) - ,@(unless (featurep 'xemacs) - '((inhibit-point-motion-hooks t) deactivate-mark)) - (inhibit-modification-hooks t) - buffer-file-name buffer-file-truename) - ,@body) - (and (not ,modified) (buffer-modified-p) - (set-buffer-modified-p nil))))))) -(put 'save-buffer-state-x 'lisp-indent-function 0) + (declare (debug t) (indent 0)) + `(let ((inhibit-point-motion-hooks t)) + (with-silent-modifications + ,@body)))) (defvar outline-level) (defvar imenu-use-markers) @@ -188,7 +107,7 @@ ;; Additional to the `defalias' below, we must set `antlr-c-forward-sws' to ;; `c-forward-syntactic-ws' when `c-forward-sws' is not defined after requiring ;; cc-mode. -(defalias 'antlr-c-forward-sws 'c-forward-sws) +(defalias 'antlr-c-forward-sws #'c-forward-sws) ;;;;########################################################################## @@ -231,7 +150,6 @@ value of `antlr-language' if the first group in the string matched by REGEXP in `antlr-language-limit-n-regexp' is one of the OPTION-VALUEs. An OPTION-VALUE of nil denotes the fallback element. MODELINE-STRING is also displayed in the mode line next to \"Antlr\"." - :group 'antlr :type '(repeat (group :value (java-mode "") (function :tag "Major mode") (string :tag "Mode line string") @@ -245,7 +163,6 @@ also displayed in the mode line next to \"Antlr\"." Looks like \(LIMIT . REGEXP). Search for REGEXP from the beginning of the buffer to LIMIT and use the first group in the matched string to set the language according to `antlr-language-alist'." - :group 'antlr :type '(cons (choice :tag "Limit" (const :tag "No" nil) (integer :value 0)) regexp)) @@ -259,7 +176,6 @@ the language according to `antlr-language-alist'." If nil, the actions with their surrounding braces are hidden. If a number, do not hide the braces, only hide the contents if its length is greater than this number." - :group 'antlr :type '(choice (const :tag "Completely hidden" nil) (integer :tag "Hidden if longer than" :value 3))) @@ -268,7 +184,6 @@ greater than this number." If nil, no continuation line of a block comment is changed. If t, they are changed according to `c-indentation-line'. When not nil and not t, they are only changed by \\[antlr-indent-command]." - :group 'antlr :type '(radio (const :tag "No" nil) (const :tag "Always" t) (sexp :tag "With TAB" :format "%t" :value tab))) @@ -282,7 +197,6 @@ The first element whose MAJOR-MODE is nil or equal to `major-mode' and whose REGEXP is nil or matches variable `buffer-file-name' is used to set `tab-width' and `indent-tabs-mode'. This is useful to support both ANTLR's and Java's indentation styles. Used by `antlr-set-tabs'." - :group 'antlr :type '(repeat (group :value (antlr-mode nil 8 nil) (choice (const :tag "All" nil) (function :tag "Major mode")) @@ -294,14 +208,12 @@ ANTLR's and Java's indentation styles. Used by `antlr-set-tabs'." "If non-nil, cc-mode indentation style used for `antlr-mode'. See `c-set-style' and for details, where the most interesting part in `c-style-alist' is the value of `c-basic-offset'." - :group 'antlr :type '(choice (const nil) regexp)) (defcustom antlr-indent-item-regexp "[]}):;|&]" ; & is local ANTLR extension (SGML's and-connector) "Regexp matching lines which should be indented by one TAB less. See `antlr-indent-line' and command \\[antlr-indent-command]." - :group 'antlr :type 'regexp) (defcustom antlr-indent-at-bol-alist @@ -316,7 +228,6 @@ If `antlr-language' equals to a MODE, the line starting at the first non-whitespace is matched by the corresponding REGEXP, and the line is part of a header action, indent the line at column 0 instead according to the normal rules of `antlr-indent-line'." - :group 'antlr :type '(repeat (cons (function :tag "Major mode") regexp))) ;; adopt indentation to cc-engine @@ -337,7 +248,6 @@ to the normal rules of `antlr-indent-line'." "Non-nil, if the major mode menu should include option submenus. If nil, the menu just includes a command to insert options. Otherwise, it includes four submenus to insert file/grammar/rule/subrule options." - :group 'antlr :type 'boolean) (defcustom antlr-tool-version 20701 @@ -349,7 +259,6 @@ version correct option values when using \\[antlr-insert-option]. Don't use a number smaller than 20600 since the stored history of Antlr's options starts with v2.06.00, see `antlr-options-alists'. You can make this variable buffer-local." - :group 'antlr :type 'integer) (defcustom antlr-options-auto-colon t @@ -358,7 +267,6 @@ A `:' is only inserted if this value is non-nil, if a rule or subrule option is inserted with \\[antlr-insert-option], if there was no rule or subrule options section before, and if a `:' is not already present after the section, ignoring whitespace, comments and the init action." - :group 'antlr :type 'boolean) (defcustom antlr-options-style nil @@ -369,7 +277,6 @@ identifier. The only style symbol used in the default value of `antlr-options-alist' is `language-as-string'. See also `antlr-read-value'." - :group 'antlr :type '(repeat (symbol :tag "Style symbol"))) (defcustom antlr-options-push-mark t @@ -380,7 +287,6 @@ number, only set mark if point was outside the options area before and the number of lines between point and the insert position is greater than this value. Otherwise, only set mark if point was outside the options area before." - :group 'antlr :type '(radio (const :tag "No" nil) (const :tag "Always" t) (integer :tag "Lines between" :value 10) @@ -391,7 +297,6 @@ options area before." This string is only used if the option to insert did not exist before or if there was no `=' after it. In other words, the spacing around an existing `=' won't be changed when changing an option value." - :group 'antlr :type 'string) @@ -576,13 +481,11 @@ AS-STRING is non-nil and is either t or a symbol which is a member of "Command used in \\[antlr-run-tool] to run the Antlr tool. This variable should include all options passed to Antlr except the option \"-glib\" which is automatically suggested if necessary." - :group 'antlr :type 'string) (defcustom antlr-ask-about-save t "If not nil, \\[antlr-run-tool] asks which buffers to save. Otherwise, it saves all modified buffers before running without asking." - :group 'antlr :type 'boolean) (defcustom antlr-makefile-specification @@ -604,7 +507,6 @@ Then, GEN-VAR is a string with the name of the variable which contains the file names of all makefile rules. GEN-VAR-FORMAT is a format string producing the variable of each target with substitution COUNT/%d where COUNT starts with 1. GEN-SEP is used to separate long variable values." - :group 'antlr :type '(list (string :tag "Rule separator") (choice (const :tag "Direct targets" nil) @@ -683,7 +585,6 @@ DIRECTORY is the name of the current directory.") "Non-nil, if a \"Index\" menu should be added to the menubar. If it is a string, it is used instead \"Index\". Requires package imenu." - :group 'antlr :type '(choice (const :tag "No menu" nil) (const :tag "Index menu" t) (string :tag "Other menu name"))) @@ -719,9 +620,7 @@ imenu." (easy-menu-define antlr-mode-menu antlr-mode-map "Major mode menu." `("Antlr" - ,@(if (cond-emacs-xemacs - :EMACS antlr-options-use-submenus - :XEMACS antlr-options-use-submenus) + ,@(if antlr-options-use-submenus `(("Insert File Option" :filter ,(lambda (x) (antlr-options-menu-filter 1 x))) ("Insert Grammar Option" @@ -780,7 +679,6 @@ bound to `antlr-language'. For example, with value ((java-mode . 2) (c++-mode . 0)) Java actions are fontified with level 2 and C++ actions are not fontified at all." - :group 'antlr :type '(choice (const :tag "None" none) (const :tag "Inherit" inherit) (const :tag "Default" nil) @@ -824,62 +722,49 @@ in the grammar's actions and semantic predicates, see (defface antlr-default '((t nil)) "Face to prevent strings from language dependent highlighting. -Do not change." - :group 'antlr) +Do not change.") (defface antlr-keyword - (cond-emacs-xemacs - '((((class color) (background light)) - (:foreground "black" :EMACS :weight bold :XEMACS :bold t)) - (t :inherit font-lock-keyword-face))) - "ANTLR keywords." - :group 'antlr) + '((((class color) (background light)) + (:foreground "black" :weight bold)) + (t :inherit font-lock-keyword-face)) + "ANTLR keywords.") (defface antlr-syntax - (cond-emacs-xemacs - '((((class color) (background light)) - (:foreground "black" :EMACS :weight bold :XEMACS :bold t)) - (t :inherit font-lock-constant-face))) - "ANTLR syntax symbols like :, |, (, ), ...." - :group 'antlr) + '((((class color) (background light)) + (:foreground "black" :weight bold)) + (t :inherit font-lock-constant-face)) + "ANTLR syntax symbols like :, |, (, ), ....") (defface antlr-ruledef - (cond-emacs-xemacs - '((((class color) (background light)) - (:foreground "blue" :EMACS :weight bold :XEMACS :bold t)) - (t :inherit font-lock-function-name-face))) - "ANTLR rule references (definition)." - :group 'antlr) + '((((class color) (background light)) + (:foreground "blue" :weight bold)) + (t :inherit font-lock-function-name-face)) + "ANTLR rule references (definition).") (defface antlr-tokendef - (cond-emacs-xemacs - '((((class color) (background light)) - (:foreground "blue" :EMACS :weight bold :XEMACS :bold t)) - (t :inherit font-lock-function-name-face))) - "ANTLR token references (definition)." - :group 'antlr) + '((((class color) (background light)) + (:foreground "blue" :weight bold)) + (t :inherit font-lock-function-name-face)) + "ANTLR token references (definition).") (defface antlr-ruleref '((((class color) (background light)) (:foreground "blue4")) (t :inherit font-lock-type-face)) - "ANTLR rule references (usage)." - :group 'antlr) + "ANTLR rule references (usage).") (defface antlr-tokenref '((((class color) (background light)) (:foreground "orange4")) (t :inherit font-lock-type-face)) - "ANTLR token references (usage)." - :group 'antlr) + "ANTLR token references (usage).") (defface antlr-literal - (cond-emacs-xemacs - '((((class color) (background light)) - (:foreground "brown4" :EMACS :weight bold :XEMACS :bold t)) - (t :inherit font-lock-string-face))) + '((((class color) (background light)) + (:foreground "brown4" :weight bold)) + (t :inherit font-lock-string-face)) "ANTLR special literal tokens. It is used to highlight strings matched by the first regexp group of -`antlr-font-lock-literal-regexp'." - :group 'antlr) +`antlr-font-lock-literal-regexp'.") (defcustom antlr-font-lock-literal-regexp "\"\\(\\sw\\(\\sw\\|-\\)*\\)\"" "Regexp matching literals with special syntax highlighting, or nil. @@ -887,7 +772,6 @@ If nil, there is no special syntax highlighting for some literals. Otherwise, it should be a regular expression which must contain a regexp group. The string matched by the first group is highlighted with `antlr-font-lock-literal-face'." - :group 'antlr :type '(choice (const :tag "None" nil) regexp)) (defvar antlr-class-header-regexp @@ -895,50 +779,48 @@ group. The string matched by the first group is highlighted with "Regexp matching class headers.") (defvar antlr-font-lock-additional-keywords - (cond-emacs-xemacs - `((antlr-invalidate-context-cache) - ("\\$setType[ \t]*(\\([A-Za-z\300-\326\330-\337]\\sw*\\))" - (1 'antlr-tokendef)) - ("\\$\\sw+" (0 'antlr-keyword)) - ;; the tokens are already fontified as string/docstrings: - (,(lambda (limit) - (if antlr-font-lock-literal-regexp - (antlr-re-search-forward antlr-font-lock-literal-regexp limit))) - (1 'antlr-literal t) - :XEMACS (0 nil)) ; XEmacs bug workaround - (,(lambda (limit) - (antlr-re-search-forward antlr-class-header-regexp limit)) - (1 'antlr-keyword) - (2 'antlr-ruledef) - (3 'antlr-keyword) - (4 (if (member (match-string 4) '("Lexer" "Parser" "TreeParser")) - 'antlr-keyword - 'font-lock-type-face))) - (,(lambda (limit) - (antlr-re-search-forward - "\\<\\(header\\|options\\|tokens\\|exception\\|catch\\|returns\\)\\>" - limit)) + `((antlr-invalidate-context-cache) + ("\\$setType[ \t]*(\\([A-Za-z\300-\326\330-\337]\\sw*\\))" + (1 'antlr-tokendef)) + ("\\$\\sw+" (0 'antlr-keyword)) + ;; the tokens are already fontified as string/docstrings: + (,(lambda (limit) + (if antlr-font-lock-literal-regexp + (antlr-re-search-forward antlr-font-lock-literal-regexp limit))) + (1 'antlr-literal t)) + (,(lambda (limit) + (antlr-re-search-forward antlr-class-header-regexp limit)) + (1 'antlr-keyword) + (2 'antlr-ruledef) + (3 'antlr-keyword) + (4 (if (member (match-string 4) '("Lexer" "Parser" "TreeParser")) + 'antlr-keyword + 'font-lock-type-face))) + (,(lambda (limit) + (antlr-re-search-forward + "\\<\\(header\\|options\\|tokens\\|exception\\|catch\\|returns\\)\\>" + limit)) (1 'antlr-keyword)) - (,(lambda (limit) - (antlr-re-search-forward - "^\\(private\\|public\\|protected\\)\\>[ \t]*\\(\\(\\sw+[ \t]*\\(:\\)?\\)\\)?" - limit)) - (1 'font-lock-type-face) ; not XEmacs's java level-3 fruit salad + (,(lambda (limit) + (antlr-re-search-forward + "^\\(private\\|public\\|protected\\)\\>[ \t]*\\(\\(\\sw+[ \t]*\\(:\\)?\\)\\)?" + limit)) + (1 'font-lock-type-face) ; not XEmacs's java level-3 fruit salad (3 (if (antlr-upcase-p (char-after (match-beginning 3))) 'antlr-tokendef 'antlr-ruledef) nil t) (4 'antlr-syntax nil t)) - (,(lambda (limit) - (antlr-re-search-forward "^\\(\\sw+\\)[ \t]*\\(:\\)?" limit)) + (,(lambda (limit) + (antlr-re-search-forward "^\\(\\sw+\\)[ \t]*\\(:\\)?" limit)) (1 (if (antlr-upcase-p (char-after (match-beginning 0))) 'antlr-tokendef 'antlr-ruledef) nil t) (2 'antlr-syntax nil t)) - (,(lambda (limit) - ;; v:ruleref and v:"literal" is allowed... - (antlr-re-search-forward "\\(\\sw+\\)[ \t]*\\([=:]\\)?" limit)) + (,(lambda (limit) + ;; v:ruleref and v:"literal" is allowed... + (antlr-re-search-forward "\\(\\sw+\\)[ \t]*\\([=:]\\)?" limit)) (1 (if (match-beginning 2) (if (eq (char-after (match-beginning 2)) ?=) 'antlr-default @@ -947,9 +829,9 @@ group. The string matched by the first group is highlighted with 'antlr-tokenref 'antlr-ruleref))) (2 'antlr-default nil t)) - (,(lambda (limit) - (antlr-re-search-forward "[|&:;(~]\\|)\\([*+?]\\|=>\\)?" limit)) - (0 'antlr-syntax)))) + (,(lambda (limit) + (antlr-re-search-forward "[|&:;(~]\\|)\\([*+?]\\|=>\\)?" limit)) + (0 'antlr-syntax))) "Font-lock keywords for ANTLR's normal grammar code. See `antlr-font-lock-keywords-alist' for the keywords of actions.") @@ -1015,35 +897,6 @@ Used for `antlr-slow-syntactic-context'.") ;;; Syntax functions -- Emacs vs XEmacs dependent, part 1 ;;;=========================================================================== -;; From help.el (XEmacs-21.1), without `copy-syntax-table' -(defmacro antlr-with-syntax-table (syntab &rest body) - "Evaluate BODY with the syntax table SYNTAB." - `(let ((stab (syntax-table))) - (unwind-protect - (progn (set-syntax-table ,syntab) ,@body) - (set-syntax-table stab)))) -(put 'antlr-with-syntax-table 'lisp-indent-function 1) -(put 'antlr-with-syntax-table 'edebug-form-spec '(form body)) - -(defunx antlr-default-directory () - :xemacs-and-try default-directory - "Return `default-directory'." - default-directory) - -;; Check Emacs-21.1 simple.el, `shell-command'. -(defunx antlr-read-shell-command (prompt &optional initial-input history) - :xemacs-and-try read-shell-command - "Read a string from the minibuffer, using `shell-command-history'." - (read-from-minibuffer prompt initial-input nil nil - (or history 'shell-command-history))) - -(defunx antlr-with-displaying-help-buffer (thunk &optional _name) - :xemacs-and-try with-displaying-help-buffer - "Make a help buffer and call `thunk' there." - (with-output-to-temp-buffer "*Help*" - (save-excursion (funcall thunk)))) - - ;;;=========================================================================== ;;; Context cache ;;;=========================================================================== @@ -1056,26 +909,18 @@ Used for `antlr-slow-syntactic-context'.") ;;;(defvar antlr-statistics-cache 0) ;;;(defvar antlr-statistics-inval 0) -(defunx antlr-invalidate-context-cache (&rest _dummies) +(defun antlr-invalidate-context-cache (&rest _dummies) ;; checkdoc-params: (dummies) "Invalidate context cache for syntactical context information." - :XEMACS ; XEmacs bug workaround - (with-current-buffer (get-buffer-create " ANTLR XEmacs bug workaround") - (buffer-syntactic-context-depth) - nil) - :EMACS ;;; (cl-incf antlr-statistics-inval) (setq antlr-slow-context-cache nil)) -(defunx antlr-syntactic-context () +(defun antlr-syntactic-context () "Return some syntactic context information. Return `string' if point is within a string, `block-comment' or `comment' is point is within a comment or the depth within all parenthesis-syntax delimiters at point otherwise. WARNING: this may alter `match-data'." - :XEMACS - (or (buffer-syntactic-context) (buffer-syntactic-context-depth)) - :EMACS (let ((orig (point)) diff state ;; Arg, Emacs's (buffer-modified-tick) changes with font-lock. Use ;; hack that `loudly' is bound during font-locking => cache use will @@ -1094,9 +939,9 @@ WARNING: this may alter `match-data'." (if (>= orig antlr-slow-cache-diff-threshold) (beginning-of-defun) (goto-char (point-min))) -;;; (cond ((and diff (< diff 0)) (cl-incf antlr-statistics-full-neg)) -;;; ((and diff (>= diff 3000)) (cl-incf antlr-statistics-full-diff)) -;;; (t (cl-incf antlr-statistics-full-other))) + ;; (cond ((and diff (< diff 0)) (cl-incf antlr-statistics-full-neg)) + ;; ((and diff (>= diff 3000)) (cl-incf antlr-statistics-full-diff)) + ;; (t (cl-incf antlr-statistics-full-other))) (setq state (parse-partial-sexp (point) orig))) (goto-char orig) (if antlr-slow-context-cache @@ -1108,52 +953,52 @@ WARNING: this may alter `match-data'." ((nth 4 state) 'comment) ; block-comment? -- we don't care (t (car state))))) -;;; (cl-incf (aref antlr-statistics 2)) -;;; (unless (and (eq (current-buffer) -;;; (caar antlr-slow-context-cache)) -;;; (eq (buffer-modified-tick) -;;; (cdar antlr-slow-context-cache))) -;;; (cl-incf (aref antlr-statistics 1)) -;;; (setq antlr-slow-context-cache nil)) -;;; (let* ((orig (point)) -;;; (base (cadr antlr-slow-context-cache)) -;;; (curr (cddr antlr-slow-context-cache)) -;;; (state (cond ((eq orig (car curr)) (cdr curr)) -;;; ((eq orig (car base)) (cdr base)))) -;;; diff diff2) -;;; (unless state -;;; (cl-incf (aref antlr-statistics 3)) -;;; (when curr -;;; (if (< (setq diff (abs (- orig (car curr)))) -;;; (setq diff2 (abs (- orig (car base))))) -;;; (setq state curr) -;;; (setq state base -;;; diff diff2)) -;;; (if (or (>= (1+ diff) (point)) (>= diff 3000)) -;;; (setq state nil))) ; start from bod/bob -;;; (if state -;;; (setq state -;;; (parse-partial-sexp (car state) orig nil nil (cdr state))) -;;; (if (>= orig 3000) (beginning-of-defun) (goto-char (point-min))) -;;; (cl-incf (aref antlr-statistics 4)) -;;; (setq cw (list orig (point) base curr)) -;;; (setq state (parse-partial-sexp (point) orig))) -;;; (goto-char orig) -;;; (if antlr-slow-context-cache -;;; (setcdr (cdr antlr-slow-context-cache) (cons orig state)) -;;; (setq antlr-slow-context-cache -;;; (cons (cons (current-buffer) (buffer-modified-tick)) -;;; (cons (cons orig state) (cons orig state)))))) -;;; (cond ((nth 3 state) 'string) -;;; ((nth 4 state) 'comment) ; block-comment? -- we don't care -;;; (t (car state))))) - -;;; (beginning-of-defun) -;;; (let ((state (parse-partial-sexp (point) orig))) -;;; (goto-char orig) -;;; (cond ((nth 3 state) 'string) -;;; ((nth 4 state) 'comment) ; block-comment? -- we don't care -;;; (t (car state)))))) +;; (cl-incf (aref antlr-statistics 2)) +;; (unless (and (eq (current-buffer) +;; (caar antlr-slow-context-cache)) +;; (eq (buffer-modified-tick) +;; (cdar antlr-slow-context-cache))) +;; (cl-incf (aref antlr-statistics 1)) +;; (setq antlr-slow-context-cache nil)) +;; (let* ((orig (point)) +;; (base (cadr antlr-slow-context-cache)) +;; (curr (cddr antlr-slow-context-cache)) +;; (state (cond ((eq orig (car curr)) (cdr curr)) +;; ((eq orig (car base)) (cdr base)))) +;; diff diff2) +;; (unless state +;; (cl-incf (aref antlr-statistics 3)) +;; (when curr +;; (if (< (setq diff (abs (- orig (car curr)))) +;; (setq diff2 (abs (- orig (car base))))) +;; (setq state curr) +;; (setq state base +;; diff diff2)) +;; (if (or (>= (1+ diff) (point)) (>= diff 3000)) +;; (setq state nil))) ; start from bod/bob +;; (if state +;; (setq state +;; (parse-partial-sexp (car state) orig nil nil (cdr state))) +;; (if (>= orig 3000) (beginning-of-defun) (goto-char (point-min))) +;; (cl-incf (aref antlr-statistics 4)) +;; (setq cw (list orig (point) base curr)) +;; (setq state (parse-partial-sexp (point) orig))) +;; (goto-char orig) +;; (if antlr-slow-context-cache +;; (setcdr (cdr antlr-slow-context-cache) (cons orig state)) +;; (setq antlr-slow-context-cache +;; (cons (cons (current-buffer) (buffer-modified-tick)) +;; (cons (cons orig state) (cons orig state)))))) +;; (cond ((nth 3 state) 'string) +;; ((nth 4 state) 'comment) ; block-comment? -- we don't care +;; (t (car state))))) + +;; (beginning-of-defun) +;; (let ((state (parse-partial-sexp (point) orig))) +;; (goto-char orig) +;; (cond ((nth 3 state) 'string) +;; ((nth 4 state) 'comment) ; block-comment? -- we don't care +;; (t (car state)))))) ;;;=========================================================================== @@ -1207,7 +1052,7 @@ strings and actions/semantic predicates." (defsubst antlr-skip-sexps (count) "Skip the next COUNT balanced expressions and the comments after it. Return position before the comments after the last expression." - (goto-char (or (ignore-errors-x (scan-sexps (point) count)) (point-max))) + (goto-char (or (ignore-errors (scan-sexps (point) count)) (point-max))) (prog1 (point) (antlr-c-forward-sws))) @@ -1229,7 +1074,8 @@ See `antlr-font-lock-additional-keywords', `antlr-language' and antlr-font-lock-keywords-alist)) (if (eq antlr-font-lock-maximum-decoration 'inherit) font-lock-maximum-decoration - antlr-font-lock-maximum-decoration))))))) + antlr-font-lock-maximum-decoration))) + t)))) ;;;=========================================================================== @@ -1246,10 +1092,9 @@ IF TOKENREFS-ONLY is non-nil, just return alist with tokenref names." (let ((items nil) (classes nil) (continue t)) - ;; Using `imenu-progress-message' would require imenu for compilation, but - ;; nobody is missing these messages. The generic imenu function searches - ;; backward, which is slower and more likely not to work during editing. - (antlr-with-syntax-table antlr-action-syntax-table + ;; The generic imenu function searches backward, which is slower + ;; and more likely not to work during editing. + (with-syntax-table antlr-action-syntax-table (antlr-invalidate-context-cache) (goto-char (point-min)) (antlr-skip-file-prelude t) @@ -1393,37 +1238,37 @@ Move to the beginning of the current rule if point is inside a rule." A grammar class header and the file prelude are also considered as a rule." (save-excursion - (antlr-with-syntax-table antlr-action-syntax-table + (with-syntax-table antlr-action-syntax-table (not (antlr-outside-rule-p))))) -(defunx antlr-end-of-rule (&optional arg) +(defun antlr-end-of-rule (&optional arg) "Move forward to next end of rule. Do it ARG [default: 1] many times. A grammar class header and the file prelude are also considered as a rule. Negative argument ARG means move back to ARGth preceding end of rule. If ARG is zero, run `antlr-end-of-body'." - (interactive "_p") + (interactive "^p") (if (zerop arg) (antlr-end-of-body) - (antlr-with-syntax-table antlr-action-syntax-table + (with-syntax-table antlr-action-syntax-table (antlr-next-rule arg nil)))) -(defunx antlr-beginning-of-rule (&optional arg) +(defun antlr-beginning-of-rule (&optional arg) "Move backward to preceding beginning of rule. Do it ARG many times. A grammar class header and the file prelude are also considered as a rule. Negative argument ARG means move forward to ARGth next beginning of rule. If ARG is zero, run `antlr-beginning-of-body'." - (interactive "_p") + (interactive "^p") (if (zerop arg) (antlr-beginning-of-body) - (antlr-with-syntax-table antlr-action-syntax-table + (with-syntax-table antlr-action-syntax-table (antlr-next-rule (- arg) t)))) -(defunx antlr-end-of-body (&optional msg) +(defun antlr-end-of-body (&optional msg) "Move to position after the `;' of the current rule. A grammar class header is also considered as a rule. With optional prefix arg MSG, move to `:'." - (interactive "_") - (antlr-with-syntax-table antlr-action-syntax-table + (interactive "^") + (with-syntax-table antlr-action-syntax-table (let ((orig (point))) (if (antlr-outside-rule-p) (error "Outside an ANTLR rule")) @@ -1441,9 +1286,9 @@ prefix arg MSG, move to `:'." (error msg)) (antlr-c-forward-sws)))))) -(defunx antlr-beginning-of-body () +(defun antlr-beginning-of-body () "Move to the first element after the `:' of the current rule." - (interactive "_") + (interactive "^") (antlr-end-of-body "Class headers and the file prelude are without `:'")) @@ -1459,7 +1304,7 @@ If non-nil, TRANSFORM is used on literals instead of `downcase-region'." (let ((literals 0)) (save-excursion (goto-char (point-min)) - (antlr-with-syntax-table antlr-action-syntax-table + (with-syntax-table antlr-action-syntax-table (antlr-invalidate-context-cache) (while (antlr-re-search-forward "\"\\(\\sw\\(\\sw\\|-\\)*\\)\"" nil) (funcall transform (match-beginning 0) (match-end 0)) @@ -1488,10 +1333,10 @@ Display a message unless optional argument SILENT is non-nil." (antlr-hide-actions 0 t) (save-excursion (goto-char (point-min)) - (antlr-with-syntax-table antlr-action-syntax-table + (with-syntax-table antlr-action-syntax-table (antlr-invalidate-context-cache) (while (antlr-re-search-forward regexp nil) - (let ((beg (ignore-errors-x (scan-sexps (point) -1)))) + (let ((beg (ignore-errors (scan-sexps (point) -1)))) (when beg (if diff ; braces are visible (if (> (point) (+ beg diff)) @@ -1684,7 +1529,7 @@ like \(AREA . PLACE), see `antlr-option-location'." (cond ((null pos) 'error) ((looking-at "options[ \t\n]*{") (goto-char (match-end 0)) - (setq pos (ignore-errors-x (scan-lists (point) 1 1))) + (setq pos (ignore-errors (scan-lists (point) 1 1))) (antlr-option-location orig min0 max0 (point) (if pos (1- pos) (point-max)) @@ -1709,7 +1554,7 @@ is undefined." (widen) (if (eq requested 1) 1 - (antlr-with-syntax-table antlr-action-syntax-table + (with-syntax-table antlr-action-syntax-table (antlr-invalidate-context-cache) (let* ((orig (point)) (outsidep (antlr-outside-rule-p)) @@ -2087,7 +1932,7 @@ its export vocabulary is used as an import vocabulary." (unless buffer-file-name (error "Grammar buffer does not visit a file")) (let (classes export-vocabs import-vocabs superclasses default-vocab) - (antlr-with-syntax-table antlr-action-syntax-table + (with-syntax-table antlr-action-syntax-table (goto-char (point-min)) (while (antlr-re-search-forward antlr-class-header-regexp nil) ;; parse class definition -------------------------------------------- @@ -2240,9 +2085,9 @@ Use prefix argument ARG to return \(COMMAND FILE SAVED)." (setq glibs (car (antlr-superclasses-glibs supers (car (antlr-directory-dependencies - (antlr-default-directory))))))) - (list (antlr-read-shell-command "Run Antlr on current file with: " - (concat antlr-tool-command glibs " ")) + default-directory)))))) + (list (read-shell-command "Run Antlr on current file with: " + (concat antlr-tool-command glibs " ")) buffer-file-name supers))) @@ -2264,7 +2109,7 @@ Also insert strings PRE and POST before and after the variable." "Insert Makefile rules in the current buffer at point. IN-MAKEFILE is non-nil, if the current buffer is the Makefile. See command `antlr-show-makefile-rules' for detail." - (let* ((dirname (antlr-default-directory)) + (let* ((dirname default-directory) (deps0 (antlr-directory-dependencies dirname)) (classes (car deps0)) ; CLASS -> (FILE . EVOCAB) ... (deps (cdr deps0)) ; FILE -> (c . s) (ev . iv) . LANGUAGE @@ -2343,7 +2188,9 @@ commentary with value `antlr-help-unknown-file-text' is added. The *Help* buffer always starts with the text in `antlr-help-rules-intro'." (interactive) (if (null (derived-mode-p 'makefile-mode)) - (antlr-with-displaying-help-buffer 'antlr-insert-makefile-rules) + (with-output-to-temp-buffer "*Help*" + (save-excursion + (antlr-insert-makefile-rules))) (push-mark) (antlr-insert-makefile-rules t))) @@ -2386,7 +2233,7 @@ to a lesser extent, `antlr-tab-offset-alist'." (skip-chars-forward " \t") (setq boi (point)) ;; check syntax at beginning of indentation ---------------------------- - (antlr-with-syntax-table antlr-action-syntax-table + (with-syntax-table antlr-action-syntax-table (antlr-invalidate-context-cache) (setq syntax (antlr-syntactic-context)) (cond ((symbolp syntax) @@ -2482,7 +2329,7 @@ ANTLR's syntax and influences the auto indentation, see (interactive "*P") (if (or arg (save-excursion (skip-chars-backward " \t") (not (bolp))) - (antlr-with-syntax-table antlr-action-syntax-table + (with-syntax-table antlr-action-syntax-table (antlr-invalidate-context-cache) (let ((context (antlr-syntactic-context))) (not (and (numberp context) @@ -2525,7 +2372,7 @@ ANTLR's syntax and influences the auto indentation, see (while settings (when (boundp (car settings)) (ignore-errors - (set (car settings) (eval (cadr settings))))) + (set (car settings) (eval (cadr settings) t)))) (setq settings (cddr settings))))) (defun antlr-language-option (search) @@ -2572,20 +2419,11 @@ the default language." (cadr (assq antlr-language antlr-language-alist))))) ;; indentation, for the C engine ------------------------------------------- (setq c-buffer-is-cc-mode antlr-language) - (cond ((fboundp 'c-init-language-vars-for) ; cc-mode 5.30.5+ - (c-init-language-vars-for antlr-language)) - ((fboundp 'c-init-c-language-vars) ; cc-mode 5.30 to 5.30.4 - (c-init-c-language-vars) ; not perfect, but OK - (setq c-recognize-knr-p nil)) - ((fboundp 'c-init-language-vars) ; cc-mode 5.29 - (let ((init-fn 'c-init-language-vars)) - (funcall init-fn))) ; is a function in v5.29 - (t ; cc-mode upto 5.28 - (antlr-c-init-language-vars))) ; do it myself + (c-init-language-vars-for antlr-language) (c-basic-common-init antlr-language (or antlr-indent-style "gnu")) (set (make-local-variable 'outline-regexp) "[^#\n\^M]") - (set (make-local-variable 'outline-level) 'c-outline-level) ;TODO: define own - (set (make-local-variable 'indent-line-function) 'antlr-indent-line) + (set (make-local-variable 'outline-level) #'c-outline-level) ;TODO: define own + (set (make-local-variable 'indent-line-function) #'antlr-indent-line) (set (make-local-variable 'indent-region-function) nil) ; too lazy (setq comment-start "// " comment-end "" @@ -2595,7 +2433,7 @@ the default language." (when (featurep 'xemacs) (easy-menu-add antlr-mode-menu)) (set (make-local-variable 'imenu-create-index-function) - 'antlr-imenu-create-index-function) + #'antlr-imenu-create-index-function) (set (make-local-variable 'imenu-generic-expression) t) ; fool stupid test (and antlr-imenu-name ; there should be a global variable... (fboundp 'imenu-add-to-menubar) @@ -2625,6 +2463,6 @@ Used in `antlr-mode'. Also a useful function in `java-mode-hook'." (provide 'antlr-mode) -;;; Local IspellPersDict: .ispell_antlr +;; Local IspellPersDict: .ispell_antlr ;;; antlr-mode.el ends here diff --git a/lisp/progmodes/asm-mode.el b/lisp/progmodes/asm-mode.el index 99b2ec6d87e..2f7d7bf7966 100644 --- a/lisp/progmodes/asm-mode.el +++ b/lisp/progmodes/asm-mode.el @@ -73,19 +73,19 @@ ;; Note that the comment character isn't set up until asm-mode is called. (define-key map ":" 'asm-colon) (define-key map "\C-c;" 'comment-region) - (define-key map [menu-bar asm-mode] (cons "Asm" (make-sparse-keymap))) - (define-key map [menu-bar asm-mode comment-region] - '(menu-item "Comment Region" comment-region - :help "Comment or uncomment each line in the region")) - (define-key map [menu-bar asm-mode newline-and-indent] - '(menu-item "Insert Newline and Indent" newline-and-indent - :help "Insert a newline, then indent according to major mode")) - (define-key map [menu-bar asm-mode asm-colon] - '(menu-item "Insert Colon" asm-colon - :help "Insert a colon; if it follows a label, delete the label's indentation")) map) "Keymap for Asm mode.") +(easy-menu-define asm-mode-menu asm-mode-map + "Menu for Asm mode." + '("Asm" + ["Insert Colon" asm-colon + :help "Insert a colon; if it follows a label, delete the label's indentation"] + ["Insert Newline and Indent" newline-and-indent + :help "Insert a newline, then indent according to major mode"] + ["Comment Region" comment-region + :help "Comment or uncomment each line in the region"])) + (defconst asm-font-lock-keywords (append '(("^\\(\\(\\sw\\|\\s_\\)+\\)\\>:?[ \t]*\\(\\sw+\\(\\.\\sw+\\)*\\)?" diff --git a/lisp/progmodes/bug-reference.el b/lisp/progmodes/bug-reference.el index a759394abeb..9b9c58eb1f2 100644 --- a/lisp/progmodes/bug-reference.el +++ b/lisp/progmodes/bug-reference.el @@ -1,4 +1,4 @@ -;; bug-reference.el --- buttonize bug references -*- lexical-binding: t; -*- +;;; bug-reference.el --- buttonize bug references -*- lexical-binding: t; -*- ;; Copyright (C) 2008-2021 Free Software Foundation, Inc. @@ -25,10 +25,13 @@ ;; This file provides minor modes for putting clickable overlays on ;; references to bugs. A bug reference is text like "PR foo/29292"; -;; this is mapped to a URL using a user-supplied format. +;; this is mapped to a URL using a user-supplied format; see +;; `bug-reference-url-format' and `bug-reference-bug-regexp'. More +;; extensive documentation is in (info "(emacs) Bug Reference"). ;; Two minor modes are provided. One works on any text in the buffer; -;; the other operates only on comments and strings. +;; the other operates only on comments and strings. By default, the +;; URL link is followed by invoking C-c RET or mouse-2. ;;; Code: @@ -73,8 +76,7 @@ so that it is considered safe, see `enable-local-variables'.") "Regular expression matching bug references. The second subexpression should match the bug reference (usually a number)." :type 'regexp - :version "24.3" ; previously defconst - :group 'bug-reference) + :version "24.3") ; previously defconst ;;;###autoload (put 'bug-reference-bug-regexp 'safe-local-variable 'stringp) @@ -127,6 +129,9 @@ The second subexpression should match the bug reference (usually a number)." "Open URL corresponding to the bug reference at POS." (interactive (list (if (integerp last-command-event) (point) last-command-event))) + (when (null bug-reference-url-format) + (user-error + "You must customize some bug-reference variables; see Emacs info node Bug Reference")) (if (and (not (integerp pos)) (eventp pos)) ;; POS is a mouse event; switch to the proper window/buffer (let ((posn (event-start pos))) @@ -139,7 +144,7 @@ The second subexpression should match the bug reference (usually a number)." (when url (browse-url url)))))) -(defun bug-reference--maybe-setup-from-vc (url url-rx bug-rx bug-url-fmt) +(defun bug-reference-maybe-setup-from-vc (url url-rx bug-rx bug-url-fmt) (when (string-match url-rx url) (setq-local bug-reference-bug-regexp bug-rx) (setq-local bug-reference-url-format @@ -179,6 +184,22 @@ The second subexpression should match the bug reference (usually a number)." "/issues/" (match-string 2)))))) ;; + ;; Codeberg projects. + ;; + ;; The systematics is exactly as for Github projects. + ("[/@]codeberg.org[/:]\\([.A-Za-z0-9_/-]+\\)\\.git" + "\\([.A-Za-z0-9_/-]+\\)?\\(?:#\\)\\([0-9]+\\)\\>" + ,(lambda (groups) + (let ((ns-project (nth 1 groups))) + (lambda () + (concat "https://codeberg.org/" + (or + ;; Explicit user/proj#18 link. + (match-string 1) + ns-project) + "/issues/" + (match-string 2)))))) + ;; ;; GitLab projects. ;; ;; Here #18 is an issue and !17 is a merge request. Explicit @@ -196,6 +217,30 @@ The second subexpression should match the bug reference (usually a number)." (if (string= (match-string 3) "#") "issues/" "merge_requests/") + (match-string 2)))))) + ;; + ;; Sourcehut projects. + ;; + ;; #19 is an issue. Other project's issues can be referenced as + ;; #~user/project#19. + ;; + ;; Caveat: The code assumes that a project on git.sr.ht or + ;; hg.sr.ht has a tracker of the same name on todo.sh.ht. That's + ;; a very common setup but all sr.ht services are loosely coupled, + ;; so you can have a repo without tracker, or a repo with a + ;; tracker using a different name, etc. So we can only try to + ;; make a good guess. + ("[/@]\\(?:git\\|hg\\).sr.ht[/:]\\(~[.A-Za-z0-9_/-]+\\)" + "\\(~[.A-Za-z0-9_/-]+\\)?\\(?:#\\)\\([0-9]+\\)\\>" + ,(lambda (groups) + (let ((ns-project (nth 1 groups))) + (lambda () + (concat "https://todo.sr.ht/" + (or + ;; Explicit user/proj#18 link. + (match-string 1) + ns-project) + "/" (match-string 2))))))) "An alist for setting up `bug-reference-mode' based on VC URL. @@ -225,7 +270,7 @@ and apply it if applicable." (when url (catch 'found (dolist (config bug-reference-setup-from-vc-alist) - (when (apply #'bug-reference--maybe-setup-from-vc + (when (apply #'bug-reference-maybe-setup-from-vc url config) (throw 'found t))))))))) @@ -239,8 +284,8 @@ and apply it if applicable." "An alist for setting up `bug-reference-mode' in mail modes. This takes action if `bug-reference-mode' is enabled in group and -message buffers of Emacs mail clients. Currently, only Gnus is -supported. +message buffers of Emacs mail clients. Currently, Gnus and Rmail +are supported. Each element has the form @@ -259,7 +304,7 @@ same `bug-reference-url-format' and `bug-reference-url-format'.") (defvar gnus-newsgroup-name) -(defun bug-reference--maybe-setup-from-mail (group header-values) +(defun bug-reference-maybe-setup-from-mail (group header-values) "Set up according to mail GROUP or HEADER-VALUES. Group is a mail group/folder name and HEADER-VALUES is a list of mail header values, e.g., the values of From, To, Cc, List-ID, @@ -295,65 +340,83 @@ and set it if applicable." ;; article changes. (add-hook 'gnus-article-prepare-hook #'bug-reference--try-setup-gnus-article) - (bug-reference--maybe-setup-from-mail gnus-newsgroup-name nil))) + (bug-reference-maybe-setup-from-mail gnus-newsgroup-name nil))) (defvar gnus-article-buffer) (defvar gnus-original-article-buffer) (defvar gnus-summary-buffer) +(defvar bug-reference-mode) (defun bug-reference--try-setup-gnus-article () - (with-demoted-errors - "Error in bug-reference--try-setup-gnus-article: %S" - (when (and bug-reference-mode ;; Only if enabled in article buffers. - (derived-mode-p - 'gnus-article-mode - ;; Apparently, gnus-article-prepare-hook is run in the - ;; summary buffer... - 'gnus-summary-mode) - gnus-article-buffer - gnus-original-article-buffer - (buffer-live-p (get-buffer gnus-article-buffer)) - (buffer-live-p (get-buffer gnus-original-article-buffer))) - (with-current-buffer gnus-article-buffer - (catch 'setup-done - ;; Copy over the values from the summary buffer. - (when (and gnus-summary-buffer - (buffer-live-p gnus-summary-buffer)) - (setq-local bug-reference-bug-regexp - (with-current-buffer gnus-summary-buffer - bug-reference-bug-regexp)) - (setq-local bug-reference-url-format - (with-current-buffer gnus-summary-buffer - bug-reference-url-format)) - (when (and bug-reference-bug-regexp - bug-reference-url-format) - (throw 'setup-done t))) - ;; If the summary had no values, try setting according to - ;; the values of the From, To, and Cc headers. - (let (header-values) - (with-current-buffer - (get-buffer gnus-original-article-buffer) - (save-excursion - (goto-char (point-min)) - ;; The Newsgroup is omitted because we already matched - ;; based on group name in the summary buffer. - (dolist (field '("list-id" "to" "from" "cc")) - (let ((val (mail-fetch-field field))) - (when val - (push val header-values)))))) - (bug-reference--maybe-setup-from-mail nil header-values))))))) + (when (and bug-reference-mode ;; Only if enabled in article buffers. + (derived-mode-p + 'gnus-article-mode + ;; Apparently, gnus-article-prepare-hook is run in the + ;; summary buffer... + 'gnus-summary-mode) + gnus-article-buffer + gnus-original-article-buffer + (buffer-live-p (get-buffer gnus-article-buffer)) + (buffer-live-p (get-buffer gnus-original-article-buffer))) + (with-current-buffer gnus-article-buffer + (catch 'setup-done + ;; Copy over the values from the summary buffer. + (when (and gnus-summary-buffer + (buffer-live-p gnus-summary-buffer)) + (setq-local bug-reference-bug-regexp + (with-current-buffer gnus-summary-buffer + bug-reference-bug-regexp)) + (setq-local bug-reference-url-format + (with-current-buffer gnus-summary-buffer + bug-reference-url-format)) + (when (and bug-reference-bug-regexp + bug-reference-url-format) + (throw 'setup-done t))) + ;; If the summary had no values, try setting according to + ;; the values of the From, To, and Cc headers. + (let (header-values) + (with-current-buffer + (get-buffer gnus-original-article-buffer) + (save-excursion + (goto-char (point-min)) + ;; The Newsgroup is omitted because we already matched + ;; based on group name in the summary buffer. + (dolist (field '("list-id" "to" "from" "cc")) + (let ((val (mail-fetch-field field))) + (when val + (push val header-values)))))) + (bug-reference-maybe-setup-from-mail nil header-values)))))) + +(defun bug-reference-try-setup-from-rmail () + "Try setting up `bug-reference-mode' from the current rmail mail. +Guesses suitable `bug-reference-bug-regexp' and +`bug-reference-url-format' values by matching the current Rmail +file's name against GROUP-REGEXP and the values of List-Id, To, +From, and Cc against HEADER-REGEXP in +`bug-reference-setup-from-mail-alist'." + (when (and bug-reference-mode + (derived-mode-p 'rmail-mode)) + (let (header-values) + (save-excursion + (goto-char (point-min)) + (dolist (field '("list-id" "to" "from" "cc")) + (let ((val (mail-fetch-field field))) + (when val + (push val header-values))))) + (bug-reference-maybe-setup-from-mail + (buffer-file-name) header-values)))) (defvar bug-reference-setup-from-irc-alist `((,(concat "#" (regexp-opt '("emacs" "gnus" "org-mode" "rcirc" "erc") 'words)) - "freenode" + "Libera.Chat" "\\([Bb]ug ?#?\\)\\([0-9]+\\(?:#[0-9]+\\)?\\)" "https://debbugs.gnu.org/%s")) "An alist for setting up `bug-reference-mode' in IRC modes. This takes action if `bug-reference-mode' is enabled in IRC -channels using one of Emacs' IRC clients (rcirc and ERC). -Currently, rcirc and ERC are supported. +channels using one of Emacs' IRC clients. Currently, rcirc and +ERC are supported. Each element has the form @@ -361,12 +424,12 @@ Each element has the form CHANNEL-REGEXP is a regexp matched against the current IRC channel name (e.g. #emacs). NETWORK-REGEXP is matched against -the IRC network name (e.g. freenode). Both entries are optional. -If all given entries match, BUG-REGEXP is set as +the IRC network name (e.g. Libera.Chat). Both entries are +optional. If all given entries match, BUG-REGEXP is set as `bug-reference-bug-regexp' and URL-FORMAT is set as `bug-reference-url-format'.") -(defun bug-reference--maybe-setup-from-irc (channel network) +(defun bug-reference-maybe-setup-from-irc (channel network) "Set up according to IRC CHANNEL or NETWORK. CHANNEL is an IRC channel name (or generally a target, i.e., it could also be a user name) and NETWORK is that channel's network @@ -402,7 +465,7 @@ corresponding BUG-REGEXP and URL-FORMAT are set." Test each configuration in `bug-reference-setup-from-irc-alist' and set it if applicable." (when (derived-mode-p 'rcirc-mode) - (bug-reference--maybe-setup-from-irc + (bug-reference-maybe-setup-from-irc rcirc-target (and rcirc-server-buffer (buffer-live-p rcirc-server-buffer) @@ -417,10 +480,29 @@ and set it if applicable." Test each configuration in `bug-reference-setup-from-irc-alist' and set it if applicable." (when (derived-mode-p 'erc-mode) - (bug-reference--maybe-setup-from-irc + (bug-reference-maybe-setup-from-irc (erc-format-target) (erc-network-name)))) +(defvar bug-reference-auto-setup-functions + (list #'bug-reference-try-setup-from-vc + #'bug-reference-try-setup-from-gnus + #'bug-reference-try-setup-from-rmail + #'bug-reference-try-setup-from-rcirc + #'bug-reference-try-setup-from-erc) + "Functions trying to auto-setup `bug-reference-mode'. +These functions are run after `bug-reference-mode' has been +activated in a buffer and try to guess suitable values for +`bug-reference-bug-regexp' and `bug-reference-url-format'. Their +guesswork is based on these variables: + +- `bug-reference-setup-from-vc-alist' for guessing based on + version control, e.g., URL of repository. +- `bug-reference-setup-from-mail-alist' for guessing based on + mail group names or mail header values. +- `bug-reference-setup-from-irc-alist' for guessing based on IRC + channel or network names.") + (defun bug-reference--run-auto-setup () (when (or bug-reference-mode bug-reference-prog-mode) @@ -431,19 +513,13 @@ and set it if applicable." (with-demoted-errors "Error during bug-reference auto-setup: %S" (catch 'setup - (dolist (f (list #'bug-reference-try-setup-from-vc - #'bug-reference-try-setup-from-gnus - #'bug-reference-try-setup-from-rcirc - #'bug-reference-try-setup-from-erc)) + (dolist (f bug-reference-auto-setup-functions) (when (funcall f) (throw 'setup t)))))))) ;;;###autoload (define-minor-mode bug-reference-mode "Toggle hyperlinking bug references in the buffer (Bug Reference mode)." - nil - "" - nil :after-hook (bug-reference--run-auto-setup) (if bug-reference-mode (jit-lock-register #'bug-reference-fontify) @@ -452,12 +528,21 @@ and set it if applicable." (widen) (bug-reference-unfontify (point-min) (point-max))))) +(defun bug-reference-mode-force-auto-setup () + "Enable `bug-reference-mode' and force auto-setup. +Enabling `bug-reference-mode' runs its auto-setup only if +`bug-reference-bug-regexp' and `bug-reference-url-format' are not +set already. This function sets the latter to `nil' +buffer-locally, so that the auto-setup will always run. + +This is mostly intended for MUA modes like `rmail-mode' where the +same buffer is re-used for different contexts." + (setq-local bug-reference-url-format nil) + (bug-reference-mode)) + ;;;###autoload (define-minor-mode bug-reference-prog-mode "Like `bug-reference-mode', but only buttonize in comments and strings." - nil - "" - nil :after-hook (bug-reference--run-auto-setup) (if bug-reference-prog-mode (jit-lock-register #'bug-reference-fontify) diff --git a/lisp/progmodes/cc-align.el b/lisp/progmodes/cc-align.el index d14ef1744af..9234d0b19b9 100644 --- a/lisp/progmodes/cc-align.el +++ b/lisp/progmodes/cc-align.el @@ -1,4 +1,4 @@ -;;; cc-align.el --- custom indentation functions for CC Mode +;;; cc-align.el --- custom indentation functions for CC Mode -*- lexical-binding: t -*- ;; Copyright (C) 1985, 1987, 1992-2021 Free Software Foundation, Inc. @@ -44,6 +44,9 @@ (cc-require 'cc-vars) (cc-require 'cc-engine) +(defvar c-syntactic-context) +(defvar c-syntactic-element) + ;; Standard line-up functions ;; @@ -274,8 +277,10 @@ statement-block-intro, statement-case-intro, arglist-intro." (save-excursion (beginning-of-line) (backward-up-list 1) + (forward-char) (skip-chars-forward " \t" (c-point 'eol)) - (vector (1+ (current-column))))) + (if (eolp) (skip-chars-backward " \t")) + (vector (current-column)))) (defun c-lineup-arglist-close-under-paren (langelem) "Line up a line under the enclosing open paren. @@ -1145,7 +1150,8 @@ Works with brace-list-intro." ; the line. (save-excursion ; "{" earlier on the line (goto-char (c-langelem-pos - (assq 'brace-list-intro c-syntactic-context))) + (assq 'brace-list-entry + c-syntactic-context))) (and (eq (c-backward-token-2 1 nil diff --git a/lisp/progmodes/cc-awk.el b/lisp/progmodes/cc-awk.el index 32289443725..334e82114fc 100644 --- a/lisp/progmodes/cc-awk.el +++ b/lisp/progmodes/cc-awk.el @@ -1,4 +1,4 @@ -;;; cc-awk.el --- AWK specific code within cc-mode. +;;; cc-awk.el --- AWK specific code within cc-mode. -*- lexical-binding: t -*- ;; Copyright (C) 1988, 1994, 1996, 2000-2021 Free Software Foundation, ;; Inc. @@ -1227,4 +1227,4 @@ comment at the start of cc-engine.el for more info." ;; indent-tabs-mode: t ;; tab-width: 8 ;; End: -;;; awk-mode.el ends here +;;; cc-awk.el ends here diff --git a/lisp/progmodes/cc-bytecomp.el b/lisp/progmodes/cc-bytecomp.el index 3f7caf3c2e9..edbac64eadb 100644 --- a/lisp/progmodes/cc-bytecomp.el +++ b/lisp/progmodes/cc-bytecomp.el @@ -1,4 +1,4 @@ -;;; cc-bytecomp.el --- compile time setup for proper compilation +;;; cc-bytecomp.el --- compile time setup for proper compilation -*- lexical-binding: t -*- ;; Copyright (C) 2000-2021 Free Software Foundation, Inc. @@ -85,8 +85,8 @@ (defvar cc-bytecomp-environment-set nil) -(defmacro cc-bytecomp-debug-msg (&rest args) - (ignore args) +(defmacro cc-bytecomp-debug-msg (&rest _args) ; Change to ARGS when needed. + ;; (declare (debug t)) ;;`(message ,@args) ) @@ -97,6 +97,8 @@ ;; compilation can trigger loading (various `require' type forms) ;; and loading can trigger compilation (the package manager does ;; this). We walk the lisp stack if necessary. + ;; Never native compile to allow cc-defs.el:2345 hack. + (declare (speed -1)) (cond ((and load-in-progress (boundp 'byte-compile-dest-file) @@ -108,14 +110,15 @@ (memq (cadr elt) '(load require byte-compile-file byte-recompile-directory - batch-byte-compile))))) + batch-byte-compile batch-native-compile))))) (setq n (1+ n))) (cond ((memq (cadr elt) '(load require)) 'loading) ((memq (cadr elt) '(byte-compile-file byte-recompile-directory - batch-byte-compile)) + batch-byte-compile + batch-native-compile)) 'compiling) (t ; Can't happen. (message "cc-bytecomp-compiling-or-loading: System flags spuriously set") @@ -284,7 +287,9 @@ perhaps a `cc-bytecomp-restore-environment' is forgotten somewhere")) (cons cc-file cc-bytecomp-loaded-files)) (cc-bytecomp-debug-msg "cc-bytecomp-load: Loading %S" cc-file) - (load cc-file nil t t) + ;; native-comp may async compile also intalled el.gz + ;; files therefore we may have to load here other el.gz. + (load cc-part nil t) (cc-bytecomp-debug-msg "cc-bytecomp-load: Loaded %S" cc-file))) (cc-bytecomp-setup-environment) @@ -297,6 +302,7 @@ during compilation, but compile in a `require'. Don't use within Having cyclic cc-require's will result in infinite recursion. That's somewhat intentional." + (declare (debug t)) `(progn (eval-when-compile (cc-bytecomp-load (symbol-name ,cc-part))) @@ -309,6 +315,7 @@ time, (ii) generate code to load the file at load time. CC-PART will normally be a quoted name such as \\='cc-fix. CONDITION should not be quoted." + (declare (debug t)) (if (eval condition) (progn (cc-bytecomp-load (symbol-name (eval cc-part))) @@ -323,6 +330,7 @@ after the loading of FILE. CC-PART will normally be a quoted name such as \\='cc-fix. FILE should be a string. CONDITION should not be quoted." + (declare (debug t)) (if (eval condition) (progn (cc-bytecomp-load (symbol-name (eval cc-part))) @@ -333,6 +341,7 @@ should be a string. CONDITION should not be quoted." (defmacro cc-provide (feature) "A replacement for the `provide' form that restores the environment after the compilation. Don't use within `eval-when-compile'." + (declare (debug t)) `(progn (eval-when-compile (cc-bytecomp-restore-environment)) (provide ,feature))) @@ -344,6 +353,7 @@ during compilation. Don't use outside `eval-when-compile' or Having cyclic cc-load's will result in infinite recursion. That's somewhat intentional." + (declare (debug t)) `(or (and (featurep 'cc-bytecomp) (cc-bytecomp-load ,cc-part)) (load ,cc-part nil t nil))) @@ -352,6 +362,7 @@ somewhat intentional." "Force loading of the corresponding .el file in the current directory during compilation, but do a compile time `require' otherwise. Don't use within `eval-when-compile'." + (declare (debug t)) `(eval-when-compile (if (and (fboundp 'cc-bytecomp-is-compiling) (cc-bytecomp-is-compiling)) @@ -363,6 +374,7 @@ use within `eval-when-compile'." "Do a `require' of an external package. This restores and sets up the compilation environment before and afterwards. Don't use within `eval-when-compile'." + (declare (debug t)) `(progn (eval-when-compile (cc-bytecomp-restore-environment)) (require ,feature) @@ -371,6 +383,7 @@ afterwards. Don't use within `eval-when-compile'." (defmacro cc-bytecomp-defvar (var) "Binds the symbol as a variable during compilation of the file, to silence the byte compiler. Don't use within `eval-when-compile'." + (declare (debug nil)) `(eval-when-compile (if (boundp ',var) (cc-bytecomp-debug-msg @@ -398,6 +411,7 @@ definition. That means that this macro will not shut up warnings about incorrect number of arguments. It's dangerous to try to replace existing functions since the byte compiler might need the definition at compile time, e.g. for macros and inline functions." + (declare (debug nil)) `(eval-when-compile (if (fboundp ',fun) (cc-bytecomp-debug-msg @@ -419,6 +433,7 @@ at compile time, e.g. for macros and inline functions." (defmacro cc-bytecomp-put (symbol propname value) "Set a property on a symbol during compilation (and evaluation) of the file. Don't use outside `eval-when-compile'." + (declare (debug t)) `(eval-when-compile (if (not (assoc (cons ,symbol ,propname) cc-bytecomp-original-properties)) (progn @@ -439,6 +454,7 @@ the file. Don't use outside `eval-when-compile'." the compilation. This is the same as using `boundp' but additionally exclude any variables that have been bound during compilation with `cc-bytecomp-defvar'." + (declare (debug t)) (if (and (cc-bytecomp-is-compiling) (memq (car (cdr symbol)) cc-bytecomp-unbound-variables)) nil @@ -449,6 +465,7 @@ exclude any variables that have been bound during compilation with the compilation. This is the same as using `fboundp' but additionally exclude any functions that have been bound during compilation with `cc-bytecomp-defun'." + (declare (debug t)) (let (fun-elem) (if (and (cc-bytecomp-is-compiling) (setq fun-elem (assq (car (cdr symbol)) diff --git a/lisp/progmodes/cc-cmds.el b/lisp/progmodes/cc-cmds.el index 33a03602070..bdfdf178d43 100644 --- a/lisp/progmodes/cc-cmds.el +++ b/lisp/progmodes/cc-cmds.el @@ -1,4 +1,4 @@ -;;; cc-cmds.el --- user level commands for CC Mode +;;; cc-cmds.el --- user level commands for CC Mode -*- lexical-binding: t -*- ;; Copyright (C) 1985, 1987, 1992-2021 Free Software Foundation, Inc. @@ -49,12 +49,11 @@ ; which looks at this. (cc-bytecomp-defun electric-pair-post-self-insert-function) (cc-bytecomp-defvar c-indent-to-body-directives) +(defvar c-syntactic-context) ;; Indentation / Display syntax functions (defvar c-fix-backslashes t) -(defvar c-syntactic-context) - (defun c-indent-line (&optional syntax quiet ignore-point-pos) "Indent the current line according to the syntactic context, if `c-syntactic-indentation' is non-nil. Optional SYNTAX is the @@ -1220,9 +1219,9 @@ numeric argument is supplied, or the point is inside a literal." (self-insert-command (prefix-numeric-value arg))) (setq final-pos (point)) -;;;; 2010-01-31: There used to be code here to put a syntax-table text -;;;; property on the new < or > and its mate (if any) when they are template -;;;; parens. This is now done in an after-change function. +;;;; 2010-01-31: There used to be code here to put a syntax-table text +;;;; property on the new < or > and its mate (if any) when they are template +;;;; parens. This is now done in an after-change function. (when (and (not arg) (not literal)) ;; Have we got a delimiter on a #include directive? @@ -1639,8 +1638,8 @@ No indentation or other \"electric\" behavior is performed." ;; ;; This function might do hidden buffer changes. (save-excursion - (let* (kluge-start - decl-result brace-decl-p + (let* (knr-start knr-res + decl-result (start (point)) (paren-state (c-parse-state)) (least-enclosing (c-least-enclosing-brace paren-state))) @@ -1670,63 +1669,54 @@ No indentation or other \"electric\" behavior is performed." (not (looking-at c-defun-type-name-decl-key)))))) 'at-function-end) (t - ;; Find the start of the current declaration. NOTE: If we're in the - ;; variables after a "struct/eval" type block, we don't get to the - ;; real declaration here - we detect and correct for this later. - - ;;If we're in the parameters' parens, move back out of them. - (if least-enclosing (goto-char least-enclosing)) ;; Kluge so that c-beginning-of-decl-1 won't go back if we're already ;; at a declaration. (if (or (and (eolp) (not (eobp))) ; EOL is matched by "\\s>" - (not (looking-at -"\\([;#]\\|\\'\\|\\s(\\|\\s)\\|\\s\"\\|\\s\\\\|\\s$\\|\\s<\\|\\s>\\|\\s!\\)"))) + (not (c-looking-at-non-alphnumspace))) (forward-char)) - (setq kluge-start (point)) - ;; First approximation as to whether the current "header" we're in is - ;; one followed by braces. - (setq brace-decl-p - (save-excursion - (and (c-syntactic-re-search-forward "[;{]" nil t t) - (or (eq (char-before) ?\{) - (and c-recognize-knr-p - ;; Might have stopped on the - ;; ';' in a K&R argdecl. In - ;; that case the declaration - ;; should contain a block. - (c-in-knr-argdecl)))))) - (setq decl-result - (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? - (if (or (eq decl-result 'label) - (looking-at c-protection-key)) - (setq brace-decl-p nil)) - (cond - ((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 - (if (eq (point) start) - 'at-header + (if (and least-enclosing + (eq (char-after least-enclosing) ?\()) + (c-go-list-forward least-enclosing)) + (c-forward-syntactic-ws) + (setq knr-start (point)) + (if (and (c-syntactic-re-search-forward "[;{]" nil t t) + (eq (char-before) ?\{)) + (progn + (backward-char) + (cond + ((or (progn + (c-backward-syntactic-ws) + (<= (point) start)) + (and c-recognize-knr-p + (and (setq knr-res (c-in-knr-argdecl)) + (<= knr-res knr-start)))) 'in-header) - 'outwith-function)) - ((eq decl-result 'previous) - (if (and (not brace-decl-p) - (c-in-function-trailer-p)) - 'at-function-end - 'outwith-function)) - (t (error - "c-where-wrt-brace-construct: c-beginning-of-decl-1 returned %s" - decl-result)))))))) + ((and knr-res + (goto-char knr-res) + (c-backward-syntactic-ws))) ; Always returns nil. + (t + (when (eq (char-before) ?\)) + ;; The `c-go-list-backward' is a precaution against + ;; `c-beginning-of-decl-1' spuriously finding a C++ lambda + ;; function inside the parentheses. + (c-go-list-backward)) + (setq decl-result + (car (c-beginning-of-decl-1 + (and least-enclosing + (c-safe-position + least-enclosing paren-state))))) + (cond + ((> (point) start) + 'outwith-function) + ((eq decl-result 'same) + (if (eq (point) start) + 'at-header + 'in-header)) + (t (error + "c-where-wrt-brace-construct: c-beginning-of-decl-1 returned %s" + decl-result)))))) + 'outwith-function)))))) (defun c-backward-to-nth-BOF-{ (n where) ;; Skip to the opening brace of the Nth function before point. If @@ -1749,9 +1739,11 @@ No indentation or other \"electric\" behavior is performed." (goto-char (c-least-enclosing-brace (c-parse-state))) (setq n (1- n))) ((eq where 'in-header) - (c-syntactic-re-search-forward "{") - (backward-char) - (setq n (1- n))) + (let ((encl-paren (c-least-enclosing-brace (c-parse-state)))) + (if encl-paren (goto-char encl-paren)) + (c-syntactic-re-search-forward "{" nil t t) + (backward-char) + (setq n (1- n)))) ((memq where '(at-header outwith-function at-function-end in-trailer)) (c-syntactic-skip-backward "^}") (when (eq (char-before) ?\}) @@ -1832,15 +1824,18 @@ No indentation or other \"electric\" behavior is performed." nil))) (eval-and-compile - (defmacro c-while-widening-to-decl-block (condition) + (defmacro c-while-widening-to-decl-block (condition &optional no-where) ;; Repeatedly evaluate CONDITION until it returns nil. After each ;; evaluation, if `c-defun-tactic' is set appropriately, widen to innards ;; of the next enclosing declaration block (e.g. namespace, class), or the ;; buffer's original restriction. ;; + ;; If NO-WHERE is non-nil, don't compile in a `(setq where ....)'. + ;; ;; This is a very special purpose macro, which assumes the existence of ;; several variables. It is for use only in c-beginning-of-defun and ;; c-end-of-defun. + (declare (debug t)) `(while (and ,condition (eq c-defun-tactic 'go-outward) @@ -1848,7 +1843,8 @@ No indentation or other \"electric\" behavior is performed." (setq paren-state (c-whack-state-after lim paren-state)) (setq lim (c-widen-to-enclosing-decl-scope paren-state orig-point-min orig-point-max)) - (setq where 'in-block)))) + ,@(if (not no-where) + `((setq where 'in-block)))))) (def-edebug-spec c-while-widening-to-decl-block t) @@ -1965,21 +1961,24 @@ defun." ;; The actual movement is done below. (setq n (1- n))) ((memq where '(at-function-end outwith-function at-header in-header)) - (when (c-syntactic-re-search-forward "{" nil 'eob) + (if (eq where 'in-header) + (let ((pos (c-least-enclosing-brace (c-parse-state)))) + (if pos (c-go-list-forward pos)))) + (when (c-syntactic-re-search-forward "{" nil 'eob t) (backward-char) (forward-sexp) (setq n (1- n)))) (t (error "c-forward-to-nth-EOF-\\;-or-}: `where' is %s" where))) - (when (c-in-function-trailer-p) - (c-syntactic-re-search-forward ";" nil 'eob t)) - ;; Each time round the loop, go forward to a "}" at the outermost level. (while (and (> n 0) (not (eobp))) (when (c-syntactic-re-search-forward "{" nil 'eob) (backward-char) (forward-sexp) (setq n (1- n)))) + + (when (c-in-function-trailer-p) + (c-syntactic-re-search-forward ";" nil 'eob t)) n) (defun c-end-of-defun (&optional arg) @@ -2326,11 +2325,11 @@ with a brace block, at the outermost level of nesting." (c-save-buffer-state ((paren-state (c-parse-state)) (orig-point-min (point-min)) (orig-point-max (point-max)) - lim name limits where) + lim name limits) (setq lim (c-widen-to-enclosing-decl-scope paren-state orig-point-min orig-point-max)) (and lim (setq lim (1- lim))) - (c-while-widening-to-decl-block (not (setq name (c-defun-name-1)))) + (c-while-widening-to-decl-block (not (setq name (c-defun-name-1))) t) (when name (setq limits (c-declaration-limits-1 near)) (cons name limits))) @@ -2946,10 +2945,13 @@ function does not require the declaration to contain a brace block." (c-looking-at-special-brace-list))) (or allow-early-stop (/= here last)) (save-excursion ; Is this a check that we're NOT at top level? -;;;; NO! This seems to check that (i) EITHER we're at the top level; OR (ii) The next enclosing -;;;; level of bracketing is a '{'. HMM. Doesn't seem to make sense. -;;;; 2003/8/8 This might have something to do with the GCC extension "Statement Expressions", e.g. -;;;; while ({stmt1 ; stmt2 ; exp ;}). This form excludes such Statement Expressions. +;;;; NO! This seems to check that (i) EITHER we're at the top level; +;;;; OR (ii) The next enclosing level of bracketing is a '{'. HMM. +;;;; Doesn't seem to make sense. +;;;; 2003/8/8 This might have something to do with the GCC extension +;;;; "Statement Expressions", e.g. +;;;; while ({stmt1 ; stmt2 ; exp ;}). +;;;; This form excludes such Statement Expressions. (or (not (c-safe (up-list -1) t)) (= (char-after) ?{)))) (goto-char last) diff --git a/lisp/progmodes/cc-defs.el b/lisp/progmodes/cc-defs.el index 38fe23b0eaf..01bd64cb5c3 100644 --- a/lisp/progmodes/cc-defs.el +++ b/lisp/progmodes/cc-defs.el @@ -1,4 +1,4 @@ -;;; cc-defs.el --- compile time definitions for CC Mode +;;; cc-defs.el --- compile time definitions for CC Mode -*- lexical-binding: t -*- ;; Copyright (C) 1985, 1987, 1992-2021 Free Software Foundation, Inc. @@ -125,7 +125,7 @@ The result of the body appears to the compiler as a quoted constant. This variant works around bugs in `eval-when-compile' in various \(X)Emacs versions. See cc-defs.el for details." - + (declare (indent 0) (debug t)) (if c-inside-eval-when-compile ;; XEmacs 21.4.6 has a bug in `eval-when-compile' in that it ;; evaluates its body at macro expansion time if it's nested @@ -170,17 +170,20 @@ This variant works around bugs in `eval-when-compile' in various ;; constant that we eval. That otoh introduce a problem in ;; that a returned lambda expression doesn't get byte ;; compiled (even if `function' is used). - (eval '(let ((c-inside-eval-when-compile t)) ,@body))))) - - (put 'cc-eval-when-compile 'lisp-indent-hook 0)) + (eval '(let ((c-inside-eval-when-compile t)) ,@body)))))) ;;; Macros. +(or (fboundp 'cadar) (defsubst cadar (elt) (car (cdar elt)))) +(or (fboundp 'caddr) (defsubst caddr (elt) (car (cddr elt)))) +(or (fboundp 'cdddr) (defsubst cdddr (elt) (cdr (cddr elt)))) + (defmacro c--mapcan (fun liszt) ;; CC Mode equivalent of `mapcan' which bridges the difference ;; between the host [X]Emacsen." ;; The motivation for this macro is to avoid the irritating message ;; "function `mapcan' from cl package called at runtime" produced by Emacs. + (declare (debug t)) (cond ((and (fboundp 'mapcan) (subrp (symbol-function 'mapcan))) @@ -196,18 +199,21 @@ This variant works around bugs in `eval-when-compile' in various (defmacro c--set-difference (liszt1 liszt2 &rest other-args) ;; Macro to smooth out the renaming of `set-difference' in Emacs 24.3. + (declare (debug (form form &rest [symbolp form]))) (if (eq c--cl-library 'cl-lib) `(cl-set-difference ,liszt1 ,liszt2 ,@other-args) `(set-difference ,liszt1 ,liszt2 ,@other-args))) (defmacro c--intersection (liszt1 liszt2 &rest other-args) ;; Macro to smooth out the renaming of `intersection' in Emacs 24.3. + (declare (debug (form form &rest [symbolp form]))) (if (eq c--cl-library 'cl-lib) `(cl-intersection ,liszt1 ,liszt2 ,@other-args) `(intersection ,liszt1 ,liszt2 ,@other-args))) (eval-and-compile (defmacro c--macroexpand-all (form &optional environment) + (declare (debug t)) ;; Macro to smooth out the renaming of `cl-macroexpand-all' in Emacs 24.3. (if (fboundp 'macroexpand-all) `(macroexpand-all ,form ,environment) @@ -215,6 +221,7 @@ This variant works around bugs in `eval-when-compile' in various (defmacro c--delete-duplicates (cl-seq &rest cl-keys) ;; Macro to smooth out the renaming of `delete-duplicates' in Emacs 24.3. + (declare (debug (form &rest [symbolp form]))) (if (eq c--cl-library 'cl-lib) `(cl-delete-duplicates ,cl-seq ,@cl-keys) `(delete-duplicates ,cl-seq ,@cl-keys)))) @@ -222,6 +229,7 @@ This variant works around bugs in `eval-when-compile' in various (defmacro c-font-lock-flush (beg end) "Declare the region BEG...END's fontification as out-of-date. On XEmacs and older Emacsen, this refontifies that region immediately." + (declare (debug t)) (if (fboundp 'font-lock-flush) `(font-lock-flush ,beg ,end) `(font-lock-fontify-region ,beg ,end))) @@ -232,6 +240,7 @@ The current point is used if POINT isn't specified. POSITION can be one of the following symbols: `bol' -- beginning of line +`boll' -- beginning of logical line (i.e. without preceding escaped NL) `eol' -- end of line `eoll' -- end of logical line (i.e. without escaped NL) `bod' -- beginning of defun @@ -249,6 +258,7 @@ one of the following symbols: If the referenced position doesn't exist, the closest accessible point to it is returned. This function does not modify the point or the mark." + (declare (debug t)) (if (eq (car-safe position) 'quote) (let ((position (eval position))) (cond @@ -261,6 +271,15 @@ to it is returned. This function does not modify the point or the mark." (beginning-of-line) (point)))) + ((eq position 'boll) + `(save-excursion + ,@(if point `((goto-char ,point))) + (while (progn (beginning-of-line) + (when (not (bobp)) + (eq (char-before (1- (point))) ?\\))) + (backward-char)) + (point))) + ((eq position 'eol) (if (and (cc-bytecomp-fboundp 'line-end-position) (not point)) '(line-end-position) @@ -417,6 +436,7 @@ to it is returned. This function does not modify the point or the mark." (defmacro c-is-escaped (pos) ;; Are there an odd number of backslashes before POS? + (declare (debug t)) `(save-excursion (goto-char ,pos) (not (zerop (logand (skip-chars-backward "\\\\") 1))))) @@ -424,6 +444,7 @@ to it is returned. This function does not modify the point or the mark." (defmacro c-will-be-escaped (pos beg end) ;; Will the character after POS be escaped after the removal of (BEG END)? ;; It is assumed that (>= POS END). + (declare (debug t)) `(save-excursion (let ((-end- ,end) count) @@ -436,6 +457,7 @@ to it is returned. This function does not modify the point or the mark." (defmacro c-will-be-unescaped (beg) ;; Would the character after BEG be unescaped? + (declare (debug t)) `(save-excursion (let (count) (goto-char ,beg) @@ -446,6 +468,7 @@ to it is returned. This function does not modify the point or the mark." (defmacro c-next-single-property-change (position prop &optional object limit) ;; See the doc string for either of the defuns expanded to. + (declare (debug t)) (if (and c-use-extents (fboundp 'next-single-char-property-change)) ;; XEmacs >= 2005-01-25 @@ -455,6 +478,7 @@ to it is returned. This function does not modify the point or the mark." (defmacro c-previous-single-property-change (position prop &optional object limit) ;; See the doc string for either of the defuns expanded to. + (declare (debug t)) (if (and c-use-extents (fboundp 'previous-single-char-property-change)) ;; XEmacs >= 2005-01-25 @@ -474,6 +498,7 @@ to it is returned. This function does not modify the point or the mark." (defmacro c-set-region-active (activate) ;; Activate the region if ACTIVE is non-nil, deactivate it ;; otherwise. Covers the differences between Emacs and XEmacs. + (declare (debug t)) (if (fboundp 'zmacs-activate-region) ;; XEmacs. `(if ,activate @@ -483,6 +508,7 @@ to it is returned. This function does not modify the point or the mark." `(setq mark-active ,activate))) (defmacro c-set-keymap-parent (map parent) + (declare (debug t)) (cond ;; XEmacs ((cc-bytecomp-fboundp 'set-keymap-parents) @@ -495,6 +521,7 @@ to it is returned. This function does not modify the point or the mark." (defmacro c-delete-and-extract-region (start end) "Delete the text between START and END and return it." + (declare (debug t)) (if (cc-bytecomp-fboundp 'delete-and-extract-region) ;; Emacs 21.1 and later `(delete-and-extract-region ,start ,end) @@ -505,15 +532,16 @@ to it is returned. This function does not modify the point or the mark." (defmacro c-safe (&rest body) ;; safely execute BODY, return nil if an error occurred + (declare (indent 0) (debug t)) `(condition-case nil (progn ,@body) (error nil))) -(put 'c-safe 'lisp-indent-function 0) (defmacro c-int-to-char (integer) ;; In Emacs, a character is an integer. In XEmacs, a character is a ;; type distinct from an integer. Sometimes we need to convert integers to ;; characters. `c-int-to-char' makes this conversion, if necessary. + (declare (debug t)) (if (fboundp 'int-to-char) `(int-to-char ,integer) integer)) @@ -521,6 +549,7 @@ to it is returned. This function does not modify the point or the mark." (defmacro c-characterp (arg) ;; Return t when ARG is a character (XEmacs) or integer (Emacs), otherwise ;; return nil. + (declare (debug t)) (if (integerp ?c) `(integerp ,arg) `(characterp ,arg))) @@ -567,6 +596,7 @@ to it is returned. This function does not modify the point or the mark." ;; string opener, or after the introductory R of one. The match data is ;; overwritten. On success the opener's identifier will be (match-string ;; 1). Text properties on any characters are ignored. + (declare (debug t)) (if pos `(save-excursion (goto-char ,pos) @@ -599,7 +629,7 @@ must not be within a `c-save-buffer-state', since the user then wouldn't be able to undo them. The return value is the value of the last form in BODY." - (declare (debug t) (indent 1)) + (declare (debug let*) (indent 1)) (if (fboundp 'with-silent-modifications) `(with-silent-modifications (let* ,varlist ,@body)) `(let* ((modified (buffer-modified-p)) (buffer-undo-list t) @@ -628,6 +658,7 @@ If BODY makes a change that unconditionally is undone then wrap this macro inside `c-save-buffer-state'. That way the change can be done even when the buffer is read-only, and without interference from various buffer change hooks." + (declare (indent 0) (debug t)) `(let (-tnt-chng-keep -tnt-chng-state) (unwind-protect @@ -638,7 +669,6 @@ various buffer change hooks." -tnt-chng-state (c-tnt-chng-record-state) -tnt-chng-keep (progn ,@body)) (c-tnt-chng-cleanup -tnt-chng-keep -tnt-chng-state)))) -(put 'c-tentative-buffer-changes 'lisp-indent-function 0) (defun c-tnt-chng-record-state () ;; Used internally in `c-tentative-buffer-changes'. @@ -691,14 +721,17 @@ whitespace. LIMIT sets an upper limit of the forward movement, if specified. If LIMIT or the end of the buffer is reached inside a comment or -preprocessor directive, the point will be left there. +preprocessor directive, the point will be left there. If point starts +on the wrong side of LIMIT, it stays unchanged. Note that this function might do hidden buffer changes. See the comment at the start of cc-engine.el for more info." + (declare (debug t)) (if limit - `(save-restriction - (narrow-to-region (point-min) (or ,limit (point-max))) - (c-forward-sws)) + `(when (< (point) (or ,limit (point-max))) + (save-restriction + (narrow-to-region (point-min) (or ,limit (point-max))) + (c-forward-sws))) '(c-forward-sws))) (defmacro c-backward-syntactic-ws (&optional limit) @@ -710,14 +743,17 @@ whitespace. LIMIT sets a lower limit of the backward movement, if specified. If LIMIT is reached inside a line comment or preprocessor directive then -the point is moved into it past the whitespace at the end. +the point is moved into it past the whitespace at the end. If point +starts on the wrong side of LIMIT, it stays unchanged. Note that this function might do hidden buffer changes. See the comment at the start of cc-engine.el for more info." + (declare (debug t)) (if limit - `(save-restriction - (narrow-to-region (or ,limit (point-min)) (point-max)) - (c-backward-sws)) + `(when (> (point) (or ,limit (point-min))) + (save-restriction + (narrow-to-region (or ,limit (point-min)) (point-max)) + (c-backward-sws))) '(c-backward-sws))) (defmacro c-forward-sexp (&optional count) @@ -729,11 +765,13 @@ This is like `forward-sexp' except that it isn't interactive and does not do any user friendly adjustments of the point and that it isn't susceptible to user configurations such as disabling of signals in certain situations." + (declare (debug t)) (or count (setq count 1)) `(goto-char (scan-sexps (point) ,count))) (defmacro c-backward-sexp (&optional count) "See `c-forward-sexp' and reverse directions." + (declare (debug t)) (or count (setq count 1)) `(c-forward-sexp ,(if (numberp count) (- count) `(- ,count)))) @@ -743,6 +781,7 @@ for unbalanced parens. A limit for the search may be given. FROM is assumed to be on the right side of it." + (declare (debug t)) (let ((res (if (featurep 'xemacs) `(scan-lists ,from ,count ,depth nil t) `(c-safe (scan-lists ,from ,count ,depth))))) @@ -770,6 +809,7 @@ leave point unmoved. A LIMIT for the search may be given. The start position is assumed to be before it." + (declare (debug t)) `(let ((dest (c-safe-scan-lists ,(or pos '(point)) 1 0 ,limit))) (when dest (goto-char dest) dest))) @@ -780,6 +820,7 @@ leave point unmoved. A LIMIT for the search may be given. The start position is assumed to be after it." + (declare (debug t)) `(let ((dest (c-safe-scan-lists ,(or pos '(point)) -1 0 ,limit))) (when dest (goto-char dest) dest))) @@ -789,6 +830,7 @@ or nil if no such position exists. The point is used if POS is left out. A limit for the search may be given. The start position is assumed to be before it." + (declare (debug t)) `(c-safe-scan-lists ,(or pos '(point)) 1 1 ,limit)) (defmacro c-up-list-backward (&optional pos limit) @@ -797,6 +839,7 @@ or nil if no such position exists. The point is used if POS is left out. A limit for the search may be given. The start position is assumed to be after it." + (declare (debug t)) `(c-safe-scan-lists ,(or pos '(point)) -1 1 ,limit)) (defmacro c-down-list-forward (&optional pos limit) @@ -805,6 +848,7 @@ or nil if no such position exists. The point is used if POS is left out. A limit for the search may be given. The start position is assumed to be before it." + (declare (debug t)) `(c-safe-scan-lists ,(or pos '(point)) 1 -1 ,limit)) (defmacro c-down-list-backward (&optional pos limit) @@ -813,6 +857,7 @@ or nil if no such position exists. The point is used if POS is left out. A limit for the search may be given. The start position is assumed to be after it." + (declare (debug t)) `(c-safe-scan-lists ,(or pos '(point)) -1 -1 ,limit)) (defmacro c-go-up-list-forward (&optional pos limit) @@ -822,6 +867,7 @@ position exists, otherwise nil is returned and the point isn't moved. A limit for the search may be given. The start position is assumed to be before it." + (declare (debug t)) `(let ((dest (c-up-list-forward ,pos ,limit))) (when dest (goto-char dest) t))) @@ -832,6 +878,7 @@ position exists, otherwise nil is returned and the point isn't moved. A limit for the search may be given. The start position is assumed to be after it." + (declare (debug t)) `(let ((dest (c-up-list-backward ,pos ,limit))) (when dest (goto-char dest) t))) @@ -842,6 +889,7 @@ exists, otherwise nil is returned and the point isn't moved. A limit for the search may be given. The start position is assumed to be before it." + (declare (debug t)) `(let ((dest (c-down-list-forward ,pos ,limit))) (when dest (goto-char dest) t))) @@ -852,6 +900,7 @@ exists, otherwise nil is returned and the point isn't moved. A limit for the search may be given. The start position is assumed to be after it." + (declare (debug t)) `(let ((dest (c-down-list-backward ,pos ,limit))) (when dest (goto-char dest) t))) @@ -963,6 +1012,7 @@ be after it." ;; point)? Always returns nil for languages which don't have Virtual ;; semicolons. ;; This macro might do hidden buffer changes. + (declare (debug t)) `(if c-at-vsemi-p-fn (funcall c-at-vsemi-p-fn ,@(if pos `(,pos))))) @@ -980,6 +1030,7 @@ be after it." (defmacro c-benign-error (format &rest args) ;; Formats an error message for the echo area and dings, i.e. like ;; `error' but doesn't abort. + (declare (debug t)) `(progn (message ,format ,@args) (ding))) @@ -989,18 +1040,19 @@ be after it." ;; 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'. !!!! + (declare (indent 1) (debug t)) `(let ((c-with-syntax-table-orig-table (syntax-table))) (unwind-protect (progn (set-syntax-table ,table) ,@code) (set-syntax-table c-with-syntax-table-orig-table)))) -(put 'c-with-syntax-table 'lisp-indent-function 1) (defmacro c-skip-ws-forward (&optional limit) "Skip over any whitespace following point. This function skips over horizontal and vertical whitespace and line continuations." + (declare (debug t)) (if limit `(let ((limit (or ,limit (point-max)))) (while (progn @@ -1022,6 +1074,7 @@ continuations." "Skip over any whitespace preceding point. This function skips over horizontal and vertical whitespace and line continuations." + (declare (debug t)) (if limit `(let ((limit (or ,limit (point-min)))) (while (progn @@ -1044,6 +1097,7 @@ continuations." "Return non-nil if the current CC Mode major mode is MODE. MODE is either a mode symbol or a list of mode symbols." + (declare (debug t)) (if c-langs-are-parametric ;; Inside a `c-lang-defconst'. `(c-lang-major-mode-is ,mode) @@ -1126,6 +1180,7 @@ MODE is either a mode symbol or a list of mode symbols." ;; 21) then it's assumed that the property is present on it. ;; ;; This macro does a hidden buffer change. + (declare (debug t)) (setq property (eval property)) (if (or c-use-extents (not (cc-bytecomp-boundp 'text-property-default-nonsticky))) @@ -1143,6 +1198,7 @@ MODE is either a mode symbol or a list of mode symbols." ;; Get the value of the given property on the character at POS if ;; it's been put there by `c-put-char-property'. PROPERTY is ;; assumed to be constant. + (declare (debug t)) (setq property (eval property)) (if c-use-extents ;; XEmacs. @@ -1173,6 +1229,7 @@ MODE is either a mode symbol or a list of mode symbols." ;; constant. ;; ;; This macro does a hidden buffer change. + (declare (debug t)) (setq property (eval property)) (cond (c-use-extents ;; XEmacs. @@ -1195,6 +1252,7 @@ MODE is either a mode symbol or a list of mode symbols." ;; Return the first position in the range [FROM to) where the text property ;; PROPERTY is set, or `most-positive-fixnum' if there is no such position. ;; PROPERTY should be a quoted constant. + (declare (debug t)) `(let ((-from- ,from) (-to- ,to) pos) (cond ((and (< -from- -to-) @@ -1210,31 +1268,44 @@ MODE is either a mode symbol or a list of mode symbols." ;; region that has been put with `c-put-char-property'. PROPERTY is ;; assumed to be constant. ;; + ;; The returned value is the buffer position of the lowest character + ;; whose PROPERTY was removed, or nil if there was none. + ;; ;; Note that this function does not clean up the property from the ;; lists of the `rear-nonsticky' properties in the region, if such ;; are used. Thus it should not be used for common properties like ;; `syntax-table'. ;; ;; This macro does hidden buffer changes. + (declare (debug t)) (setq property (eval property)) - (if c-use-extents - ;; XEmacs. - `(map-extents (lambda (ext ignored) - (delete-extent ext)) - nil ,from ,to nil nil ',property) - ;; Emacs. - (if (and (fboundp 'syntax-ppss) - (eq `,property 'syntax-table)) - `(let ((-from- ,from) (-to- ,to)) - (setq c-syntax-table-hwm - (min c-syntax-table-hwm - (c-min-property-position -from- -to- ',property))) - (remove-text-properties -from- -to- '(,property nil))) - `(remove-text-properties ,from ,to '(,property nil))))) + `(let* ((-to- ,to) + (ret (c-min-property-position ,from -to- ',property))) + (if (< ret -to-) + (progn + ,(cond + (c-use-extents + ;; XEmacs + `(map-extents (lambda (ext ignored) + (delete-extent ext)) + nil ret -to- nil nil ',property)) + ((and (fboundp 'syntax-ppss) + (eq property 'syntax-table)) + ;; Emacs 'syntax-table + `(progn + (setq c-syntax-table-hwm + (min c-syntax-table-hwm ret)) + (remove-text-properties ret -to- '(,property nil)))) + (t + ;; Emacs other property. + `(remove-text-properties ret -to- '(,property nil)))) + ret) + nil))) (defmacro c-clear-syn-tab-properties (from to) ;; Remove all occurrences of the `syntax-table' and `c-fl-syn-tab' text ;; properties between FROM and TO. + (declare (debug t)) `(let ((-from- ,from) (-to- ,to)) (when (and c-min-syn-tab-mkr c-max-syn-tab-mkr @@ -1256,6 +1327,7 @@ LIMIT bounds the search. The comparison is done with `equal'. Leave point just after the character, and set the match data on this character, and return point. If VALUE isn't found, Return nil; point is then left undefined." + (declare (debug t)) `(let ((place (point))) (while (and @@ -1275,6 +1347,7 @@ LIMIT bounds the search. The comparison is done with `equal'. Leave point just before the character, set the match data on this character, and return point. If VALUE isn't found, Return nil; point is then left undefined." + (declare (debug t)) `(let ((place (point))) (while (and @@ -1318,6 +1391,7 @@ been put there by c-put-char-property. POINT remains unchanged." which have the value VALUE, as tested by `equal'. These properties are assumed to be over individual characters, having been put there by c-put-char-property. POINT remains unchanged." + (declare (debug t)) (if c-use-extents ;; XEmacs `(let ((-property- ,property)) @@ -1338,6 +1412,7 @@ PROPERTY must be a constant. Leave point just after the character, and set the match data on this character, and return point. If the search fails, return nil; point is then left undefined." + (declare (debug t)) `(let ((char-skip (concat "^" (char-to-string ,char))) (-limit- (or ,limit (point-max))) (-value- ,value)) @@ -1361,6 +1436,7 @@ PROPERTY must be a constant. Leave point just before the character, and set the match data on this character, and return point. If the search fails, return nil; point is then left undefined." + (declare (debug t)) `(let ((char-skip (concat "^" (char-to-string ,char))) (-limit- (or ,limit (point-min))) (-value- ,value)) @@ -1384,6 +1460,7 @@ PROPERTY must be a constant. Leave point just after the character, and set the match data on this character, and return point. If the search fails, return nil; point is then left undefined." + (declare (debug t)) `(let ((char-skip (concat "^" (char-to-string ,char))) (-limit- (or ,limit (point-max))) (-value- ,value)) @@ -1432,6 +1509,7 @@ by `equal'. These properties are assumed to be over individual characters, having been put there by c-put-char-property. POINT remains unchanged. Return the position of the first removed property, or nil." + (declare (debug t)) (if c-use-extents ;; XEmacs `(let ((-property- ,property) @@ -1455,6 +1533,7 @@ property, or nil." ;; `c-put-char-property' must be a constant. "Put the text property PROPERTY with value VALUE on characters with value CHAR in the region [FROM to)." + (declare (debug t)) `(let ((skip-string (concat "^" (list ,char))) (-to- ,to)) (save-excursion @@ -1477,6 +1556,7 @@ with value CHAR in the region [FROM to)." ;; Put an overlay/extent covering the given range in the current ;; buffer. It's currently undefined whether it's front/end sticky ;; or not. The overlay/extent object is returned. + (declare (debug t)) (if (cc-bytecomp-fboundp 'make-overlay) ;; Emacs. `(let ((ol (make-overlay ,from ,to))) @@ -1490,6 +1570,7 @@ with value CHAR in the region [FROM to)." (defmacro c-delete-overlay (overlay) ;; Deletes an overlay/extent object previously retrieved using ;; `c-put-overlay'. + (declare (debug t)) (if (cc-bytecomp-fboundp 'make-overlay) ;; Emacs. `(delete-overlay ,overlay) @@ -1497,80 +1578,6 @@ with value CHAR in the region [FROM to)." `(delete-extent ,overlay))) -;; Make edebug understand the macros. -;(eval-after-load "edebug" ; 2006-07-09: def-edebug-spec is now in subr.el. -; '(progn -(def-edebug-spec cc-eval-when-compile (&rest def-form)) -(def-edebug-spec c-font-lock-flush t) -(def-edebug-spec c--mapcan t) -(def-edebug-spec c--set-difference (form form &rest [symbolp form])) -(def-edebug-spec c--intersection (form form &rest [symbolp form])) -(def-edebug-spec c--delete-duplicates (form &rest [symbolp form])) -(def-edebug-spec c-point t) -(def-edebug-spec c-is-escaped t) -(def-edebug-spec c-will-be-escaped t) -(def-edebug-spec c-next-single-property-change t) -(def-edebug-spec c-delete-and-extract-region t) -(def-edebug-spec c-set-region-active t) -(def-edebug-spec c-set-keymap-parent t) -(def-edebug-spec c-safe t) -(def-edebug-spec c-int-to-char t) -(def-edebug-spec c-characterp t) -(def-edebug-spec c-save-buffer-state let*) -(def-edebug-spec c-tentative-buffer-changes t) -(def-edebug-spec c-forward-syntactic-ws t) -(def-edebug-spec c-backward-syntactic-ws t) -(def-edebug-spec c-forward-sexp t) -(def-edebug-spec c-backward-sexp t) -(def-edebug-spec c-safe-scan-lists t) -(def-edebug-spec c-go-list-forward t) -(def-edebug-spec c-go-list-backward t) -(def-edebug-spec c-up-list-forward t) -(def-edebug-spec c-up-list-backward t) -(def-edebug-spec c-down-list-forward t) -(def-edebug-spec c-down-list-backward t) -(def-edebug-spec c-go-up-list-forward t) -(def-edebug-spec c-go-up-list-backward t) -(def-edebug-spec c-go-down-list-forward t) -(def-edebug-spec c-go-down-list-backward t) -(def-edebug-spec c-at-vsemi-p t) -(def-edebug-spec c-add-syntax t) -(def-edebug-spec c-add-class-syntax t) -(def-edebug-spec c-benign-error t) -(def-edebug-spec c-with-syntax-table t) -(def-edebug-spec c-skip-ws-forward t) -(def-edebug-spec c-skip-ws-backward t) -(def-edebug-spec c-major-mode-is t) -(def-edebug-spec c-search-forward-char-property t) -(def-edebug-spec c-search-backward-char-property t) -(def-edebug-spec c-put-char-property t) -(def-edebug-spec c-put-syn-tab t) -(def-edebug-spec c-get-char-property t) -(def-edebug-spec c-clear-char-property t) -(def-edebug-spec c-clear-syn-tab t) -;;(def-edebug-spec c-min-property-position nil) ; invoked only by macros -(def-edebug-spec c-min-property-position t) ; Now invoked from functions (2019-07) -(def-edebug-spec c-clear-char-property-with-value t) -(def-edebug-spec c-clear-char-property-with-value-on-char t) -(def-edebug-spec c-put-char-properties-on-char t) -(def-edebug-spec c-clear-char-properties t) -(def-edebug-spec c-clear-syn-tab-properties t) -(def-edebug-spec c-with-extended-string-fences (form form body)) -(def-edebug-spec c-put-overlay t) -(def-edebug-spec c-delete-overlay t) -(def-edebug-spec c-mark-<-as-paren t) -(def-edebug-spec c-mark->-as-paren t) -(def-edebug-spec c-unmark-<->-as-paren t) -(def-edebug-spec c-with-<->-as-parens-suppressed (body)) -(def-edebug-spec c-self-bind-state-cache (body)) -(def-edebug-spec c-sc-scan-lists-no-category+1+1 t) -(def-edebug-spec c-sc-scan-lists-no-category+1-1 t) -(def-edebug-spec c-sc-scan-lists-no-category-1+1 t) -(def-edebug-spec c-sc-scan-lists-no-category-1-1 t) -(def-edebug-spec c-sc-scan-lists t) -(def-edebug-spec c-sc-parse-partial-sexp t);)) - - ;;; Functions. ;; Note: All these after the macros, to be on safe side in avoiding @@ -1600,6 +1607,7 @@ with value CHAR in the region [FROM to)." ;; 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'. + (declare (debug t)) (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))) @@ -1614,6 +1622,7 @@ with value CHAR in the region [FROM to)." ;; 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'. + (declare (debug t)) (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))) @@ -1627,6 +1636,7 @@ with value CHAR in the region [FROM to)." ;; 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'. + (declare (debug t)) `(c-clear-char-property ,pos ,(if c-use-category ''category ''syntax-table))) (defsubst c-suppress-<->-as-parens () @@ -1647,50 +1657,13 @@ with value CHAR in the region [FROM to)." ;; Like progn, except that the paren property is suppressed on all ;; template brackets whilst they are running. This macro does a hidden ;; buffer change. + (declare (debug (body))) `(unwind-protect (progn (c-suppress-<->-as-parens) ,@forms) (c-restore-<->-as-parens))) -;;;;;;;;;;;;;;; - -(defmacro c-self-bind-state-cache (&rest forms) - ;; Bind the state cache to itself and execute the FORMS. Return the result - ;; of the last FORM executed. It is assumed that no buffer changes will - ;; happen in FORMS, and no hidden buffer changes which could affect the - ;; parsing will be made by FORMS. - `(let* ((c-state-cache (copy-tree c-state-cache)) - (c-state-cache-good-pos c-state-cache-good-pos) - ;(c-state-nonlit-pos-cache (copy-tree c-state-nonlit-pos-cache)) - ;(c-state-nonlit-pos-cache-limit c-state-nonlit-pos-cache-limit) - ;(c-state-semi-nonlit-pos-cache (copy-tree c-state-semi-nonlit-pos-cache)) - ;(c-state-semi-nonlit-pos-cache-limit c-state-semi-nonlit-pos-cache) - (c-state-brace-pair-desert (copy-tree c-state-brace-pair-desert)) - (c-state-point-min c-state-point-min) - (c-state-point-min-lit-type c-state-point-min-lit-type) - (c-state-point-min-lit-start c-state-point-min-lit-start) - (c-state-min-scan-pos c-state-min-scan-pos) - (c-state-old-cpp-beg-marker (if (markerp c-state-old-cpp-beg-marker) - (copy-marker c-state-old-cpp-beg-marker) - c-state-old-cpp-beg-marker)) - (c-state-old-cpp-beg (if (markerp c-state-old-cpp-beg) - c-state-old-cpp-beg-marker - c-state-old-cpp-beg)) - (c-state-old-cpp-end-marker (if (markerp c-state-old-cpp-end-marker) - (copy-marker c-state-old-cpp-end-marker) - c-state-old-cpp-end-marker)) - (c-state-old-cpp-end (if (markerp c-state-old-cpp-end) - c-state-old-cpp-end-marker - c-state-old-cpp-end)) - (c-parse-state-state c-parse-state-state)) - (prog1 - (progn ,@forms) - (if (markerp c-state-old-cpp-beg-marker) - (move-marker c-state-old-cpp-beg-marker nil)) - (if (markerp c-state-old-cpp-end-marker) - (move-marker c-state-old-cpp-end-marker nil))))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; 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 @@ -1704,8 +1677,8 @@ with value CHAR in the region [FROM to)." ;; 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))) + (declare (debug t)) + `(let ((pos (scan-lists ,from 1 1))) (while (eq (char-before pos) ?>) (setq pos (scan-lists pos 1 1))) pos)) @@ -1714,8 +1687,8 @@ with value CHAR in the region [FROM to)." ;; 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))) + (declare (debug t)) + `(let ((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))) @@ -1725,8 +1698,8 @@ with value CHAR in the region [FROM to)." ;; 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))) + (declare (debug t)) + `(let ((pos (scan-lists ,from -1 1))) (while (eq (char-after pos) ?<) (setq pos (scan-lists pos -1 1))) pos)) @@ -1735,14 +1708,15 @@ with value CHAR in the region [FROM to)." ;; 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))) + (declare (debug t)) + `(let ((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) + (declare (debug t)) (if c-use-category `(scan-lists ,from ,count ,depth) (cond @@ -1790,6 +1764,7 @@ with value CHAR in the region [FROM to)." (defmacro c-sc-parse-partial-sexp (from to &optional targetdepth stopbefore oldstate) + (declare (debug t)) (if c-use-category `(parse-partial-sexp ,from ,to ,targetdepth ,stopbefore ,oldstate) `(c-sc-parse-partial-sexp-no-category ,from ,to ,targetdepth ,stopbefore @@ -2350,6 +2325,7 @@ system." "Can be used inside a VAL in `c-lang-defconst' to evaluate FORM immediately, i.e. at the same time as the `c-lang-defconst' form itself is evaluated." + (declare (debug t)) ;; Evaluate at macro expansion time, i.e. in the ;; `c--macroexpand-all' inside `c-lang-defconst'. (eval form)) @@ -2392,7 +2368,8 @@ one `c-lang-defconst' for each NAME is permitted per file. If there already is one it will be completely replaced; the value in the earlier definition will not affect `c-lang-const' on the same constant. A file is identified by its base name." - + (declare (indent 1) + (debug (&define name [&optional stringp] [&rest sexp def-form]))) (let* ((sym (intern (symbol-name name) c-lang-constants)) ;; Make `c-lang-const' expand to a straightforward call to ;; `c-get-lang-constant' in `c--macroexpand-all' below. @@ -2483,12 +2460,6 @@ constant. A file is identified by its base name." (c-define-lang-constant ',name ,bindings ,@(and pre-files `(',pre-files)))))) -(put 'c-lang-defconst 'lisp-indent-function 1) -;(eval-after-load "edebug" ; 2006-07-09: def-edebug-spec is now in subr.el. -; ' -(def-edebug-spec c-lang-defconst - (&define name [&optional stringp] [&rest sexp def-form])) - (defun c-define-lang-constant (name bindings &optional pre-files) ;; Used by `c-lang-defconst'. @@ -2544,6 +2515,7 @@ LANG is the name of the language, i.e. the mode name without the language. NAME and LANG are not evaluated so they should not be quoted." + (declare (debug (name &optional symbolp))) (or (symbolp name) (error "Not a symbol: %S" name)) (or (symbolp lang) diff --git a/lisp/progmodes/cc-engine.el b/lisp/progmodes/cc-engine.el index 484624b8664..5d2e41ae575 100644 --- a/lisp/progmodes/cc-engine.el +++ b/lisp/progmodes/cc-engine.el @@ -1,4 +1,4 @@ -;;; cc-engine.el --- core syntax guessing engine for CC mode -*- coding: utf-8 -*- +;;; cc-engine.el --- core syntax guessing engine for CC mode -*- lexical-binding:t; coding: utf-8 -*- ;; Copyright (C) 1985, 1987, 1992-2021 Free Software Foundation, Inc. @@ -163,11 +163,14 @@ (defvar c-doc-line-join-re) (defvar c-doc-bright-comment-start-re) (defvar c-doc-line-join-end-ch) +(defvar c-syntactic-context) +(defvar c-syntactic-element) (cc-bytecomp-defvar c-min-syn-tab-mkr) (cc-bytecomp-defvar c-max-syn-tab-mkr) (cc-bytecomp-defun c-clear-syn-tab) (cc-bytecomp-defun c-clear-string-fences) (cc-bytecomp-defun c-restore-string-fences) +(cc-bytecomp-defun c-remove-string-fences) ;; Make declarations for all the `c-lang-defvar' variables in cc-langs. @@ -735,6 +738,7 @@ comment at the start of cc-engine.el for more info." '(setq stack (cons (cons state saved-pos) stack))) (defmacro c-bos-pop-state (&optional do-if-done) + (declare (debug t)) `(if (setq state (car (car stack)) saved-pos (cdr (car stack)) stack (cdr stack)) @@ -759,6 +763,7 @@ comment at the start of cc-engine.el for more info." (goto-char pos) (setq sym nil))) (defmacro c-bos-save-error-info (missing got) + (declare (debug t)) `(setq saved-pos (vector pos ,missing ,got))) (defmacro c-bos-report-error () '(unless noerror @@ -1184,6 +1189,15 @@ comment at the start of cc-engine.el for more info." ;; suitable error. (setq pre-stmt-found t) (throw 'loop nil)) + ;; Handle C++'s `constexpr', etc. + (if (save-excursion + (and (looking-at c-block-stmt-hangon-key) + (progn + (c-backward-syntactic-ws lim) + (c-safe (c-backward-sexp) t)) + (looking-at c-block-stmt-2-key) + (setq pos (point)))) + (goto-char pos)) (cond ;; Have we moved into a macro? ((and (not macro-start) @@ -1860,51 +1874,51 @@ comment at the start of cc-engine.el for more info." ; (setq in-face (point))) ; (not (eobp))))))) -(defmacro c-debug-sws-msg (&rest args) - (ignore args) +(defmacro c-debug-sws-msg (&rest _args) + ;; (declare (debug t)) ;;`(message ,@args) ) (defmacro c-put-is-sws (beg end) ;; This macro does a hidden buffer change. + (declare (debug t)) `(let ((beg ,beg) (end ,end)) (put-text-property beg end 'c-is-sws t) ,@(when (facep 'c-debug-is-sws-face) '((c-debug-add-face beg end 'c-debug-is-sws-face))))) -(def-edebug-spec c-put-is-sws t) (defmacro c-put-in-sws (beg end) ;; This macro does a hidden buffer change. + (declare (debug t)) `(let ((beg ,beg) (end ,end)) (put-text-property beg end 'c-in-sws t) ,@(when (facep 'c-debug-is-sws-face) '((c-debug-add-face beg end 'c-debug-in-sws-face))))) -(def-edebug-spec c-put-in-sws t) (defmacro c-remove-is-sws (beg end) ;; This macro does a hidden buffer change. + (declare (debug t)) `(let ((beg ,beg) (end ,end)) (remove-text-properties beg end '(c-is-sws nil)) ,@(when (facep 'c-debug-is-sws-face) '((c-debug-remove-face beg end 'c-debug-is-sws-face))))) -(def-edebug-spec c-remove-is-sws t) (defmacro c-remove-in-sws (beg end) ;; This macro does a hidden buffer change. + (declare (debug t)) `(let ((beg ,beg) (end ,end)) (remove-text-properties beg end '(c-in-sws nil)) ,@(when (facep 'c-debug-is-sws-face) '((c-debug-remove-face beg end 'c-debug-in-sws-face))))) -(def-edebug-spec c-remove-in-sws t) (defmacro c-remove-is-and-in-sws (beg end) ;; This macro does a hidden buffer change. + (declare (debug t)) `(let ((beg ,beg) (end ,end)) (remove-text-properties beg end '(c-is-sws nil c-in-sws nil)) ,@(when (facep 'c-debug-is-sws-face) '((c-debug-remove-face beg end 'c-debug-is-sws-face) (c-debug-remove-face beg end 'c-debug-in-sws-face))))) -(def-edebug-spec c-remove-is-and-in-sws t) ;; The type of literal position `end' is in a `before-change-functions' ;; function - one of `c', `c++', `pound', `noise', `attribute' or nil (but NOT @@ -2665,7 +2679,7 @@ comment at the start of cc-engine.el for more info." ;; One of the above "near" caches is associated with each of these functions. ;; ;; When searching this cache, these functions first seek an exact match, then -;; a "close" match from the assiciated near cache. If neither of these +;; a "close" match from the associated near cache. If neither of these ;; succeed, the nearest preceding entry in the far cache is used. ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -2708,9 +2722,9 @@ comment at the start of cc-engine.el for more info." ;; two char construct (such as a comment opener or an escaped character).) (if (and (consp elt) (>= (length elt) 3)) ;; Inside a string or comment - (let ((depth 0) (containing nil) (last nil) + (let ((depth 0) (containing nil) in-string in-comment - (min-depth 0) com-style com-str-start (intermediate nil) + (min-depth 0) com-style com-str-start (char-1 (nth 3 elt)) ; first char of poss. 2-char construct (pos (car elt)) (type (cadr elt))) @@ -2727,14 +2741,13 @@ comment at the start of cc-engine.el for more info." (1- pos) pos)) (if (memq 'pps-extended-state c-emacs-features) - (list depth containing last + (list depth containing nil in-string in-comment nil min-depth com-style com-str-start - intermediate nil) - (list depth containing last + nil nil) + (list depth containing nil in-string in-comment nil - min-depth com-style com-str-start - intermediate))) + min-depth com-style com-str-start nil))) ;; Not in a string or comment. (if (memq 'pps-extended-state c-emacs-features) @@ -3128,21 +3141,21 @@ comment at the start of cc-engine.el for more info." (setq base far-base s far-s end nil)))) - (when - (or - (and (> here base) (null end)) - (null (nth 8 s)) - (and end (>= here end)) - (not - (or - (and (nth 3 s) ; string - (not (eq (char-before here) ?\\))) - (and (nth 4 s) (not (nth 7 s)) ; Block comment - (not (memq (char-before here) - c-block-comment-awkward-chars))) - (and (nth 4 s) (nth 7 s) ; Line comment - (not (memq (char-before here) '(?\\ ?\n))))))) + (cond + ((or (and (> here base) (null end)) + (null (nth 8 s)) + (and end (>= here end))) (setq s (parse-partial-sexp base here nil nil s))) + ((or (and (nth 3 s) ; string + (eq (char-before here) ?\\)) + (and (nth 4 s) (not (nth 7 s)) ; block comment + (memq (char-before here) c-block-comment-awkward-chars)) + (and (nth 4 s) (nth 7 s) ; line comment + (memq (char-before here) '(?\\ ?\n)))) + (setq s + (if (>= here base) + (parse-partial-sexp base here nil nil s) + (parse-partial-sexp (nth 8 s) here))))) (cond ((or (nth 3 s) (and (nth 4 s) @@ -3507,6 +3520,7 @@ mhtml-mode." (defmacro c-state-cache-top-lparen (&optional cache) ;; Return the address of the top left brace/bracket/paren recorded in CACHE ;; (default `c-state-cache') (or nil). + (declare (debug t)) (let ((cash (or cache 'c-state-cache))) `(if (consp (car ,cash)) (caar ,cash) @@ -3515,6 +3529,7 @@ mhtml-mode." (defmacro c-state-cache-top-paren (&optional cache) ;; Return the address of the latest brace/bracket/paren (whether left or ;; right) recorded in CACHE (default `c-state-cache') or nil. + (declare (debug t)) (let ((cash (or cache 'c-state-cache))) `(if (consp (car ,cash)) (cdar ,cash) @@ -3523,6 +3538,7 @@ mhtml-mode." (defmacro c-state-cache-after-top-paren (&optional cache) ;; Return the position just after the latest brace/bracket/paren (whether ;; left or right) recorded in CACHE (default `c-state-cache') or nil. + (declare (debug t)) (let ((cash (or cache 'c-state-cache))) `(if (consp (car ,cash)) (cdar ,cash) @@ -3784,12 +3800,14 @@ mhtml-mode." (point))) (bra ; Position of "{". ;; Don't start scanning in the middle of a CPP construct unless - ;; it contains HERE - these constructs, in Emacs, are "commented - ;; out" with category properties. - (if (eq (c-get-char-property macro-start-or-from 'category) - 'c-cpp-delimiter) - macro-start-or-from - from)) + ;; it contains HERE. + (if (and (not (eq macro-start-or-from from)) + (< macro-start-or-from here) ; Might not be needed. + (progn (goto-char macro-start-or-from) + (c-end-of-macro) + (>= (point) here))) + from + macro-start-or-from)) ce) ; Position of "}" (or upper-lim (setq upper-lim from)) @@ -4319,38 +4337,29 @@ mhtml-mode." (setq c-state-nonlit-pos-cache-limit (1- here))) (c-truncate-lit-pos-cache here) - ;; `c-state-cache': - ;; Case 1: if `here' is in a literal containing point-min, everything - ;; becomes (or is already) nil. - (if (or (null c-state-cache-good-pos) - (< here (c-state-get-min-scan-pos))) - (setq c-state-cache nil - c-state-cache-good-pos nil - c-state-min-scan-pos nil) - - ;; Truncate `c-state-cache' and set `c-state-cache-good-pos' to a value - ;; below `here'. To maintain its consistency, we may need to insert a new - ;; brace pair. - (let ((here-bol (c-point 'bol here)) - too-high-pa ; recorded {/(/[ next above or just below here, or nil. - dropped-cons) ; was the last removed element a brace pair? - ;; The easy bit - knock over-the-top bits off `c-state-cache'. - (while (and c-state-cache - (>= (c-state-cache-top-paren) here)) - (setq dropped-cons (consp (car c-state-cache)) - too-high-pa (c-state-cache-top-lparen) - c-state-cache (cdr c-state-cache))) - - ;; Do we need to add in an earlier brace pair, having lopped one off? - (if (and dropped-cons - (<= too-high-pa here)) - (c-append-lower-brace-pair-to-state-cache too-high-pa here here-bol)) - (if (and c-state-cache-good-pos (< here c-state-cache-good-pos)) - (setq c-state-cache-good-pos - (or (save-excursion - (goto-char here) - (c-literal-start)) - here))))) + (cond + ;; `c-state-cache': + ;; Case 1: if `here' is in a literal containing point-min, everything + ;; becomes (or is already) nil. + ((or (null c-state-cache-good-pos) + (< here (c-state-get-min-scan-pos))) + (setq c-state-cache nil + c-state-cache-good-pos nil + c-state-min-scan-pos nil)) + + ;; Case 2: `here' is below `c-state-cache-good-pos', so we need to amend + ;; the entire `c-state-cache' data. + ((< here c-state-cache-good-pos) + (let* ((res (c-remove-stale-state-cache-backwards here)) + (good-pos (car res)) + (scan-backward-pos (cadr res)) + (scan-forward-p (car (cddr res)))) + (if scan-backward-pos + (c-append-lower-brace-pair-to-state-cache scan-backward-pos here)) + (setq c-state-cache-good-pos + (if scan-forward-p + (c-append-to-state-cache good-pos here) + good-pos))))) ;; The brace-pair desert marker: (when (car c-state-brace-pair-desert) @@ -4484,6 +4493,7 @@ mhtml-mode." (defmacro c-state-maybe-marker (place marker) ;; If PLACE is non-nil, return a marker marking it, otherwise nil. ;; We (re)use MARKER. + (declare (debug (form symbolp))) `(let ((-place- ,place)) (and -place- (or ,marker (setq ,marker (make-marker))) @@ -5970,6 +5980,7 @@ comment at the start of cc-engine.el for more info." ; spots and the preceding token end.") (defmacro c-debug-put-decl-spot-faces (match-pos decl-pos) + (declare (debug t)) (when (facep 'c-debug-decl-spot-face) `(c-save-buffer-state ((match-pos ,match-pos) (decl-pos ,decl-pos)) (c-debug-add-face (max match-pos (point-min)) decl-pos @@ -5977,6 +5988,7 @@ comment at the start of cc-engine.el for more info." (c-debug-add-face decl-pos (min (1+ decl-pos) (point-max)) 'c-debug-decl-spot-face)))) (defmacro c-debug-remove-decl-spot-faces (beg end) + (declare (debug t)) (when (facep 'c-debug-decl-spot-face) `(c-save-buffer-state () (c-debug-remove-face ,beg ,end 'c-debug-decl-spot-face) @@ -6931,8 +6943,10 @@ 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-unmark-<->-as-paren (1- (point)))) - (c-unmark-<->-as-paren pos)))) + (c-unmark-<->-as-paren (1- (point))) + (c-truncate-lit-pos-cache (1- (point)))) + (c-unmark-<->-as-paren pos) + (c-truncate-lit-pos-cache pos)))) (defun c-clear->-pair-props (&optional pos) ;; POS (default point) is at a > character. If it is marked with @@ -6948,8 +6962,10 @@ 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-unmark-<->-as-paren (point))) - (c-unmark-<->-as-paren pos)))) + (c-unmark-<->-as-paren (point)) + (c-truncate-lit-pos-cache (point))) + (c-unmark-<->-as-paren pos) + (c-truncate-lit-pos-cache pos)))) (defun c-clear-<>-pair-props (&optional pos) ;; POS (default point) is at a < or > character. If it has an @@ -6982,7 +6998,8 @@ comment at the start of cc-engine.el for more info." (equal (c-get-char-property (1- (point)) 'syntax-table) c->-as-paren-syntax)) ; should always be true. (c-unmark-<->-as-paren (1- (point))) - (c-unmark-<->-as-paren pos)) + (c-unmark-<->-as-paren pos) + (c-truncate-lit-pos-cache pos)) t))) (defun c-clear->-pair-props-if-match-before (lim &optional pos) @@ -7003,6 +7020,7 @@ comment at the start of cc-engine.el for more info." (equal (c-get-char-property (point) 'syntax-table) c-<-as-paren-syntax)) ; should always be true. (c-unmark-<->-as-paren (point)) + (c-truncate-lit-pos-cache (point)) (c-unmark-<->-as-paren pos)) t))) @@ -7150,554 +7168,954 @@ comment at the start of cc-engine.el for more info." (goto-char c-new-END))))) -;; Functions to handle C++ raw strings. +;; Handling of CC Mode multi-line strings. ;; -;; A valid C++ raw string looks like -;; R"<id>(<contents>)<id>" -;; , where <id> is an identifier from 0 to 16 characters long, not containing -;; spaces, control characters, or left/right paren. <contents> can include -;; anything which isn't the terminating )<id>", including new lines, "s, -;; parentheses, etc. +;; By a "multi-line string" is meant a string opened by a "decorated" +;; double-quote mark, and which can continue over several lines without the +;; need to escape the newlines, terminating at a closer, a possibly +;; "decorated" double-quote mark. The string can usually contain double +;; quotes without them being quoted, whether or not backslashes quote the +;; following character being a matter of configuration. ;; -;; CC Mode handles C++ raw strings by the use of `syntax-table' text +;; CC Mode handles multi-line strings by the use of `syntax-table' text ;; properties as follows: ;; -;; (i) On a validly terminated raw string, no `syntax-table' text properties -;; are applied to the opening and closing delimiters, but any " in the -;; contents is given the property value "punctuation" (`(1)') to prevent it -;; interacting with the "s in the delimiters. +;; (i) On a validly terminated ml string, syntax-table text-properties are +;; applied as needed to the opener, so that the " character in the opener +;; (or (usually) the first of them if there are several) retains its normal +;; syntax, and any other characters with obtrusive syntax are given +;; "punctuation" '(1) properties. Similarly, the " character in the closer +;; retains its normal syntax, and characters with obtrusive syntax are +;; "punctuated out" as before. ;; -;; The font locking routine `c-font-lock-raw-strings' (in cc-fonts.el) -;; recognizes valid raw strings, and fontifies the delimiters (apart from -;; the parentheses) with the default face and the parentheses and the -;; <contents> with font-lock-string-face. +;; The font locking routine `c-font-lock-ml-strings' (in cc-fonts.el) +;; recognizes validly terminated ml strings and fontifies (typically) the +;; innermost character of each delimiter in font-lock-string-face and the +;; rest of those delimiters in the default face. The contents, of course, +;; are in font-lock-string-face. ;; -;; (ii) A valid, but unterminated, raw string opening delimiter gets the -;; "punctuation" value (`(1)') of the `syntax-table' text property, and the -;; open parenthesis gets the "string fence" value (`(15)'). When such a -;; delimiter is found, no attempt is made in any way to "correct" any text -;; properties after the delimiter. +;; (ii) A valid, but unterminated, ml string's opening delimiter gets the +;; "punctuation" value (`(1)') of the `syntax-table' text property on its ", +;; and the last char of the opener gets the "string fence" value '(15). +;; (The latter takes precedence over the former.) When such a delimiter is +;; found, no attempt is made in any way to "correct" any text properties +;; after the delimiter. ;; -;; `c-font-lock-raw-strings' puts c-font-lock-warning-face on the entire -;; unmatched opening delimiter (from the R up to the open paren), and allows -;; the rest of the buffer to get font-lock-string-face, caused by the -;; unmatched "string fence" `syntax-table' text property value. +;; `c-font-lock-ml-strings' puts c-font-lock-warning-face on the entire +;; unmatched opening delimiter, and allows the tail of the buffer to get +;; font-lock-string-face, caused by the unmatched "string fence" +;; `syntax-table' text property value. ;; -;; (iii) Inside a macro, a valid raw string is handled as in (i). An -;; unmatched opening delimiter is handled slightly differently. In addition -;; to the "punctuation" and "string fence" properties on the delimiter, -;; another "string fence" `syntax-table' property is applied to the last -;; possible character of the macro before the terminating linefeed (if there -;; is such a character after the "("). This "last possible" character is +;; (iii) Inside a macro, a valid ml string is handled as in (i). An unmatched +;; opening delimiter is handled slightly differently. In addition to the +;; "punctuation" and "string fence" properties on the delimiter, another +;; "string fence" `syntax-table' property is applied to the last possible +;; character of the macro before the terminating linefeed (if there is such +;; a character after the delimiter). This "last possible" character is ;; never a backslash escaping the end of line. If the character preceding ;; this "last possible" character is itself a backslash, this preceding -;; character gets a "punctuation" `syntax-table' value. If the "(" is -;; already at the end of the macro, it gets the "punctuation" value, and no -;; "string fence"s are used. +;; character gets a "punctuation" `syntax-table' value. If the last +;; character of the closing delimiter is already at the end of the macro, it +;; gets the "punctuation" value, and no "string fence"s are used. ;; ;; The effect on the fontification of either of these tactics is that the ;; rest of the macro (if any) after the "(" gets font-lock-string-face, but ;; the rest of the file is fontified normally. -;; The values of the function `c-raw-string-pos' at before-change-functions' -;; BEG and END. -(defvar c-old-beg-rs nil) -(defvar c-old-end-rs nil) -;; Whether a buffer change has disrupted or will disrupt the terminating id of -;; a raw string. -(defvar c-raw-string-end-delim-disrupted nil) - -(defun c-raw-string-pos () - ;; Get POINT's relationship to any containing raw string. - ;; If point isn't in a raw string, return nil. - ;; Otherwise, return the following list: - ;; - ;; (POS B\" B\( E\) E\") - ;; - ;; , where POS is the symbol `open-delim' if point is in the opening - ;; delimiter, the symbol `close-delim' if it's in the closing delimiter, and - ;; nil if it's in the string body. B\", B\(, E\), E\" are the positions of - ;; the opening and closing quotes and parentheses of a correctly terminated - ;; raw string. (N.B.: E\) and E\" are NOT on the "outside" of these - ;; characters.) If the raw string is not terminated, E\) and E\" are set to +(defun c-ml-string-make-closer-re (_opener) + "Return c-ml-string-any-closer-re. + +This is a suitable language specific value of +`c-make-ml-string-closer-re-function' for most languages with +multi-line strings (but not C++, for example)." + c-ml-string-any-closer-re) + +(defun c-ml-string-make-opener-re (_closer) + "Return c-ml-string-opener-re. + +This is a suitable language specific value of +`c-make-ml-string-opener-re-function' for most languages with +multi-line strings (but not C++, for example)." + c-ml-string-opener-re) + +(defun c-c++-make-ml-string-closer-re (opener) + "Construct a regexp for a C++ raw string closer matching OPENER." + (concat "\\()" (regexp-quote (substring opener 2 -1)) "\\(\"\\)\\)")) + +(defun c-c++-make-ml-string-opener-re (closer) + "Construct a regexp for a C++ raw string opener matching CLOSER." + (concat "\\(R\\(\"\\)" (regexp-quote (substring closer 1 -1)) "(\\)")) + +;; The positions of various components of mult-line strings surrounding BEG, +;; END and (1- BEG) (of before-change-functions) as returned by +;; `c-ml-string-delims-around-point'. +(defvar c-old-beg-ml nil) +(defvar c-old-1-beg-ml nil) ; only non-nil when `c-old-beg-ml' is nil. +(defvar c-old-end-ml nil) +;; The values of the function `c-position-wrt-ml-delims' at +;; before-change-function's BEG and END. +(defvar c-beg-pos nil) +(defvar c-end-pos nil) +;; Whether a buffer change has disrupted or will disrupt the terminator of an +;; multi-line string. +(defvar c-ml-string-end-delim-disrupted nil) + +(defun c-depropertize-ml-string-delims (string-delims) + ;; Remove any syntax-table text properties from the multi-line string + ;; delimiters specified by STRING-DELIMS, the output of + ;; `c-ml-string-delims-around-point'. + (let (found) + (if (setq found (c-clear-char-properties (caar string-delims) + (cadar string-delims) + 'syntax-table)) + (c-truncate-lit-pos-cache found)) + (when (cdr string-delims) + (if (setq found (c-clear-char-properties (cadr string-delims) + (caddr string-delims) + 'syntax-table)) + (c-truncate-lit-pos-cache found))))) + +(defun c-get-ml-closer (open-delim) + ;; Return the closer, a three element dotted list of the closer's start, its + ;; end and the position of the double quote, matching the given multi-line + ;; string OPENER, also such a three element dotted list. Otherwise return + ;; nil. All pertinent syntax-table text properties must be in place. + (save-excursion + (goto-char (cadr open-delim)) + (and (not (equal (c-get-char-property (1- (point)) 'syntax-table) + '(15))) + (re-search-forward (funcall c-make-ml-string-closer-re-function + (buffer-substring-no-properties + (car open-delim) (cadr open-delim))) + nil t) + (cons (match-beginning 1) + (cons (match-end 1) (match-beginning 2)))))) + +(defun c-ml-string-opener-around-point () + ;; If point is inside an ml string opener, return a dotted list of the start + ;; and end of that opener, and the position of its double-quote. That list + ;; will not include any "context characters" before or after the opener. If + ;; an opener is found, the match-data will indicate it, with (match-string + ;; 1) being the entire delimiter, and (match-string 2) the "main" double + ;; quote. Otherwise the match-data is undefined. + (let ((here (point)) found) + (goto-char (max (- here (1- c-ml-string-max-opener-len)) (point-min))) + (while + (and + (setq found + (search-forward-regexp + c-ml-string-opener-re + (min (+ here (1- c-ml-string-max-opener-len)) (point-max)) + 'bound)) + (<= (match-end 1) here))) + (prog1 + (and found + (< (match-beginning 1) here) + (cons (match-beginning 1) + (cons (match-end 1) (match-beginning 2)))) + (goto-char here)))) + +(defun c-ml-string-opener-intersects-region (&optional start finish) + ;; If any part of the region [START FINISH] is inside an ml-string opener, + ;; return a dotted list of the start, end and double-quote position of that + ;; opener. That list wlll not include any "context characters" before or + ;; after the opener. If an opener is found, the match-data will indicate + ;; it, with (match-string 1) being the entire delimiter, and (match-string + ;; 2) the "main" double-quote. Otherwise, the match-data is undefined. + ;; Both START and FINISH default to point. FINISH may not be at an earlier + ;; buffer position than START. + (let ((here (point)) found) + (or finish (setq finish (point))) + (or start (setq start (point))) + (goto-char (max (- start (1- c-ml-string-max-opener-len)) (point-min))) + (while + (and + (setq found + (search-forward-regexp + c-ml-string-opener-re + (min (+ finish (1- c-ml-string-max-opener-len)) (point-max)) + 'bound)) + (<= (match-end 1) start))) + (prog1 + (and found + (< (match-beginning 1) finish) + (cons (match-beginning 1) + (cons (match-end 1) (match-beginning 2)))) + (goto-char here)))) + +(defun c-ml-string-opener-at-or-around-point (&optional position) + ;; If POSITION (default point) is at or inside an ml string opener, return a + ;; dotted list of the start and end of that opener, and the position of the + ;; double-quote in it. That list will not include any "context characters" + ;; before or after the opener. + (let ((here (point)) + found) + (or position (setq position (point))) + (goto-char (max (- position (1- c-ml-string-max-opener-len)) (point-min))) + (while + (and + (setq found + (search-forward-regexp + c-ml-string-opener-re + (min (+ position c-ml-string-max-opener-len) (point-max)) + 'bound)) + (<= (match-end 1) position))) + (prog1 + (and found + (<= (match-beginning 1) position) + (cons (match-beginning 1) + (cons (match-end 1) (match-beginning 2)))) + (goto-char here)))) + +(defun c-ml-string-back-to-neutral (opening-point) + ;; Given OPENING-POINT, the position of the start of a multiline string + ;; opening delimiter, move point back to a neutral position within the ml + ;; string. It is assumed that point is within the innards of or the closing + ;; delimiter of string opened by OPEN-DELIM. + (let ((opener-end (save-excursion + (goto-char opening-point) + (looking-at c-ml-string-opener-re) + (match-end 1)))) + (if (not c-ml-string-back-closer-re) + (goto-char (max (c-point 'boll) opener-end)) + (re-search-backward c-ml-string-back-closer-re + (max opener-end + (c-point 'eopl)) + 'bound)))) + +(defun c-ml-string-in-end-delim (beg end open-delim) + ;; If the region (BEG END) intersects or touches a possible multiline string + ;; terminator, return a cons of the position of the start and end of the + ;; first such terminator. The syntax-table text properties must be in a + ;; consistent state when using this function. OPEN-DELIM is the three + ;; element dotted list of the start, end, and double quote position of the + ;; multiline string opener that BEG is in, or nil if it isn't in one. + (save-excursion + (goto-char beg) + (when open-delim + ;; If BEG is in an opener, move back to a position we know to be "safe". + (if (<= beg (cadr open-delim)) + (goto-char (cadr open-delim)) + (c-ml-string-back-to-neutral (car open-delim)))) + + (let (saved-match-data) + (or + ;; If we might be in the middle of "context" bytes at the start of a + ;; closer, move to after the closer. + (and c-ml-string-back-closer-re + (looking-at c-ml-string-any-closer-re) + (eq (c-in-literal) 'string) + (setq saved-match-data (match-data)) + (goto-char (match-end 0))) + + ;; Otherwise, move forward over closers while we haven't yet reached END, + ;; until we're after BEG. + (progn + (while + (let (found) + (while ; Go over a single real closer. + (and + (search-forward-regexp + c-ml-string-any-closer-re + (min (+ end c-ml-string-max-closer-len-no-leader) + (point-max)) + t) + (save-excursion + (goto-char (match-end 1)) + (if (c-in-literal) ; a psuedo closer. + t + (setq saved-match-data (match-data)) + (setq found t) + nil)))) + (and found + (<= (point) beg)) + ;; (not (save-excursion + ;; (goto-char (match-beginning 2)) + ;; (c-literal-start))) + )))) + (set-match-data saved-match-data)) + + ;; Test whether we've found the sought closing delimiter. + (unless (or (null (match-data)) + (and (not (eobp)) + (<= (point) beg)) + (> (match-beginning 0) beg) + (progn (goto-char (match-beginning 2)) + (not (c-literal-start)))) + (cons (match-beginning 1) (match-end 1))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun c-ml-string-delims-around-point () + ;; Get POINT's relationship to any containing multi-line string or such a + ;; multi-line string which point is at the end of. + ;; + ;; If point isn't thus situated, return nil. + ;; Otherwise return the following cons: + ;; + ;; (OPENER . CLOSER) + ;; + ;; , where each of OPENER and CLOSER is a dotted list of the form + ;; + ;; (START-DELIM END-DELIM . QUOTE-POSITION) + ;; + ;; , the bounds of the delimiters and the buffer position of the ?" in the + ;; delimiter. If the ml-string is not validly terminated, CLOSER is instead ;; nil. ;; ;; Note: this function is dependent upon the correct syntax-table text ;; properties being set. - (let ((state (c-semi-pp-to-literal (point))) - open-quote-pos open-paren-pos close-paren-pos close-quote-pos id) - (save-excursion - (when - (and - (cond - ((null (cadr state)) - (or (eq (char-after) ?\") - (search-backward "\"" (max (- (point) 17) (point-min)) t))) - ((and (eq (cadr state) 'string) - (goto-char (nth 2 state)) - (cond - ((eq (char-after) ?\")) - ((eq (char-after) ?\() - (let ((here (point))) - (goto-char (max (- (point) 18) (point-min))) - (while - (and - (search-forward-regexp - c-c++-raw-string-opener-re - (1+ here) 'limit) - (< (point) here))) - (and (eq (point) (1+ here)) - (match-beginning 1) - (goto-char (1- (match-beginning 1))))))) - (not (bobp))))) - (c-at-c++-raw-string-opener)) - (setq open-quote-pos (point) - open-paren-pos (match-end 1) - id (match-string-no-properties 1)) - (goto-char (1+ open-paren-pos)) - (when (and (not (c-get-char-property open-paren-pos 'syntax-table)) - (search-forward (concat ")" id "\"") nil t)) - (setq close-paren-pos (match-beginning 0) - close-quote-pos (1- (point)))))) - (and open-quote-pos - (list - (cond - ((<= (point) open-paren-pos) - 'open-delim) - ((and close-paren-pos - (> (point) close-paren-pos)) - 'close-delim) - (t nil)) - open-quote-pos open-paren-pos close-paren-pos close-quote-pos)))) - -(defun c-raw-string-in-end-delim (beg end) - ;; If the region (BEG END) intersects a possible raw string terminator, - ;; return a cons of the position of the ) and the position of the " in the - ;; first one found. - (save-excursion - (goto-char (max (- beg 17) (point-min))) - (while - (and - (search-forward-regexp ")\\([^ ()\\\n\r\t]\\{0,16\\}\\)\"" - (min (+ end 17) (point-max)) t) - (<= (point) beg))) - (unless (or (<= (point) beg) - (>= (match-beginning 0) end)) - (cons (match-beginning 0) (match-end 1))))) - -(defun c-depropertize-raw-string (id open-quote open-paren bound) - ;; Point is immediately after a raw string opening delimiter. Remove any - ;; `syntax-table' text properties associated with the delimiter (if it's - ;; unmatched) or the raw string. - ;; - ;; ID, a string, is the delimiter's identifier. OPEN-QUOTE and OPEN-PAREN - ;; are the buffer positions of the delimiter's components. BOUND is the - ;; bound for searching for a matching closing delimiter; it is usually nil, - ;; but if we're inside a macro, it's the end of the macro (i.e. just before - ;; the terminating \n). - ;; - ;; Point is moved to after the (terminated) raw string, or left after the - ;; unmatched opening delimiter, as the case may be. The return value is of - ;; no significance. - (let ((open-paren-prop (c-get-char-property open-paren 'syntax-table)) - first) - ;; If the delimiter is "unclosed", or sombody's used " in their id, clear - ;; the 'syntax-table property from all of them. - (setq first (c-clear-char-property-with-value-on-char - open-quote open-paren 'syntax-table '(1) ?\")) - (if first (c-truncate-lit-pos-cache first)) + (let ((here (point)) + (state (c-semi-pp-to-literal (point))) + open-dlist close-dlist ret found opener) (cond - ((null open-paren-prop) - ;; Should be a terminated raw string... - (when (search-forward (concat ")" id "\"") nil t) - ;; Yes, it is. :-) - ;; Clear any '(1)s from "s in the identifier. - (setq first (c-clear-char-property-with-value-on-char - (1+ (match-beginning 0)) (1- (match-end 0)) - 'syntax-table '(1) ?\")) - (if first (c-truncate-lit-pos-cache first)) - ;; Clear any random `syntax-table' text properties from the contents. - (let* ((closing-paren (match-beginning 0)) - (first-st - (and - (< (1+ open-paren) closing-paren) - (or - (and (c-get-char-property (1+ open-paren) 'syntax-table) - (1+ open-paren)) - (and - (setq first - (c-next-single-property-change - (1+ open-paren) 'syntax-table nil closing-paren)) - (< first closing-paren) - first))))) - (when first-st - (c-clear-char-properties first-st (match-beginning 0) - 'syntax-table) - (c-truncate-lit-pos-cache first-st)) - (when (c-get-char-property (1- (match-end 0)) 'syntax-table) - ;; Was previously an unterminated (ordinary) string - (save-excursion - (goto-char (1- (match-end 0))) - (when (c-safe (c-forward-sexp)) ; to '(1) at EOL. - (c-clear-char-property (1- (point)) 'syntax-table)) - (c-clear-char-property (1- (match-end 0)) 'syntax-table) - (c-truncate-lit-pos-cache (1- (match-end 0)))))))) - ((or (and (equal open-paren-prop '(15)) (null bound)) - (equal open-paren-prop '(1))) - ;; An unterminated raw string either not in a macro, or in a macro with - ;; the open parenthesis right up against the end of macro - (c-clear-char-property open-quote 'syntax-table) - (c-truncate-lit-pos-cache open-quote) - (c-clear-char-property open-paren 'syntax-table)) - (t - ;; An unterminated string in a macro, with at least one char after the - ;; open paren - (c-clear-char-property open-quote 'syntax-table) - (c-truncate-lit-pos-cache open-quote) - (c-clear-char-property open-paren 'syntax-table) - (c-clear-char-property-with-value (1+ open-paren) bound 'syntax-table - '(15)))))) - -(defun c-depropertize-raw-strings-in-region (start finish) - ;; Remove any `syntax-table' text properties associated with C++ raw strings - ;; contained in the region (START FINISH). Point is undefined at entry and - ;; exit, and the return value has no significance. - (goto-char start) - (while (and (< (point) finish) - (re-search-forward - (concat "\\(" ; 1 - c-anchored-cpp-prefix ; 2 - "\\)\\|\\(" ; 3 - c-c++-raw-string-opener-re ; 4 - "\\)") - finish t)) - (when (save-excursion - (goto-char (match-beginning 0)) (not (c-in-literal))) - (if (match-beginning 4) ; the id - ;; We've found a raw string - (c-depropertize-raw-string - (match-string-no-properties 4) ; id - (1+ (match-beginning 3)) ; open quote - (match-end 4) ; open paren - nil) ; bound - ;; We've found a CPP construct. Search for raw strings within it. - (goto-char (match-beginning 2)) ; the "#" - (c-end-of-macro) - (let ((eom (point))) - (goto-char (match-end 2)) ; after the "#". - (while (and (< (point) eom) - (c-syntactic-re-search-forward - c-c++-raw-string-opener-re eom t)) - (c-depropertize-raw-string - (match-string-no-properties 1) ; id - (1+ (match-beginning 0)) ; open quote - (match-end 1) ; open paren - eom))))))) ; bound. - -(defun c-before-change-check-raw-strings (beg end) - ;; This function clears `syntax-table' text properties from C++ raw strings - ;; whose delimiters are about to change in the region (c-new-BEG c-new-END). - ;; BEG and END are the standard arguments supplied to any before-change - ;; function. + ((or + ;; Is HERE between the start of an opener and the "? + (and (null (cadr state)) + (progn + ;; Search for the start of the opener. + (goto-char (max (- (point) (1- c-ml-string-max-opener-len)) + (point-min))) + (setq found nil) + ;; In the next loop, skip over any complete ml strings, or an ml + ;; string opener which is in a macro not containing HERE, or an + ;; apparent "opener" which is in a comment or string. + (while + (and (re-search-forward c-ml-string-opener-re + (+ here (1- c-ml-string-max-opener-len)) + t) + (< (match-beginning 1) here) + (or + (save-excursion + (goto-char (match-beginning 1)) + (or (c-in-literal) + (and (c-beginning-of-macro) + (< (progn (c-end-of-macro) (point)) + here)))) + (and + (setq found (match-beginning 1)) + (<= (point) here) + (save-match-data + (re-search-forward + (funcall c-make-ml-string-closer-re-function + (match-string-no-properties 1)) + here t)) + (<= (point) here)))) + (setq found nil)) + found)) + ;; Is HERE after the "? + (and (eq (cadr state) 'string) + (goto-char (nth 2 state)) + (c-ml-string-opener-at-or-around-point))) + (setq open-dlist (cons (match-beginning 1) + (cons (match-end 1) (match-beginning 2)))) + (goto-char (cadr open-dlist)) + (setq ret + (cons open-dlist + (if (re-search-forward + (funcall c-make-ml-string-closer-re-function + (match-string-no-properties 1)) + nil t) + (cons (match-beginning 1) + (cons (match-end 1) (match-beginning 2))) + nil))) + (goto-char here) + ret) + ;; Is HERE between the " and the end of the closer? + ((and (null (cadr state)) + (progn + (if (null c-ml-string-back-closer-re) + (goto-char (max (- here (1- c-ml-string-max-closer-len)) + (point-min))) + (goto-char here) + (re-search-backward c-ml-string-back-closer-re nil t)) + (re-search-forward c-ml-string-any-closer-re + (+ here -1 c-ml-string-max-closer-len-no-leader) + t)) + (>= (match-end 1) here) + (<= (match-end 2) here) + (setq close-dlist (cons (match-beginning 1) + (cons (match-end 1) (match-beginning 2)))) + (goto-char (car close-dlist)) + (setq state (c-semi-pp-to-literal (point))) + (eq (cadr state) 'string) + (goto-char (nth 2 state)) + (setq opener (c-ml-string-opener-around-point)) + (goto-char (cadr opener)) + (setq open-dlist (cons (match-beginning 1) + (cons (match-end 1) (match-beginning 2)))) + (re-search-forward (funcall c-make-ml-string-closer-re-function + (match-string-no-properties 1)) + nil t)) + (goto-char here) + (cons open-dlist close-dlist)) + + (t (goto-char here) + nil)))) + +(defun c-position-wrt-ml-delims (ml-string-delims) + ;; Given ML-STRING-DELIMS, a structure produced by + ;; `c-ml-string-delims-around-point' called at point, return one of the + ;; following indicating where POINT is with respect to the multi-line + ;; string: + ;; o - nil; not in the string. + ;; o - open-delim: in the open-delimiter. + ;; o - close-delim: in the close-delimiter. + ;; o - after-close: just after the close-delimiter + ;; o - string: inside the delimited string. + (cond + ((null ml-string-delims) + nil) + ((< (point) (cadar ml-string-delims)) + 'open-delim) + ((or (null (cdr ml-string-delims)) + (<= (point) (cadr ml-string-delims))) + 'string) + ((eq (point) (caddr ml-string-delims)) + 'after-close) + (t 'close-delim))) + +(defun c-before-change-check-ml-strings (beg end) + ;; This function clears `syntax-table' text properties from multi-line + ;; strings whose delimiters are about to change in the region (c-new-BEG + ;; c-new-END). BEG and END are the standard arguments supplied to any + ;; before-change function. ;; ;; Point is undefined on both entry and exit, and the return value has no ;; significance. ;; ;; This function is called as a before-change function solely due to its - ;; membership of the C++ value of `c-get-state-before-change-functions'. + ;; membership of mode-specific value of + ;; `c-get-state-before-change-functions'. (goto-char end) - (setq c-raw-string-end-delim-disrupted nil) + (setq c-ml-string-end-delim-disrupted nil) ;; We use the following to detect a R"<id>( being swallowed into a string by ;; the pending change. (setq c-old-END-literality (c-in-literal)) + (goto-char beg) + (setq c-old-beg-ml (c-ml-string-delims-around-point)) + (setq c-beg-pos (c-position-wrt-ml-delims c-old-beg-ml)) + (setq c-old-1-beg-ml + (and (not (or c-old-beg-ml (bobp))) + (goto-char (1- beg)) + (c-ml-string-delims-around-point))) + (goto-char end) + (setq c-old-end-ml + (if (or (eq end beg) + (and c-old-beg-ml + (>= end (caar c-old-beg-ml)) + (or (null (cdr c-old-beg-ml)) + (< end (caddr c-old-beg-ml))))) + c-old-beg-ml + (c-ml-string-delims-around-point))) + (setq c-end-pos (c-position-wrt-ml-delims c-old-end-ml)) + (c-save-buffer-state - ((term-del (c-raw-string-in-end-delim beg end)) + ((term-del (c-ml-string-in-end-delim beg end (car c-old-beg-ml))) Rquote close-quote) - (setq c-old-beg-rs (progn (goto-char beg) (c-raw-string-pos)) - c-old-end-rs (progn (goto-char end) (c-raw-string-pos))) (cond - ;; We're not changing, or we're obliterating raw strings. - ((and (null c-old-beg-rs) (null c-old-end-rs))) - ;; We're changing the putative terminating delimiter of a raw string + ;; We're not changing, or we're obliterating ml strings. + ((and (null c-beg-pos) (null c-end-pos))) + ;; We're changing the putative terminating delimiter of an ml string ;; containing BEG. - ((and c-old-beg-rs term-del - (or (null (nth 3 c-old-beg-rs)) - (<= (car term-del) (nth 3 c-old-beg-rs)))) - (setq Rquote (1- (cadr c-old-beg-rs)) - close-quote (1+ (cdr term-del))) - (setq c-raw-string-end-delim-disrupted t) - (c-depropertize-raw-strings-in-region Rquote close-quote) + ((and c-beg-pos term-del + (or (null (cdr c-old-beg-ml)) + (<= (car term-del) (cadr c-old-beg-ml)))) + (setq Rquote (caar c-old-beg-ml) + close-quote (cdr term-del)) + (setq c-ml-string-end-delim-disrupted t) + (c-depropertize-ml-strings-in-region Rquote close-quote) (setq c-new-BEG (min c-new-BEG Rquote) c-new-END (max c-new-END close-quote))) ;; We're breaking an escaped NL in a raw string in a macro. - ((and c-old-end-rs + ((and c-old-end-ml (< beg end) (goto-char end) (eq (char-before) ?\\) (c-beginning-of-macro)) (let ((bom (point)) (eom (progn (c-end-of-macro) (point)))) - (c-depropertize-raw-strings-in-region bom eom) + (c-depropertize-ml-strings-in-region bom eom) (setq c-new-BEG (min c-new-BEG bom) c-new-END (max c-new-END eom)))) ;; We're changing only the contents of a raw string. - ((and (equal (cdr c-old-beg-rs) (cdr c-old-end-rs)) - (null (car c-old-beg-rs)) (null (car c-old-end-rs)))) + ;; Any critical deletion of "s will be handled in + ;; `c-after-change-unmark-ml-strings'. + ((and (equal c-old-beg-ml c-old-end-ml) + (eq c-beg-pos 'string) (eq c-end-pos 'string))) ((or ;; We're removing (at least part of) the R" of the starting delim of a ;; raw string: - (null c-old-beg-rs) - (and (eq beg (cadr c-old-beg-rs)) + (null c-old-beg-ml) + (and (eq beg (caar c-old-beg-ml)) (< beg end)) ;; Or we're removing the ( of the starting delim of a raw string. - (and (eq (car c-old-beg-rs) 'open-delim) - (or (null c-old-end-rs) - (not (eq (car c-old-end-rs) 'open-delim)) - (not (equal (cdr c-old-beg-rs) (cdr c-old-end-rs)))))) - (let ((close (nth 4 (or c-old-end-rs c-old-beg-rs)))) - (setq Rquote (1- (cadr (or c-old-end-rs c-old-beg-rs))) - close-quote (if close (1+ close) (point-max)))) - (c-depropertize-raw-strings-in-region Rquote close-quote) + (and (eq c-beg-pos 'open-delim) + (or (null c-old-end-ml) + (not (eq c-end-pos 'open-delim)) + (not (equal c-old-beg-ml c-old-end-ml)))) + ;; Or we're disrupting a starting delim by typing into it, or removing + ;; characters from it. + (and (eq c-beg-pos 'open-delim) + (eq c-end-pos 'open-delim) + (equal c-old-beg-ml c-old-end-ml))) + (let ((close (caddr (or c-old-end-ml c-old-beg-ml)))) + (setq Rquote (caar (or c-old-end-ml c-old-beg-ml)) + close-quote (or close (point-max)))) + (c-depropertize-ml-strings-in-region Rquote close-quote) (setq c-new-BEG (min c-new-BEG Rquote) - c-new-END (max c-new-END close-quote))) - ;; We're changing only the text of the identifier of the opening - ;; delimiter of a raw string. - ((and (eq (car c-old-beg-rs) 'open-delim) - (equal c-old-beg-rs c-old-end-rs)))))) - -(defun c-propertize-raw-string-id (start end) - ;; If the raw string identifier between buffer positions START and END - ;; contains any double quote characters, put a punctuation syntax-table text - ;; property on them. The return value is of no significance. - (save-excursion - (goto-char start) - (while (and (skip-chars-forward "^\"" end) - (< (point) end)) - (c-put-char-property (point) 'syntax-table '(1)) - (c-truncate-lit-pos-cache (point)) - (forward-char)))) + c-new-END (max c-new-END close-quote)))))) -(defun c-propertize-raw-string-opener (id open-quote open-paren bound) - ;; Point is immediately after a raw string opening delimiter. Apply any - ;; pertinent `syntax-table' text properties to the delimiter and also the - ;; raw string, should there be a valid matching closing delimiter. - ;; - ;; ID, a string, is the delimiter's identifier. OPEN-QUOTE and OPEN-PAREN - ;; are the buffer positions of the delimiter's components. BOUND is the - ;; bound for searching for a matching closing delimiter; it is usually nil, - ;; but if we're inside a macro, it's the end of the macro (i.e. the position - ;; of the closing newline). - ;; - ;; Point is moved to after the (terminated) raw string and t is returned, or - ;; it is left after the unmatched opening delimiter and nil is returned. - (c-propertize-raw-string-id (1+ open-quote) open-paren) - (prog1 - (if (search-forward (concat ")" id "\"") bound t) - (let ((end-string (match-beginning 0)) - (after-quote (match-end 0))) - (c-propertize-raw-string-id - (1+ (match-beginning 0)) (1- (match-end 0))) - (goto-char open-paren) - (while (progn (skip-syntax-forward "^\"" end-string) - (< (point) end-string)) - (c-put-char-property (point) 'syntax-table '(1)) ; punctuation - (c-truncate-lit-pos-cache (point)) - (forward-char)) - (goto-char after-quote) - t) - (c-put-char-property open-quote 'syntax-table '(1)) ; punctuation - (c-truncate-lit-pos-cache open-quote) - (c-put-char-property open-paren 'syntax-table '(15)) ; generic string - (when bound - ;; In a CPP construct, we try to apply a generic-string - ;; `syntax-table' text property to the last possible character in - ;; the string, so that only characters within the macro get - ;; "stringed out". - (goto-char bound) - (if (save-restriction - (narrow-to-region (1+ open-paren) (point-max)) - (re-search-backward - (eval-when-compile - ;; This regular expression matches either an escape pair - ;; (which isn't an escaped NL) (submatch 5) or a - ;; non-escaped character (which isn't itself a backslash) - ;; (submatch 10). The long preambles to these - ;; (respectively submatches 2-4 and 6-9) ensure that we - ;; have the correct parity for sequences of backslashes, - ;; etc.. - (concat "\\(" ; 1 - "\\(\\`[^\\]?\\|[^\\][^\\]\\)\\(\\\\\\(.\\|\n\\)\\)*" ; 2-4 - "\\(\\\\.\\)" ; 5 - "\\|" - "\\(\\`\\|[^\\]\\|\\(\\`[^\\]?\\|[^\\][^\\]\\)\\(\\\\\\(.\\|\n\\)\\)+\\)" ; 6-9 - "\\([^\\]\\)" ; 10 - "\\)" - "\\(\\\\\n\\)*\\=")) ; 11 - (1+ open-paren) t)) - (if (match-beginning 10) - (progn - (c-put-char-property (match-beginning 10) 'syntax-table '(15)) - (c-truncate-lit-pos-cache (match-beginning 10))) - (c-put-char-property (match-beginning 5) 'syntax-table '(1)) - (c-put-char-property (1+ (match-beginning 5)) 'syntax-table '(15)) - (c-truncate-lit-pos-cache (1+ (match-beginning 5)))) - ;; (c-put-char-property open-paren 'syntax-table '(1)) - ) - (goto-char bound)) - nil))) - -(defun c-after-change-unmark-raw-strings (beg end _old-len) - ;; This function removes `syntax-table' text properties from any raw strings +(defun c-after-change-unmark-ml-strings (beg end old-len) + ;; This function removes `syntax-table' text properties from any ml strings ;; which have been affected by the current change. These are those which - ;; have been "stringed out" and from newly formed raw strings, or any - ;; existing raw string which the new text terminates. BEG, END, and - ;; _OLD-LEN are the standard arguments supplied to any + ;; have been "stringed out" and from newly formed ml strings, or any + ;; existing ml string which the new text terminates. BEG, END, and + ;; OLD-LEN are the standard arguments supplied to any ;; after-change-function. ;; ;; Point is undefined on both entry and exit, and the return value has no ;; significance. ;; ;; This functions is called as an after-change function by virtue of its - ;; membership of the C++ value of `c-before-font-lock-functions'. + ;; membership of the mode's value of `c-before-font-lock-functions'. ;; (when (< beg end) - (c-save-buffer-state (found eoll state id found-beg) - ;; Has an inserted " swallowed up a R"(, turning it into "...R"(? + ;; + ;; Maintainers' note: Be careful with the use of `c-old-beg-ml' and + ;; `c-old-end-ml'; since text has been inserted or removed, most of the + ;; components in these variables will no longer be valid. (caar + ;; c-old-beg-ml) is normally OK, (cadar c-old-beg-ml) often is, any others + ;; will need adjstments. + (c-save-buffer-state (found eoll state opener) + ;; Has an inserted " swallowed up a R"(, turning it into "...R"(? + (goto-char end) + (setq eoll (c-point 'eoll)) + (when (and (null c-old-END-literality) + (search-forward-regexp c-ml-string-opener-re eoll t)) + (setq state (c-semi-pp-to-literal end)) + (when (eq (cadr state) 'string) + (unwind-protect + ;; Temporarily insert a closing string delimiter.... + (progn + (goto-char end) + (cond + ((c-characterp (nth 3 (car state))) + (insert (nth 3 (car state)))) + ((eq (nth 3 (car state)) t) + (insert ?\") + (c-put-char-property end 'syntax-table '(15)))) + (c-truncate-lit-pos-cache end) + ;; ....ensure c-new-END extends right to the end of the about + ;; to be un-stringed raw string.... + (save-excursion + (goto-char (1+ (match-end 1))) ; Count inserted " too. + (setq c-new-END + (max c-new-END + (if (re-search-forward + (funcall c-make-ml-string-closer-re-function + (match-string-no-properties 1)) + nil t) + (1- (match-end 1)) ; 1- For the inserted ". + eoll)))) + + ;; ...and clear `syntax-table' text propertes from the + ;; following raw strings. + (c-depropertize-ml-strings-in-region (point) (1+ eoll))) + ;; Remove the temporary string delimiter. + (goto-char end) + (delete-char 1) + (c-truncate-lit-pos-cache end)))) + + ;; Have we just created a new starting id? + (goto-char beg) + (setq opener + (if (eq beg end) + (c-ml-string-opener-at-or-around-point end) + (c-ml-string-opener-intersects-region beg end))) + (when + (and opener (<= (car opener) end) + (setq state (c-semi-pp-to-literal (car opener))) + (not (cadr state))) + (setq c-new-BEG (min c-new-BEG (car opener))) + (goto-char (cadr opener)) + (when (re-search-forward + (funcall c-make-ml-string-closer-re-function + (buffer-substring-no-properties + (car opener) (cadr opener))) + nil t) ; No bound + (setq c-new-END (max c-new-END (match-end 1)))) + (goto-char c-new-BEG) + (while (c-search-forward-char-property-with-value-on-char + 'syntax-table '(15) ?\" c-new-END) + (c-remove-string-fences (1- (point)))) + (c-depropertize-ml-strings-in-region c-new-BEG c-new-END)) + + ;; Have we matched up with an existing terminator by typing into or + ;; deleting from an opening delimiter? ... or by messing up a raw string's + ;; terminator so that it now matches a later terminator? + (when + (cond + ((or c-ml-string-end-delim-disrupted + (and c-old-beg-ml + (eq c-beg-pos 'open-delim))) + (goto-char (caar c-old-beg-ml))) + ((and (< beg end) + (not c-old-beg-ml) + c-old-1-beg-ml + (save-excursion + (goto-char (1- beg)) + (c-ml-string-back-to-neutral (caar c-old-1-beg-ml)) + (re-search-forward + (funcall c-make-ml-string-closer-re-function + (buffer-substring-no-properties + (caar c-old-1-beg-ml) + (cadar c-old-1-beg-ml))) + nil 'bound) + (> (point) beg))) + (goto-char (caar c-old-1-beg-ml)) + (setq c-new-BEG (min c-new-BEG (point))) + (c-truncate-lit-pos-cache (point)))) + + (when (looking-at c-ml-string-opener-re) + (goto-char (match-end 1)) + (when (re-search-forward (funcall c-make-ml-string-closer-re-function + (match-string-no-properties 1)) + nil t) ; No bound + ;; If what is to be the new delimiter was previously an unterminated + ;; ordinary string, clear the c-fl-syn-tab properties from this old + ;; string. + (when (c-get-char-property (match-beginning 2) 'c-fl-syn-tab) + (c-remove-string-fences (match-beginning 2))) + (setq c-new-END (point-max)) + (c-clear-char-properties (caar (or c-old-beg-ml c-old-1-beg-ml)) + c-new-END + 'syntax-table) + (c-truncate-lit-pos-cache + (caar (or c-old-beg-ml c-old-1-beg-ml)))))) + + ;; Have we disturbed the innards of an ml string, possibly by deleting "s? + (when (and + c-old-beg-ml + (eq c-beg-pos 'string) + (eq beg end)) + (goto-char beg) + (c-ml-string-back-to-neutral (caar c-old-beg-ml)) + (let ((bound (if (cdr c-old-end-ml) + (min (+ (- (caddr c-old-end-ml) old-len) + c-ml-string-max-closer-len-no-leader) + (point-max)) + (point-max))) + (new-END-end-ml-string + (if (cdr c-old-end-ml) + (- (caddr c-old-end-ml) old-len) + (point-max)))) + (when (and + (re-search-forward + (funcall c-make-ml-string-closer-re-function + (buffer-substring-no-properties + (caar c-old-beg-ml) (cadar c-old-beg-ml))) + bound 'bound) + (< (match-end 1) new-END-end-ml-string)) + (setq c-new-END (max new-END-end-ml-string c-new-END)) + (c-clear-char-properties (caar c-old-beg-ml) c-new-END + 'syntax-table) + (setq c-new-BEG (min (caar c-old-beg-ml) c-new-BEG)) + (c-truncate-lit-pos-cache (caar c-old-beg-ml))))) + + ;; Have we terminated an existing raw string by inserting or removing + ;; text? + (when + (and + (< beg end) + (eq c-old-END-literality 'string) + c-old-beg-ml) + ;; Have we just made or modified a closing delimiter? (goto-char end) - (setq eoll (c-point 'eoll)) - (when (and (null c-old-END-literality) - (search-forward-regexp c-c++-raw-string-opener-re eoll t)) - (setq state (c-semi-pp-to-literal end)) - (when (eq (cadr state) 'string) - (unwind-protect - ;; Temporarily insert a closing string delimiter.... - (progn - (goto-char end) - (cond - ((c-characterp (nth 3 (car state))) - (insert (nth 3 (car state)))) - ((eq (nth 3 (car state)) t) - (insert ?\") - (c-put-char-property end 'syntax-table '(15)))) - (c-truncate-lit-pos-cache end) - ;; ....ensure c-new-END extends right to the end of the about - ;; to be un-stringed raw string.... - (save-excursion - (goto-char (match-beginning 1)) - (let ((end-bs (c-raw-string-pos))) - (setq c-new-END - (max c-new-END - (if (nth 4 end-bs) - (1+ (nth 4 end-bs)) - eoll))))) - - ;; ...and clear `syntax-table' text propertes from the - ;; following raw strings. - (c-depropertize-raw-strings-in-region (point) (1+ eoll))) - ;; Remove the temporary string delimiter. - (goto-char end) - (delete-char 1)))) - - ;; Have we just created a new starting id? - (goto-char (max (- beg 18) (point-min))) + (c-ml-string-back-to-neutral (caar c-old-beg-ml)) (while (and (setq found - (search-forward-regexp c-c++-raw-string-opener-re - c-new-END 'bound)) - (<= (match-end 0) beg))) + (search-forward-regexp + c-ml-string-any-closer-re + (+ (c-point 'eol end) + (1- c-ml-string-max-closer-len-no-leader)) + t)) + (< (match-end 1) beg)) + (goto-char (match-end 1))) (when (and found (<= (match-beginning 0) end)) - (setq c-new-BEG (min c-new-BEG (match-beginning 0))) - (c-depropertize-raw-strings-in-region c-new-BEG c-new-END)) - - ;; Have we invalidated an opening delimiter by typing into it? - (when (and c-old-beg-rs - (eq (car c-old-beg-rs) 'open-delim) - (equal (c-get-char-property (cadr c-old-beg-rs) - 'syntax-table) - '(1))) - (goto-char (1- (cadr c-old-beg-rs))) - (unless (looking-at c-c++-raw-string-opener-re) - (c-clear-char-property (1+ (point)) 'syntax-table) - (c-truncate-lit-pos-cache (1+ (point))) - (if (c-search-forward-char-property 'syntax-table '(15) - (c-point 'eol)) - (c-clear-char-property (1- (point)) 'syntax-table)))) - - ;; Have we matched up with an existing terminator by typing into an - ;; opening delimiter? ... or by messing up a raw string's terminator so - ;; that it now matches a later terminator? - (when - (or c-raw-string-end-delim-disrupted - (and c-old-beg-rs - (eq (car c-old-beg-rs) 'open-delim))) - (goto-char (cadr c-old-beg-rs)) - (when (looking-at c-c++-raw-string-opener-1-re) - (setq id (match-string-no-properties 1)) - (when (search-forward (concat ")" id "\"") nil t) ; No bound. - (setq c-new-END (point-max)) - (c-clear-char-properties (cadr c-old-beg-rs) c-new-END - 'syntax-table) - (c-truncate-lit-pos-cache (cadr c-old-beg-rs))))) - ;; Have we terminated an existing raw string by inserting or removing - ;; text? - (when (eq c-old-END-literality 'string) - ;; Have we just made or modified a closing delimiter? - (goto-char (max (- beg 18) (point-min))) - (while - (and - (setq found - (search-forward-regexp ")\\([^ ()\\\n\r\t]\\{0,16\\}\\)\"" - (+ end 17) t)) - (< (match-end 0) beg))) - (when (and found (<= (match-beginning 0) end)) - (setq id (match-string-no-properties 1)) - (goto-char (match-beginning 0)) + (let ((opener-re (funcall c-make-ml-string-opener-re-function + (match-string 1)))) (while (and - (setq found (search-backward (concat "R\"" id "(") nil t)) + (setq found (re-search-backward opener-re nil t)) (setq state (c-semi-pp-to-literal (point))) - (memq (nth 3 (car state)) '(t ?\")))) - (when found - (setq c-new-BEG (min (point) c-new-BEG) - c-new-END (point-max)) - (c-clear-syn-tab-properties (point) c-new-END) - (c-truncate-lit-pos-cache (point))))) - - ;; Are there any raw strings in a newly created macro? - (when (< beg end) - (goto-char beg) - (setq found-beg (point)) - (when (search-forward-regexp c-anchored-cpp-prefix end t) + (memq (nth 3 (car state)) '(t ?\"))))) + (when found + (setq c-new-BEG (min (point) c-new-BEG) + c-new-END (point-max)) + (c-clear-syn-tab-properties (point) c-new-END) + (c-truncate-lit-pos-cache (point))))) + + ;; Are there any raw strings in a newly created macro? + (goto-char (c-point 'bol beg)) + (while (and (< (point) (c-point 'eol end)) + (re-search-forward c-anchored-cpp-prefix (c-point 'eol end) + 'boundt)) + (when (and (<= beg (match-end 1)) + (>= end (match-beginning 1))) + (goto-char (match-beginning 1)) (c-end-of-macro) - (c-depropertize-raw-strings-in-region found-beg (point)))))) + (c-depropertize-ml-strings-in-region + (match-beginning 1) (point)))))) -(defun c-maybe-re-mark-raw-string () +(defun c-maybe-re-mark-ml-string () ;; When this function is called, point is immediately after a " which opens - ;; a string. If this " is the characteristic " of a raw string - ;; opener, apply the pertinent `syntax-table' text properties to the - ;; entire raw string (when properly terminated) or just the delimiter - ;; (otherwise). In either of these cases, return t, otherwise return nil. - ;; - (let (in-macro macro-end) + ;; a string. If this " is the characteristic " of a multi-line string + ;; opener, apply the pertinent `syntax-table' text properties to the entire + ;; ml string (when properly terminated) or just the delimiter (otherwise). + ;; In either of these cases, return t, otherwise return nil. Point is moved + ;; to after the terminated raw string, or to the end of the containing + ;; macro, or to point-max. + ;; + (let (delim in-macro macro-end) (when (and - (eq (char-before (1- (point))) ?R) - (looking-at "\\([^ ()\\\n\r\t]\\{0,16\\}\\)(")) + (setq delim (c-ml-string-opener-at-or-around-point (1- (point)))) + (save-excursion + (goto-char (car delim)) + (not (c-in-literal)))) (save-excursion (setq in-macro (c-beginning-of-macro)) (setq macro-end (when in-macro (c-end-of-macro) - (point) ;; (min (1+ (point)) (point-max)) + (point) ))) (when (not - (c-propertize-raw-string-opener - (match-string-no-properties 1) ; id - (1- (point)) ; open quote - (match-end 1) ; open paren - macro-end)) ; bound (end of macro) or nil. + (c-propertize-ml-string-opener + delim + macro-end)) ; bound (end of macro) or nil. (goto-char (or macro-end (point-max)))) t))) +(defun c-propertize-ml-string-id (delim) + ;; Apply punctuation ('(1)) syntax-table text properties to the opening or + ;; closing delimiter given by the three element dotted list DELIM, such that + ;; its "total syntactic effect" is that of a single ". + (save-excursion + (goto-char (car delim)) + (while (and (skip-chars-forward c-ml-string-non-punc-skip-chars + (cadr delim)) + (< (point) (cadr delim))) + (when (not (eq (point) (cddr delim))) + (c-put-char-property (point) 'syntax-table '(1)) + (c-truncate-lit-pos-cache (point))) + (forward-char)))) + +(defun c-propertize-ml-string-opener (delim bound) + ;; DELIM defines the opening delimiter of a multi-line string in the + ;; way returned by `c-ml-string-opener-around-point'. Apply any + ;; pertinent `syntax-table' text properties to this opening delimiter and in + ;; the case of a terminated ml string, also to the innards of the string and + ;; the terminating delimiter. + ;; + ;; BOUND is the end of the macro we're inside (i.e. the position of the + ;; closing newline), if any, otherwise nil. + ;; + ;; Point is undefined at the function start. For a terminated ml string, + ;; point is left after the terminating delimiter and t is returned. For an + ;; unterminated string, point is left at the end of the macro, if any, or + ;; after the unmatched opening delimiter, and nil is returned. + (c-propertize-ml-string-id delim) + (goto-char (cadr delim)) + (if (re-search-forward + (funcall c-make-ml-string-closer-re-function + (buffer-substring-no-properties + (car delim) (cadr delim))) + bound t) + + (let ((end-delim + (cons (match-beginning 1) + (cons (match-end 1) (match-beginning 2))))) + (c-propertize-ml-string-id end-delim) + (goto-char (cadr delim)) + (while (progn (skip-syntax-forward c-ml-string-non-punc-skip-chars + (car end-delim)) + (< (point) (car end-delim))) + (c-put-char-property (point) 'syntax-table '(1)) ; punctuation + (c-truncate-lit-pos-cache (point)) + (forward-char)) + (goto-char (cadr end-delim)) + t) + (c-put-char-property (cddr delim) 'syntax-table '(1)) + (c-put-char-property (1- (cadr delim)) 'syntax-table '(15)) + (c-truncate-lit-pos-cache (1- (cddr delim))) + (when bound + ;; In a CPP construct, we try to apply a generic-string + ;; `syntax-table' text property to the last possible character in + ;; the string, so that only characters within the macro get + ;; "stringed out". + (goto-char bound) + (if (save-restriction + (narrow-to-region (cadr delim) (point-max)) + (re-search-backward + (eval-when-compile + ;; This regular expression matches either an escape pair + ;; (which isn't an escaped NL) (submatch 5) or a + ;; non-escaped character (which isn't itself a backslash) + ;; (submatch 10). The long preambles to these + ;; (respectively submatches 2-4 and 6-9) ensure that we + ;; have the correct parity for sequences of backslashes, + ;; etc.. + (concat "\\(" ; 1 + "\\(\\`[^\\]?\\|[^\\][^\\]\\)\\(\\\\\\(.\\|\n\\)\\)*" ; 2-4 + "\\(\\\\.\\)" ; 5 + "\\|" + "\\(\\`\\|[^\\]\\|\\(\\`[^\\]?\\|[^\\][^\\]\\)\\(\\\\\\(.\\|\n\\)\\)+\\)" ; 6-9 + "\\([^\\]\\)" ; 10 + "\\)" + "\\(\\\\\n\\)*\\=")) ; 11 + (cadr delim) t)) + (if (match-beginning 10) + (progn + (c-put-char-property (match-beginning 10) 'syntax-table '(15)) + (c-truncate-lit-pos-cache (match-beginning 10))) + (c-put-char-property (match-beginning 5) 'syntax-table '(1)) + (c-put-char-property (1+ (match-beginning 5)) 'syntax-table '(15)) + (c-truncate-lit-pos-cache (match-beginning 5)))) + (goto-char bound)) + nil)) + +(defvar c-neutralize-pos nil) + ;; Buffer position of character neutralized by punctuation syntax-table + ;; text property ('(1)), or nil if there's no such character. +(defvar c-neutralized-prop nil) + ;; syntax-table text property that was on the character at + ;; `c-neutralize-pos' before it was replaced with '(1), or nil if none. + +(defun c-depropertize-ml-string (string-delims bound) + ;; Remove any `syntax-table' text properties associated with the opening + ;; delimiter of a multi-line string (if it's unmatched) or with the entire + ;; string. Exception: A single punctuation ('(1)) property will be left on + ;; a string character to make the entire set of multi-line strings + ;; syntactically neutral. This is done using the global variable + ;; `c-neutralize-pos', the position of this property (or nil if there is + ;; none). + ;; + ;; STRING-DELIMS, of the form of the output from + ;; `c-ml-string-delims-around-point' defines the current ml string. BOUND + ;; is the bound for searching for a matching closing delimiter; it is + ;; usually nil, but if we're inside a macro, it's the end of the macro + ;; (i.e. just before the terminating \n). + ;; + ;; Point is undefined on input, and is moved to after the (terminated) raw + ;; string, or left after the unmatched opening delimiter, as the case may + ;; be. The return value is of no significance. + + ;; Handle the special case of a closing " previously having been an + ;; unterminated ordinary string. + (when + (and + (cdr string-delims) + (equal (c-get-char-property (cdddr string-delims) ; pos of closing ". + 'syntax-table) + '(15))) + (goto-char (cdddr string-delims)) + (when (c-safe (c-forward-sexp)) ; To '(15) at EOL. + (c-clear-char-property (1- (point)) 'syntax-table) + (c-truncate-lit-pos-cache (1- (point))))) + ;; The '(15) in the closing delimiter will be cleared by the following. + + (c-depropertize-ml-string-delims string-delims) + (let ((bound1 (if (cdr string-delims) + (caddr string-delims) ; end of closing delimiter. + bound)) + first s) + (if (and + bound1 + (setq first (c-clear-char-properties (cadar string-delims) bound1 + 'syntax-table))) + (c-truncate-lit-pos-cache first)) + (setq s (parse-partial-sexp (or c-neutralize-pos (caar string-delims)) + (or bound1 (point-max)))) + (cond + ((not (nth 3 s))) ; Nothing changed by this ml-string. + ((not c-neutralize-pos) ; "New" unbalanced quote in this ml-s. + (setq c-neutralize-pos (nth 8 s)) + (setq c-neutralized-prop (c-get-char-property c-neutralize-pos + 'syntax-table)) + (c-put-char-property c-neutralize-pos 'syntax-table '(1)) + (c-truncate-lit-pos-cache c-neutralize-pos)) + ((eq (nth 3 s) (char-after c-neutralize-pos)) + ;; New unbalanced quote balances old one. + (if c-neutralized-prop + (c-put-char-property c-neutralize-pos 'syntax-table + c-neutralized-prop) + (c-clear-char-property c-neutralize-pos 'syntax-table)) + (c-truncate-lit-pos-cache c-neutralize-pos) + (setq c-neutralize-pos nil)) + ;; New unbalanced quote doesn't balance old one. Nothing to do. + ))) + +(defun c-depropertize-ml-strings-in-region (start finish) + ;; Remove any `syntax-table' text properties associated with multi-line + ;; strings contained in the region (START FINISH). Point is undefined at + ;; entry and exit, and the return value has no significance. + (setq c-neutralize-pos nil) + (goto-char start) + (while (and (< (point) finish) + (re-search-forward + c-ml-string-cpp-or-opener-re + finish t)) + (if (match-beginning (+ c-cpp-or-ml-match-offset 1)) ; opening delimiter + ;; We've found a raw string + (let ((open-delim + (cons (match-beginning (+ c-cpp-or-ml-match-offset 1)) + (cons (match-end (+ c-cpp-or-ml-match-offset 1)) + (match-beginning (+ c-cpp-or-ml-match-offset 2)))))) + (c-depropertize-ml-string + (cons open-delim + (when + (and + (re-search-forward + (funcall c-make-ml-string-closer-re-function + (match-string-no-properties + (+ c-cpp-or-ml-match-offset 1))) + (min (+ finish c-ml-string-max-closer-len-no-leader) + (point-max)) + t) + (<= (match-end 1) finish)) + (cons (match-beginning 1) + (cons (match-end 1) (match-beginning 2))))) + nil)) ; bound + ;; We've found a CPP construct. Search for raw strings within it. + (goto-char (match-beginning 2)) ; the "#" + (c-end-of-macro) + (let ((eom (point))) + (goto-char (match-end 2)) ; after the "#". + (while (and (< (point) eom) + (c-syntactic-re-search-forward + c-ml-string-opener-re eom t)) + (save-excursion + (let ((open-delim (cons (match-beginning 1) + (cons (match-end 1) + (match-beginning 2))))) + (c-depropertize-ml-string + (cons open-delim + (when (re-search-forward + (funcall c-make-ml-string-closer-re-function + (match-string-no-properties 1)) + eom t) + (cons (match-beginning 1) + (cons (match-end 1) (match-beginning 2))))) + eom))))))) ; bound. + (when c-neutralize-pos + (if c-neutralized-prop + (c-put-char-property c-neutralize-pos 'syntax-table + c-neutralized-prop) + (c-clear-char-property c-neutralize-pos 'syntax-table)) + (c-truncate-lit-pos-cache c-neutralize-pos))) + ;; Handling of small scale constructs like types and names. @@ -7771,6 +8189,7 @@ comment at the start of cc-engine.el for more info." (defvar c-last-identifier-range nil) (defmacro c-record-type-id (range) + (declare (debug t)) (if (eq (car-safe range) 'cons) ;; Always true. `(setq c-record-type-identifiers @@ -7781,6 +8200,7 @@ comment at the start of cc-engine.el for more info." (cons range c-record-type-identifiers)))))) (defmacro c-record-ref-id (range) + (declare (debug t)) (if (eq (car-safe range) 'cons) ;; Always true. `(setq c-record-ref-identifiers @@ -7806,6 +8226,7 @@ comment at the start of cc-engine.el for more info." ;; if TYPE is 'type or as a reference if TYPE is 'ref. ;; ;; This macro might do hidden buffer changes. + (declare (debug t)) `(let (res) (setq c-last-identifier-range nil) (while (if (setq res ,(if (eq type 'type) @@ -7830,6 +8251,7 @@ comment at the start of cc-engine.el for more info." ;; `c-forward-keyword-prefixed-id'. ;; ;; This macro might do hidden buffer changes. + (declare (debug t)) `(while (and (progn ,(when update-safe-pos '(setq safe-pos (point))) @@ -8042,13 +8464,14 @@ comment at the start of cc-engine.el for more info." ;; bracket arglist. It's propagated through the return value ;; on successful completion. (c-record-found-types c-record-found-types) + (syntax-table-prop-on-< (c-get-char-property (point) 'syntax-table)) ;; List that collects the positions after the argument ;; separating ',' in the arglist. arg-start-pos) ;; If the '<' has paren open syntax then we've marked it as an angle ;; bracket arglist before, so skip to the end. (if (and (not c-parse-and-markup-<>-arglists) - (c-get-char-property (point) 'syntax-table)) + syntax-table-prop-on-<) (progn (forward-char) @@ -8133,8 +8556,20 @@ comment at the start of cc-engine.el for more info." (c-put-c-type-property (1- (car arg-start-pos)) 'c-<>-arg-sep) (setq arg-start-pos (cdr arg-start-pos))) + (when (and (not syntax-table-prop-on-<) + (c-get-char-property (1- (point)) + 'syntax-table)) + ;; Clear the now spuriously matching < of its + ;; syntax-table property. This could happen on + ;; inserting "_cast" into "static <" with C-y. + (save-excursion + (and (c-go-list-backward) + (eq (char-after) ?<) + (c-truncate-lit-pos-cache (point)) + (c-unmark-<->-as-paren (point))))) (c-mark-<-as-paren start) - (c-mark->-as-paren (1- (point)))) + (c-mark->-as-paren (1- (point))) + (c-truncate-lit-pos-cache start)) (setq res t) nil)) ; Exit the loop. @@ -8298,7 +8733,7 @@ comment at the start of cc-engine.el for more info." ;; o - nil if no name is found; ;; o - 'template if it's an identifier ending with an angle bracket ;; arglist; - ;; o - 'operator of it's an operator identifier; + ;; o - 'operator if it's an operator identifier; ;; o - t if it's some other kind of name. ;; ;; This function records identifier ranges on @@ -8318,6 +8753,7 @@ comment at the start of cc-engine.el for more info." (lim+ (c-determine-+ve-limit 500))) (while (and + (< (point) lim+) (looking-at c-identifier-key) (progn @@ -8367,23 +8803,28 @@ comment at the start of cc-engine.el for more info." ;; '*', '&' or a name followed by ":: *", ;; where each can be followed by a sequence ;; of `c-opt-type-modifier-key'. - (while (cond ((looking-at "[*&]") - (goto-char (match-end 0)) - t) - ((looking-at c-identifier-start) - (and (c-forward-name) - (looking-at "::") - (progn - (goto-char (match-end 0)) - (c-forward-syntactic-ws lim+) - (eq (char-after) ?*)) - (progn - (forward-char) - t)))) + (while + (and + (< (point) lim+) + (cond ((looking-at "[*&]") + (goto-char (match-end 0)) + t) + ((looking-at c-identifier-start) + (and (c-forward-name) + (looking-at "::") + (progn + (goto-char (match-end 0)) + (c-forward-syntactic-ws lim+) + (eq (char-after) ?*)) + (progn + (forward-char) + t))))) (while (progn (c-forward-syntactic-ws lim+) (setq pos (point)) - (looking-at c-opt-type-modifier-key)) + (and + (<= (point) lim+) + (looking-at c-opt-type-modifier-key))) (goto-char (match-end 1)))))) ((looking-at c-overloadable-operators-regexp) @@ -8429,6 +8870,9 @@ comment at the start of cc-engine.el for more info." ;; Maybe an angle bracket arglist. (when (let (c-last-identifier-range) (c-forward-<>-arglist nil)) + ;; <> arglists can legitimately be very long, so recalculate + ;; `lim+'. + (setq lim+ (c-determine-+ve-limit 500)) (c-forward-syntactic-ws lim+) (unless (eq (char-after) ?\() @@ -8764,6 +9208,7 @@ comment at the start of cc-engine.el for more info." (defmacro c-pull-open-brace (ps) ;; Pull the next open brace from PS (which has the form of paren-state), ;; skipping over any brace pairs. Returns NIL when PS is exhausted. + (declare (debug (symbolp))) `(progn (while (consp (car ,ps)) (setq ,ps (cdr ,ps))) @@ -8879,6 +9324,7 @@ comment at the start of cc-engine.el for more info." ;; a comma. If either of <symbol> or bracketed <expression> is missing, ;; throw nil to 'level. If the terminating } or ) is unmatched, throw nil ;; to 'done. This is not a general purpose macro! + (declare (debug t)) `(while (eq (char-before) ?,) (backward-char) (c-backward-syntactic-ws ,limit) @@ -9272,6 +9718,7 @@ This function might do hidden buffer changes." ;; sometimes consumes the identifier in the declaration as a type. ;; This is used to "backtrack" and make the last type be treated as ;; an identifier instead. + (declare (debug nil)) `(progn ,(unless short ;; These identifiers are bound only in the inner let. @@ -11419,7 +11866,9 @@ comment at the start of cc-engine.el for more info." ;; 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)))))) + (looking-at c-type-decl-prefix-key) + (and (eq (char-after) ?{) + (not (c-looking-at-statement-block)))))))) ;; In Pike a list of modifiers may be followed by a brace ;; to make them apply to many identifiers. Note that the @@ -11826,15 +12275,17 @@ comment at the start of cc-engine.el for more info." ;; POINT, or nil if there is no such position, or we do not know it. LIM is ;; a backward search limit. ;; - ;; The determination of whether the brace starts a brace list is solely by - ;; the context of the brace, not by its contents. + ;; The determination of whether the brace starts a brace list is mainly by + ;; the context of the brace, not by its contents. In exceptional + ;; circumstances (e.g. "struct A {" in C++ Mode), the contents are examined, + ;; too. ;; ;; Here, "brace list" does not include the body of an enum. (save-excursion (let ((start (point)) (braceassignp 'dontknow) inexpr-brace-list bufpos macro-start res pos after-type-id-pos - in-paren parens-before-brace + pos2 in-paren parens-before-brace paren-state paren-pos) (setq res (c-backward-token-2 1 t lim)) @@ -11850,12 +12301,16 @@ comment at the start of cc-engine.el for more info." (goto-char paren-pos) (setq braceassignp 'c++-noassign in-paren 'in-paren)) - ((looking-at c-pre-id-bracelist-key) + ((looking-at c-pre-brace-non-bracelist-key) (setq braceassignp nil)) ((looking-at c-return-key)) ((and (looking-at c-symbol-start) (not (looking-at c-keywords-regexp))) - (setq after-type-id-pos (point))) + (if (save-excursion + (and (zerop (c-backward-token-2 1 t lim)) + (looking-at c-pre-id-bracelist-key))) + (setq braceassignp 'c++-noassign) + (setq after-type-id-pos (point)))) ((eq (char-after) ?\() (setq parens-before-brace t) nil) @@ -11869,8 +12324,13 @@ comment at the start of cc-engine.el for more info." (eq (char-after paren-pos) ?\() (setq in-paren 'in-paren) (goto-char paren-pos))) - ((looking-at c-pre-id-bracelist-key)) + ((looking-at c-pre-brace-non-bracelist-key)) ((looking-at c-return-key)) + ((and (looking-at c-symbol-start) + (not (looking-at c-keywords-regexp)) + (save-excursion + (and (zerop (c-backward-token-2 1 t lim)) + (looking-at c-pre-id-bracelist-key))))) (t (setq after-type-id-pos (point)) nil)))) (setq braceassignp 'c++-noassign)) @@ -11955,8 +12415,12 @@ comment at the start of cc-engine.el for more info." (cond (braceassignp ;; We've hit the beginning of the aggregate list. - (c-beginning-of-statement-1 containing-sexp) - (cons (point) (or in-paren inexpr-brace-list))) + (setq pos2 (point)) + (cons + (if (eq (c-beginning-of-statement-1 containing-sexp) 'same) + (point) + pos2) + (or in-paren inexpr-brace-list))) ((and after-type-id-pos (save-excursion (when (eq (char-after) ?\;) @@ -11968,34 +12432,36 @@ comment at the start of cc-engine.el for more info." (c-get-char-property (point) 'syntax-table)) (c-go-list-forward nil after-type-id-pos) (c-forward-syntactic-ws))) - (and - (or (not (looking-at c-class-key)) - (save-excursion - (goto-char (match-end 1)) - (c-forward-syntactic-ws) - (not (eq (point) after-type-id-pos)))) - (progn - (setq res - (c-forward-decl-or-cast-1 - (save-excursion (c-backward-syntactic-ws) (point)) - nil nil)) - (and (consp res) - (cond - ((eq (car res) after-type-id-pos)) - ((> (car res) after-type-id-pos) nil) - (t - (catch 'find-decl - (save-excursion - (goto-char (car res)) - (c-do-declarators - (point-max) t nil nil - (lambda (id-start _id-end _tok _not-top _func _init) - (cond - ((> id-start after-type-id-pos) - (throw 'find-decl nil)) - ((eq id-start after-type-id-pos) - (throw 'find-decl t))))) - nil))))))))) + (if (and (not (eq (point) after-type-id-pos)) + (or (not (looking-at c-class-key)) + (save-excursion + (goto-char (match-end 1)) + (c-forward-syntactic-ws) + (not (eq (point) after-type-id-pos))))) + (progn + (setq res + (c-forward-decl-or-cast-1 (c-point 'bosws) + nil nil)) + (and (consp res) + (cond + ((eq (car res) after-type-id-pos)) + ((> (car res) after-type-id-pos) nil) + (t + (catch 'find-decl + (save-excursion + (goto-char (car res)) + (c-do-declarators + (point-max) t nil nil + (lambda (id-start _id-end _tok _not-top _func _init) + (cond + ((> id-start after-type-id-pos) + (throw 'find-decl nil)) + ((eq id-start after-type-id-pos) + (throw 'find-decl t))))) + nil)))))) + (save-excursion + (goto-char start) + (not (c-looking-at-statement-block)))))) (cons bufpos (or in-paren inexpr-brace-list))) ((or (eq (char-after) ?\;) ;; Brace lists can't contain a semicolon, so we're done. @@ -12145,33 +12611,31 @@ comment at the start of cc-engine.el for more info." (defun c-looking-at-statement-block () ;; Point is at an opening brace. If this is a statement block (i.e. the ;; elements in the block are terminated by semicolons, or the block is - ;; empty, or the block contains a keyword) return non-nil. Otherwise, - ;; return nil. + ;; empty, or the block contains a characteristic keyword, or there is a + ;; nested statement block) return non-nil. Otherwise, return nil. (let ((here (point))) (prog1 (if (c-go-list-forward) (let ((there (point))) (backward-char) - (c-syntactic-skip-backward "^;," here t) + (c-syntactic-skip-backward "^;" here t) (cond - ((eq (char-before) ?\;) t) - ((eq (char-before) ?,) nil) - (t ; We're at (1+ here). - (cond - ((progn (c-forward-syntactic-ws) - (eq (point) (1- there)))) - ((c-syntactic-re-search-forward c-keywords-regexp there t)) - ((c-syntactic-re-search-forward "{" there t t) - (backward-char) - (c-looking-at-statement-block)) - (t nil))))) + ((eq (char-before) ?\;)) + ((progn (c-forward-syntactic-ws) + (eq (point) (1- there)))) + ((c-syntactic-re-search-forward + c-stmt-block-only-keywords-regexp there t)) + ((c-syntactic-re-search-forward "{" there t t) + (backward-char) + (c-looking-at-statement-block)) + (t nil))) (forward-char) (cond - ((c-syntactic-re-search-forward "[;,]" nil t t) - (eq (char-before) ?\;)) + ((c-syntactic-re-search-forward ";" nil t t)) ((progn (c-forward-syntactic-ws) (eobp))) - ((c-syntactic-re-search-forward c-keywords-regexp nil t t)) + ((c-syntactic-re-search-forward c-stmt-block-only-keywords-regexp + nil t t)) ((c-syntactic-re-search-forward "{" nil t t) (backward-char) (c-looking-at-statement-block)) @@ -12211,7 +12675,7 @@ comment at the start of cc-engine.el for more info." (save-excursion (while (progn - (c-syntactic-skip-backward "^;=}>" closest-lim t) + (c-syntactic-skip-backward "^;=,}>" closest-lim t) (and (eq (char-before) ?>) (c-backward-token-2) (not (looking-at c-haskell-op-re))))) @@ -14658,18 +15122,6 @@ Cannot combine absolute offsets %S and %S in `add' method" indent))) -(def-edebug-spec c-bos-pop-state t) -(def-edebug-spec c-bos-save-error-info t) -(def-edebug-spec c-state-cache-top-lparen t) -(def-edebug-spec c-state-cache-top-paren t) -(def-edebug-spec c-state-cache-after-top-paren t) -(def-edebug-spec c-state-maybe-marker (form symbolp)) -(def-edebug-spec c-record-type-id t) -(def-edebug-spec c-record-ref-id t) -(def-edebug-spec c-forward-keyword-prefixed-id t) -(def-edebug-spec c-forward-id-comma-list t) -(def-edebug-spec c-pull-open-brace (symbolp)) - (cc-provide 'cc-engine) ;; Local Variables: diff --git a/lisp/progmodes/cc-fonts.el b/lisp/progmodes/cc-fonts.el index 4e283764ceb..7e7053b98e1 100644 --- a/lisp/progmodes/cc-fonts.el +++ b/lisp/progmodes/cc-fonts.el @@ -1,4 +1,4 @@ -;;; cc-fonts.el --- font lock support for CC Mode +;;; cc-fonts.el --- font lock support for CC Mode -*- lexical-binding: t -*- ;; Copyright (C) 2002-2021 Free Software Foundation, Inc. @@ -218,6 +218,7 @@ ;; incorrectly. ;; ;; This function does a hidden buffer change. + (declare (debug t)) (if (fboundp 'font-lock-set-face) ;; Note: This function has no docstring in XEmacs so it might be ;; considered internal. @@ -228,6 +229,7 @@ ;; This is the inverse of `c-put-font-lock-face'. ;; ;; This function does a hidden buffer change. + (declare (debug t)) (if (fboundp 'font-lock-remove-face) `(font-lock-remove-face ,from ,to) `(remove-text-properties ,from ,to '(face nil)))) @@ -238,11 +240,13 @@ ;; region should include them. ;; ;; This function does a hidden buffer change. + (declare (debug t)) (if (featurep 'xemacs) `(c-put-font-lock-face (1+ ,from) (1- ,to) 'font-lock-string-face) `(c-put-font-lock-face ,from ,to 'font-lock-string-face))) (defmacro c-fontify-types-and-refs (varlist &rest body) + (declare (indent 1) (debug let*)) ;; Like `let', but additionally activates `c-record-type-identifiers' ;; and `c-record-ref-identifiers', and fontifies the recorded ranges ;; accordingly on exit. @@ -253,7 +257,6 @@ ,@varlist) (prog1 (progn ,@body) (c-fontify-recorded-types-and-refs)))) - (put 'c-fontify-types-and-refs 'lisp-indent-function 1) (defun c-skip-comments-and-strings (limit) ;; If the point is within a region fontified as a comment or @@ -482,20 +485,7 @@ ;; In the next form, check that point hasn't been moved beyond ;; `limit' in any of the above stanzas. ,(c-make-font-lock-search-form (car normal) (cdr normal) t) - nil)))) - -; (eval-after-load "edebug" ; 2006-07-09: def-edebug-spec is now in subr.el. -; '(progn -(def-edebug-spec c-put-font-lock-face t) -(def-edebug-spec c-remove-font-lock-face t) -(def-edebug-spec c-put-font-lock-string-face t) - (def-edebug-spec c-fontify-types-and-refs let*) - (def-edebug-spec c-make-syntactic-matcher t) - ;; If there are literal quoted or backquoted highlight specs in - ;; the call to `c-make-font-lock-search-function' then let's - ;; instrument the forms in them. - (def-edebug-spec c-make-font-lock-search-function - (form &rest &or ("quote" (&rest form)) ("`" (&rest form)) form)));)) + nil))))) (defun c-fontify-recorded-types-and-refs () ;; Convert the ranges recorded on `c-record-type-identifiers' and @@ -791,9 +781,9 @@ casts and declarations are fontified. Used on level 2 and higher." ;; Invalid single quotes. c-font-lock-invalid-single-quotes - ;; Fontify C++ raw strings. - ,@(when (c-major-mode-is 'c++-mode) - '(c-font-lock-raw-strings)) + ;; Fontify multiline strings. + ,@(when (c-lang-const c-ml-string-opener-re) + '(c-font-lock-ml-strings)) ;; Fontify keyword constants. ,@(when (c-lang-const c-constant-kwds) @@ -1679,9 +1669,7 @@ 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 - (when (not (c-back-over-member-initializers - (max (- (point) 2000) (point-min)))) ; c-determine-limit - ; is too slow, here. + (when (not (c-back-over-member-initializers decl-search-lim)) (unless (or (eobp) (looking-at "\\s(\\|\\s)")) (forward-char)) @@ -1749,8 +1737,8 @@ casts and declarations are fontified. Used on level 2 and higher." (c-font-lock-declarators limit t in-typedef (not (c-bs-at-toplevel-p (point))))))))))) -(defun c-font-lock-raw-strings (limit) - ;; Fontify C++ raw strings. +(defun c-font-lock-ml-strings (limit) + ;; Fontify multi-line strings. ;; ;; This function will be called from font-lock for a region bounded by POINT ;; and LIMIT, as though it were to identify a keyword for @@ -1760,52 +1748,75 @@ casts and declarations are fontified. Used on level 2 and higher." (let* ((state (c-semi-pp-to-literal (point))) (string-start (and (eq (cadr state) 'string) (car (cddr state)))) - (raw-id (and string-start - (c-at-c++-raw-string-opener string-start) - (match-string-no-properties 1))) - (content-start (and raw-id (point)))) + (open-delim (and string-start + (save-excursion + (goto-char (1+ string-start)) + (c-ml-string-opener-around-point)))) + (string-delims (and open-delim + (cons open-delim (c-get-ml-closer open-delim)))) + found) ;; We go round the next loop twice per raw string, once for each "end". (while (< (point) limit) - (if raw-id - ;; Search for the raw string end delimiter - (progn - (when (search-forward-regexp (concat ")\\(" (regexp-quote raw-id) "\\)\"") - limit 'limit) - (c-put-font-lock-face content-start (match-beginning 1) - 'font-lock-string-face) - (c-remove-font-lock-face (match-beginning 1) (point))) - (setq raw-id nil)) - ;; Search for the start of a raw string. - (when (search-forward-regexp - "R\\(\"\\)\\([^ ()\\\n\r\t]\\{0,16\\}\\)(" limit 'limit) - (when - ;; Make sure we're not in a comment or string. - (and - (not (memq (c-get-char-property (match-beginning 0) 'face) - '(font-lock-comment-face font-lock-comment-delimiter-face - font-lock-string-face))) - (or (and (eobp) - (eq (c-get-char-property (1- (point)) 'face) - 'font-lock-warning-face)) - (not (eq (c-get-char-property (point) 'face) 'font-lock-comment-face)) - ;; (eq (c-get-char-property (point) 'face) 'font-lock-string-face) - (and (equal (c-get-char-property (match-end 2) 'syntax-table) '(1)) - (equal (c-get-char-property (match-beginning 1) 'syntax-table) - '(1))))) - (let ((paren-prop (c-get-char-property (1- (point)) 'syntax-table))) - (if paren-prop - (progn - (c-put-font-lock-face (match-beginning 0) (match-end 0) - 'font-lock-warning-face) - (when - (and - (equal paren-prop '(15)) - (not (c-search-forward-char-property 'syntax-table '(15) limit))) - (goto-char limit))) - (c-remove-font-lock-face (match-beginning 0) (match-end 2)) - (setq raw-id (match-string-no-properties 2)) - (setq content-start (match-end 0))))))))) - nil) + (cond + ;; Point is not in an ml string + ((not string-delims) + (while (and (setq found (re-search-forward c-ml-string-opener-re + limit 'limit)) + (> (match-beginning 0) (point-min)) + (memq (c-get-char-property (1- (match-beginning 0)) 'face) + '(font-lock-comment-face font-lock-string-face + font-lock-comment-delimiter-face)))) + (when found + (setq open-delim (cons (match-beginning 1) + (cons (match-end 1) (match-beginning 2))) + string-delims (cons open-delim (c-get-ml-closer open-delim))) + (goto-char (caar string-delims)))) + + ;; Point is in the body of an ml string. + ((and string-delims + (>= (point) (cadar string-delims)) + (or (not (cdr string-delims)) + (< (point) (cadr string-delims)))) + (if (cdr string-delims) + (goto-char (cadr string-delims)) + (if (equal (c-get-char-property (1- (cadar string-delims)) + 'syntax-table) + '(15)) ; "Always" the case. + ;; The next search should be successful for an unterminated ml + ;; string inside a macro, but not for any other unterminated + ;; string. + (progn + (or (c-search-forward-char-property 'syntax-table '(15) limit) + (goto-char limit)) + (setq string-delims nil)) + (c-benign-error "Missing '(15) syntax-table property at %d" + (1- (cadar string-delims))) + (setq string-delims nil)))) + + ;; Point is at or in a closing delimiter + ((and string-delims + (cdr string-delims) + (>= (point) (cadr string-delims))) + (c-put-font-lock-face (cadr string-delims) (1+ (cadr string-delims)) + 'font-lock-string-face) + (c-remove-font-lock-face (1+ (cadr string-delims)) + (caddr string-delims)) + (goto-char (caddr string-delims)) + (setq string-delims nil)) + + ;; point is at or in an opening delimiter. + (t + (if (cdr string-delims) + (progn + (c-remove-font-lock-face (caar string-delims) + (1- (cadar string-delims))) + (c-put-font-lock-face (1- (cadar string-delims)) + (cadar string-delims) + 'font-lock-string-face)) + (c-put-font-lock-face (caar string-delims) (cadar string-delims) + 'font-lock-warning-face)) + (goto-char (cadar string-delims))))) + nil)) (defun c-font-lock-c++-lambda-captures (limit) ;; Fontify the lambda capture component of C++ lambda declarations. @@ -2287,7 +2298,7 @@ need for `c-font-lock-extra-types'.") ;; font-lock-keyword-face. It always returns NIL to inhibit this and ;; prevent a repeat invocation. See elisp/lispref page "Search-based ;; fontification". - (let (pos after-name) + (let (pos) (while (c-syntactic-re-search-forward c-using-key limit 'end) (while ; Do one declarator of a comma separated list, each time around. (progn @@ -2295,7 +2306,6 @@ need for `c-font-lock-extra-types'.") (setq pos (point)) ; token after "using". (when (and (c-on-identifier) (c-forward-name)) - (setq after-name (point)) (cond ((eq (char-after) ?=) ; using foo = <type-id>; (goto-char pos) @@ -2305,7 +2315,8 @@ need for `c-font-lock-extra-types'.") (c-go-up-list-backward) (eq (char-after) ?{) (eq (car (c-beginning-of-decl-1 - (c-determine-limit 1000))) 'same) + (c-determine-limit 1000))) + 'same) (looking-at c-colon-type-list-re))) ;; Inherited protected member: leave unfontified ) @@ -2712,6 +2723,7 @@ need for `pike-font-lock-extra-types'.") (defmacro c-set-doc-comment-re-element (suffix) ;; Set the variable `c-doc-line-join-re' to a buffer local value suitable ;; for the current doc comment style, or kill the local value. + (declare (debug t)) (let ((var (intern (concat "c-doc" suffix)))) `(let* ((styles (c-get-doc-comment-style)) elts) @@ -2738,6 +2750,7 @@ need for `pike-font-lock-extra-types'.") (defmacro c-set-doc-comment-char-list (suffix) ;; Set the variable 'c-doc-<suffix>' to the list of *-<suffix>, which must ;; be characters, and * represents the doc comment style. + (declare (debug t)) (let ((var (intern (concat "c-doc" suffix)))) `(let* ((styles (c-get-doc-comment-style)) elts) @@ -2783,14 +2796,15 @@ need for `pike-font-lock-extra-types'.") ;; is used as a flag in other code to skip comments. ;; ;; This function might do hidden buffer changes. - - (let (comment-beg region-beg) + (declare (indent 2)) + (let (comment-beg region-beg comment-mid) (if (memq (get-text-property (point) 'face) '(font-lock-comment-face font-lock-comment-delimiter-face)) ;; Handle the case when the fontified region starts inside a ;; comment. (let ((start (c-literal-start))) - (setq region-beg (point)) + (setq region-beg (point) + comment-mid (point)) (when start (goto-char start)) (when (looking-at prefix) @@ -2816,7 +2830,8 @@ need for `pike-font-lock-extra-types'.") (goto-char comment-beg) (c-in-literal))))) (setq comment-beg nil)) - (setq region-beg comment-beg)) + (setq region-beg comment-beg + comment-mid comment-beg)) (if (elt (parse-partial-sexp comment-beg (+ comment-beg 2)) 7) ;; Collect a sequence of doc style line comments. @@ -2824,15 +2839,16 @@ need for `pike-font-lock-extra-types'.") (goto-char comment-beg) (while (and (progn (c-forward-single-comment) - (c-put-font-lock-face comment-beg (point) + (c-put-font-lock-face comment-mid (point) c-doc-face-name) (skip-syntax-forward " ") - (setq comment-beg (point)) + (setq comment-beg (point) + comment-mid (point)) (< (point) limit)) (looking-at prefix)))) (goto-char comment-beg) (c-forward-single-comment) - (c-put-font-lock-face comment-beg (point) c-doc-face-name)) + (c-put-font-lock-face region-beg (point) c-doc-face-name)) (if (> (point) limit) (goto-char limit)) (setq comment-beg nil) @@ -2866,7 +2882,6 @@ need for `pike-font-lock-extra-types'.") (goto-char region-end))))) nil) -(put 'c-font-lock-doc-comments 'lisp-indent-function 2) (defun c-find-invalid-doc-markup (regexp limit) ;; Used to fontify invalid markup in doc comments after the correct diff --git a/lisp/progmodes/cc-guess.el b/lisp/progmodes/cc-guess.el index 1b852ec4910..9c88c14a6c1 100644 --- a/lisp/progmodes/cc-guess.el +++ b/lisp/progmodes/cc-guess.el @@ -1,4 +1,4 @@ -;;; cc-guess.el --- guess indentation values by scanning existing code +;;; cc-guess.el --- guess indentation values by scanning existing code -*- lexical-binding: t -*- ;; Copyright (C) 1985, 1987, 1992-2006, 2011-2021 Free Software ;; Foundation, Inc. @@ -58,7 +58,7 @@ ;; ;; If you want to reuse the guessed style in future emacs sessions, ;; you may want to put it to your .emacs. `c-guess-view' is for -;; you. It emits emacs lisp code which defines the last guessed +;; you. It emits Emacs Lisp code which defines the last guessed ;; style, in a temporary buffer. You can put the emitted code into ;; your .emacs. This command was suggested by Alan Mackenzie. @@ -527,7 +527,7 @@ is called with one argument, the guessed style." (cdr needs-markers))))) (defun c-guess-view (&optional with-name) - "Emit emacs lisp code which defines the last guessed style. + "Emit Emacs Lisp code which defines the last guessed style. So you can put the code into .emacs if you prefer the guessed code. \"STYLE NAME HERE\" is used as the name for the style in the diff --git a/lisp/progmodes/cc-langs.el b/lisp/progmodes/cc-langs.el index 07479389c62..0b125bc43fa 100644 --- a/lisp/progmodes/cc-langs.el +++ b/lisp/progmodes/cc-langs.el @@ -1,4 +1,4 @@ -;;; cc-langs.el --- language specific settings for CC Mode -*- coding: utf-8 -*- +;;; cc-langs.el --- language specific settings for CC Mode -*- lexical-binding: t; coding: utf-8 -*- ;; Copyright (C) 1985, 1987, 1992-2021 Free Software Foundation, Inc. @@ -159,7 +159,9 @@ evaluated and bound to VAR when the result from the macro `c-lang-const' is typically used in VAL to get the right value for the language being initialized, and such calls will be macro expanded to the evaluated constant value at compile time." - + (declare (indent defun) + (debug (&define name def-form + &optional &or ("quote" symbolp) stringp))) (when (and (not doc) (eq (car-safe val) 'c-lang-const) (eq (nth 1 val) var) @@ -191,6 +193,7 @@ Emacs variable like `comment-start'. `c-lang-const' is typically used in VAL to get the right value for the language being initialized, and such calls will be macro expanded to the evaluated constant value at compile time." + (declare (debug (&define name def-form))) (let ((elem (assq var (cdr c-emacs-variable-inits)))) (if elem (setcdr elem (list val)) ; Maybe remove "list", sometime. 2006-07-19 @@ -200,13 +203,6 @@ the evaluated constant value at compile time." ;; Return the symbol, like the other def* forms. `',var) -(put 'c-lang-defvar 'lisp-indent-function 'defun) -; (eval-after-load "edebug" ; 2006-07-09: def-edebug-spec is now in subr.el. -; ' -(def-edebug-spec c-lang-defvar - (&define name def-form &optional &or ("quote" symbolp) stringp)) -(def-edebug-spec c-lang-setvar (&define name def-form)) - ;; Suppress "might not be defined at runtime" warning. ;; This file is only used when compiling other cc files. (declare-function cl-delete-duplicates "cl-seq" (cl-seq &rest cl-keys)) @@ -337,7 +333,8 @@ the evaluated constant value at compile time." This includes setting \\=' and \" as string delimiters, and setting up the comment syntax to handle both line style \"//\" and block style \"/*\" \"*/\" comments." - + ;; Never native compile to allow cc-mode.el:467 hack. + (declare (speed -1)) (modify-syntax-entry ?_ "_" table) (modify-syntax-entry ?\\ "\\" table) (modify-syntax-entry ?+ "." table) @@ -378,12 +375,14 @@ The syntax tables aren't stored directly since they're quite large." (let ((table (make-syntax-table))) (c-populate-syntax-table table) ;; Mode specific syntaxes. - ,(cond ((or (c-major-mode-is 'objc-mode) (c-major-mode-is 'java-mode)) + ,(cond ((c-major-mode-is 'objc-mode) ;; Let '@' be part of symbols in ObjC to cope with ;; its compiler directives as single keyword tokens. ;; This is then necessary since it's assumed that ;; every keyword is a single symbol. '(modify-syntax-entry ?@ "_" table)) + ((c-major-mode-is 'java-mode) + '(modify-syntax-entry ?@ "'" table)) ((c-major-mode-is 'pike-mode) '(modify-syntax-entry ?@ "." table))) table))) @@ -454,9 +453,9 @@ so that all identifiers are recognized as words.") ;; The value here may be a list of functions or a single function. t 'c-before-change-check-unbalanced-strings c++ '(c-extend-region-for-CPP - c-before-change-check-raw-strings - c-before-change-check-<>-operators c-depropertize-CPP + c-before-change-check-ml-strings + c-before-change-check-<>-operators c-truncate-bs-cache c-before-change-check-unbalanced-strings c-parse-quotes-before-change) @@ -468,6 +467,8 @@ so that all identifiers are recognized as words.") java '(c-parse-quotes-before-change c-before-change-check-unbalanced-strings c-before-change-check-<>-operators) + pike '(c-before-change-check-ml-strings + c-before-change-check-unbalanced-strings) awk 'c-awk-record-region-clear-NL) (c-lang-defvar c-get-state-before-change-functions (let ((fs (c-lang-const c-get-state-before-change-functions))) @@ -507,7 +508,7 @@ parameters \(point-min) and \(point-max).") c-change-expand-fl-region) c++ '(c-depropertize-new-text c-after-change-escape-NL-in-string - c-after-change-unmark-raw-strings + c-after-change-unmark-ml-strings c-parse-quotes-after-change c-after-change-mark-abnormal-strings c-extend-font-lock-region-for-macros @@ -520,6 +521,11 @@ parameters \(point-min) and \(point-max).") c-after-change-mark-abnormal-strings c-restore-<>-properties c-change-expand-fl-region) + pike '(c-depropertize-new-text + c-after-change-escape-NL-in-string + c-after-change-unmark-ml-strings + c-after-change-mark-abnormal-strings + c-change-expand-fl-region) awk '(c-depropertize-new-text c-awk-extend-and-syntax-tablify-region)) (c-lang-defvar c-before-font-lock-functions @@ -579,14 +585,12 @@ don't have EOL terminated statements. " (c-lang-defvar c-at-vsemi-p-fn (c-lang-const c-at-vsemi-p-fn)) (c-lang-defconst c-vsemi-status-unknown-p-fn - "Contains a predicate regarding the presence of virtual semicolons. -More precisely, the function answers the question, \"are we unsure whether a -virtual semicolon exists on this line?\". The (admittedly kludgy) purpose of -such a function is to prevent an infinite recursion in -`c-beginning-of-statement-1' when point starts at a `while' token. The function -MUST NOT UNDER ANY CIRCUMSTANCES call `c-beginning-of-statement-1', even -indirectly. This variable contains nil for languages which don't have EOL -terminated statements." + "A function \"are we unsure whether there is a virtual semicolon on this line?\". +The (admittedly kludgy) purpose of such a function is to prevent an infinite +recursion in c-beginning-of-statement-1 when point starts at a `while' token. +The function MUST NOT UNDER ANY CIRCUMSTANCES call `c-beginning-of-statement-1', +even indirectly. This variable contains nil for languages which don't have +EOL terminated statements." t nil (c c++ objc) 'c-macro-vsemi-status-unknown-p awk 'c-awk-vsemi-status-unknown-p) @@ -623,6 +627,176 @@ Note that to set up a language to use this, additionally: '(?\"))) (c-lang-defvar c-string-delims (c-lang-const c-string-delims)) + +;; The next section of the code defines multi-line ("ml") strings for each +;; language. By default, there are no ml strings in a language. To configure +;; them, set each needed lang const in the section. See further details in +;; cc-engine.el (search for "Handling of CC Mode multi-line strings."). +(c-lang-defconst c-ml-string-backslash-escapes + ;; N.B. if `c-ml-string-backslash-escapes' is non-nil, you probably need a + ;; `c-ml-string-any-closer-re' that scans backslashed characters, etc. + "If non-nil, a \\ character escapes the next character in a ml string. +Otherwise such a \\ will be marked to be handled as any other character." + t nil + pike t + ) + +(c-lang-defconst c-ml-string-non-punc-skip-chars + ;; A `skip-chars-forward' argument which skips over all ml string characters + ;; which don't need to be marked with punctuation ('(1)) syntax. + t (if (c-lang-const c-ml-string-backslash-escapes) + "^\"" + "^\"\\")) +(c-lang-defvar c-ml-string-non-punc-skip-chars + (c-lang-const c-ml-string-non-punc-skip-chars)) + +(c-lang-defconst c-ml-string-opener-re + "If non-nil, a regexp that matches a multi-line string opener. +It may also match context. + +Such an opener must be at least 2 characters long, and must +contain a \" character. (match-string 1) matches the actual +delimiter and (match-string 2) matches the actual \". If a +delimiter contains several \"s, it is recommended to configure +the first of them as \"the\" \"." + t nil + pike "\\(#\\(\"\\)\\)" + c++ "\\(R\\(\"\\)[^ ()\\\n\r\t]\\{0,16\\}(\\)") +(c-lang-defvar c-ml-string-opener-re (c-lang-const c-ml-string-opener-re)) + +(c-lang-defconst c-ml-string-max-opener-len + "If non-nil, the maximum length of a multi-line string opener." + t nil + pike 2 + c++ 19) +(c-lang-defvar c-ml-string-max-opener-len + (c-lang-const c-ml-string-max-opener-len)) + +(c-lang-defconst c-ml-string-any-closer-re + "If non-nil, a regexp that matches any multi-line string closer. +It may also match context. + +A search for this regexp starting at the end of the corresponding +opener must find the first closer as the first match. + +Such a closer must include a \" character. (match-string 1) +matches the actual delimiter and and (match-string 2) matches the +actual \". If a delimiter contains several \"s, it is +recommended to regard the last of them as \"the\" \"." + t nil + pike "\\(?:\\=\\|[^\\\"]\\)\\(?:\\\\.\\)*\\(\\(\"\\)\\)" + c++ "\\()[^ ()\\n\r\t]\\{0,16\\}\\(\"\\)\\)") +;; csharp "\\(?:\\=\\|[^\"]\\)\\(?:\"\"\\)*\\(\\(\"\\)\\)\\(?:[^\"]\\|\\'\\)" +(c-lang-defvar c-ml-string-any-closer-re + (c-lang-const c-ml-string-any-closer-re)) + +(c-lang-defconst c-ml-string-max-closer-len + "If non-nil, the maximum length of a multi-line string closer. +This must include the length of any \"context trailer\" following +the actual closer and any \"context leader\" preceding it. This +variable is ignored when `c-ml-string-back-closer-re' is non-nil." + t nil + c++ 18) +(c-lang-defvar c-ml-string-max-closer-len + (c-lang-const c-ml-string-max-closer-len)) + +(c-lang-defconst c-ml-string-max-closer-len-no-leader + "If non-nil, the maximum length of a ml string closer without its leader. +By \"leader\" is meant the context bytes preceding the actual +multi-line string closer, that part of +`c-ml-string-any-closer-re''s match preceding (match-beginning 1)." + t nil + pike 1 + ;; 2 + ;; 3 + c++ 18) +(c-lang-defvar c-ml-string-max-closer-len-no-leader + (c-lang-const c-ml-string-max-closer-len-no-leader)) + +(c-lang-defconst c-ml-string-back-closer-re + "A regexp to move back out of a putative ml closer point is in. + +This variable need only be non-nil for languages with multi-line +string closers that can contain an indefinite length \"leader\" +preceding the actual closer. It was designed for formats where +an unbounded number of \\s or \"s might precede the closer +proper, for example in Pike Mode or csharp-mode. + +If point is in a putative multi-line string closer, a backward +regexp search with `c-ml-string-back-closer-re' will leave point +in a \"safe place\", from where a forward regexp search with +`c-ml-string-any-closer-re' can test whether the original +position was inside an actual closer. + +When non-nil, this variable should end in \"\\\\\\==\". Note that +such a backward search will match a minimal string, so a +\"context character\" is probably needed at the start of the +regexp. The value for csharp-mode would be something like +\"\\\\(:?\\\\`\\\\|[^\\\"]\\\\)\\\"*\\\\\\==\"." + t nil + pike "\\(:?\\`\\|[^\\\"]\\)\\(:?\\\\.\\)*\\=" + ;;pike ;; 2 + ;; "\\(:?\\`\\|[^\"]\\)\"*\\=" + ) +(c-lang-defvar c-ml-string-back-closer-re + (c-lang-const c-ml-string-back-closer-re)) + +(c-lang-defconst c-make-ml-string-closer-re-function + "If non-nil, a function which creates a closer regexp matching an opener. + +Such a function is given one argument, a multi-line opener (a +string), and returns a regexp which will match the corresponding +closer. When this regexp matches, (match-string 1) should be the +actual closing delimiter, and (match-string 2) the \"active\" \" +it contains. + +A forward regexp search for this regexp starting at the end of +the opener must find the closer as its first match." + t (if (c-lang-const c-ml-string-any-closer-re) + 'c-ml-string-make-closer-re) + c++ 'c-c++-make-ml-string-closer-re) +(c-lang-defvar c-make-ml-string-closer-re-function + (c-lang-const c-make-ml-string-closer-re-function)) + +(c-lang-defconst c-make-ml-string-opener-re-function + "If non-nil, a function which creates an opener regexp matching a closer. + +Such a function is given one argument, a multi-line closer (a +string), and returns a regexp which will match the corresponding +opener. When this regexp matches, (match-string 1) should be the +actual opening delimiter, and (match-string 2) the \"active\" \" +it contains. + +A backward regexp search for this regexp starting at the start of +the closer might not find the opener as its first match, should +there be copies of the opener contained in the multi-line string." + t (if (c-lang-const c-ml-string-opener-re) + 'c-ml-string-make-opener-re) + c++ 'c-c++-make-ml-string-opener-re) +(c-lang-defvar c-make-ml-string-opener-re-function + (c-lang-const c-make-ml-string-opener-re-function)) + +(c-lang-defconst c-ml-string-cpp-or-opener-re + ;; A regexp which matches either a macro or a multi-line string opener. + t (concat "\\(" + (or (c-lang-const c-anchored-cpp-prefix) "\\`a\\`") + "\\)\\|\\(" + (or (c-lang-const c-ml-string-opener-re) "\\`a\\`") + "\\)")) +(c-lang-defvar c-ml-string-cpp-or-opener-re + (c-lang-const c-ml-string-cpp-or-opener-re)) + +(c-lang-defconst c-cpp-or-ml-match-offset + ;; The offset to be added onto match numbers for a multi-line string in + ;; matches for `c-cpp-or-ml-string-opener-re'. + t (if (c-lang-const c-anchored-cpp-prefix) + (+ 2 (regexp-opt-depth (c-lang-const c-anchored-cpp-prefix))) + 2)) +(c-lang-defvar c-cpp-or-ml-match-offset + (c-lang-const c-cpp-or-ml-match-offset)) +;; End of ml string section. + + (c-lang-defconst c-has-quoted-numbers "Whether the language has numbers quoted like 4'294'967'295." t nil @@ -863,9 +1037,15 @@ literals." "Set if the language supports multiline string literals without escaped newlines. If t, all string literals are multiline. If a character, only literals where the open quote is immediately preceded by that -literal are multiline." - t nil - pike ?#) +literal are multiline. + +Note that from CC Mode 5.36, this character use is obsolete, +having been superseded by the \"multi-line string\" mechanism. +If both mechanisms are set for a language, the newer one prevails +over the old `c-multiline-string-start-char'. See the variables +in the page containing `c-ml-string-opener-re' in cc-langs.el for +further directions." + t nil) (c-lang-defvar c-multiline-string-start-char (c-lang-const c-multiline-string-start-char)) @@ -2746,7 +2926,8 @@ if this isn't nil." `c-recognize-<>-arglists' for details. That language constant is assumed to be set if this isn't nil." t nil - c++ '("template") + c++ '("template" "const_cast" "dynamic_cast" "reinterpret_cast" + "static_cast") idl '("fixed" "string" "wstring")) (c-lang-defconst c-<>-sexp-kwds @@ -3098,6 +3279,36 @@ Note that Java specific rules are currently applied to tell this from t (c-make-keywords-re t (c-lang-const c-keywords))) (c-lang-defvar c-keywords-regexp (c-lang-const c-keywords-regexp)) +(c-lang-defconst c-stmt-block-only-keywords + "All keywords which unambiguously signify a statement block (as opposed to + a brace list) when occurring inside braces." + t (c--set-difference + (c-lang-const c-keywords) + (append (c-lang-const c-primary-expr-kwds) + (c-lang-const c-constant-kwds) + `(,@(when (c-major-mode-is 'c++-mode) + '("typeid" "dynamic_cast" "static_cast" "const_cast" + "reinterpret_cast" "alignof"))) + (c-lang-const c-type-modifier-prefix-kwds) + (c-lang-const c-overloadable-operators) + (c-lang-const c-template-typename-kwds) + `(,@(when (c-major-mode-is 'c++-mode) + '("reflexpr"))) + `(,@(when (c-major-mode-is '(c-mode c++-mode)) + '("sizeof"))) + (c-lang-const c-pre-lambda-tokens) + (c-lang-const c-block-decls-with-vars) + (c-lang-const c-primitive-type-kwds)) + :test 'string-equal)) + +(c-lang-defconst c-stmt-block-only-keywords-regexp + ;; A regexp matching a keyword in `c-stmt-block-only-keywords'. Such a + ;; match can start and end only at token boundaries. + t (concat "\\(^\\|\\=\\|[^" (c-lang-const c-symbol-chars) "]\\)" + (c-make-keywords-re t (c-lang-const c-stmt-block-only-keywords)))) +(c-lang-defvar c-stmt-block-only-keywords-regexp + (c-lang-const c-stmt-block-only-keywords-regexp)) + (c-lang-defconst c-keyword-member-alist ;; An alist with all the keywords in the cars. The cdr for each ;; keyword is a list of the symbols for the `*-kwds' lists that @@ -3650,13 +3861,25 @@ list." c t) (c-lang-defvar c-recognize-knr-p (c-lang-const c-recognize-knr-p)) +(c-lang-defconst c-pre-id-bracelist-kwds + "Keywords which, preceding an identifier and brace, signify a bracelist. +This is only used in c++-mode." + t nil + c++ '("new" "throw")) + (c-lang-defconst c-pre-id-bracelist-key - "A regexp matching tokens which, preceding an identifier, signify a bracelist. -" - t regexp-unmatchable - c++ "new\\([^[:alnum:]_$]\\|$\\)\\|&&?\\(\\S.\\|$\\)") + ;; A regexp matching keywords which, preceding an identifier and brace, + ;; signify a bracelist. Only used in c++-mode. + t (c-make-keywords-re t (c-lang-const c-pre-id-bracelist-kwds))) (c-lang-defvar c-pre-id-bracelist-key (c-lang-const c-pre-id-bracelist-key)) +(c-lang-defconst c-pre-brace-non-bracelist-key + "A regexp matching tokens which, preceding a brace, make it a non-bracelist." + t regexp-unmatchable + c++ "&&?\\(\\S.\\|$\\)") +(c-lang-defvar c-pre-brace-non-bracelist-key + (c-lang-const c-pre-brace-non-bracelist-key)) + (c-lang-defconst c-recognize-typeless-decls "Non-nil means function declarations without return type should be recognized. That can introduce an ambiguity with parenthesized macro @@ -4051,6 +4274,7 @@ accomplish that conveniently." This macro is expanded at compile time to a form tailored for the mode in question, so MODE must be a constant. Therefore MODE is not evaluated and should not be quoted." + (declare (debug nil)) `(funcall ,(c-make-init-lang-vars-fun mode))) diff --git a/lisp/progmodes/cc-menus.el b/lisp/progmodes/cc-menus.el index 0ff6efb7d37..a099ec1de95 100644 --- a/lisp/progmodes/cc-menus.el +++ b/lisp/progmodes/cc-menus.el @@ -1,4 +1,4 @@ -;;; cc-menus.el --- imenu support for CC Mode +;;; cc-menus.el --- imenu support for CC Mode -*- lexical-binding: t -*- ;; Copyright (C) 1985, 1987, 1992-2021 Free Software Foundation, Inc. diff --git a/lisp/progmodes/cc-mode.el b/lisp/progmodes/cc-mode.el index cfb23d0d45e..057d292246f 100644 --- a/lisp/progmodes/cc-mode.el +++ b/lisp/progmodes/cc-mode.el @@ -1,4 +1,4 @@ -;;; cc-mode.el --- major mode for editing C and similar languages +;;; cc-mode.el --- major mode for editing C and similar languages -*- lexical-binding: t -*- ;; Copyright (C) 1985, 1987, 1992-2021 Free Software Foundation, Inc. @@ -969,6 +969,7 @@ Note that the style variables are always made local to the buffer." (defmacro c-run-mode-hooks (&rest hooks) ;; Emacs 21.1 has introduced a system with delayed mode hooks that ;; requires the use of the new function `run-mode-hooks'. + (declare (debug t)) (if (cc-bytecomp-fboundp 'run-mode-hooks) `(run-mode-hooks ,@hooks) `(progn ,@(mapcar (lambda (hook) `(run-hooks ,hook)) hooks)))) @@ -1002,8 +1003,8 @@ Note that the style variables are always made local to the buffer." (goto-char (match-beginning 1)) (setq m-beg (point)) (c-end-of-macro) - (when (c-major-mode-is 'c++-mode) - (save-excursion (c-depropertize-raw-strings-in-region m-beg (point)))) + (when c-ml-string-opener-re + (save-excursion (c-depropertize-ml-strings-in-region m-beg (point)))) (c-clear-char-property-with-value m-beg (point) 'syntax-table '(1))) (while (and (< (point) end) @@ -1013,8 +1014,8 @@ Note that the style variables are always made local to the buffer." (setq m-beg (point)) (c-end-of-macro)) (when (and ss-found (> (point) end)) - (when (c-major-mode-is 'c++-mode) - (save-excursion (c-depropertize-raw-strings-in-region m-beg (point)))) + (when c-ml-string-opener-re + (save-excursion (c-depropertize-ml-strings-in-region m-beg (point)))) (c-clear-char-property-with-value m-beg (point) 'syntax-table '(1))) (while (and (< (point) c-new-END) @@ -1022,8 +1023,8 @@ Note that the style variables are always made local to the buffer." (goto-char (match-beginning 1)) (setq m-beg (point)) (c-end-of-macro) - (when (c-major-mode-is 'c++-mode) - (save-excursion (c-depropertize-raw-strings-in-region m-beg (point)))) + (when c-ml-string-opener-re + (save-excursion (c-depropertize-ml-strings-in-region m-beg (point)))) (c-clear-char-property-with-value m-beg (point) 'syntax-table '(1))))) @@ -1173,12 +1174,15 @@ Note that the style variables are always made local to the buffer." ))))) (defun c-unescaped-nls-in-string-p (&optional quote-pos) - ;; Return whether unescaped newlines can be inside strings. + ;; Return whether unescaped newlines can be inside strings. If the current + ;; language handles multi-line strings, the value of this function is always + ;; nil. ;; ;; QUOTE-POS, if present, is the position of the opening quote of a string. ;; Depending on the language, there might be a special character before it ;; signifying the validity of such NLs. (cond + (c-ml-string-opener-re nil) ((null c-multiline-string-start-char) nil) ((c-characterp c-multiline-string-start-char) (and quote-pos @@ -1322,13 +1326,13 @@ Note that the style variables are always made local to the buffer." (setq pos (c-min-property-position pos c-max-syn-tab-mkr 'c-fl-syn-tab)) (when (< pos c-max-syn-tab-mkr) - (goto-char pos)) - (when (and (save-match-data - (c-search-backward-char-property-with-value-on-char - 'c-fl-syn-tab '(15) ?\" - (max (- (point) 500) (point-min)))) - (not (equal (c-get-char-property (point) 'syntax-table) '(1)))) - (setq pos (1+ pos))) + (goto-char pos) + (when (and (save-match-data + (c-search-backward-char-property-with-value-on-char + 'c-fl-syn-tab '(15) ?\" + (max (- (point) 500) (point-min)))) + (not (equal (c-get-char-property (point) 'syntax-table) '(1)))) + (setq pos (1+ pos)))) (while (< pos c-max-syn-tab-mkr) (setq pos (c-min-property-position pos c-max-syn-tab-mkr 'c-fl-syn-tab)) @@ -1434,7 +1438,8 @@ Note that the style variables are always made local to the buffer." ;; quotes up until the next unescaped EOL. Also guard against the change ;; being the insertion of \ before an EOL, escaping it. (cond - ((c-characterp c-multiline-string-start-char) + ((and (not c-ml-string-opener-re) + (c-characterp c-multiline-string-start-char)) ;; The text about to be inserted might contain a multiline string ;; opener. Set c-new-END after anything which might be affected. ;; Go to the end of the putative multiline string. @@ -1460,7 +1465,8 @@ Note that the style variables are always made local to the buffer." (< (point) (point-max)))))) (setq c-new-END (max (point) c-new-END))) - (c-multiline-string-start-char + ((and (not c-ml-string-opener-re) + c-multiline-string-start-char) (setq c-bc-changed-stringiness (not (eq (eq end-literal-type 'string) (eq beg-literal-type 'string)))) @@ -1505,7 +1511,7 @@ Note that the style variables are always made local to the buffer." ;; Opening " at EOB. (c-clear-syn-tab (1- (point)))) (when (and (c-search-backward-char-property 'syntax-table '(15) c-new-BEG) - (memq (char-after) c-string-delims)) ; Ignore an unterminated raw string's (. + (memq (char-after) c-string-delims)) ; Ignore an unterminated ml string's (. ;; Opening " on last line of text (without EOL). (c-remove-string-fences) (setq c-new-BEG (min c-new-BEG (point)))))) @@ -1519,13 +1525,16 @@ Note that the style variables are always made local to the buffer." (unless (or (and - ;; Don't set c-new-BEG/END if we're in a raw string. + ;; Don't set c-new-BEG/END if we're in an ml string. + c-ml-string-opener-re (eq beg-literal-type 'string) - (c-at-c++-raw-string-opener (car beg-limits))) + (c-ml-string-opener-at-or-around-point (car beg-limits))) (and c-multiline-string-start-char + (not c-ml-string-opener-re) (not (c-characterp c-multiline-string-start-char)))) (when (and (eq end-literal-type 'string) - (not (eq (char-before (cdr end-limits)) ?\()) + (or (memq (char-before (cdr end-limits)) c-string-delims) + (memq (char-before (cdr end-limits)) '(?\n ?\r))) (memq (char-after (car end-limits)) c-string-delims)) (setq c-new-END (max c-new-END (cdr end-limits))) (when (equal (c-get-char-property (car end-limits) 'syntax-table) @@ -1548,6 +1557,7 @@ Note that the style variables are always made local to the buffer." ;; This function is called exclusively as an after-change function via ;; `c-before-font-lock-functions'. (if (and c-multiline-string-start-char + (not c-ml-string-opener-re) (not (c-characterp c-multiline-string-start-char))) ;; Only the last " might need to be marked. (c-save-buffer-state @@ -1590,6 +1600,7 @@ Note that the style variables are always made local to the buffer." ((and (null beg-literal-type) (goto-char beg) (and (not (bobp)) + (not c-ml-string-opener-re) (eq (char-before) c-multiline-string-start-char)) (memq (char-after) c-string-delims)) (cons (point) @@ -1614,6 +1625,7 @@ Note that the style variables are always made local to the buffer." (point)) c-new-END)) s) + (goto-char (cond ((null beg-literal-type) c-new-BEG) @@ -1637,8 +1649,9 @@ Note that the style variables are always made local to the buffer." (and (memq (char-before) c-string-delims) (not (nth 4 s))))) ; Check we're actually out of the ; comment. not stuck at EOB - (unless (and (c-major-mode-is 'c++-mode) - (c-maybe-re-mark-raw-string)) + (unless + (and c-ml-string-opener-re + (c-maybe-re-mark-ml-string)) (if (c-unescaped-nls-in-string-p (1- (point))) (looking-at "\\(\\\\\\(.\\|\n\\)\\|[^\"]\\)*") (looking-at (cdr (assq (char-before) c-string-innards-re-alist)))) @@ -1677,21 +1690,15 @@ Note that the style variables are always made local to the buffer." (progn (goto-char end) (setq lit-start (c-literal-start))) (memq (char-after lit-start) c-string-delims) - (or (not (c-major-mode-is 'c++-mode)) + (or (not c-ml-string-opener-re) (progn (goto-char lit-start) - (and (not (and (eq (char-before) ?R) - (looking-at c-c++-raw-string-opener-1-re))) - (not (and (eq (char-after) ?\() - (equal (c-get-char-property - (point) 'syntax-table) - '(15)))))) + (not (c-ml-string-opener-at-or-around-point))) (save-excursion (c-beginning-of-macro)))) (goto-char (1+ end)) ; After the \ - ;; Search forward for EOLL - (setq lim (re-search-forward "\\(?:\\\\\\(?:.\\|\n\\)\\|[^\\\n\r]\\)*" - nil t)) + ;; Search forward for EOLL. + (setq lim (c-point 'eoll)) (goto-char (1+ end)) (when (c-search-forward-char-property-with-value-on-char 'syntax-table '(15) ?\" lim) @@ -2503,6 +2510,7 @@ This function is called from `c-common-init', once per mode initialization." ;; Emacs < 22 and XEmacs (defmacro c-advise-fl-for-region (function) + (declare (debug t)) `(defadvice ,function (before get-awk-region activate) ;; Make sure that any string/regexp is completely font-locked. (when c-buffer-is-cc-mode @@ -2977,7 +2985,7 @@ Key bindings: ;; bug reporting (defconst c-mode-help-address - "submit@debbugs.gnu.org" + "bug-gnu-emacs@gnu.org" "Address(es) for CC Mode bug reports.") (defun c-version () diff --git a/lisp/progmodes/cc-styles.el b/lisp/progmodes/cc-styles.el index aec259f1b38..8514434e9ac 100644 --- a/lisp/progmodes/cc-styles.el +++ b/lisp/progmodes/cc-styles.el @@ -1,4 +1,4 @@ -;;; cc-styles.el --- support for styles in CC Mode +;;; cc-styles.el --- support for styles in CC Mode -*- lexical-binding: t -*- ;; Copyright (C) 1985, 1987, 1992-2021 Free Software Foundation, Inc. @@ -374,7 +374,7 @@ in this way. If DONT-OVERRIDE is t, style variables that already have values (i.e., whose values are not the symbol `set-from-style') will not be overridden. CC Mode calls c-set-style internally in this way whilst initializing a buffer; if -cc-set-style is called like this from anywhere else, it will usually behave as +c-set-style is called like this from anywhere else, it will usually behave as a null operation." (interactive (list (let ((completion-ignore-case t) @@ -464,7 +464,7 @@ STYLE using `c-set-style' if the optional SET-P flag is non-nil." offset)) ;;;###autoload -(defun c-set-offset (symbol offset &optional ignored) +(defun c-set-offset (symbol offset &optional _ignored) "Change the value of a syntactic element symbol in `c-offsets-alist'. SYMBOL is the syntactic element symbol to change and OFFSET is the new offset for that syntactic element. The optional argument is not used @@ -476,8 +476,8 @@ and exists only for compatibility reasons." (if current-prefix-arg " or add" "") ": ") (mapcar - #'(lambda (langelem) - (cons (format "%s" (car langelem)) nil)) + (lambda (langelem) + (cons (format "%s" (car langelem)) nil)) (get 'c-offsets-alist 'c-stylevar-fallback)) nil (not current-prefix-arg) ;; initial contents tries to be the last element diff --git a/lisp/progmodes/cc-vars.el b/lisp/progmodes/cc-vars.el index 88ee092da79..b33fea0b48c 100644 --- a/lisp/progmodes/cc-vars.el +++ b/lisp/progmodes/cc-vars.el @@ -1,4 +1,4 @@ -;;; cc-vars.el --- user customization variables for CC Mode +;;; cc-vars.el --- user customization variables for CC Mode -*- lexical-binding: t -*- ;; Copyright (C) 1985, 1987, 1992-2021 Free Software Foundation, Inc. @@ -42,6 +42,9 @@ (cc-require 'cc-defs) +(defvar c-syntactic-context) +(defvar c-syntactic-element) + (cc-eval-when-compile (require 'custom) (require 'widget)) diff --git a/lisp/progmodes/cfengine.el b/lisp/progmodes/cfengine.el index f516664f7f4..4649e506541 100644 --- a/lisp/progmodes/cfengine.el +++ b/lisp/progmodes/cfengine.el @@ -1,4 +1,4 @@ -;;; cfengine.el --- mode for editing Cfengine files +;;; cfengine.el --- mode for editing Cfengine files -*- lexical-binding: t; -*- ;; Copyright (C) 2001-2021 Free Software Foundation, Inc. @@ -69,7 +69,6 @@ (defcustom cfengine-indent 2 "Size of a CFEngine indentation step in columns." - :group 'cfengine :type 'integer) (defcustom cfengine-cf-promises @@ -86,7 +85,6 @@ Used for syntax discovery and checking. Set to nil to disable the `compile-command' override. In that case, the ElDoc support will use a fallback syntax definition." :version "24.4" - :group 'cfengine :type '(choice file (const nil))) (defcustom cfengine-parameters-indent '(promise pname 2) @@ -145,7 +143,6 @@ bundle agent rcfiles } " :version "24.4" - :group 'cfengine :type '(list (choice (const :tag "Anchor at beginning of promise" promise) (const :tag "Anchor at beginning of line" bol)) @@ -799,7 +796,6 @@ bundle agent rcfiles (defcustom cfengine-mode-abbrevs nil "Abbrevs for CFEngine2 mode." - :group 'cfengine :type '(repeat (list (string :tag "Name") (string :tag "Expansion") (choice :tag "Hook" (const nil) function)))) @@ -991,13 +987,11 @@ Intended as the value of `indent-line-function'." (if (> (- (point-max) pos) (point)) (goto-char (- (point-max) pos))))) -;; This doesn't work too well in Emacs 21.2. See 22.1 development -;; code. (defun cfengine-fill-paragraph (&optional justify) "Fill `paragraphs' in Cfengine code." (interactive "P") (or (if (fboundp 'fill-comment-paragraph) - (fill-comment-paragraph justify) ; post Emacs 21.3 + (fill-comment-paragraph justify) ;; else do nothing in a comment (nth 4 (parse-partial-sexp (save-excursion (beginning-of-defun) @@ -1446,7 +1440,7 @@ to the action header." (cfengine3-mode) (cfengine2-mode))) -(defalias 'cfengine-mode 'cfengine3-mode) +(defalias 'cfengine-mode #'cfengine3-mode) (provide 'cfengine3) (provide 'cfengine) diff --git a/lisp/progmodes/cmacexp.el b/lisp/progmodes/cmacexp.el index 1a45b1cb838..0f7c8c6f31a 100644 --- a/lisp/progmodes/cmacexp.el +++ b/lisp/progmodes/cmacexp.el @@ -1,7 +1,6 @@ -;;; cmacexp.el --- expand C macros in a region +;;; cmacexp.el --- expand C macros in a region -*- lexical-binding: t -*- -;; Copyright (C) 1992, 1994, 1996, 2000-2021 Free Software Foundation, -;; Inc. +;; Copyright (C) 1992-2021 Free Software Foundation, Inc. ;; Author: Francesco Potortì <pot@gnu.org> ;; Adapted-By: ESR @@ -33,20 +32,20 @@ ;; USAGE ============================================================= -;; In C mode C-C C-e is bound to c-macro-expand. The result of the +;; In C mode C-c C-e is bound to `c-macro-expand'. The result of the ;; expansion is put in a separate buffer. A user option allows the ;; window displaying the buffer to be optimally sized. ;; -;; When called with a C-u prefix, c-macro-expand replaces the selected +;; When called with a C-u prefix, `c-macro-expand' replaces the selected ;; region with the expansion. Both the preprocessor name and the -;; initial flag can be set by the user. If c-macro-prompt-flag is set +;; initial flag can be set by the user. If `c-macro-prompt-flag' is set ;; to a non-nil value the user is offered to change the options to the -;; preprocessor each time c-macro-expand is invoked. Preprocessor -;; arguments default to the last ones entered. If c-macro-prompt-flag +;; preprocessor each time `c-macro-expand' is invoked. Preprocessor +;; arguments default to the last ones entered. If `c-macro-prompt-flag' ;; is nil, one must use M-x set-variable to set a different value for -;; c-macro-cppflags. +;; `c-macro-cppflags'. -;; A c-macro-expansion function is provided for non-interactive use. +;; A `c-macro-expansion' function is provided for non-interactive use. ;; INSTALLATION ====================================================== @@ -54,18 +53,22 @@ ;; If you want the *Macroexpansion* window to be not higher than ;; necessary: -;;(setq c-macro-shrink-window-flag t) +;; +;; (setq c-macro-shrink-window-flag t) ;; ;; If you use a preprocessor other than /lib/cpp (be careful to set a ;; -C option or equivalent in order to make the preprocessor not to ;; strip the comments): -;;(setq c-macro-preprocessor "gpp -C") +;; +;; (setq c-macro-preprocessor "gpp -C") ;; ;; If you often use a particular set of flags: -;;(setq c-macro-cppflags "-I /usr/include/local -DDEBUG" +;; +;; (setq c-macro-cppflags "-I /usr/include/local -DDEBUG" ;; ;; If you want the "Preprocessor arguments: " prompt: -;;(setq c-macro-prompt-flag t) +;; +;; (setq c-macro-prompt-flag t) ;; BUG REPORTS ======================================================= @@ -87,25 +90,19 @@ (require 'cc-mode) -(provide 'cmacexp) - (defvar msdos-shells) - (defgroup c-macro nil "Expand C macros in a region." :group 'c) - (defcustom c-macro-shrink-window-flag nil "Non-nil means shrink the *Macroexpansion* window to fit its contents." - :type 'boolean - :group 'c-macro) + :type 'boolean) (defcustom c-macro-prompt-flag nil "Non-nil makes `c-macro-expand' prompt for preprocessor arguments." - :type 'boolean - :group 'c-macro) + :type 'boolean) (defcustom c-macro-preprocessor (cond ;; Solaris has it in an unusual place. @@ -129,13 +126,11 @@ If you change this, be sure to preserve the `-C' (don't strip comments) option, or to set an equivalent one." - :type 'string - :group 'c-macro) + :type 'string) (defcustom c-macro-cppflags "" "Preprocessor flags used by `c-macro-expand'." - :type 'string - :group 'c-macro) + :type 'string) (defconst c-macro-buffer-name "*Macroexpansion*") @@ -146,7 +141,7 @@ Normally display output in temp buffer, but prefix arg means replace the region with it. `c-macro-preprocessor' specifies the preprocessor to use. -Tf the user option `c-macro-prompt-flag' is non-nil +If the user option `c-macro-prompt-flag' is non-nil prompt for arguments to the preprocessor \(e.g. `-DDEBUG -I ./include'), otherwise use `c-macro-cppflags'. @@ -396,4 +391,6 @@ Optional arg DISPLAY non-nil means show messages in the echo area." ;; Cleanup. (kill-buffer outbuf)))) +(provide 'cmacexp) + ;;; cmacexp.el ends here diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el index 48b5ee99736..1fb6124ab56 100644 --- a/lisp/progmodes/compile.el +++ b/lisp/progmodes/compile.el @@ -173,6 +173,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 + (eval-when-compile `((absoft "^\\(?:[Ee]rror on \\|[Ww]arning on\\( \\)\\)?[Ll]ine[ \t]+\\([0-9]+\\)[ \t]+\ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1)) @@ -615,7 +616,7 @@ File = \\(.+\\), Line = \\([0-9]+\\)\\(?:, Column = \\([0-9]+\\)\\)?" ;; we do not know what lines will follow. (guile-file "^In \\(.+\\..+\\):\n" 1 nil nil 0) (guile-line "^ *\\([0-9]+\\): *\\([0-9]+\\)" nil 1 2) - ) + )) "Alist of values for `compilation-error-regexp-alist'.") (defcustom compilation-error-regexp-alist @@ -1248,11 +1249,14 @@ POS and RES.") (setq col (match-string-no-properties col)) (string-to-number col)))) (setq end-col - (or (if (functionp end-col) (funcall end-col) - (and end-col - (setq end-col (match-string-no-properties end-col)) - (- (string-to-number end-col) -1))) - (and end-line -1))) + (let ((ec (if (functionp end-col) + (funcall end-col) + (and end-col (match-beginning end-col) + (string-to-number + (match-string-no-properties end-col)))))) + (if ec + (1+ ec) ; Add one to get an exclusive upper bound. + (and end-line -1)))) (if (consp type) ; not a static type, check what it is. (setq type (or (and (car type) (match-end (car type)) 1) (and (cdr type) (match-end (cdr type)) 0) @@ -1540,7 +1544,7 @@ to `compilation-error-regexp-alist' if RULES is nil." file line end-line col end-col (or type 2) fmt rule)) - (when (integerp file) + (when file (let ((this-type (if (consp type) (compilation-type type) (or type 2)))) @@ -2844,8 +2848,9 @@ and overlay is highlighted between MK and END-MK." (when (and (not pre-existing) w) (compilation-set-window-height w)) - (if from-compilation-buffer - ;; If the compilation buffer window was selected, + (if (or from-compilation-buffer + (eq w (selected-window))) + ;; If the compilation buffer window is selected, ;; keep the compilation buffer in this window; ;; display the source in another window. (let ((pop-up-windows t)) @@ -3040,12 +3045,7 @@ TRUE-DIRNAME is the `file-truename' of DIRNAME, if given." ;; Get the specified directory from FILE. (spec-directory (if (cdr file) - ;; This function is active in `compilation-filter'. - ;; There could be problems to call `file-truename' - ;; for remote compilation processes. - (if (file-remote-p default-directory) - (concat comint-file-name-prefix (cdr file)) - (file-truename (concat comint-file-name-prefix (cdr file))))))) + (file-truename (concat comint-file-name-prefix (cdr file)))))) ;; Check for a comint-file-name-prefix and prepend it if appropriate. ;; (This is very useful for compilation-minor-mode in an rlogin-mode diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el index a70e8e36c0b..3370df64919 100644 --- a/lisp/progmodes/cperl-mode.el +++ b/lisp/progmodes/cperl-mode.el @@ -92,6 +92,7 @@ (concat msg ": "))))) (eval-when-compile (require 'cl-lib)) +(require 'facemenu) (defvar msb-menu-cond) (defvar gud-perldb-history) @@ -440,12 +441,6 @@ after reload." :type 'boolean :group 'cperl-speed) -(defcustom cperl-imenu-addback nil - "Not-nil means add backreferences to generated `imenu's. -May require patched `imenu' and `imenu-go'. Obsolete." - :type 'boolean - :group 'cperl-help-system) - (defcustom cperl-max-help-size 66 "Non-nil means shrink-wrapping of info-buffer allowed up to these percents." :type '(choice integer (const nil)) @@ -659,8 +654,8 @@ Run Perl/Tools/Insert-spaces-if-needed to fix your lazy typing. Switch auto-help on/off with Perl/Tools/Auto-help. -Though with contemporary Emaxen CPerl mode should maintain the correct -parsing of Perl even when editing, sometimes it may be lost. Fix this by +Though CPerl mode should maintain the correct parsing of Perl even when +editing, sometimes it may be lost. Fix this by \\[normal-mode] @@ -676,63 +671,20 @@ micro-docs on what I know about CPerl problems.") "Description of problems in CPerl mode. `fill-paragraph' on a comment may leave the point behind the paragraph. It also triggers a bug in some versions of Emacs (CPerl tries -to detect it and bulk out). - -See documentation of a variable `cperl-problems-old-emaxen' for the -problems which disappear if you upgrade Emacs to a reasonably new -version (20.3 for Emacs).") +to detect it and bulk out).") (defvar cperl-problems-old-emaxen 'please-ignore-this-line - "Description of problems in CPerl mode specific for older Emacs versions. - -Emacs had a _very_ restricted syntax parsing engine until version -20.1. Most problems below are corrected starting from this version of -Emacs, and all of them should be fixed in version 20.3. (Or apply -patches to Emacs 19.33/34 - see tips.) - -Note that even with newer Emacsen in some very rare cases the details -of interaction of `font-lock' and syntaxification may be not cleaned -up yet. You may get slightly different colors basing on the order of -fontification and syntaxification. Say, the initial faces is correct, -but editing the buffer breaks this. - -Even with older Emacsen CPerl mode tries to corrects some Emacs -misunderstandings, however, for efficiency reasons the degree of -correction is different for different operations. The partially -corrected problems are: POD sections, here-documents, regexps. The -operations are: highlighting, indentation, electric keywords, electric -braces. - -This may be confusing, since the regexp s#//#/#; may be highlighted -as a comment, but it will be recognized as a regexp by the indentation -code. Or the opposite case, when a POD section is highlighted, but -may break the indentation of the following code (though indentation -should work if the balance of delimiters is not broken by POD). - -The main trick (to make $ a \"backslash\") makes constructions like -${aaa} look like unbalanced braces. The only trick I can think of is -to insert it as $ {aaa} (valid in perl5, not in perl4). - -Similar problems arise in regexps, when /(\\s|$)/ should be rewritten -as /($|\\s)/. Note that such a transposition is not always possible. - -The solution is to upgrade your Emacs or patch an older one. Note -that Emacs 20.2 has some bugs related to `syntax-table' text -properties. Patches are available on the main CPerl download site, -and on CPAN. - -If these bugs cannot be fixed on your machine (say, you have an inferior -environment and cannot recompile), you may still disable all the fancy stuff -via `cperl-use-syntax-table-text-property'.") + "This used to contain a description of problems in CPerl mode +specific for very old Emacs versions. This is no longer relevant +and has been removed.") +(make-obsolete-variable 'cperl-problems-old-emaxen nil "28.1") (defvar cperl-praise 'please-ignore-this-line "Advantages of CPerl mode. 0) It uses the newest `syntax-table' property ;-); -1) It does 99% of Perl syntax correct (as opposed to 80-90% in Perl -mode - but the latter number may have improved too in last years) even -with old Emaxen which do not support `syntax-table' property. +1) It does 99% of Perl syntax correct. When using `syntax-table' property for syntax assist hints, it should handle 99.995% of lines correct - or somesuch. It automatically @@ -813,8 +765,7 @@ the settings present before the switch. 9) When doing indentation of control constructs, may correct line-breaks/spacing between elements of the construct. -10) Uses a linear-time algorithm for indentation of regions (on Emaxen with -capable syntax engines). +10) Uses a linear-time algorithm for indentation of regions. 11) Syntax-highlight, indentation, sexp-recognition inside regular expressions. ") @@ -838,8 +789,8 @@ syntax-parsing routines, and marks them up so that either A1) CPerl may work around these deficiencies (for big chunks, mostly PODs and HERE-documents), or - A2) On capable Emaxen CPerl will use improved syntax-handling - which reads mark-up hints directly. + A2) CPerl will use improved syntax-handling which reads mark-up + hints directly. The scan in case A2 is much more comprehensive, thus may be slower. @@ -957,22 +908,12 @@ In regular expressions (including character classes): (defun cperl-make-indent (column &optional minimum keep) - "Makes indent of the current line the requested amount. -Unless KEEP, removes the old indentation. Works around a bug in ancient -versions of Emacs." - (let ((prop (get-text-property (point) 'syntax-type))) - (or keep - (delete-horizontal-space)) - (indent-to column minimum) - ;; In old versions (e.g., 19.33) `indent-to' would not inherit properties - (and prop - (> (current-column) 0) - (save-excursion - (beginning-of-line) - (or (get-text-property (point) 'syntax-type) - (and (looking-at "\\=[ \t]") - (put-text-property (point) (match-end 0) - 'syntax-type prop))))))) + "Indent from point with tabs and spaces until COLUMN is reached. +MINIMUM is like in `indent-to', which see. +Unless KEEP, removes the old indentation." + (or keep + (delete-horizontal-space)) + (indent-to column minimum)) ;; Probably it is too late to set these guys already, but it can help later: @@ -1019,9 +960,12 @@ versions of Emacs." "Abbrev table in use in CPerl mode buffers." :parents (list cperl-mode-electric-keywords-abbrev-table)) -(when (boundp 'edit-var-mode-alist) - ;; FIXME: What package uses this? - (add-to-list 'edit-var-mode-alist '(perl-mode (regexp . "^cperl-")))) +;; ;; TODO: Commented out as we don't know what it is used for. If +;; ;; there are no bug reports about this for Emacs 28.1, this +;; ;; can probably be removed. (Code search online reveals nothing.) +;; (when (boundp 'edit-var-mode-alist) +;; ;; FIXME: What package uses this? +;; (add-to-list 'edit-var-mode-alist '(perl-mode (regexp . "^cperl-")))) (defvar cperl-mode-map (let ((map (make-sparse-keymap))) @@ -1091,172 +1035,314 @@ versions of Emacs." map) "Keymap used in CPerl mode.") -(defvar cperl-menu) (defvar cperl-lazy-installed) (defvar cperl-old-style nil) -(condition-case nil - (progn - (require 'easymenu) - (easy-menu-define - cperl-menu cperl-mode-map "Menu for CPerl mode" - '("Perl" - ["Beginning of function" beginning-of-defun t] - ["End of function" end-of-defun t] - ["Mark function" mark-defun t] - ["Indent expression" cperl-indent-exp t] - ["Fill paragraph/comment" fill-paragraph t] - "----" - ["Line up a construction" cperl-lineup (use-region-p)] - ["Invert if/unless/while etc" cperl-invert-if-unless t] - ("Regexp" - ["Beautify" cperl-beautify-regexp - cperl-use-syntax-table-text-property] - ["Beautify one level deep" (cperl-beautify-regexp 1) - cperl-use-syntax-table-text-property] - ["Beautify a group" cperl-beautify-level - cperl-use-syntax-table-text-property] - ["Beautify a group one level deep" (cperl-beautify-level 1) - cperl-use-syntax-table-text-property] - ["Contract a group" cperl-contract-level - cperl-use-syntax-table-text-property] - ["Contract groups" cperl-contract-levels - cperl-use-syntax-table-text-property] - "----" - ["Find next interpolated" cperl-next-interpolated-REx - (next-single-property-change (point-min) 'REx-interpolated)] - ["Find next interpolated (no //o)" - cperl-next-interpolated-REx-0 - (or (text-property-any (point-min) (point-max) 'REx-interpolated t) - (text-property-any (point-min) (point-max) 'REx-interpolated 1))] - ["Find next interpolated (neither //o nor whole-REx)" - cperl-next-interpolated-REx-1 - (text-property-any (point-min) (point-max) 'REx-interpolated t)]) - ["Insert spaces if needed to fix style" cperl-find-bad-style t] - ["Refresh \"hard\" constructions" cperl-find-pods-heres t] - "----" - ["Indent region" cperl-indent-region (use-region-p)] - ["Comment region" cperl-comment-region (use-region-p)] - ["Uncomment region" cperl-uncomment-region (use-region-p)] - "----" - ["Run" mode-compile (fboundp 'mode-compile)] - ["Kill" mode-compile-kill (and (fboundp 'mode-compile-kill) - (get-buffer "*compilation*"))] - ["Next error" next-error (get-buffer "*compilation*")] - ["Check syntax" cperl-check-syntax (fboundp 'mode-compile)] - "----" - ["Debugger" cperl-db t] - "----" - ("Tools" - ["Imenu" imenu (fboundp 'imenu)] - ["Imenu on Perl Info" cperl-imenu-on-info (featurep 'imenu)] - "----" - ["Ispell PODs" cperl-pod-spell - ;; Better not to update syntaxification here: - ;; debugging syntaxification can be broken by this??? - (or - (get-text-property (point-min) 'in-pod) - (< (progn - (and cperl-syntaxify-for-menu - (cperl-update-syntaxification (point-max))) - (next-single-property-change (point-min) 'in-pod nil (point-max))) - (point-max)))] - ["Ispell HERE-DOCs" cperl-here-doc-spell - (< (progn - (and cperl-syntaxify-for-menu - (cperl-update-syntaxification (point-max))) - (next-single-property-change (point-min) 'here-doc-group nil (point-max))) - (point-max))] - ["Narrow to this HERE-DOC" cperl-narrow-to-here-doc - (eq 'here-doc (progn - (and cperl-syntaxify-for-menu - (cperl-update-syntaxification (point))) - (get-text-property (point) 'syntax-type)))] - ["Select this HERE-DOC or POD section" - cperl-select-this-pod-or-here-doc - (memq (progn - (and cperl-syntaxify-for-menu - (cperl-update-syntaxification (point))) - (get-text-property (point) 'syntax-type)) - '(here-doc pod))] - "----" - ["CPerl pretty print (experimental)" cperl-ps-print - (fboundp 'ps-extend-face-list)] - "----" - ["Syntaxify region" cperl-find-pods-heres-region - (use-region-p)] - ["Profile syntaxification" cperl-time-fontification t] - ["Debug errors in delayed fontification" cperl-emulate-lazy-lock t] - ["Debug unwind for syntactic scan" cperl-toggle-set-debug-unwind t] - ["Debug backtrace on syntactic scan (BEWARE!!!)" - (cperl-toggle-set-debug-unwind nil t) t] - "----" - ["Class Hierarchy from TAGS" cperl-tags-hier-init t] - ;;["Update classes" (cperl-tags-hier-init t) tags-table-list] - ("Tags" - ;; ["Create tags for current file" cperl-etags t] - ;; ["Add tags for current file" (cperl-etags t) t] - ;; ["Create tags for Perl files in directory" (cperl-etags nil t) t] - ;; ["Add tags for Perl files in directory" (cperl-etags t t) t] - ;; ["Create tags for Perl files in (sub)directories" - ;; (cperl-etags nil 'recursive) t] - ;; ["Add tags for Perl files in (sub)directories" - ;; (cperl-etags t 'recursive) t]) - ;; ;;? cperl-write-tags (&optional file erase recurse dir inbuffer) - ["Create tags for current file" (cperl-write-tags nil t) t] - ["Add tags for current file" (cperl-write-tags) t] - ["Create tags for Perl files in directory" - (cperl-write-tags nil t nil t) t] - ["Add tags for Perl files in directory" - (cperl-write-tags nil nil nil t) t] - ["Create tags for Perl files in (sub)directories" - (cperl-write-tags nil t t t) t] - ["Add tags for Perl files in (sub)directories" - (cperl-write-tags nil nil t t) t])) - ("Perl docs" - ["Define word at point" imenu-go-find-at-position - (fboundp 'imenu-go-find-at-position)] - ["Help on function" cperl-info-on-command t] - ["Help on function at point" cperl-info-on-current-command t] - ["Help on symbol at point" cperl-get-help t] - ["Perldoc" cperl-perldoc t] - ["Perldoc on word at point" cperl-perldoc-at-point t] - ["View manpage of POD in this file" cperl-build-manpage t] - ["Auto-help on" cperl-lazy-install - (not cperl-lazy-installed)] - ["Auto-help off" cperl-lazy-unstall - cperl-lazy-installed]) - ("Toggle..." - ["Auto newline" cperl-toggle-auto-newline t] - ["Electric parens" cperl-toggle-electric t] - ["Electric keywords" cperl-toggle-abbrev t] - ["Fix whitespace on indent" cperl-toggle-construct-fix t] - ["Auto-help on Perl constructs" cperl-toggle-autohelp t] - ["Auto fill" auto-fill-mode t]) - ("Indent styles..." - ["CPerl" (cperl-set-style "CPerl") t] - ["PBP" (cperl-set-style "PBP") t] - ["PerlStyle" (cperl-set-style "PerlStyle") t] - ["GNU" (cperl-set-style "GNU") t] - ["C++" (cperl-set-style "C++") t] - ["K&R" (cperl-set-style "K&R") t] - ["BSD" (cperl-set-style "BSD") t] - ["Whitesmith" (cperl-set-style "Whitesmith") t] - ["Memorize Current" (cperl-set-style "Current") t] - ["Memorized" (cperl-set-style-back) cperl-old-style]) - ("Micro-docs" - ["Tips" (describe-variable 'cperl-tips) t] - ["Problems" (describe-variable 'cperl-problems) t] - ["Speed" (describe-variable 'cperl-speed) t] - ["Praise" (describe-variable 'cperl-praise) t] - ["Faces" (describe-variable 'cperl-tips-faces) t] - ["CPerl mode" (describe-function 'cperl-mode) t])))) - (error nil)) +(easy-menu-define cperl-menu cperl-mode-map + "Menu for CPerl mode." + '("Perl" + ["Beginning of function" beginning-of-defun t] + ["End of function" end-of-defun t] + ["Mark function" mark-defun t] + ["Indent expression" cperl-indent-exp t] + ["Fill paragraph/comment" fill-paragraph t] + "----" + ["Line up a construction" cperl-lineup (use-region-p)] + ["Invert if/unless/while etc" cperl-invert-if-unless t] + ("Regexp" + ["Beautify" cperl-beautify-regexp + cperl-use-syntax-table-text-property] + ["Beautify one level deep" (cperl-beautify-regexp 1) + cperl-use-syntax-table-text-property] + ["Beautify a group" cperl-beautify-level + cperl-use-syntax-table-text-property] + ["Beautify a group one level deep" (cperl-beautify-level 1) + cperl-use-syntax-table-text-property] + ["Contract a group" cperl-contract-level + cperl-use-syntax-table-text-property] + ["Contract groups" cperl-contract-levels + cperl-use-syntax-table-text-property] + "----" + ["Find next interpolated" cperl-next-interpolated-REx + (next-single-property-change (point-min) 'REx-interpolated)] + ["Find next interpolated (no //o)" + cperl-next-interpolated-REx-0 + (or (text-property-any (point-min) (point-max) 'REx-interpolated t) + (text-property-any (point-min) (point-max) 'REx-interpolated 1))] + ["Find next interpolated (neither //o nor whole-REx)" + cperl-next-interpolated-REx-1 + (text-property-any (point-min) (point-max) 'REx-interpolated t)]) + ["Insert spaces if needed to fix style" cperl-find-bad-style t] + ["Refresh \"hard\" constructions" cperl-find-pods-heres t] + "----" + ["Indent region" cperl-indent-region (use-region-p)] + ["Comment region" cperl-comment-region (use-region-p)] + ["Uncomment region" cperl-uncomment-region (use-region-p)] + "----" + ["Run" mode-compile (fboundp 'mode-compile)] + ["Kill" mode-compile-kill (and (fboundp 'mode-compile-kill) + (get-buffer "*compilation*"))] + ["Next error" next-error (get-buffer "*compilation*")] + ["Check syntax" cperl-check-syntax (fboundp 'mode-compile)] + "----" + ["Debugger" cperl-db t] + "----" + ("Tools" + ["Imenu" imenu (fboundp 'imenu)] + ["Imenu on Perl Info" cperl-imenu-on-info (featurep 'imenu)] + "----" + ["Ispell PODs" cperl-pod-spell + ;; Better not to update syntaxification here: + ;; debugging syntaxification can be broken by this??? + (or + (get-text-property (point-min) 'in-pod) + (< (progn + (and cperl-syntaxify-for-menu + (cperl-update-syntaxification (point-max))) + (next-single-property-change (point-min) 'in-pod nil (point-max))) + (point-max)))] + ["Ispell HERE-DOCs" cperl-here-doc-spell + (< (progn + (and cperl-syntaxify-for-menu + (cperl-update-syntaxification (point-max))) + (next-single-property-change (point-min) 'here-doc-group nil (point-max))) + (point-max))] + ["Narrow to this HERE-DOC" cperl-narrow-to-here-doc + (eq 'here-doc (progn + (and cperl-syntaxify-for-menu + (cperl-update-syntaxification (point))) + (get-text-property (point) 'syntax-type)))] + ["Select this HERE-DOC or POD section" + cperl-select-this-pod-or-here-doc + (memq (progn + (and cperl-syntaxify-for-menu + (cperl-update-syntaxification (point))) + (get-text-property (point) 'syntax-type)) + '(here-doc pod))] + "----" + ["CPerl pretty print (experimental)" cperl-ps-print + (fboundp 'ps-extend-face-list)] + "----" + ["Syntaxify region" cperl-find-pods-heres-region + (use-region-p)] + ["Profile syntaxification" cperl-time-fontification t] + ["Debug errors in delayed fontification" cperl-emulate-lazy-lock t] + ["Debug unwind for syntactic scan" cperl-toggle-set-debug-unwind t] + ["Debug backtrace on syntactic scan (BEWARE!!!)" + (cperl-toggle-set-debug-unwind nil t) t] + "----" + ["Class Hierarchy from TAGS" cperl-tags-hier-init t] + ;;["Update classes" (cperl-tags-hier-init t) tags-table-list] + ("Tags" + ;; ["Create tags for current file" cperl-etags t] + ;; ["Add tags for current file" (cperl-etags t) t] + ;; ["Create tags for Perl files in directory" (cperl-etags nil t) t] + ;; ["Add tags for Perl files in directory" (cperl-etags t t) t] + ;; ["Create tags for Perl files in (sub)directories" + ;; (cperl-etags nil 'recursive) t] + ;; ["Add tags for Perl files in (sub)directories" + ;; (cperl-etags t 'recursive) t]) + ;; ;;? cperl-write-tags (&optional file erase recurse dir inbuffer) + ["Create tags for current file" (cperl-write-tags nil t) t] + ["Add tags for current file" (cperl-write-tags) t] + ["Create tags for Perl files in directory" + (cperl-write-tags nil t nil t) t] + ["Add tags for Perl files in directory" + (cperl-write-tags nil nil nil t) t] + ["Create tags for Perl files in (sub)directories" + (cperl-write-tags nil t t t) t] + ["Add tags for Perl files in (sub)directories" + (cperl-write-tags nil nil t t) t])) + ("Perl docs" + ["Define word at point" imenu-go-find-at-position + (fboundp 'imenu-go-find-at-position)] + ["Help on function" cperl-info-on-command t] + ["Help on function at point" cperl-info-on-current-command t] + ["Help on symbol at point" cperl-get-help t] + ["Perldoc" cperl-perldoc t] + ["Perldoc on word at point" cperl-perldoc-at-point t] + ["View manpage of POD in this file" cperl-build-manpage t] + ["Auto-help on" cperl-lazy-install + (not cperl-lazy-installed)] + ["Auto-help off" cperl-lazy-unstall + cperl-lazy-installed]) + ("Toggle..." + ["Auto newline" cperl-toggle-auto-newline t] + ["Electric parens" cperl-toggle-electric t] + ["Electric keywords" cperl-toggle-abbrev t] + ["Fix whitespace on indent" cperl-toggle-construct-fix t] + ["Auto-help on Perl constructs" cperl-toggle-autohelp t] + ["Auto fill" auto-fill-mode t]) + ("Indent styles..." + ["CPerl" (cperl-set-style "CPerl") t] + ["PBP" (cperl-set-style "PBP") t] + ["PerlStyle" (cperl-set-style "PerlStyle") t] + ["GNU" (cperl-set-style "GNU") t] + ["C++" (cperl-set-style "C++") t] + ["K&R" (cperl-set-style "K&R") t] + ["BSD" (cperl-set-style "BSD") t] + ["Whitesmith" (cperl-set-style "Whitesmith") t] + ["Memorize Current" (cperl-set-style "Current") t] + ["Memorized" (cperl-set-style-back) cperl-old-style]) + ("Micro-docs" + ["Tips" (describe-variable 'cperl-tips) t] + ["Problems" (describe-variable 'cperl-problems) t] + ["Speed" (describe-variable 'cperl-speed) t] + ["Praise" (describe-variable 'cperl-praise) t] + ["Faces" (describe-variable 'cperl-tips-faces) t] + ["CPerl mode" (describe-function 'cperl-mode) t]))) (autoload 'c-macro-expand "cmacexp" "Display the result of expanding all C macros occurring in the region. The expansion is entirely correct because it uses the C preprocessor." t) + +;;; Perl Grammar Components +;; +;; The following regular expressions are building blocks for a +;; minimalistic Perl grammar, to be used instead of individual (and +;; not always consistent) literal regular expressions. + +(defconst cperl--basic-identifier-regexp + (rx (sequence (or alpha "_") (* (or word "_")))) + "A regular expression for the name of a \"basic\" Perl variable. +Neither namespace separators nor sigils are included. As is, +this regular expression applies to labels,subroutine calls where +the ampersand sigil is not required, and names of subroutine +attributes.") + +(defconst cperl--label-regexp + (rx-to-string + `(sequence + symbol-start + (regexp ,cperl--basic-identifier-regexp) + (0+ space) + ":")) + "A regular expression for a Perl label. +By convention, labels are uppercase alphabetics, but this isn't +enforced.") + +(defconst cperl--normal-identifier-regexp + (rx-to-string + `(or + (sequence + (1+ (sequence + (opt (regexp ,cperl--basic-identifier-regexp)) + "::")) + (opt (regexp ,cperl--basic-identifier-regexp))) + (regexp ,cperl--basic-identifier-regexp))) + "A regular expression for a Perl variable name with optional namespace. +Examples are `foo`, `Some::Module::VERSION`, and `::` (yes, that +is a legal variable name).") + +(defconst cperl--special-identifier-regexp + (rx-to-string + `(or + (1+ digit) ; $0, $1, $2, ... + (sequence "^" (any "A-Z" "]^_?\\")) ; $^V + (sequence "{" (0+ space) ; ${^MATCH} + "^" (any "A-Z" "]^_?\\") + (0+ (any "A-Z" "_" digit)) + (0+ space) "}") + (in "!\"$%&'()+,-./:;<=>?@\\]^_`|~"))) ; $., $|, $", ... but not $^ or ${ + "The list of Perl \"punctuation\" variables, as listed in perlvar.") + +(defconst cperl--ws-regexp + (rx-to-string + '(or space "\n")) + "Regular expression for a single whitespace in Perl.") + +(defconst cperl--eol-comment-regexp + (rx-to-string + '(sequence "#" (0+ (not (in "\n"))) "\n")) + "Regular expression for a single end-of-line comment in Perl") + +(defconst cperl--ws-or-comment-regexp + (rx-to-string + `(1+ + (or + (regexp ,cperl--ws-regexp) + (regexp ,cperl--eol-comment-regexp)))) + "Regular expression for a sequence of whitespace and comments in Perl.") + +(defconst cperl--ows-regexp + (rx-to-string + `(opt (regexp ,cperl--ws-or-comment-regexp))) + "Regular expression for optional whitespaces or comments in Perl") + +(defconst cperl--version-regexp + (rx-to-string + `(or + (sequence (opt "v") + (>= 2 (sequence (1+ digit) ".")) + (1+ digit) + (opt (sequence "_" (1+ word)))) + (sequence (1+ digit) + (opt (sequence "." (1+ digit))) + (opt (sequence "_" (1+ word)))))) + "A sequence for recommended version number schemes in Perl.") + +(defconst cperl--package-regexp + (rx-to-string + `(sequence + "package" ; FIXME: the "class" and "role" keywords need to be + ; recognized soon...ish. + (regexp ,cperl--ws-or-comment-regexp) + (group (regexp ,cperl--normal-identifier-regexp)) + (opt + (sequence + (regexp ,cperl--ws-or-comment-regexp) + (group (regexp ,cperl--version-regexp)))))) + "A regular expression for package NAME VERSION in Perl. +Contains two groups for the package name and version.") + +(defconst cperl--package-for-imenu-regexp + (rx-to-string + `(sequence + (regexp ,cperl--package-regexp) + (regexp ,cperl--ows-regexp) + (group (or ";" "{")))) + "A regular expression to collect package names for `imenu`. +Catches \"package NAME;\", \"package NAME VERSION;\", \"package +NAME BLOCK\" and \"package NAME VERSION BLOCK.\" Contains three +groups: Two from `cperl--package-regexp` for the package name and +version, and a third to detect \"package BLOCK\" syntax.") + +(defconst cperl--sub-name-regexp + (rx-to-string + `(sequence + (optional (sequence (group (or "my" "state" "our")) + (regexp ,cperl--ws-or-comment-regexp))) + "sub" ; FIXME: the "method" and maybe "fun" keywords need to be + ; recognized soon...ish. + (regexp ,cperl--ws-or-comment-regexp) + (group (regexp ,cperl--normal-identifier-regexp)))) + "A regular expression to detect a subroutine start. +Contains two groups: One for to distinguish lexical from +\"normal\" subroutines and one for the subroutine name.") + +(defconst cperl--pod-heading-regexp + (rx-to-string + `(sequence + line-start "=head" + (group (in "1-4")) + (1+ (in " \t")) + (group (1+ (not (in "\n")))) + line-end)) ; that line-end seems to be redundant? + "A regular expression to detect a POD heading. +Contains two groups: One for the heading level, and one for the +heading text.") + +(defconst cperl--imenu-entries-regexp + (rx-to-string + `(or + (regexp ,cperl--package-for-imenu-regexp) ; 1..3 + (regexp ,cperl--sub-name-regexp) ; 4..5 + (regexp ,cperl--pod-heading-regexp))) ; 6..7 + "A regular expression to collect stuff that goes into the `imenu` index. +Covers packages, subroutines, and POD headings.") + + ;; These two must be unwound, otherwise take exponential time (defconst cperl-maybe-white-and-comment-rex "[ \t\n]*\\(#[^\n]*\n[ \t\n]*\\)*" "Regular expression to match optional whitespace with interspersed comments. @@ -1268,8 +1354,7 @@ Should contain exactly one group.") Should contain exactly one group.") -;; Is incorporated in `cperl-imenu--function-name-regexp-perl' -;; `cperl-outline-regexp', `defun-prompt-regexp'. +;; Is incorporated in `cperl-outline-regexp', `defun-prompt-regexp'. ;; Details of groups in this may be used in several functions; see comments ;; near mentioned above variable(s)... ;; sub($$):lvalue{} sub:lvalue{} Both allowed... @@ -1396,13 +1481,15 @@ the last)." (defvar cperl-font-lock-multiline nil) (defvar cperl-font-locking nil) -;; NB as it stands the code in cperl-mode assumes this only has one -;; element. Since XEmacs 19 support has been dropped, this could all be simplified. -(defvar cperl-compilation-error-regexp-alist +(defvar cperl-compilation-error-regexp-list ;; This look like a paranoiac regexp: could anybody find a better one? (which WORKS). - '(("^[^\n]* \\(file\\|at\\) \\([^ \t\n]+\\) [^\n]*line \\([0-9]+\\)[\\., \n]" - 2 3)) - "Alist that specifies how to match errors in perl output.") + '("^[^\n]* \\(file\\|at\\) \\([^ \t\n]+\\) [^\n]*line \\([0-9]+\\)[\\., \n]" + 2 3) + "List that specifies how to match errors in Perl output.") + +(defvar cperl-compilation-error-regexp-alist) +(make-obsolete-variable 'cperl-compilation-error-regexp-alist + 'cperl-compilation-error-regexp-list "28.1") (defvar compilation-error-regexp-alist) @@ -1512,8 +1599,7 @@ span the needed amount of lines. Variables `cperl-pod-here-scan', `cperl-pod-here-fontify', `cperl-pod-face', `cperl-pod-head-face' control processing of POD and -here-docs sections. With capable Emaxen results of scan are used -for indentation too, otherwise they are used for highlighting only. +here-docs sections. Results of scan are used for indentation too. Variables controlling indentation style: `cperl-tab-always-indent' @@ -1639,19 +1725,18 @@ or as help on variables `cperl-tips', `cperl-problems', (setq-local imenu-sort-function nil) (setq-local vc-rcs-header cperl-vc-rcs-header) (setq-local vc-sccs-header cperl-vc-sccs-header) - (cond ((boundp 'compilation-error-regexp-alist-alist);; xemacs 20.x - (setq-local compilation-error-regexp-alist-alist - (cons (cons 'cperl (car cperl-compilation-error-regexp-alist)) - compilation-error-regexp-alist-alist)) - (if (fboundp 'compilation-build-compilation-error-regexp-alist) - (let ((f 'compilation-build-compilation-error-regexp-alist)) - (funcall f)) - (make-local-variable 'compilation-error-regexp-alist) - (push 'cperl compilation-error-regexp-alist))) - ((boundp 'compilation-error-regexp-alist);; xemacs 19.x - (setq-local compilation-error-regexp-alist - (append cperl-compilation-error-regexp-alist - compilation-error-regexp-alist)))) + (when (boundp 'compilation-error-regexp-alist-alist) + ;; The let here is just a compatibility kludge for the obsolete + ;; variable `cperl-compilation-error-regexp-alist'. It can be removed + ;; when that variable is removed. + (let ((regexp (if (boundp 'cperl-compilation-error-regexp-alist) + (car cperl-compilation-error-regexp-alist) + cperl-compilation-error-regexp-list))) + (setq-local compilation-error-regexp-alist-alist + (cons (cons 'cperl regexp) + compilation-error-regexp-alist-alist))) + (make-local-variable 'compilation-error-regexp-alist) + (push 'cperl compilation-error-regexp-alist)) (setq-local font-lock-defaults '((cperl-load-font-lock-keywords cperl-load-font-lock-keywords-1 @@ -1665,12 +1750,12 @@ or as help on variables `cperl-tips', `cperl-problems', (setq-local syntax-propertize-function (lambda (start end) (goto-char start) - ;; Even if cperl-fontify-syntaxically has already gone + ;; Even if cperl-fontify-syntactically has already gone ;; beyond `start', syntax-propertize has just removed ;; syntax-table properties between start and end, so we have ;; to re-apply them. (setq cperl-syntax-done-to start) - (cperl-fontify-syntaxically end)))) + (cperl-fontify-syntactically end)))) (setq cperl-font-lock-multiline t) ; Not localized... (setq-local font-lock-multiline t) (setq-local font-lock-fontify-region-function @@ -2139,7 +2224,7 @@ Help message may be switched off by setting `cperl-message-electric-keyword' to nil." (let ((beg (point-at-bol))) (and (save-excursion - (backward-sexp 1) + (skip-chars-backward "[:alpha:]") (cperl-after-expr-p nil "{;:")) (save-excursion (not @@ -3500,7 +3585,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', "\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>" ; QUOTED CONSTRUCT "\\|" ;; 1+6+2+1=10 extra () before this: - "\\([?/<]\\)" ; /blah/ or ?blah? or <file*glob> + "\\([/<]\\)" ; /blah/ or <file*glob> "\\|" ;; 1+6+2+1+1=11 extra () before this "\\<" cperl-sub-regexp "\\>" ; sub with proto/attr @@ -3523,7 +3608,8 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', ;; 1+6+2+1+1+6+1+1+1=20 extra () before this: "\\|" "\\\\\\(['`\"($]\\)") ; BACKWACKED something-hairy - "")))) + ""))) + warning-message) (unwind-protect (progn (save-excursion @@ -3586,7 +3672,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (looking-at "\\(cut\\|end\\)\\>")) (if (or (nth 3 state) (nth 4 state) ignore-max) nil ; Doing a chunk only - (message "=cut is not preceded by a POD section") + (setq warning-message "=cut is not preceded by a POD section") (or (car err-l) (setcar err-l (point)))) (beginning-of-line) @@ -3601,7 +3687,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (goto-char b) (if (re-search-forward "\n=\\(cut\\|end\\)\\>" stop-point 'toend) (progn - (message "=cut is not preceded by an empty line") + (setq warning-message "=cut is not preceded by an empty line") (setq b1 t) (or (car err-l) (setcar err-l b)))))) (beginning-of-line 2) ; An empty line after =cut is not POD! @@ -3744,7 +3830,8 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (progn ; Pretend we matched at the end (goto-char (point-max)) (re-search-forward "\\'") - (message "End of here-document `%s' not found." tag) + (setq warning-message + (format "End of here-document `%s' not found." tag)) (or (car err-l) (setcar err-l b)))) (if cperl-pod-here-fontify (progn @@ -3821,7 +3908,8 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', 'face font-lock-string-face) (cperl-commentify (point) (+ (point) 2) nil) (cperl-put-do-not-fontify (point) (+ (point) 2) t)) - (message "End of format `%s' not found." name) + (setq warning-message + (format "End of format `%s' not found." name)) (or (car err-l) (setcar err-l b))) (forward-line) (if (> (point) max) @@ -3832,7 +3920,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', ;; 1+6+2=9 extra () before this: ;; "\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>" ;; "\\|" - ;; "\\([?/<]\\)" ; /blah/ or ?blah? or <file*glob> + ;; "\\([/<]\\)" ; /blah/ or <file*glob> (setq b1 (if (match-beginning 10) 10 11) argument (buffer-substring (match-beginning b1) (match-end b1)) @@ -3842,21 +3930,24 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', bb (char-after (1- (match-beginning b1))) ; tmp holder ;; bb == "Not a stringy" bb (if (eq b1 10) ; user variables/whatever - (and (memq bb (append "$@%*#_:-&>" nil)) ; $#y) - (cond ((eq bb ?-) (eq c ?s)) ; -s file test - ((eq bb ?\:) ; $opt::s - (eq (char-after - (- (match-beginning b1) 2)) - ?\:)) - ((eq bb ?\>) ; $foo->s - (eq (char-after - (- (match-beginning b1) 2)) - ?\-)) - ((eq bb ?\&) - (not (eq (char-after ; &&m/blah/ - (- (match-beginning b1) 2)) - ?\&))) - (t t))) + (or + ; false positive: "y_" has no word boundary + (save-match-data (looking-at "_")) + (and (memq bb (append "$@%*#_:-&>" nil)) ; $#y) + (cond ((eq bb ?-) (eq c ?s)) ; -s file test + ((eq bb ?\:) ; $opt::s + (eq (char-after + (- (match-beginning b1) 2)) + ?\:)) + ((eq bb ?\>) ; $foo->s + (eq (char-after + (- (match-beginning b1) 2)) + ?\-)) + ((eq bb ?\&) + (not (eq (char-after ; &&m/blah/ + (- (match-beginning b1) 2)) + ?\&))) + (t t)))) ;; <file> or <$file> (and (eq c ?\<) ;; Do not stringify <FH>, <$fh> : @@ -3867,7 +3958,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (goto-char (match-beginning b1)) (cperl-backward-to-noncomment (point-min)) (or bb - (if (eq b1 11) ; bare /blah/ or ?blah? or <foo> + (if (eq b1 11) ; bare /blah/ or <foo> (setq argument "" b1 nil bb ; Not a regexp? @@ -3875,7 +3966,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', ;; What is below: regexp-p? (and (or (memq (preceding-char) - (append (if (memq c '(?\? ?\<)) + (append (if (char-equal c ?\<) ;; $a++ ? 1 : 2 "~{(=|&*!,;:[" "~{(=|&+-*!,;:[") nil)) @@ -3886,14 +3977,11 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (forward-sexp -1) ;; After these keywords `/' starts a RE. One should add all the ;; functions/builtins which expect an argument, but ... - (if (eq (preceding-char) ?-) - ;; -d ?foo? is a RE - (looking-at "[a-zA-Z]\\>") (and (not (memq (preceding-char) '(?$ ?@ ?& ?%))) (looking-at - "\\(while\\|if\\|unless\\|until\\|and\\|or\\|not\\|xor\\|split\\|grep\\|map\\|print\\|say\\|return\\)\\>"))))) + "\\(while\\|if\\|unless\\|until\\|for\\(each\\)?\\|and\\|or\\|not\\|xor\\|split\\|grep\\|map\\|print\\|say\\|return\\)\\>")))) (and (eq (preceding-char) ?.) (eq (char-after (- (point) 2)) ?.)) (bobp)) @@ -4338,8 +4426,9 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', REx-subgr-end argument) ; continue (setq argument nil))) (and argument - (message "Couldn't find end of charclass in a REx, pos=%s" - REx-subgr-start)) + (setq warning-message + (format "Couldn't find end of charclass in a REx, pos=%s" + REx-subgr-start))) (setq argument (1- (point))) (goto-char REx-subgr-end) (cperl-highlight-charclass @@ -4395,7 +4484,8 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (setq qtag "Can't find })"))) (progn (goto-char (1- e)) - (message "%s" qtag)) + (setq warning-message + (format "%s" qtag))) (cperl-postpone-fontification (1- tag) (1- (point)) 'face font-lock-variable-name-face) @@ -4424,9 +4514,9 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', ;; (1- e) 'toend) (search-forward ")" (1- e) 'toend) ;;) - (message - "Couldn't find end of (?#...)-comment in a REx, pos=%s" - REx-subgr-start)))) + (setq warning-message + (format "Couldn't find end of (?#...)-comment in a REx, pos=%s" + REx-subgr-start))))) (if (>= (point) e) (goto-char (1- e))) (cond @@ -4504,8 +4594,8 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (if (> (point) stop-point) (progn (if end - (message "Garbage after __END__/__DATA__ ignored") - (message "Unbalanced syntax found while scanning") + (setq warning-message "Garbage after __END__/__DATA__ ignored") + (setq warning-message "Unbalanced syntax found while scanning") (or (car err-l) (setcar err-l b))) (goto-char stop-point)))) (setq cperl-syntax-state (cons state-point state) @@ -4524,6 +4614,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', ;; cperl-mode-syntax-table. ;; (set-syntax-table cperl-mode-syntax-table) ) + (when warning-message (message warning-message)) (list (car err-l) overshoot))) (defun cperl-find-pods-heres-region (min max) @@ -5188,117 +5279,80 @@ indentation and initial hashes. Behaves usually outside of comment." ;; Previous space could have gone: (or (memq (preceding-char) '(?\s ?\t)) (insert " ")))))) -(defun cperl-imenu-addback (lst &optional isback name) - ;; We suppose that the lst is a DAG, unless the first element only - ;; loops back, and ISBACK is set. Thus this function cannot be - ;; applied twice without ISBACK set. - (cond ((not cperl-imenu-addback) lst) - (t - (or name - (setq name "+++BACK+++")) - (mapc (lambda (elt) - (if (and (listp elt) (listp (cdr elt))) - (progn - ;; In the other order it goes up - ;; one level only ;-( - (setcdr elt (cons (cons name lst) - (cdr elt))) - (cperl-imenu-addback (cdr elt) t name)))) - (if isback (cdr lst) lst)) - lst))) - -(defun cperl-imenu--create-perl-index (&optional regexp) - (require 'imenu) ; May be called from TAGS creator - (let ((index-alist '()) (index-pack-alist '()) (index-pod-alist '()) +(defun cperl-imenu--create-perl-index () + "Implement `imenu-create-index-function` for CPerl mode. +This function relies on syntaxification to exclude lines which +look like declarations but actually are part of a string, a +comment, or POD." + (interactive) ; We'll remove that at some point + (goto-char (point-min)) + (cperl-update-syntaxification (point-max)) + (let ((case-fold-search nil) + (index-alist '()) + (index-package-alist '()) + (index-pod-alist '()) + (index-sub-alist '()) (index-unsorted-alist '()) - (index-meth-alist '()) meth - packages ends-ranges p marker is-proto - is-pack index index1 name (end-range 0) package) - (goto-char (point-min)) - (cperl-update-syntaxification (point-max)) - ;; Search for the function - (progn ;;save-match-data - (while (re-search-forward - (or regexp cperl-imenu--function-name-regexp-perl) - nil t) - ;; 2=package-group, 5=package-name 8=sub-name + (package-stack '()) ; for package NAME BLOCK + (current-package "(main)") + (current-package-end (point-max))) ; end of package scope + ;; collect index entries + (while (re-search-forward cperl--imenu-entries-regexp nil t) + ;; First, check whether we have left the scope of previously + ;; recorded packages, and if so, eliminate them from the stack. + (while (< current-package-end (point)) + (setq current-package (pop package-stack)) + (setq current-package-end (pop package-stack))) + (let ((state (syntax-ppss)) + name marker) ; for the "current" entry (cond - ((and ; Skip some noise if building tags - (match-beginning 5) ; package name - ;;(eq (char-after (match-beginning 2)) ?p) ; package - (not (save-match-data - (looking-at "[ \t\n]*;")))) ; Plain text word 'package' - nil) - ((and - (or (match-beginning 2) - (match-beginning 8)) ; package or sub - ;; Skip if quoted (will not skip multi-line ''-strings :-(): - (null (get-text-property (match-beginning 1) 'syntax-table)) - (null (get-text-property (match-beginning 1) 'syntax-type)) - (null (get-text-property (match-beginning 1) 'in-pod))) - (setq is-pack (match-beginning 2)) - ;; (if (looking-at "([^()]*)[ \t\n\f]*") - ;; (goto-char (match-end 0))) ; Messes what follows - (setq meth nil - p (point)) - (while (and ends-ranges (>= p (car ends-ranges))) - ;; delete obsolete entries - (setq ends-ranges (cdr ends-ranges) packages (cdr packages))) - (setq package (or (car packages) "") - end-range (or (car ends-ranges) 0)) - (if is-pack ; doing "package" - (progn - (if (match-beginning 5) ; named package - (setq name (buffer-substring (match-beginning 5) - (match-end 5)) - name (progn - (set-text-properties 0 (length name) nil name) - name) - package (concat name "::") - name (concat "package " name)) - ;; Support nameless packages - (setq name "package;" package "")) - (setq end-range - (save-excursion - (parse-partial-sexp (point) (point-max) -1) (point)) - ends-ranges (cons end-range ends-ranges) - packages (cons package packages))) - (setq is-proto - (or (eq (following-char) ?\;) - (eq 0 (get-text-property (point) 'attrib-group))))) - ;; Skip this function name if it is a prototype declaration. - (if (and is-proto (not is-pack)) nil - (or is-pack - (setq name - (buffer-substring (match-beginning 8) (match-end 8))) - (set-text-properties 0 (length name) nil name)) - (setq marker (make-marker)) - (set-marker marker (match-end (if is-pack 2 8))) - (cond (is-pack nil) - ((string-match "[:']" name) - (setq meth t)) - ((> p end-range) nil) - (t - (setq name (concat package name) meth t))) - (setq index (cons name marker)) - (if is-pack - (push index index-pack-alist) - (push index index-alist)) - (if meth (push index index-meth-alist)) - (push index index-unsorted-alist))) - ((match-beginning 16) ; POD section - (setq name (buffer-substring (match-beginning 17) (match-end 17)) - marker (make-marker)) - (set-marker marker (match-beginning 17)) - (set-text-properties 0 (length name) nil name) - (setq name (concat (make-string - (* 3 (- (char-after (match-beginning 16)) ?1)) - ?\ ) - name) - index (cons name marker)) - (setq index1 (cons (concat "=" name) (cdr index))) - (push index index-pod-alist) - (push index1 index-unsorted-alist))))) + ((nth 3 state) nil) ; matched in a string, so skip + ((match-string 1) ; found a package name! + (unless (nth 4 state) ; skip if in a comment + (setq name (match-string-no-properties 1) + marker (copy-marker (match-end 1))) + (if (string= (match-string 3) ";") + (setq current-package name) ; package NAME; + ;; No semicolon, therefore we have: package NAME BLOCK. + ;; Stash the current package, because we need to restore + ;; it after the end of BLOCK. + (push current-package-end package-stack) + (push current-package package-stack) + ;; record the current name and its scope + (setq current-package name) + (setq current-package-end (save-excursion + (goto-char (match-beginning 3)) + (forward-sexp) + (point))) + (push (cons name marker) index-package-alist) + (push (cons (concat "package " name) marker) index-unsorted-alist)))) + ((match-string 5) ; found a sub name! + (unless (nth 4 state) ; skip if in a comment + (setq name (match-string-no-properties 5) + marker (copy-marker (match-end 5))) + ;; Qualify the sub name with the package if it doesn't + ;; already have one, and if it isn't lexically scoped. + ;; "my" and "state" subs are lexically scoped, but "our" + ;; are just lexical aliases to package subs. + (if (and (null (string-match "::" name)) + (or (null (match-string 4)) + (string-equal (match-string 4) "our"))) + (setq name (concat current-package "::" name))) + (let ((index (cons name marker))) + (push index index-alist) + (push index index-sub-alist) + (push index index-unsorted-alist)))) + ((match-string 6) ; found a POD heading! + (when (get-text-property (match-beginning 6) 'in-pod) + (setq name (concat (make-string + (* 3 (- (char-after (match-beginning 6)) ?1)) + ?\ ) + (match-string-no-properties 7)) + marker (copy-marker (match-beginning 7))) + (push (cons name marker) index-pod-alist) + (push (cons (concat "=" name) marker) index-unsorted-alist))) + (t (error "Unidentified match: %s" (match-string 0)))))) + ;; Now format the collected stuff (setq index-alist (if (default-value 'imenu-sort-function) (sort index-alist (default-value 'imenu-sort-function)) @@ -5307,14 +5361,14 @@ indentation and initial hashes. Behaves usually outside of comment." (push (cons "+POD headers+..." (nreverse index-pod-alist)) index-alist)) - (and (or index-pack-alist index-meth-alist) - (let ((lst index-pack-alist) hier-list pack elt group name) - ;; Remove "package ", reverse and uniquify. + (and (or index-package-alist index-sub-alist) + (let ((lst index-package-alist) hier-list pack elt group name) + ;; reverse and uniquify. (while lst - (setq elt (car lst) lst (cdr lst) name (substring (car elt) 8)) + (setq elt (car lst) lst (cdr lst) name (car elt)) (if (assoc name hier-list) nil (setq hier-list (cons (cons name (cdr elt)) hier-list)))) - (setq lst index-meth-alist) + (setq lst index-sub-alist) (while lst (setq elt (car lst) lst (cdr lst)) (cond ((string-match "\\(::\\|'\\)[_a-zA-Z0-9]+$" (car elt)) @@ -5342,17 +5396,18 @@ indentation and initial hashes. Behaves usually outside of comment." (push (cons "+Hierarchy+..." hier-list) index-alist))) - (and index-pack-alist + (and index-package-alist (push (cons "+Packages+..." - (nreverse index-pack-alist)) + (nreverse index-package-alist)) index-alist)) - (and (or index-pack-alist index-pod-alist + (and (or index-package-alist index-pod-alist (default-value 'imenu-sort-function)) index-unsorted-alist (push (cons "+Unsorted List+..." (nreverse index-unsorted-alist)) index-alist)) - (cperl-imenu-addback index-alist))) + ;; Finally, return the whole collection + index-alist)) ;; Suggested by Mark A. Hershberger @@ -5415,120 +5470,79 @@ indentation and initial hashes. Behaves usually outside of comment." (cons (concat "\\(^\\|[^$@%&\\]\\)\\<\\(" - ;; FIXME: Use regexp-opt. - (mapconcat - #'identity + (regexp-opt (append cperl-sub-keywords '("if" "until" "while" "elsif" "else" - "given" "when" "default" "break" - "unless" "for" - "try" "catch" "finally" - "foreach" "continue" "exit" "die" "last" "goto" "next" - "redo" "return" "local" "exec" - "do" "dump" - "use" "our" - "require" "package" "eval" "evalbytes" "my" "state" - "BEGIN" "END" "CHECK" "INIT" "UNITCHECK")) - "\\|") ; Flow control + "given" "when" "default" "break" + "unless" "for" + "try" "catch" "finally" + "foreach" "continue" "exit" "die" "last" "goto" "next" + "redo" "return" "local" "exec" + "do" "dump" + "use" "our" + "require" "package" "eval" "evalbytes" "my" "state" + "BEGIN" "END" "CHECK" "INIT" "UNITCHECK"))) ; Flow control "\\)\\>") 2) ; was "\\)[ \n\t;():,|&]" ; In what follows we use `type' style ; for overwritable builtins (list (concat "\\(^\\|[^$@%&\\]\\)\\<\\(" - ;; FIXME: Use regexp-opt. - ;; "CORE" "__FILE__" "__LINE__" "__SUB__" "abs" "accept" "alarm" - ;; "and" "atan2" "bind" "binmode" "bless" "caller" - ;; "chdir" "chmod" "chown" "chr" "chroot" "close" - ;; "closedir" "cmp" "connect" "continue" "cos" "crypt" - ;; "dbmclose" "dbmopen" "die" "dump" "endgrent" - ;; "endhostent" "endnetent" "endprotoent" "endpwent" - ;; "endservent" "eof" "eq" "exec" "exit" "exp" "fc" "fcntl" - ;; "fileno" "flock" "fork" "formline" "ge" "getc" - ;; "getgrent" "getgrgid" "getgrnam" "gethostbyaddr" - ;; "gethostbyname" "gethostent" "getlogin" - ;; "getnetbyaddr" "getnetbyname" "getnetent" - ;; "getpeername" "getpgrp" "getppid" "getpriority" - ;; "getprotobyname" "getprotobynumber" "getprotoent" - ;; "getpwent" "getpwnam" "getpwuid" "getservbyname" - ;; "getservbyport" "getservent" "getsockname" - ;; "getsockopt" "glob" "gmtime" "gt" "hex" "index" "int" - ;; "ioctl" "join" "kill" "lc" "lcfirst" "le" "length" - ;; "link" "listen" "localtime" "lock" "log" "lstat" "lt" - ;; "mkdir" "msgctl" "msgget" "msgrcv" "msgsnd" "ne" - ;; "not" "oct" "open" "opendir" "or" "ord" "pack" "pipe" - ;; "quotemeta" "rand" "read" "readdir" "readline" - ;; "readlink" "readpipe" "recv" "ref" "rename" "require" - ;; "reset" "reverse" "rewinddir" "rindex" "rmdir" "seek" - ;; "seekdir" "select" "semctl" "semget" "semop" "send" - ;; "setgrent" "sethostent" "setnetent" "setpgrp" - ;; "setpriority" "setprotoent" "setpwent" "setservent" - ;; "setsockopt" "shmctl" "shmget" "shmread" "shmwrite" - ;; "shutdown" "sin" "sleep" "socket" "socketpair" - ;; "sprintf" "sqrt" "srand" "stat" "substr" "symlink" - ;; "syscall" "sysopen" "sysread" "sysseek" "system" "syswrite" "tell" - ;; "telldir" "time" "times" "truncate" "uc" "ucfirst" - ;; "umask" "unlink" "unpack" "utime" "values" "vec" - ;; "wait" "waitpid" "wantarray" "warn" "write" "x" "xor" - "a\\(bs\\|ccept\\|tan2\\|larm\\|nd\\)\\|" - "b\\(in\\(d\\|mode\\)\\|less\\)\\|" - "c\\(h\\(r\\(\\|oot\\)\\|dir\\|mod\\|own\\)\\|aller\\|rypt\\|" - "lose\\(\\|dir\\)\\|mp\\|o\\(s\\|n\\(tinue\\|nect\\)\\)\\)\\|" - "CORE\\|d\\(ie\\|bm\\(close\\|open\\)\\|ump\\)\\|" - "e\\(x\\(p\\|it\\|ec\\)\\|q\\|nd\\(p\\(rotoent\\|went\\)\\|" - "hostent\\|servent\\|netent\\|grent\\)\\|of\\)\\|" - "f\\(ileno\\|c\\(ntl\\)?\\|lock\\|or\\(k\\|mline\\)\\)\\|" - "g\\(t\\|lob\\|mtime\\|e\\(\\|t\\(p\\(pid\\|r\\(iority\\|" - "oto\\(byn\\(ame\\|umber\\)\\|ent\\)\\)\\|eername\\|w" - "\\(uid\\|ent\\|nam\\)\\|grp\\)\\|host\\(by\\(addr\\|name\\)\\|" - "ent\\)\\|s\\(erv\\(by\\(port\\|name\\)\\|ent\\)\\|" - "ock\\(name\\|opt\\)\\)\\|c\\|login\\|net\\(by\\(addr\\|name\\)\\|" - "ent\\)\\|gr\\(ent\\|nam\\|gid\\)\\)\\)\\)\\|" - "hex\\|i\\(n\\(t\\|dex\\)\\|octl\\)\\|join\\|kill\\|" - "l\\(i\\(sten\\|nk\\)\\|stat\\|c\\(\\|first\\)\\|t\\|e" - "\\(\\|ngth\\)\\|o\\(c\\(altime\\|k\\)\\|g\\)\\)\\|m\\(sg\\(rcv\\|snd\\|" - "ctl\\|get\\)\\|kdir\\)\\|n\\(e\\|ot\\)\\|o\\(pen\\(\\|dir\\)\\|" - "r\\(\\|d\\)\\|ct\\)\\|p\\(ipe\\|ack\\)\\|quotemeta\\|" - "r\\(index\\|and\\|mdir\\|e\\(quire\\|ad\\(pipe\\|\\|lin" - "\\(k\\|e\\)\\|dir\\)\\|set\\|cv\\|verse\\|f\\|winddir\\|name" - "\\)\\)\\|s\\(printf\\|qrt\\|rand\\|tat\\|ubstr\\|e\\(t\\(p\\(r" - "\\(iority\\|otoent\\)\\|went\\|grp\\)\\|hostent\\|s\\(ervent\\|" - "ockopt\\)\\|netent\\|grent\\)\\|ek\\(\\|dir\\)\\|lect\\|" - "m\\(ctl\\|op\\|get\\)\\|nd\\)\\|h\\(utdown\\|m\\(read\\|ctl\\|" - "write\\|get\\)\\)\\|y\\(s\\(read\\|call\\|open\\|tem\\|write\\|seek\\)\\|" - "mlink\\)\\|in\\|leep\\|ocket\\(pair\\|\\)\\)\\|t\\(runcate\\|" - "ell\\(\\|dir\\)\\|ime\\(\\|s\\)\\)\\|u\\(c\\(\\|first\\)\\|" - "time\\|mask\\|n\\(pack\\|link\\)\\)\\|v\\(alues\\|ec\\)\\|" - "w\\(a\\(rn\\|it\\(pid\\|\\)\\|ntarray\\)\\|rite\\)\\|" - "x\\(\\|or\\)\\|__\\(FILE\\|LINE\\|PACKAGE\\|SUB\\)__" - "\\)\\>") 2 'font-lock-type-face) + (regexp-opt + '("CORE" "__FILE__" "__LINE__" "__SUB__" "__PACKAGE__" + "abs" "accept" "alarm" "and" "atan2" + "bind" "binmode" "bless" "caller" + "chdir" "chmod" "chown" "chr" "chroot" "close" + "closedir" "cmp" "connect" "continue" "cos" "crypt" + "dbmclose" "dbmopen" "die" "dump" "endgrent" + "endhostent" "endnetent" "endprotoent" "endpwent" + "endservent" "eof" "eq" "exec" "exit" "exp" "fc" "fcntl" + "fileno" "flock" "fork" "formline" "ge" "getc" + "getgrent" "getgrgid" "getgrnam" "gethostbyaddr" + "gethostbyname" "gethostent" "getlogin" + "getnetbyaddr" "getnetbyname" "getnetent" + "getpeername" "getpgrp" "getppid" "getpriority" + "getprotobyname" "getprotobynumber" "getprotoent" + "getpwent" "getpwnam" "getpwuid" "getservbyname" + "getservbyport" "getservent" "getsockname" + "getsockopt" "glob" "gmtime" "gt" "hex" "index" "int" + "ioctl" "join" "kill" "lc" "lcfirst" "le" "length" + "link" "listen" "localtime" "lock" "log" "lstat" "lt" + "mkdir" "msgctl" "msgget" "msgrcv" "msgsnd" "ne" + "not" "oct" "open" "opendir" "or" "ord" "pack" "pipe" + "quotemeta" "rand" "read" "readdir" "readline" + "readlink" "readpipe" "recv" "ref" "rename" "require" + "reset" "reverse" "rewinddir" "rindex" "rmdir" "seek" + "seekdir" "select" "semctl" "semget" "semop" "send" + "setgrent" "sethostent" "setnetent" "setpgrp" + "setpriority" "setprotoent" "setpwent" "setservent" + "setsockopt" "shmctl" "shmget" "shmread" "shmwrite" + "shutdown" "sin" "sleep" "socket" "socketpair" + "sprintf" "sqrt" "srand" "stat" "substr" "symlink" + "syscall" "sysopen" "sysread" "sysseek" "system" "syswrite" "tell" + "telldir" "time" "times" "truncate" "uc" "ucfirst" + "umask" "unlink" "unpack" "utime" "values" "vec" + "wait" "waitpid" "wantarray" "warn" "write" "x" "xor")) + "\\)\\>") + 2 'font-lock-type-face) ;; In what follows we use `other' style ;; for nonoverwritable builtins - ;; Somehow 's', 'm' are not auto-generated??? (list (concat "\\(^\\|[^$@%&\\]\\)\\<\\(" - ;; "AUTOLOAD" "BEGIN" "CHECK" "DESTROY" "END" "INIT" "UNITCHECK" "__END__" "chomp" - ;; "break" "chop" "default" "defined" "delete" "do" "each" "else" "elsif" - ;; "eval" "evalbytes" "exists" "for" "foreach" "format" "given" "goto" - ;; "grep" "if" "keys" "last" "local" "map" "my" "next" - ;; "no" "our" "package" "pop" "pos" "print" "printf" "prototype" "push" - ;; "q" "qq" "qw" "qx" "redo" "return" "say" "scalar" "shift" - ;; "sort" "splice" "split" "state" "study" "sub" "tie" "tr" - ;; "undef" "unless" "unshift" "untie" "until" "use" - ;; "when" "while" "y" - "AUTOLOAD\\|BEGIN\\|\\(UNIT\\)?CHECK\\|break\\|c\\(atch\\|ho\\(p\\|mp\\)\\)\\|d\\(e\\(f\\(inally\\|ault\\|ined\\)\\|lete\\)\\|" - "o\\)\\|DESTROY\\|e\\(ach\\|val\\(bytes\\)?\\|xists\\|ls\\(e\\|if\\)\\)\\|" - "END\\|for\\(\\|each\\|mat\\)\\|g\\(iven\\|rep\\|oto\\)\\|INIT\\|if\\|keys\\|" - "l\\(ast\\|ocal\\)\\|m\\(ap\\|y\\)\\|n\\(ext\\|o\\)\\|our\\|" - "p\\(ackage\\|rototype\\|rint\\(\\|f\\)\\|ush\\|o\\(p\\|s\\)\\)\\|" - "q\\(\\|q\\|w\\|x\\|r\\)\\|re\\(turn\\|do\\)\\|s\\(ay\\|pli\\(ce\\|t\\)\\|" - "calar\\|t\\(ate\\|udy\\)\\|ub\\|hift\\|ort\\)\\|t\\(ry?\\|ied?\\)\\|" - "u\\(se\\|n\\(shift\\|ti\\(l\\|e\\)\\|def\\|less\\)\\)\\|" - "wh\\(en\\|ile\\)\\|y\\|__\\(END\\|DATA\\)__" ;__DATA__ added manually - "\\|[sm]" ; Added manually - "\\)\\>") + (regexp-opt + '("AUTOLOAD" "BEGIN" "CHECK" "DESTROY" "END" "INIT" "UNITCHECK" + "__END__" "__DATA__" "break" "catch" "chomp" "chop" "default" + "defined" "delete" "do" "each" "else" "elsif" "eval" + "evalbytes" "exists" "finally" "for" "foreach" "format" "given" + "goto" "grep" "if" "keys" "last" "local" "m" "map" "my" "next" + "no" "our" "package" "pop" "pos" "print" "printf" "prototype" + "push" "q" "qq" "qr" "qw" "qx" "redo" "return" "s" "say" "scalar" + "shift" "sort" "splice" "split" "state" "study" "sub" "tie" + "tied" "tr" "try" "undef" "unless" "unshift" "untie" "until" + "use" "when" "while" "y")) + "\\)\\>") 2 ''cperl-nonoverridable-face) ; unbound as var, so: doubly quoted ;; (mapconcat #'identity ;; '("#endif" "#else" "#ifdef" "#ifndef" "#if" @@ -6694,9 +6708,9 @@ One may build such TAGS files from CPerl mode menu." (or (nthcdr 2 elt) ;; Only in one file (setcdr elt (cdr (nth 1 elt)))))) - to l1 l2 l3) + to) ;; l1 l2 l3 ;; (setq cperl-hierarchy '(() () ())) ; Would write into '() later! - (setq cperl-hierarchy (list l1 l2 l3)) + (setq cperl-hierarchy (list () () ())) ;; (list l1 l2 l3) (or tags-table-list (call-interactively 'visit-tags-table)) (mapc @@ -6713,9 +6727,7 @@ One may build such TAGS files from CPerl mode menu." (cperl-tags-treeify to 1) (setcar (nthcdr 2 cperl-hierarchy) (cperl-menu-to-keymap (cons '("+++UPDATE+++" . -999) (cdr to)))) - (message "Updating list of classes: done, requesting display...") - ;;(cperl-imenu-addback (nth 2 cperl-hierarchy)) - )) + (message "Updating list of classes: done, requesting display..."))) (or (nth 2 cperl-hierarchy) (error "No items found")) (setq update @@ -6744,7 +6756,7 @@ One may build such TAGS files from CPerl mode menu." "\\)\\(::\\)?")) (packages (cdr (nth 1 to))) (methods (cdr (nth 2 to))) - l1 head cons1 cons2 ord writeto recurse + head cons1 cons2 ord writeto recurse ;; l1 root-packages root-functions (move-deeper (lambda (elt) @@ -6764,7 +6776,7 @@ One may build such TAGS files from CPerl mode menu." (setq root-functions (cons elt root-functions))) (t (setq root-packages (cons elt root-packages))))))) - (setcdr to l1) ; Init to dynamic space + (setcdr to nil) ;; l1 ; Init to dynamic space (setq writeto to) (setq ord 1) (mapc move-deeper packages) @@ -7217,8 +7229,7 @@ $~ The name of the current report format. ... >= ... Numeric greater than or equal to. ... >> ... Bitwise shift right. ... >>= ... Bitwise shift right assignment. -... ? ... : ... Condition=if-then-else operator. ?PAT? One-time pattern match. -?PATTERN? One-time pattern match. +... ? ... : ... Condition=if-then-else operator. @ARGV Command line arguments (not including the command name - see $0). @INC List of places to look for perl scripts during do/include/use. @_ Parameter array for subroutines; result of split() unless in list context. @@ -8387,7 +8398,7 @@ do extra unwind via `cperl-unwind-to-safe'." (setq end (point))) (font-lock-default-fontify-region beg end loudly)) -(defun cperl-fontify-syntaxically (end) +(defun cperl-fontify-syntactically (end) ;; Some vars for debugging only ;; (message "Syntaxifying...") (let ((dbg (point)) (iend end) (idone cperl-syntax-done-to) diff --git a/lisp/progmodes/cpp.el b/lisp/progmodes/cpp.el index b2c2e8dab57..6602a79b2a4 100644 --- a/lisp/progmodes/cpp.el +++ b/lisp/progmodes/cpp.el @@ -53,8 +53,7 @@ (defcustom cpp-config-file (convert-standard-filename ".cpp.el") "File name to save cpp configuration." - :type 'file - :group 'cpp) + :type 'file) (define-widget 'cpp-face 'lazy "Either a face or the special symbol `invisible'." @@ -62,13 +61,11 @@ (defcustom cpp-known-face 'invisible "Face used for known cpp symbols." - :type 'cpp-face - :group 'cpp) + :type 'cpp-face) (defcustom cpp-unknown-face 'highlight "Face used for unknown cpp symbols." - :type 'cpp-face - :group 'cpp) + :type 'cpp-face) (defcustom cpp-face-type 'light "Indicate what background face type you prefer. @@ -76,18 +73,15 @@ Can be either light or dark for color screens, mono for monochrome screens, and none if you don't use a window system and don't have a color-capable display." :options '(light dark mono nil) - :type 'symbol - :group 'cpp) + :type 'symbol) (defcustom cpp-known-writable t "Non-nil means you are allowed to modify the known conditionals." - :type 'boolean - :group 'cpp) + :type 'boolean) (defcustom cpp-unknown-writable t "Non-nil means you are allowed to modify the unknown conditionals." - :type 'boolean - :group 'cpp) + :type 'boolean) (defcustom cpp-edit-list nil "Alist of cpp macros and information about how they should be displayed. @@ -101,15 +95,13 @@ Each entry is a list with the following elements: (cpp-face :tag "False") (choice (const :tag "True branch writable" t) (const :tag "False branch writable" nil) - (const :tag "Both branches writable" both)))) - :group 'cpp) + (const :tag "Both branches writable" both))))) (defcustom cpp-message-min-time-interval 1.0 "Minimum time interval in seconds for `cpp-progress-message' messages. If nil, `cpp-progress-message' prints no progress messages." :type '(choice (const :tag "Disable progress messages" nil) float) - :group 'cpp :version "26.1") (defvar-local cpp-overlay-list nil @@ -153,36 +145,31 @@ or a cons cell (background-color . COLOR)." :value-type (choice face (const invisible) (cons (const background-color) - (string :tag "Color")))) - :group 'cpp) + (string :tag "Color"))))) (defcustom cpp-face-light-name-list '("light gray" "light blue" "light cyan" "light yellow" "light pink" "pale green" "beige" "orange" "magenta" "violet" "medium purple" "turquoise") "Background colors useful with dark foreground colors." - :type '(repeat string) - :group 'cpp) + :type '(repeat string)) (defcustom cpp-face-dark-name-list '("dim gray" "blue" "cyan" "yellow" "red" "dark green" "brown" "dark orange" "dark khaki" "dark violet" "purple" "dark turquoise") "Background colors useful with light foreground colors." - :type '(repeat string) - :group 'cpp) + :type '(repeat string)) (defcustom cpp-face-light-list nil "Alist of names and faces to be used for light backgrounds." :type '(repeat (cons string (choice face - (cons (const background-color) string)))) - :group 'cpp) + (cons (const background-color) string))))) (defcustom cpp-face-dark-list nil "Alist of names and faces to be used for dark backgrounds." :type '(repeat (cons string (choice face - (cons (const background-color) string)))) - :group 'cpp) + (cons (const background-color) string))))) (defcustom cpp-face-mono-list '(("bold" . bold) @@ -190,15 +177,13 @@ or a cons cell (background-color . COLOR)." ("italic" . italic) ("underline" . underline)) "Alist of names and faces to be used for monochrome screens." - :type '(repeat (cons string face)) - :group 'cpp) + :type '(repeat (cons string face))) (defcustom cpp-face-none-list '(("default" . default) ("invisible" . invisible)) "Alist of names and faces available even if you don't use a window system." - :type '(repeat (cons string cpp-face)) - :group 'cpp) + :type '(repeat (cons string cpp-face))) (defvar cpp-face-all-list (append cpp-face-light-list diff --git a/lisp/progmodes/cwarn.el b/lisp/progmodes/cwarn.el index 042030da396..7fd592fb2e1 100644 --- a/lisp/progmodes/cwarn.el +++ b/lisp/progmodes/cwarn.el @@ -1,4 +1,4 @@ -;;; cwarn.el --- highlight suspicious C and C++ constructions +;;; cwarn.el --- highlight suspicious C and C++ constructions -*- lexical-binding: t -*- ;; Copyright (C) 1999-2021 Free Software Foundation, Inc. @@ -128,8 +128,7 @@ on one of three forms: See variable `cwarn-font-lock-feature-keywords-alist' for available features." - :type '(repeat sexp) - :group 'cwarn) + :type '(repeat sexp)) (defcustom cwarn-font-lock-feature-keywords-alist '((assign . cwarn-font-lock-assignment-keywords) @@ -142,15 +141,13 @@ keyword list." :type '(alist :key-type (choice (const assign) (const semicolon) (const reference)) - :value-type (sexp :tag "Value")) - :group 'cwarn) + :value-type (sexp :tag "Value"))) (defcustom cwarn-verbose t "When nil, CWarn mode will not generate any messages. Currently, messages are generated when the mode is activated and deactivated." - :group 'cwarn :type 'boolean) (defcustom cwarn-mode-text " CWarn" @@ -158,13 +155,11 @@ deactivated." \(When the string is not empty, make sure that it has a leading space.)" :tag "CWarn mode text" ; To separate it from `global-...' - :group 'cwarn :type 'string) (defcustom cwarn-load-hook nil "Functions to run when CWarn mode is first loaded." :tag "Load Hook" - :group 'cwarn :type 'hook) (make-obsolete-variable 'cwarn-load-hook "use `with-eval-after-load' instead." "28.1") diff --git a/lisp/progmodes/dcl-mode.el b/lisp/progmodes/dcl-mode.el index 8943d8b6d01..ed024f24344 100644 --- a/lisp/progmodes/dcl-mode.el +++ b/lisp/progmodes/dcl-mode.el @@ -1,4 +1,4 @@ -;;; dcl-mode.el --- major mode for editing DCL command files +;;; dcl-mode.el --- major mode for editing DCL command files -*- lexical-binding: t; -*- ;; Copyright (C) 1997, 2001-2021 Free Software Foundation, Inc. @@ -23,9 +23,11 @@ ;;; Commentary: -;; DCL mode is a package for editing DCL command files. It helps you -;; indent lines, add leading `$' and trailing `-', move around in the -;; code and insert lexical functions. +;; DCL mode is a package for editing +;; [DCL](https://en.wikipedia.org/wiki/DIGITAL_Command_Language) +;; command files. +;; It helps you indent lines, add leading `$' and trailing `-', move +;; around in the code and insert lexical functions. ;; ;; Type `C-h m' when you are editing a .COM file to get more ;; information about this mode. @@ -93,12 +95,11 @@ Presently this includes some syntax, .OP.erators, and \"f$\" lexicals.") (defcustom dcl-basic-offset 4 "Number of columns to indent a block in DCL. A block is the commands between THEN-ELSE-ENDIF and between the commands -dcl-block-begin-regexp and dcl-block-end-regexp. +`dcl-block-begin-regexp' and `dcl-block-end-regexp'. The meaning of this variable may be changed if -dcl-calc-command-indent-function is set to a function." - :type 'integer - :group 'dcl) +`dcl-calc-command-indent-function' is set to a function." + :type 'integer) (defcustom dcl-continuation-offset 6 @@ -106,9 +107,8 @@ dcl-calc-command-indent-function is set to a function." A continuation line is a line that follows a line ending with `-'. The meaning of this variable may be changed if -dcl-calc-cont-indent-function is set to a function." - :type 'integer - :group 'dcl) +`dcl-calc-cont-indent-function' is set to a function." + :type 'integer) (defcustom dcl-margin-offset 8 @@ -117,37 +117,32 @@ The first command line in a file or after a SUBROUTINE statement is indented this much. Other command lines are indented the same number of columns as the preceding command line. A command line is a line that starts with `$'." - :type 'integer - :group 'dcl) + :type 'integer) (defcustom dcl-margin-label-offset 2 "Number of columns to indent a margin label in DCL. A margin label is a label that doesn't begin or end a block, i.e. it -doesn't match dcl-block-begin-regexp or dcl-block-end-regexp." - :type 'integer - :group 'dcl) +doesn't match `dcl-block-begin-regexp' or `dcl-block-end-regexp'." + :type 'integer) (defcustom dcl-comment-line-regexp "^\\$!" "Regexp describing the start of a comment line in DCL. Comment lines are not indented." - :type 'regexp - :group 'dcl) + :type 'regexp) (defcustom dcl-block-begin-regexp "loop[0-9]*:" "Regexp describing a command that begins an indented block in DCL. Set to nil to only indent at THEN-ELSE-ENDIF." - :type 'regexp - :group 'dcl) + :type 'regexp) (defcustom dcl-block-end-regexp "endloop[0-9]*:" "Regexp describing a command that ends an indented block in DCL. Set to nil to only indent at THEN-ELSE-ENDIF." - :type 'regexp - :group 'dcl) + :type 'regexp) (defcustom dcl-calc-command-indent-function nil @@ -176,10 +171,9 @@ If this variable is nil, the indentation is calculated as CUR-INDENT + EXTRA-INDENT. This package includes two functions suitable for this: - dcl-calc-command-indent-multiple - dcl-calc-command-indent-hang" - :type '(choice (const nil) function) - :group 'dcl) + `dcl-calc-command-indent-multiple' + `dcl-calc-command-indent-hang'" + :type '(choice (const nil) function)) (defcustom dcl-calc-cont-indent-function 'dcl-calc-cont-indent-relative @@ -195,9 +189,8 @@ If this variable is nil, the indentation is calculated as CUR-INDENT + EXTRA-INDENT. This package includes one function suitable for this: - dcl-calc-cont-indent-relative" - :type 'function - :group 'dcl) + `dcl-calc-cont-indent-relative'" + :type 'function) (defcustom dcl-tab-always-indent t @@ -206,50 +199,41 @@ If t, pressing TAB always indents the current line. If nil, pressing TAB indents the current line if point is at the left margin. Data lines (i.e. lines not part of a command line or continuation line) are never indented." - :type 'boolean - :group 'dcl) + :type 'boolean) (defcustom dcl-electric-characters t "Non-nil means reindent immediately when a label, ELSE or ENDIF is inserted." - :type 'boolean - :group 'dcl) + :type 'boolean) (defcustom dcl-tempo-comma ", " "Text to insert when a comma is needed in a template, in DCL mode." - :type 'string - :group 'dcl) + :type 'string) (defcustom dcl-tempo-left-paren "(" "Text to insert when a left parenthesis is needed in a template in DCL." - :type 'string - :group 'dcl) + :type 'string) (defcustom dcl-tempo-right-paren ")" "Text to insert when a right parenthesis is needed in a template in DCL." - :type 'string - :group 'dcl) + :type 'string) ; I couldn't decide what looked best, so I'll let you decide... ; Remember, you can also customize this with imenu-submenu-name-format. (defcustom dcl-imenu-label-labels "Labels" "Imenu menu title for sub-listing with label names." - :type 'string - :group 'dcl) + :type 'string) (defcustom dcl-imenu-label-goto "GOTO" "Imenu menu title for sub-listing with GOTO statements." - :type 'string - :group 'dcl) + :type 'string) (defcustom dcl-imenu-label-gosub "GOSUB" "Imenu menu title for sub-listing with GOSUB statements." - :type 'string - :group 'dcl) + :type 'string) (defcustom dcl-imenu-label-call "CALL" "Imenu menu title for sub-listing with CALL statements." - :type 'string - :group 'dcl) + :type 'string) (defcustom dcl-imenu-generic-expression `((nil "^\\$[ \t]*\\([A-Za-z0-9_$]+\\):[ \t]+SUBROUTINE\\b" 1) @@ -263,14 +247,12 @@ never indented." The default includes SUBROUTINE labels in the main listing and sub-listings for other labels, CALL, GOTO and GOSUB statements. See `imenu-generic-expression' for details." - :type '(repeat (sexp :tag "Imenu Expression")) - :group 'dcl) + :type '(repeat (sexp :tag "Imenu Expression"))) (defcustom dcl-mode-hook nil "Hook called by `dcl-mode'." - :type 'hook - :group 'dcl) + :type 'hook) ;;; *** Global variables **************************************************** @@ -290,80 +272,59 @@ See `imenu-generic-expression' for details." (defvar dcl-mode-map (let ((map (make-sparse-keymap))) - (define-key map "\e\n" 'dcl-split-line) - (define-key map "\e\t" 'tempo-complete-tag) - (define-key map "\e^" 'dcl-delete-indentation) - (define-key map "\em" 'dcl-back-to-indentation) - (define-key map "\ee" 'dcl-forward-command) - (define-key map "\ea" 'dcl-backward-command) - (define-key map "\e\C-q" 'dcl-indent-command) - (define-key map "\t" 'dcl-tab) - (define-key map ":" 'dcl-electric-character) - (define-key map "F" 'dcl-electric-character) - (define-key map "f" 'dcl-electric-character) - (define-key map "E" 'dcl-electric-character) - (define-key map "e" 'dcl-electric-character) - (define-key map "\C-c\C-o" 'dcl-set-option) - (define-key map "\C-c\C-f" 'tempo-forward-mark) - (define-key map "\C-c\C-b" 'tempo-backward-mark) - - (define-key map [menu-bar] (make-sparse-keymap)) - (define-key map [menu-bar dcl] - (cons "DCL" (make-sparse-keymap "DCL"))) - - ;; Define these in bottom-up order - (define-key map [menu-bar dcl tempo-backward-mark] - '("Previous template mark" . tempo-backward-mark)) - (define-key map [menu-bar dcl tempo-forward-mark] - '("Next template mark" . tempo-forward-mark)) - (define-key map [menu-bar dcl tempo-complete-tag] - '("Complete template tag" . tempo-complete-tag)) - (define-key map [menu-bar dcl dcl-separator-tempo] - '("--")) - (define-key map [menu-bar dcl dcl-save-all-options] - '("Save all options" . dcl-save-all-options)) - (define-key map [menu-bar dcl dcl-save-nondefault-options] - '("Save changed options" . dcl-save-nondefault-options)) - (define-key map [menu-bar dcl dcl-set-option] - '("Set option" . dcl-set-option)) - (define-key map [menu-bar dcl dcl-separator-option] - '("--")) - (define-key map [menu-bar dcl dcl-delete-indentation] - '("Delete indentation" . dcl-delete-indentation)) - (define-key map [menu-bar dcl dcl-split-line] - '("Split line" . dcl-split-line)) - (define-key map [menu-bar dcl dcl-indent-command] - '("Indent command" . dcl-indent-command)) - (define-key map [menu-bar dcl dcl-tab] - '("Indent line/insert tab" . dcl-tab)) - (define-key map [menu-bar dcl dcl-back-to-indentation] - '("Back to indentation" . dcl-back-to-indentation)) - (define-key map [menu-bar dcl dcl-forward-command] - '("End of statement" . dcl-forward-command)) - (define-key map [menu-bar dcl dcl-backward-command] - '("Beginning of statement" . dcl-backward-command)) - (define-key map [menu-bar dcl dcl-separator-movement] - '("--")) - (define-key map [menu-bar dcl imenu] - '("Buffer index menu" . imenu)) + (define-key map "\e\n" #'dcl-split-line) + (define-key map "\e\t" #'tempo-complete-tag) + (define-key map "\e^" #'dcl-delete-indentation) + (define-key map "\em" #'dcl-back-to-indentation) + (define-key map "\ee" #'dcl-forward-command) + (define-key map "\ea" #'dcl-backward-command) + (define-key map "\e\C-q" #'dcl-indent-command) + (define-key map "\t" #'dcl-tab) + (define-key map ":" #'dcl-electric-character) + (define-key map "F" #'dcl-electric-character) + (define-key map "f" #'dcl-electric-character) + (define-key map "E" #'dcl-electric-character) + (define-key map "e" #'dcl-electric-character) + (define-key map "\C-c\C-o" #'dcl-set-option) + (define-key map "\C-c\C-f" #'tempo-forward-mark) + (define-key map "\C-c\C-b" #'tempo-backward-mark) map) "Keymap used in DCL-mode buffers.") +(easy-menu-define dcl-mode-menu dcl-mode-map + "Menu for DCL-mode buffers." + '("DCL" + ["Buffer index menu" imenu] + "---" + ["Beginning of statement" dcl-backward-command] + ["End of statement" dcl-forward-command] + ["Back to indentation" dcl-back-to-indentation] + ["Indent line/insert tab" dcl-tab] + ["Indent command" dcl-indent-command] + ["Split line" dcl-split-line] + ["Delete indentation" dcl-delete-indentation] + "---" + ["Set option" dcl-set-option] + ["Save changed options" dcl-save-nondefault-options] + ["Save all options" dcl-save-all-options] + "---" + ["Complete template tag" tempo-complete-tag] + ["Next template mark" tempo-forward-mark] + ["Previous template mark" tempo-backward-mark])) + (defcustom dcl-ws-r "\\([ \t]*-[ \t]*\\(!.*\\)*\n\\)*[ \t]*" "Regular expression describing white space in a DCL command line. White space is any number of continued lines with only space,tab,endcomment followed by space or tab." - :type 'regexp - :group 'dcl) + :type 'regexp) (defcustom dcl-label-r "[a-zA-Z0-9_$]*:\\([ \t!]\\|$\\)" "Regular expression describing a label. A label is a name followed by a colon followed by white-space or end-of-line." - :type 'regexp - :group 'dcl) + :type 'regexp) (defcustom dcl-cmd-r @@ -373,8 +334,7 @@ A line starting with $, optionally followed by continuation lines, followed by the end of the command line. A continuation line is any characters followed by `-', optionally followed by a comment, followed by a newline." - :type 'regexp - :group 'dcl) + :type 'regexp) (defcustom dcl-command-regexp @@ -384,21 +344,19 @@ A line starting with $, optionally followed by continuation lines, followed by the end of the command line. A continuation line is any characters followed by `-', optionally followed by a comment, followed by a newline." - :type 'regexp - :group 'dcl) + :type 'regexp) (defcustom dcl-electric-reindent-regexps (list "endif" "else" dcl-label-r) "Regexps that can trigger an electric reindent. A list of regexps that will trigger a reindent if the last letter -is defined as dcl-electric-character. +is defined as `dcl-electric-character'. E.g.: if this list contains `endif', the key `f' is defined as -dcl-electric-character and you have just typed the `f' in +`dcl-electric-character' and you have just typed the `f' in `endif', the line will be reindented." - :type '(repeat regexp) - :group 'dcl) + :type '(repeat regexp)) (defvar dcl-option-alist @@ -420,7 +378,7 @@ dcl-electric-character and you have just typed the `f' in (comment-start curval) (comment-start-skip curval) ) - "Options and default values for dcl-set-option. + "Options and default values for `dcl-set-option'. An alist with option variables and functions or keywords to get a default value for the option. @@ -434,8 +392,8 @@ toggle the opposite of the current value (for t/nil)") (mapcar (lambda (option-assoc) (format "%s" (car option-assoc))) dcl-option-alist) - "The history list for dcl-set-option. -Preloaded with all known option names from dcl-option-alist") + "The history list for `dcl-set-option'. +Preloaded with all known option names from `dcl-option-alist'") ;; Must be defined after dcl-cmd-r @@ -577,7 +535,7 @@ $ There is some minimal font-lock support (see vars `dcl-font-lock-defaults' and `dcl-font-lock-keywords')." - (setq-local indent-line-function 'dcl-indent-line) + (setq-local indent-line-function #'dcl-indent-line) (setq-local comment-start "!") (setq-local comment-end "") (setq-local comment-multi-line nil) @@ -591,7 +549,7 @@ There is some minimal font-lock support (see vars (setq imenu-generic-expression dcl-imenu-generic-expression) (setq imenu-case-fold-search t) - (setq imenu-create-index-function 'dcl-imenu-create-index-function) + (setq imenu-create-index-function #'dcl-imenu-create-index-function) (make-local-variable 'dcl-comment-line-regexp) (make-local-variable 'dcl-block-begin-regexp) @@ -899,7 +857,7 @@ Returns one of the following symbols: ;;;--------------------------------------------------------------------------- (defun dcl-show-line-type () - "Test dcl-get-line-type." + "Test `dcl-get-line-type'." (interactive) (let ((type (dcl-get-line-type))) (cond @@ -944,8 +902,7 @@ $ if cond $ then $ if cond $ then -$ ! etc -" +$ ! etc" ;; calculate indentation if it's an interesting indent-type, ;; otherwise return nil to get the default indentation (let ((indent)) @@ -974,8 +931,7 @@ $ xxx If you use this function you will probably want to add \"then\" to dcl-electric-reindent-regexps and define the key \"n\" as -dcl-electric-character. -" +dcl-electric-character." (let ((case-fold-search t)) (save-excursion (cond @@ -1018,17 +974,17 @@ see if the current lines should be indented. Analyze the current line to see if it should be `outdented'. Calculate the indentation of the current line, either with the default -method or by calling dcl-calc-command-indent-function if it is +method or by calling `dcl-calc-command-indent-function' if it is non-nil. If the current line should be outdented, calculate its indentation, either with the default method or by calling -dcl-calc-command-indent-function if it is non-nil. +`dcl-calc-command-indent-function' if it is non-nil. Rules for default indentation: -If it is the first line in the buffer, indent dcl-margin-offset. +If it is the first line in the buffer, indent `dcl-margin-offset'. Go to the previous command line with a command on it. Find out how much it is indented (cur-indent). @@ -1036,7 +992,7 @@ Look at the first word on the line to see if the indentation should be adjusted. Skip margin-label, continuations and comments while looking for the first word. Save this buffer position as `last-point'. If the first word after a label is SUBROUTINE, set extra-indent to -dcl-margin-offset. +`dcl-margin-offset'. First word extra-indent THEN +dcl-basic-offset @@ -1193,8 +1149,7 @@ Indented lines will align with either: * the innermost nonclosed parenthesis $ if ((a.eq.b .and. - d.eq.c .or. f$function(xxxx, - - yyy))) -" + yyy)))" (let ((case-fold-search t) indent) (save-excursion @@ -1374,7 +1329,7 @@ Adjusts indentation on the current line. Data lines are not indented." ;;;------------------------------------------------------------------------- (defun dcl-indent-command () - "Indents the complete command line that point is on. + "Indent the complete command line that point is on. This includes continuation lines." (interactive "*") (let ((type (dcl-get-line-type))) @@ -1421,7 +1376,7 @@ the lines indentation; otherwise insert a tab." ;;;------------------------------------------------------------------------- (defun dcl-electric-character (arg) - "Inserts a character and indents if necessary. + "Insert a character and indent if necessary. Insert a character if the user gave a numeric argument or the flag `dcl-electric-characters' is not set. If an argument was given, insert that many characters. @@ -1438,7 +1393,7 @@ regexps in `dcl-electric-reindent-regexps'." (let ((case-fold-search t)) ;; There must be a better way than (memq t ...). ;; (apply 'or ...) didn't work - (if (memq t (mapcar 'dcl-was-looking-at dcl-electric-reindent-regexps)) + (if (memq t (mapcar #'dcl-was-looking-at dcl-electric-reindent-regexps)) (dcl-indent-line))))) @@ -1614,7 +1569,7 @@ Must return a string." ((fboundp action) (funcall action option-assoc)) ((eq action 'toggle) - (not (eval option))) + (not (symbol-value option))) ((eq action 'curval) (cond ((or (stringp (symbol-value option)) (numberp (symbol-value option))) @@ -1782,7 +1737,7 @@ Set or update the value of VAR in the current buffers (setq continue nil) (beginning-of-line) (insert (concat prefix-string (symbol-name var) ": " - (prin1-to-string (eval var)) " " + (prin1-to-string (symbol-value var)) " " suffix-string "\n"))) ;; Is it the variable we are looking for? (if (eq var found-var) @@ -1795,7 +1750,7 @@ Set or update the value of VAR in the current buffers (delete-region (point) (progn (read (current-buffer)) (point))) (insert " ") - (prin1 (eval var) (current-buffer)) + (prin1 (symbol-value var) (current-buffer)) (skip-chars-backward "\n") (skip-chars-forward " \t") (or (if suffix (looking-at suffix) (eolp)) @@ -1828,15 +1783,15 @@ Set or update the value of VAR in the current buffers (concat " " comment-end)))))) (insert (concat def-prefix "Local variables:" def-suffix "\n")) (insert (concat def-prefix (symbol-name var) ": " - (prin1-to-string (eval var)) def-suffix "\n")) + (prin1-to-string (symbol-value var)) def-suffix "\n")) (insert (concat def-prefix "end:" def-suffix))) ))) ;;;------------------------------------------------------------------------- (defun dcl-save-all-options () - "Save all dcl-mode options for this buffer. -Saves or updates all dcl-mode related options in a `Local Variables:' + "Save all `dcl-mode' options for this buffer. +Saves or updates all `dcl-mode' related options in a `Local Variables:' section at the end of the current buffer." (interactive "*") (mapcar (lambda (option-assoc) @@ -1862,7 +1817,8 @@ still be present in the `Local Variables:' section with its old value." (option-name (symbol-name option))) (if (and (string-equal "dcl-" (substring option-name 0 4)) - (not (equal (default-value option) (eval option)))) + (not (equal (default-value option) + (symbol-value option)))) (dcl-save-local-variable option "$! ")))) dcl-option-alist)) diff --git a/lisp/progmodes/ebnf-abn.el b/lisp/progmodes/ebnf-abn.el index 9e570b6c03f..2a37110f6ae 100644 --- a/lisp/progmodes/ebnf-abn.el +++ b/lisp/progmodes/ebnf-abn.el @@ -1,4 +1,4 @@ -;;; ebnf-abn.el --- parser for ABNF (Augmented BNF) +;;; ebnf-abn.el --- parser for ABNF (Augmented BNF) -*- lexical-binding: t; -*- ;; Copyright (C) 2001-2021 Free Software Foundation, Inc. @@ -39,10 +39,6 @@ ;; ;; See the URL: ;; `https://www.ietf.org/rfc/rfc2234.txt' -;; or -;; `http://www.faqs.org/rfcs/rfc2234.html' -;; or -;; `http://www.rnp.br/ietf/rfc/rfc2234.txt' ;; ("Augmented BNF for Syntax Specifications: ABNF"). ;; ;; diff --git a/lisp/progmodes/ebnf-bnf.el b/lisp/progmodes/ebnf-bnf.el index 93ebfe8654d..e6717cbdf01 100644 --- a/lisp/progmodes/ebnf-bnf.el +++ b/lisp/progmodes/ebnf-bnf.el @@ -1,4 +1,4 @@ -;;; ebnf-bnf.el --- parser for EBNF +;;; ebnf-bnf.el --- parser for EBNF -*- lexical-binding: t; -*- ;; Copyright (C) 1999-2021 Free Software Foundation, Inc. diff --git a/lisp/progmodes/ebnf-dtd.el b/lisp/progmodes/ebnf-dtd.el index 66e5dd095ea..93bae5a33c5 100644 --- a/lisp/progmodes/ebnf-dtd.el +++ b/lisp/progmodes/ebnf-dtd.el @@ -1,4 +1,4 @@ -;;; ebnf-dtd.el --- parser for DTD (Data Type Description for XML) +;;; ebnf-dtd.el --- parser for DTD (Data Type Description for XML) -*- lexical-binding: t; -*- ;; Copyright (C) 2001-2021 Free Software Foundation, Inc. diff --git a/lisp/progmodes/ebnf-ebx.el b/lisp/progmodes/ebnf-ebx.el index 389049e39a9..5d8541931e1 100644 --- a/lisp/progmodes/ebnf-ebx.el +++ b/lisp/progmodes/ebnf-ebx.el @@ -1,4 +1,4 @@ -;;; ebnf-ebx.el --- parser for EBNF used to specify XML (EBNFX) +;;; ebnf-ebx.el --- parser for EBNF used to specify XML (EBNFX) -*- lexical-binding: t; -*- ;; Copyright (C) 2001-2021 Free Software Foundation, Inc. diff --git a/lisp/progmodes/ebnf-iso.el b/lisp/progmodes/ebnf-iso.el index d25ff3ecb4b..b4532c76251 100644 --- a/lisp/progmodes/ebnf-iso.el +++ b/lisp/progmodes/ebnf-iso.el @@ -1,4 +1,4 @@ -;;; ebnf-iso.el --- parser for ISO EBNF +;;; ebnf-iso.el --- parser for ISO EBNF -*- lexical-binding: t; -*- ;; Copyright (C) 1999-2021 Free Software Foundation, Inc. @@ -38,7 +38,7 @@ ;; --------------- ;; ;; See the URL: -;; `http://www.cl.cam.ac.uk/~mgk25/iso-ebnf.html' +;; `https://www.cl.cam.ac.uk/~mgk25/iso-ebnf.html' ;; ("International Standard of the ISO EBNF Notation"). ;; ;; diff --git a/lisp/progmodes/ebnf-otz.el b/lisp/progmodes/ebnf-otz.el index b724d75a7e5..84e59cc0a51 100644 --- a/lisp/progmodes/ebnf-otz.el +++ b/lisp/progmodes/ebnf-otz.el @@ -1,4 +1,4 @@ -;;; ebnf-otz.el --- syntactic chart OpTimiZer +;;; ebnf-otz.el --- syntactic chart OpTimiZer -*- lexical-binding: t; -*- ;; Copyright (C) 1999-2021 Free Software Foundation, Inc. diff --git a/lisp/progmodes/ebnf-yac.el b/lisp/progmodes/ebnf-yac.el index 2765d03acba..816cc432d1b 100644 --- a/lisp/progmodes/ebnf-yac.el +++ b/lisp/progmodes/ebnf-yac.el @@ -1,4 +1,4 @@ -;;; ebnf-yac.el --- parser for Yacc/Bison +;;; ebnf-yac.el --- parser for Yacc/Bison -*- lexical-binding: t; -*- ;; Copyright (C) 1999-2021 Free Software Foundation, Inc. @@ -271,13 +271,13 @@ (let ((table (make-vector 256 'error))) ;; upper & lower case letters: (mapc - #'(lambda (char) - (aset table char 'non-terminal)) + (lambda (char) + (aset table char 'non-terminal)) "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz") ;; printable characters: (mapc - #'(lambda (char) - (aset table char 'character)) + (lambda (char) + (aset table char 'character)) "!#$&()*+-.0123456789=?@[\\]^_`~") ;; Override space characters: (aset table ?\n 'space) ; [NL] linefeed diff --git a/lisp/progmodes/ebnf2ps.el b/lisp/progmodes/ebnf2ps.el index b376423c185..884104a16f7 100644 --- a/lisp/progmodes/ebnf2ps.el +++ b/lisp/progmodes/ebnf2ps.el @@ -330,7 +330,7 @@ Please send all bug fixes and enhancements to ;; ("Augmented BNF for Syntax Specifications: ABNF"). ;; ;; `iso-ebnf' ebnf2ps recognizes the syntax described in the URL: -;; `http://www.cl.cam.ac.uk/~mgk25/iso-ebnf.html' +;; `https://www.cl.cam.ac.uk/~mgk25/iso-ebnf.html' ;; ("International Standard of the ISO EBNF Notation"). ;; The following variables *ONLY* have effect with this ;; setting: @@ -1783,7 +1783,7 @@ Valid values are: (\"Augmented BNF for Syntax Specifications: ABNF\"). `iso-ebnf' ebnf2ps recognizes the syntax described in the URL: - `http://www.cl.cam.ac.uk/~mgk25/iso-ebnf.html' + `https://www.cl.cam.ac.uk/~mgk25/iso-ebnf.html' (\"International Standard of the ISO EBNF Notation\"). The following variables *ONLY* have effect with this setting: @@ -2920,7 +2920,7 @@ See `ebnf-style-database' documentation." value (and (car value) (ebnf-apply-style1 (car value))) (while (setq value (cdr value)) - (set (caar value) (eval (cdar value))))))) + (set (caar value) (eval (cdar value) t)))))) (defun ebnf-check-style-values (values) @@ -4337,7 +4337,7 @@ end (let ((len (1- (length str))) (index 0) new start fmt) - (while (setq start (string-match "%" str index)) + (while (setq start (string-search "%" str index)) (setq fmt (if (< start len) (aref str (1+ start)) ?\?) new (concat new (substring str index start) @@ -4398,8 +4398,8 @@ end (defun ebnf-format-float (&rest floats) (mapconcat - #'(lambda (float) - (format ebnf-format-float float)) + (lambda (float) + (format ebnf-format-float float)) floats " ")) @@ -4959,8 +4959,8 @@ killed after process termination." (defvar ebnf-map-name (let ((map (make-vector 256 ?\_))) - (mapc #'(lambda (char) - (aset map char char)) + (mapc (lambda (char) + (aset map char char)) (concat "#$%&+-.0123456789=?@~" "ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyz")) @@ -5487,7 +5487,7 @@ killed after process termination." (ebnf-shape-value ebnf-chart-shape ebnf-terminal-shape-alist)) (format "/UserArrow{%s}def\n" - (let ((arrow (eval ebnf-user-arrow))) + (let ((arrow (eval ebnf-user-arrow t))) (if (stringp arrow) arrow ""))) @@ -6290,7 +6290,7 @@ killed after process termination." (defun ebnf-log-header (format-str &rest args) (when ebnf-log (apply - 'ebnf-log + #'ebnf-log (concat "\n\n===============================================================\n\n" format-str) diff --git a/lisp/progmodes/ebrowse.el b/lisp/progmodes/ebrowse.el index a174d4851e5..7524c280f25 100644 --- a/lisp/progmodes/ebrowse.el +++ b/lisp/progmodes/ebrowse.el @@ -35,7 +35,6 @@ (require 'cl-lib) (require 'seq) -(require 'easymenu) (require 'view) (require 'ebuff-menu) @@ -795,7 +794,7 @@ and TREE is a list of `ebrowse-ts' structures forming the class tree." (ebrowse-hs-version header) ebrowse-version-string)) ;; Read Lisp objects. Temporarily increase `gc-cons-threshold' to ;; prevent a GC that would not free any memory. - (let ((gc-cons-threshold 2000000)) + (let ((gc-cons-threshold (max gc-cons-threshold 2000000))) (while (not (progn (skip-chars-forward " \t\n") (eobp))) (let* ((root (read (current-buffer))) (old-root-ptr (ebrowse-class-in-tree root tree))) @@ -3185,8 +3184,8 @@ MEMBER-NAME is the name of the member found." (let* ((start (point)) (name (progn (skip-chars-forward "a-zA-Z0-9_") (buffer-substring start (point)))) - class) - (list class name)))) + ) ;; class + (list nil name)))) ;; class (defun ebrowse-tags-choose-class (_tree header name initial-class-name) diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el index a0968663163..542f8ad0b1b 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -46,160 +46,149 @@ It has `lisp-mode-abbrev-table' as its parent." "Syntax table used in `emacs-lisp-mode'.") (defvar emacs-lisp-mode-map - (let ((map (make-sparse-keymap)) - (menu-map (make-sparse-keymap "Emacs-Lisp")) - (lint-map (make-sparse-keymap)) - (prof-map (make-sparse-keymap)) - (tracing-map (make-sparse-keymap))) + (let ((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.") +(easy-menu-define emacs-lisp-mode-menu emacs-lisp-mode-map + "Menu for Emacs Lisp mode." + '("Emacs-Lisp" + ["Indent Line" lisp-indent-line] + ["Indent Region" indent-region + :help "Indent each nonblank line in the region" + :active mark-active] + ["Comment Out Region" comment-region + :help "Comment or uncomment each line in the region" + :active mark-active] + "---" + ["Evaluate Last S-expression" eval-last-sexp + :help "Evaluate sexp before point; print value in echo area"] + ["Evaluate Region" eval-region + :help "Execute the region as Lisp code" + :active mark-active] + ["Evaluate Buffer" eval-buffer + :help "Execute the current buffer as Lisp code"] + ["Interactive Expression Evaluation" ielm + :help "Interactively evaluate Emacs Lisp expressions"] + "---" + ["Byte-compile This File" emacs-lisp-byte-compile + :help "Byte compile the file containing the current buffer"] + ["Byte-compile and Load" emacs-lisp-byte-compile-and-load + :help "Byte-compile the current file (if it has changed), then load compiled code"] + ["Byte-recompile Directory..." byte-recompile-directory + :help "Recompile every `.el' file in DIRECTORY that needs recompilation"] + ["Disassemble Byte Compiled Object..." disassemble + :help "Print disassembled code for OBJECT in a buffer"] + "---" + ["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"] + ("Navigation" + ["Forward Sexp" forward-sexp + :help "Go to the next s-expression"] + ["Backward Sexp" backward-sexp + :help "Go to the previous s-expression"] + ["Beginning Of Defun" beginning-of-defun + :help "Go to the start of the current function definition"] + ["Up List" up-list + :help "Go one level up and forward"]) + ("Linting" + ["Lint Defun" elint-defun + :help "Lint the function at point"] + ["Lint Buffer" elint-current-buffer + :help "Lint the current buffer"] + ["Lint File..." elint-file + :help "Lint a file"] + ["Lint Directory..." elint-directory + :help "Lint a directory"]) + ("Profiling" + ;; Maybe this should be in a separate submenu from the ELP stuff? + ["Start Native Profiler..." profiler-start + :help "Start recording profiling information"] + ["Show Profiler Report" profiler-report + :help "Show the current profiler report" + :active (and (featurep 'profiler) + (profiler-running-p))] + ["Stop Native Profiler" profiler-stop + :help "Stop recording profiling information" + :active (and (featurep 'profiler) + (profiler-running-p))] + "---" + ["Instrument Function..." elp-instrument-function + :help "Instrument a function for profiling"] + ["Instrument Package..." elp-instrument-package + :help "Instrument for profiling all function that start with a prefix"] + ["Show Profiling Results" elp-results + :help "Display current profiling results"] + ["Reset Counters for Function..." elp-reset-function + :help "Reset the profiling information for a function"] + ["Reset Counters for All Functions" elp-reset-all + :help "Reset the profiling information for all functions being profiled"] + "---" + ["Remove Instrumentation for All Functions" elp-restore-all + :help "Restore the original definitions of all functions being profiled"] + ["Remove Instrumentation for Function..." elp-restore-function + :help "Restore an instrumented function to its original definition"]) + ("Tracing" + ["Trace Function..." trace-function + :help "Trace the function given as an argument"] + ["Trace Function Quietly..." trace-function-background + :help "Trace the function with trace output going quietly to a buffer"] + "---" + ["Untrace All" untrace-all + :help "Untrace all currently traced functions"] + ["Untrace Function..." untrace-function + :help "Untrace function, and possibly activate all remaining advice"]) + ["Construct Regexp" re-builder + :help "Construct a regexp interactively"] + ["Check Documentation Strings" checkdoc + :help "Check documentation strings for style requirements"] + ["Auto-Display Documentation Strings" eldoc-mode + :help "Display the documentation string for the item under cursor" + :style toggle + :selected (bound-and-true-p eldoc-mode)])) + (defun emacs-lisp-byte-compile () "Byte compile the file containing the current buffer." - (interactive) + (interactive nil emacs-lisp-mode) (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) +(defun emacs-lisp--before-compile-buffer () + "Make sure the buffer is saved before compiling." (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)) + (save-buffer))) + +(defun emacs-lisp-byte-compile-and-load () + "Byte-compile the current file (if it has changed), then load compiled code." + (interactive nil emacs-lisp-mode) + (emacs-lisp--before-compile-buffer) + (require 'bytecomp) (byte-recompile-file buffer-file-name nil 0) (load buffer-file-name)) +(declare-function native-compile "comp") +(defun emacs-lisp-native-compile-and-load () + "Native-compile synchronously the current file (if it has changed). +Load the compiled code when finished. + +Use `emacs-lisp-byte-compile-and-load' in combination with +`native-comp-deferred-compilation' set to `t' to achieve asynchronous +native compilation." + (interactive nil emacs-lisp-mode) + (emacs-lisp--before-compile-buffer) + (load (native-compile buffer-file-name))) + (defun emacs-lisp-macroexpand () "Macroexpand the form after point. Comments in the form will be lost." @@ -523,7 +512,7 @@ functions are annotated with \"<f>\" via the (end (unless (or (eq beg (point-max)) (member (char-syntax (char-after beg)) - '(?\s ?\" ?\( ?\)))) + '(?\" ?\())) (condition-case nil (save-excursion (goto-char beg) @@ -557,6 +546,7 @@ functions are annotated with \"<f>\" via the ((elisp--expect-function-p beg) (list nil obarray :predicate #'fboundp + :company-kind #'elisp--company-kind :company-doc-buffer #'elisp--company-doc-buffer :company-docsig #'elisp--company-doc-string :company-location #'elisp--company-location)) @@ -570,6 +560,7 @@ functions are annotated with \"<f>\" via the (symbol-plist sym))) :annotation-function (lambda (str) (if (fboundp (intern-soft str)) " <f>")) + :company-kind #'elisp--company-kind :company-doc-buffer #'elisp--company-doc-buffer :company-docsig #'elisp--company-doc-string :company-location #'elisp--company-location)) @@ -580,6 +571,11 @@ functions are annotated with \"<f>\" via the obarray #'boundp 'strict)) + :company-kind + (lambda (s) + (if (test-completion s elisp--local-variables-completion-table) + 'value + 'variable)) :company-doc-buffer #'elisp--company-doc-buffer :company-docsig #'elisp--company-doc-string :company-location #'elisp--company-location))) @@ -626,11 +622,13 @@ functions are annotated with \"<f>\" via the (looking-at "\\_<let\\*?\\_>")))) (list t obarray :predicate #'boundp + :company-kind (lambda (_) 'variable) :company-doc-buffer #'elisp--company-doc-buffer :company-docsig #'elisp--company-doc-string :company-location #'elisp--company-location)) (_ (list nil obarray :predicate #'fboundp + :company-kind #'elisp--company-kind :company-doc-buffer #'elisp--company-doc-buffer :company-docsig #'elisp--company-doc-string :company-location #'elisp--company-location @@ -646,6 +644,16 @@ functions are annotated with \"<f>\" via the " " (cadr table-etc))) (cddr table-etc))))))))) +(defun elisp--company-kind (str) + (let ((sym (intern-soft str))) + (cond + ((or (macrop sym) (special-form-p sym)) 'keyword) + ((fboundp sym) 'function) + ((boundp sym) 'variable) + ((featurep sym) 'module) + ((facep sym) 'color) + (t 'text)))) + (defun lisp-completion-at-point (&optional _predicate) (declare (obsolete elisp-completion-at-point "25.1")) (elisp-completion-at-point)) @@ -688,7 +696,7 @@ Each function should return a list of xrefs, or nil; the first non-nil result supersedes the xrefs produced by `elisp--xref-find-definitions'.") -(cl-defmethod xref-backend-definitions ((_backend (eql elisp)) identifier) +(cl-defmethod xref-backend-definitions ((_backend (eql 'elisp)) identifier) (require 'find-func) ;; FIXME: use information in source near point to filter results: ;; (dvc-log-edit ...) - exclude 'feature @@ -867,7 +875,7 @@ non-nil result supersedes the xrefs produced by (declare-function xref-apropos-regexp "xref" (pattern)) -(cl-defmethod xref-backend-apropos ((_backend (eql elisp)) pattern) +(cl-defmethod xref-backend-apropos ((_backend (eql 'elisp)) pattern) (apply #'nconc (let ((regexp (xref-apropos-regexp pattern)) lst) @@ -885,7 +893,8 @@ non-nil result supersedes the xrefs produced by (facep sym))) 'strict)) -(cl-defmethod xref-backend-identifier-completion-table ((_backend (eql elisp))) +(cl-defmethod xref-backend-identifier-completion-table ((_backend + (eql 'elisp))) elisp--xref-identifier-completion-table) (cl-defstruct (xref-elisp-location @@ -904,7 +913,13 @@ non-nil result supersedes the xrefs produced by (point-marker))))))) (cl-defmethod xref-location-group ((l xref-elisp-location)) - (xref-elisp-location-file l)) + (let ((file (xref-elisp-location-file l))) + (defvar find-function-C-source-directory) + (if (and find-function-C-source-directory + (string-match-p "\\`src/" file)) + (concat find-function-C-source-directory + (substring file 3)) + file))) (defun elisp-load-path-roots () (if (boundp 'package-user-dir) @@ -914,35 +929,31 @@ non-nil result supersedes the xrefs produced by ;;; Elisp Interaction mode (defvar lisp-interaction-mode-map - (let ((map (make-sparse-keymap)) - (menu-map (make-sparse-keymap "Lisp-Interaction"))) + (let ((map (make-sparse-keymap))) (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.") +(easy-menu-define lisp-interaction-mode-menu lisp-interaction-mode-map + "Menu for Lisp Interaction mode." + '("Lisp-Interaction" + ["Complete Lisp Symbol" completion-at-point + :help "Perform completion on Lisp symbol preceding point"] + ["Indent or Pretty-Print" indent-pp-sexp + :help "Indent each line of the list starting just after point, or prettyprint it"] + ["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"] + ["Evaluate and Print" eval-print-last-sexp + :help "Evaluate sexp before point; print value into current buffer"] + ["Evaluate Defun" eval-defun + :help "Evaluate the top-level form containing point, or after point"])) + (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 @@ -1268,9 +1279,8 @@ 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) - (let ((value (elisp--eval-last-sexp eval-last-sexp-arg-internal))) - (push value values) - value) + (values--store-value + (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) @@ -1316,8 +1326,7 @@ Reinitialize the face according to the `defface' specification." ((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)) + (remhash face-symbol face--new-frame-defaults) (put face-symbol 'face-defface-spec nil) (put face-symbol 'face-override-spec nil)) form) @@ -1337,9 +1346,11 @@ 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. + (defvar elisp--eval-defun-result) (let ((debug-on-error eval-expression-debug-on-error) (print-length eval-expression-print-length) - (print-level eval-expression-print-level)) + (print-level eval-expression-print-level) + elisp--eval-defun-result) (save-excursion ;; Arrange for eval-region to "read" the (possibly) altered form. ;; eval-region handles recording which file defines a function or @@ -1351,21 +1362,25 @@ Return the result of evaluation." (end-of-defun) (beginning-of-defun) (setq beg (point)) - (setq form (read (current-buffer))) + (setq form (funcall load-read-function (current-buffer))) (setq end (point))) ;; Alter the form if necessary. (let ((form (eval-sexp-add-defvars - (elisp--eval-defun-1 (macroexpand form))))) + (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)) + ;; This `setq' needs to be added *after* passing + ;; form through `elisp--eval-defun-1' since it + ;; would otherwise "hide" forms like `defvar's and + ;; thus defeat their special treatment. + `(setq elisp--eval-defun-result ,form)))))) + (let ((str (eval-expression-print-format elisp--eval-defun-result))) + (if str (princ str))) + elisp--eval-defun-result)) (defun eval-defun (edebug-it) "Evaluate the top-level form containing point, or after point. @@ -1395,6 +1410,7 @@ which see." (interactive "P") (cond (edebug-it (require 'edebug) + (defvar edebug-all-defs) (eval-defun (not edebug-all-defs))) (t (if (null eval-expression-debug-on-error) diff --git a/lisp/progmodes/etags.el b/lisp/progmodes/etags.el index 869529ab2db..a1f806ae8c9 100644 --- a/lisp/progmodes/etags.el +++ b/lisp/progmodes/etags.el @@ -836,11 +836,7 @@ If no tags table is loaded, do nothing and return nil." "Read a tag name, with defaulting and completion." (let* ((completion-ignore-case (find-tag--completion-ignore-case)) (default (find-tag--default)) - (spec (completing-read (if default - (format "%s (default %s): " - (substring string 0 (string-match "[ :]+\\'" string)) - default) - string) + (spec (completing-read (format-prompt string default) (tags-lazy-completion-table) nil nil nil nil default))) (if (equal spec "") @@ -899,7 +895,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'." - (interactive (find-tag-interactive "Find tag: ")) + (interactive (find-tag-interactive "Find tag")) (setq find-tag-history (cons tagname find-tag-history)) ;; Save the current buffer's value of `find-tag-hook' before @@ -971,7 +967,7 @@ Contrast this with the ring of marks gone to by the command. See documentation of variable `tags-file-name'." (declare (obsolete xref-find-definitions "25.1")) - (interactive (find-tag-interactive "Find tag: ")) + (interactive (find-tag-interactive "Find tag")) (let* ((buf (find-tag-noselect tagname next-p regexp-p)) (pos (with-current-buffer buf (point)))) (condition-case nil @@ -1000,7 +996,7 @@ 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: ")) + (interactive (find-tag-interactive "Find tag other window")) ;; This hair is to deal with the case where the tag is found in the ;; selected window's buffer; without the hair, point is moved in both @@ -1041,7 +1037,7 @@ 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: ")) + (interactive (find-tag-interactive "Find tag other frame")) (let ((pop-up-frames t)) (with-suppressed-warnings ((obsolete find-tag-other-window)) (find-tag-other-window tagname next-p)))) @@ -1065,7 +1061,7 @@ 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)) + (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)) @@ -1604,11 +1600,11 @@ that do nothing." ;; This might be a neat idea, but it's too hairy at the moment. ;;(defmacro tags-with-syntax (&rest body) +;; (declare (debug t)) ;; `(with-syntax-table ;; (with-current-buffer (find-file-noselect (file-of-tag)) ;; (syntax-table)) ;; ,@body)) -;;(put 'tags-with-syntax 'edebug-form-spec '(&rest form)) ;; exact file name match, i.e. searched tag must match complete file ;; name including directories parts if there are some. @@ -1812,7 +1808,7 @@ argument is passed to `next-file', which see)." (defun tags-search (regexp &optional files) "Search through all files listed in tags table for match for REGEXP. Stops when a match is found. -To continue searching for next match, use command \\[tags-loop-continue]. +To continue searching for next match, use the command \\[fileloop-continue]. If FILES if non-nil should be a list or an iterator returning the files to search. The search will be restricted to these files. @@ -1838,7 +1834,7 @@ Also see the documentation of the `tags-file-name' variable." "Do `query-replace-regexp' of FROM with TO on all files listed in tags table. Third arg DELIMITED (prefix arg) means replace only word-delimited matches. If you exit (\\[keyboard-quit], RET or q), you can resume the query replace -with the command \\[tags-loop-continue]. +with the command \\[fileloop-continue]. For non-interactive use, superseded by `fileloop-initialize-replace'." (declare (advertised-calling-convention (from to &optional delimited) "27.1")) (interactive (query-replace-read-args "Tags query replace (regexp)" t t)) @@ -2063,22 +2059,43 @@ for \\[find-tag] (which see)." If you want `xref-find-definitions' to find the tagged files by their file name, add `tag-partial-file-name-match-p' to the list value.") +(defcustom etags-xref-prefer-current-file nil + "Non-nil means show the matches in the current file first." + :type 'boolean + :version "28.1") + ;;;###autoload (defun etags--xref-backend () 'etags) -(cl-defmethod xref-backend-identifier-at-point ((_backend (eql etags))) +(cl-defmethod xref-backend-identifier-at-point ((_backend (eql 'etags))) (find-tag--default)) -(cl-defmethod xref-backend-identifier-completion-table ((_backend (eql etags))) +(cl-defmethod xref-backend-identifier-completion-table ((_backend + (eql 'etags))) (tags-lazy-completion-table)) -(cl-defmethod xref-backend-identifier-completion-ignore-case ((_backend (eql etags))) +(cl-defmethod xref-backend-identifier-completion-ignore-case ((_backend + (eql 'etags))) (find-tag--completion-ignore-case)) -(cl-defmethod xref-backend-definitions ((_backend (eql etags)) symbol) - (etags--xref-find-definitions symbol)) - -(cl-defmethod xref-backend-apropos ((_backend (eql etags)) pattern) +(cl-defmethod xref-backend-definitions ((_backend (eql 'etags)) symbol) + (let ((file (and buffer-file-name (expand-file-name buffer-file-name))) + (definitions (etags--xref-find-definitions symbol)) + same-file-definitions) + (when (and etags-xref-prefer-current-file file) + (cl-delete-if + (lambda (definition) + (when (equal file + (xref-location-group + (xref-item-location definition))) + (push definition same-file-definitions) + t)) + definitions) + (setq definitions (nconc (nreverse same-file-definitions) + definitions))) + definitions)) + +(cl-defmethod xref-backend-apropos ((_backend (eql 'etags)) pattern) (etags--xref-find-definitions (xref-apropos-regexp pattern) t)) (defun etags--xref-find-definitions (pattern &optional regexp?) diff --git a/lisp/progmodes/executable.el b/lisp/progmodes/executable.el index fa5724a3800..0d8b09c33c1 100644 --- a/lisp/progmodes/executable.el +++ b/lisp/progmodes/executable.el @@ -1,4 +1,4 @@ -;;; executable.el --- base functionality for executable interpreter scripts +;;; executable.el --- base functionality for executable interpreter scripts -*- lexical-binding: t -*- ;; Copyright (C) 1994-1996, 2000-2021 Free Software Foundation, Inc. @@ -54,41 +54,31 @@ "Base functionality for executable interpreter scripts." :group 'processes) -;; This used to default to `other', but that doesn't seem to have any -;; significance. fx 2000-02-11. -(defcustom executable-insert t ; 'other +(defcustom executable-insert t "Non-nil means offer to add a magic number to a file. This takes effect when you switch to certain major modes, including Shell-script mode (`sh-mode'). When you type \\[executable-set-magic], it always offers to add or update the magic number." -;;; :type '(choice (const :tag "off" nil) -;;; (const :tag "on" t) -;;; symbol) - :type 'boolean - :group 'executable) - + :type 'boolean) (defcustom executable-query 'function "If non-nil, ask user before changing an existing magic number. When this is `function', only ask when called non-interactively." :type '(choice (const :tag "Don't Ask" nil) (const :tag "Ask when non-interactive" function) - (other :tag "Ask" t)) - :group 'executable) + (other :tag "Ask" t))) (defcustom executable-magicless-file-regexp "/[Mm]akefile$\\|/\\.\\(z?profile\\|bash_profile\\|z?login\\|bash_login\\|z?logout\\|bash_logout\\|.+shrc\\|esrc\\|rcrc\\|[kz]shenv\\)$" "On files with this kind of name no magic is inserted or changed." - :type 'regexp - :group 'executable) + :type 'regexp) (defcustom executable-prefix "#!" "Interpreter magic number prefix inserted when there was no magic number. Use of `executable-prefix-env' is preferable to this option." :version "26.1" ; deprecated - :type 'string - :group 'executable) + :type 'string) (defcustom executable-prefix-env nil "If non-nil, use \"/usr/bin/env\" in interpreter magic number. @@ -96,8 +86,7 @@ If this variable is non-nil, the interpreter magic number inserted by `executable-set-magic' will be \"#!/usr/bin/env INTERPRETER\", otherwise it will be \"#!/path/to/INTERPRETER\"." :version "26.1" - :type 'boolean - :group 'executable) + :type 'boolean) (defcustom executable-chmod 73 "After saving, if the file is not executable, set this mode. @@ -105,8 +94,7 @@ This mode passed to `set-file-modes' is taken absolutely when negative, or relative to the files existing modes. Do nothing if this is nil. Typical values are 73 (+x) or -493 (rwxr-xr-x)." :type '(choice integer - (const nil)) - :group 'executable) + (const nil))) (defvar executable-command nil) @@ -114,8 +102,7 @@ Typical values are 73 (+x) or -493 (rwxr-xr-x)." (defcustom executable-self-display "tail" "Command you use with argument `-n+2' to make text files self-display. Note that the like of `more' doesn't work too well under Emacs \\[shell]." - :type 'string - :group 'executable) + :type 'string) (make-obsolete-variable 'executable-self-display nil "25.1" 'set) diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el index 5d96c62b418..77a807f21ae 100644 --- a/lisp/progmodes/flymake.el +++ b/lisp/progmodes/flymake.el @@ -284,17 +284,17 @@ If set to nil, don't suppress any zero counters." (defmacro flymake-log (level msg &rest args) "Log, at level LEVEL, the message MSG formatted with ARGS. LEVEL is passed to `display-warning', which is used to display -the warning. If this form is included in a byte-compiled file, +the warning. If this form is included in a file, the generated warning contains an indication of the file that generated it." - (let* ((compile-file (and (boundp 'byte-compile-current-file) - (symbol-value 'byte-compile-current-file))) - (sublog (if (and - compile-file - (not load-file-name)) + (let* ((file (if (fboundp 'macroexp-file-name) + (macroexp-file-name) + (and (not load-file-name) + (bound-and-true-p byte-compile-current-file)))) + (sublog (if file (intern (file-name-nondirectory - (file-name-sans-extension compile-file)))))) + (file-name-sans-extension file)))))) `(flymake--log-1 ,level ',sublog ,msg ,@args))) (defun flymake-error (text &rest args) @@ -483,7 +483,7 @@ Currently, Flymake may provide these keyword-value pairs: * `:recent-changes', a list of recent changes since the last time the backend function was called for the buffer. An empty list - indicates that no changes have been reocrded. If it is the + indicates that no changes have been recorded. If it is the first time that this backend function is called for this activation of `flymake-mode', then this argument isn't provided at all (i.e. it's not merely nil). @@ -741,7 +741,10 @@ to handle a report even if TOKEN was not expected. REGION is a (BEG . END) pair of buffer positions indicating that this report applies to that region." (let* ((state (gethash backend flymake--backend-state)) - (first-report (not (flymake--backend-state-reported-p state)))) + first-report) + (unless state + (error "Can't find state for %s in `flymake--backend-state'" backend)) + (setf first-report (not (flymake--backend-state-reported-p state))) (setf (flymake--backend-state-reported-p state) t) (let (expected-token new-diags) @@ -1198,7 +1201,6 @@ default) no filter is applied." '(" " flymake-mode-line-title flymake-mode-line-exception flymake-mode-line-counters) "Mode line construct for customizing Flymake information." - :group 'flymake :type '(repeat (choice string symbol))) (defcustom flymake-mode-line-counter-format @@ -1210,7 +1212,6 @@ default) no filter is applied." This is a suitable place for placing the `flymake-error-counter', `flymake-warning-counter' and `flymake-note-counter' constructs. Separating each of these with space is not necessary." - :group 'flymake :type '(repeat (choice string symbol))) (defvar flymake-mode-line-title '(:eval (flymake--mode-line-title)) @@ -1244,13 +1245,13 @@ correctly.") "Flymake" mouse-face mode-line-highlight help-echo - (lambda (&rest whatever) - (concat - (format "%s known backends\n" (hash-table-count flymake--backend-state)) - (format "%s running\n" (length (flymake-running-backends))) - (format "%s disabled\n" (length (flymake-disabled-backends))) - "mouse-1: Display minor mode menu\n" - "mouse-2: Show help for minor mode")) + ,(lambda (&rest _) + (concat + (format "%s known backends\n" (hash-table-count flymake--backend-state)) + (format "%s running\n" (length (flymake-running-backends))) + (format "%s disabled\n" (length (flymake-disabled-backends))) + "mouse-1: Display minor mode menu\n" + "mouse-2: Show help for minor mode")) keymap ,(let ((map (make-sparse-keymap))) (define-key map [mode-line down-mouse-1] diff --git a/lisp/progmodes/fortran.el b/lisp/progmodes/fortran.el index 3bef3986a10..707226fb2a5 100644 --- a/lisp/progmodes/fortran.el +++ b/lisp/progmodes/fortran.el @@ -650,74 +650,6 @@ Used in the Fortran entry in `hs-special-modes-alist'.") (define-key map "7" 'fortran-electric-line-number) (define-key map "8" 'fortran-electric-line-number) (define-key map "9" 'fortran-electric-line-number) - - (easy-menu-define fortran-menu map "Menu for Fortran mode." - `("Fortran" - ["Manual" (info "(emacs)Fortran") :active t - :help "Read the Emacs manual chapter on Fortran mode"] - ("Customization" - ,(custom-menu-create 'fortran) - ;; FIXME useless? - ["Set" Custom-set :active t - :help "Set current value of all edited settings in the buffer"] - ["Save" Custom-save :active t - :help "Set and save all edited settings"] - ["Reset to Current" Custom-reset-current :active t - :help "Reset all edited settings to current"] - ["Reset to Saved" Custom-reset-saved :active t - :help "Reset all edited or set settings to saved"] - ["Reset to Standard Settings" Custom-reset-standard :active t - :help "Erase all customizations in buffer"] - ) - "--" - ["Comment Region" fortran-comment-region mark-active] - ["Uncomment Region" - (fortran-comment-region (region-beginning) (region-end) 1) - mark-active] - ["Indent Region" indent-region mark-active] - ["Indent Subprogram" fortran-indent-subprogram t] - "--" - ["Beginning of Subprogram" fortran-beginning-of-subprogram :active t - :help "Move point to the start of the current subprogram"] - ["End of Subprogram" fortran-end-of-subprogram :active t - :help "Move point to the end of the current subprogram"] - ("Mark" - :help "Mark a region of code" - ["Subprogram" mark-defun t] - ["IF Block" fortran-mark-if t] - ["DO Block" fortran-mark-do t] - ) - ["Narrow to Subprogram" narrow-to-defun t] - ["Widen" widen t] - "--" - ["Temporary Column Ruler" fortran-column-ruler :active t - :help "Briefly display Fortran column numbers"] - ;; May not be '72', depending on fortran-line-length, but this - ;; seems ok for a menu item. - ["72-column Window" fortran-window-create :active t - :help "Set window width to Fortran line length"] - ["Full Width Window" - (enlarge-window-horizontally (- (frame-width) (window-width))) - :active (not (window-full-width-p)) - :help "Make window full width"] - ["Momentary 72-Column Window" fortran-window-create-momentarily - :active t :help "Briefly set window width to Fortran line length"] - "--" - ["Break Line at Point" fortran-split-line :active t - :help "Break the current line at point"] - ["Join Line" fortran-join-line :active t - :help "Join the current line to the previous one"] - ["Fill Statement/Comment" fill-paragraph t] - "--" - ["Toggle Auto Fill" auto-fill-mode :selected auto-fill-function - :style toggle - :help "Automatically fill text while typing in this buffer"] - ["Toggle Abbrev Mode" abbrev-mode :selected abbrev-mode - :style toggle :help "Expand abbreviations while typing in this buffer"] - ["Add Imenu Menu" imenu-add-menubar-index - :active (not (lookup-key (current-local-map) [menu-bar index])) - :included (fboundp 'imenu-add-to-menubar) - :help "Add an index menu to the menu-bar"])) map) "Keymap used in Fortran mode.") @@ -2209,6 +2141,81 @@ arg DO-SPACE prevents stripping the whitespace." (point))))) "main")))) +;; The menu is defined at the end because `custom-menu-create' is +;; called at load time and will result in (recursively) loading this +;; file otherwise. +(easy-menu-define fortran-menu fortran-mode-map "Menu for Fortran mode." + `("Fortran" + ["Manual" (info "(emacs)Fortran") :active t + :help "Read the Emacs manual chapter on Fortran mode"] + ("Customization" + ,(progn + ;; Tell the byte compiler that `features' is lexical. + (with-no-warnings (defvar features)) + (let ((features (cons 'fortran features))) + (custom-menu-create 'fortran))) + ;; FIXME useless? + ["Set" Custom-set :active t + :help "Set current value of all edited settings in the buffer"] + ["Save" Custom-save :active t + :help "Set and save all edited settings"] + ["Reset to Current" Custom-reset-current :active t + :help "Reset all edited settings to current"] + ["Reset to Saved" Custom-reset-saved :active t + :help "Reset all edited or set settings to saved"] + ["Reset to Standard Settings" Custom-reset-standard :active t + :help "Erase all customizations in buffer"] + ) + "--" + ["Comment Region" fortran-comment-region mark-active] + ["Uncomment Region" + (fortran-comment-region (region-beginning) (region-end) 1) + mark-active] + ["Indent Region" indent-region mark-active] + ["Indent Subprogram" fortran-indent-subprogram t] + "--" + ["Beginning of Subprogram" fortran-beginning-of-subprogram :active t + :help "Move point to the start of the current subprogram"] + ["End of Subprogram" fortran-end-of-subprogram :active t + :help "Move point to the end of the current subprogram"] + ("Mark" + :help "Mark a region of code" + ["Subprogram" mark-defun t] + ["IF Block" fortran-mark-if t] + ["DO Block" fortran-mark-do t] + ) + ["Narrow to Subprogram" narrow-to-defun t] + ["Widen" widen t] + "--" + ["Temporary Column Ruler" fortran-column-ruler :active t + :help "Briefly display Fortran column numbers"] + ;; May not be '72', depending on fortran-line-length, but this + ;; seems ok for a menu item. + ["72-column Window" fortran-window-create :active t + :help "Set window width to Fortran line length"] + ["Full Width Window" + (enlarge-window-horizontally (- (frame-width) (window-width))) + :active (not (window-full-width-p)) + :help "Make window full width"] + ["Momentary 72-Column Window" fortran-window-create-momentarily + :active t :help "Briefly set window width to Fortran line length"] + "--" + ["Break Line at Point" fortran-split-line :active t + :help "Break the current line at point"] + ["Join Line" fortran-join-line :active t + :help "Join the current line to the previous one"] + ["Fill Statement/Comment" fill-paragraph t] + "--" + ["Toggle Auto Fill" auto-fill-mode :selected auto-fill-function + :style toggle + :help "Automatically fill text while typing in this buffer"] + ["Toggle Abbrev Mode" abbrev-mode :selected abbrev-mode + :style toggle :help "Expand abbreviations while typing in this buffer"] + ["Add Imenu Menu" imenu-add-menubar-index + :active (not (lookup-key (current-local-map) [menu-bar index])) + :included (fboundp 'imenu-add-to-menubar) + :help "Add an index menu to the menu-bar"])) + (provide 'fortran) ;;; fortran.el ends here diff --git a/lisp/progmodes/gdb-mi.el b/lisp/progmodes/gdb-mi.el index 1a96755bcf0..67ad39b7f46 100644 --- a/lisp/progmodes/gdb-mi.el +++ b/lisp/progmodes/gdb-mi.el @@ -101,6 +101,19 @@ (declare-function speedbar-delete-subblock "speedbar" (indent)) (declare-function speedbar-center-buffer-smartly "speedbar" ()) +;; FIXME: The declares below are necessary because we don't call `gud-def' +;; at toplevel, so the compiler doesn't know under which circumstances +;; they're defined. +(declare-function gud-until "gud" (arg)) +(declare-function gud-print "gud" (arg)) +(declare-function gud-down "gud" (arg)) +(declare-function gud-up "gud" (arg)) +(declare-function gud-jump "gud" (arg)) +(declare-function gud-finish "gud" (arg)) +(declare-function gud-next "gud" (arg)) +(declare-function gud-stepi "gud" (arg)) +(declare-function gud-tbreak "gud" (arg)) + (defvar tool-bar-map) (defvar speedbar-initial-expansion-list-name) (defvar speedbar-frame) @@ -568,6 +581,23 @@ stopped thread is already selected." :group 'gdb-buffers :version "23.2") +(defcustom gdb-registers-enable-filter nil + "If non-nil, enable register name filter in register buffer. +Use `gdb-registers-filter-pattern-list' to control what register to +filter." + :type 'boolean + :group 'gdb-buffers + :version "28.1") + +(defcustom gdb-registers-filter-pattern-list nil + "Patterns for names that are displayed in register buffer. +Each pattern is a regular expression. GDB displays registers +whose name matches any pattern in the list. Refresh the register +buffer for the change to take effect." + :type '(repeat regexp) + :group 'gdb-buffers + :version "28.1") + (defvar gdb-debug-log nil "List of commands sent to and replies received from GDB. Most recent commands are listed first. This list stores only the last @@ -966,6 +996,8 @@ detailed description of this mode. (define-key gud-minor-mode-map [left-margin C-mouse-3] 'gdb-mouse-jump) + (gud-set-repeat-map-property 'gud-gdb-repeat-map) + (setq-local gud-gdb-completion-function 'gud-gdbmi-completions) (add-hook 'completion-at-point-functions #'gud-gdb-completion-at-point @@ -1350,7 +1382,7 @@ With arg, enter name of variable to be watched in the minibuffer." (string-match "\\(\\S-+\\)" text) (let* ((var (nth (- (count-lines (point-min) (point)) 2) gdb-var-list)) (varnum (car var))) - (if (string-match "\\." (car var)) + (if (string-search "." (car var)) (message-box "Can only delete a root expression") (gdb-var-delete-1 var varnum))))) @@ -1447,14 +1479,14 @@ With arg, enter name of variable to be watched in the minibuffer." TEXT is the text of the button we clicked on, a + or - item. TOKEN is data related to this node. INDENT is the current indentation depth." - (cond ((string-match "\\+" text) ;expand this node + (cond ((string-search "+" text) ;expand this node (let* ((var (assoc token gdb-var-list)) (expr (nth 1 var)) (children (nth 2 var))) (if (or (<= (string-to-number children) gdb-max-children) (y-or-n-p (format "%s has %s children. Continue? " expr children))) (gdb-var-list-children token)))) - ((string-match "-" text) ;contract this node + ((string-search "-" text) ;contract this node (dolist (var gdb-var-list) (if (string-match (concat token "\\.") (car var)) (setq gdb-var-list (delq var gdb-var-list)))) @@ -1931,7 +1963,7 @@ commands to be prefixed by \"-interpreter-exec console\".") The string is enclosed in double quotes. All embedded quotes, newlines, and backslashes are preceded with a backslash." (setq string (replace-regexp-in-string "\\([\"\\]\\)" "\\\\\\&" string)) - (setq string (replace-regexp-in-string "\n" "\\n" string t t)) + (setq string (string-replace "\n" "\\n" string)) (concat "\"" string "\"")) (defun gdb-input (command handler-function &optional trigger-name) @@ -2384,7 +2416,7 @@ rule from an incomplete data stream. The parser will stay in this state until the end of the current result or async record is reached." (when (< gdbmi-bnf-offset (length gud-marker-acc)) ;; Search the data stream for the end of the current record: - (let* ((newline-pos (string-match "\n" gud-marker-acc gdbmi-bnf-offset)) + (let* ((newline-pos (string-search "\n" gud-marker-acc gdbmi-bnf-offset)) (is-progressive (equal (cdr class-command) 'progressive)) (is-complete (not (null newline-pos))) result-str) @@ -4380,6 +4412,26 @@ member." 'gdb-registers-mode 'gdb-invalidate-registers) +(defun gdb-header-click-event-handler (function) + "Return a function that handles clicking event on gdb header buttons. + +This function switches to the window where the header locates and +executes FUNCTION." + (lambda (event) + (interactive "e") + (save-selected-window + ;; Make sure we are in the right buffer. + (select-window (posn-window (event-start event))) + (funcall function)))) + +(defun gdb-registers-toggle-filter () + "Toggle register filter." + (interactive) + (setq gdb-registers-enable-filter + (not gdb-registers-enable-filter)) + ;; Update the register buffer. + (gdb-invalidate-registers 'update)) + (defun gdb-registers-handler-custom () (when gdb-register-names (let ((register-values @@ -4390,17 +4442,27 @@ member." (value (gdb-mi--field register 'value)) (register-name (nth (string-to-number register-number) gdb-register-names))) - (gdb-table-add-row - table - (list - (propertize register-name - 'font-lock-face font-lock-variable-name-face) - (if (member register-number gdb-changed-registers) - (propertize value 'font-lock-face font-lock-warning-face) - value)) - `(mouse-face highlight - help-echo "mouse-2: edit value" - gdb-register-name ,register-name)))) + ;; Add register if `gdb-registers-filter-pattern-list' is nil; + ;; or any pattern that `gdb-registers-filter-pattern-list' + ;; matches. + (when (or (null gdb-registers-enable-filter) + ;; Return t if any register name matches a pattern. + (cl-loop for pattern + in gdb-registers-filter-pattern-list + if (string-match pattern register-name) + return t + finally return nil)) + (gdb-table-add-row + table + (list + (propertize register-name + 'font-lock-face font-lock-variable-name-face) + (if (member register-number gdb-changed-registers) + (propertize value 'font-lock-face font-lock-warning-face) + value)) + `(mouse-face highlight + help-echo "mouse-2: edit value" + gdb-register-name ,register-name))))) (insert (gdb-table-string table " "))) (setq mode-name (gdb-current-context-mode-name "Registers")))) @@ -4428,6 +4490,7 @@ member." (gdb-get-buffer-create 'gdb-locals-buffer gdb-thread-number) t))) + (define-key map "f" #'gdb-registers-toggle-filter) map)) (defvar gdb-registers-header @@ -4437,7 +4500,31 @@ member." mode-line-inactive) " " (gdb-propertize-header "Registers" gdb-registers-buffer - nil nil mode-line))) + nil nil mode-line) + " " + '(:eval + (format + "[filter %s %s]" + (propertize + (if gdb-registers-enable-filter "[on]" "[off]") + 'face (if gdb-registers-enable-filter + '(:weight bold :inherit success) + 'shadow) + 'help-echo "mouse-1: toggle filter" + 'mouse-face 'mode-line-highlight + 'local-map (gdb-make-header-line-mouse-map + 'mouse-1 (gdb-header-click-event-handler + #'gdb-registers-toggle-filter))) + (propertize + "[set]" + 'face 'mode-line + 'help-echo "mouse-1: Customize filter patterns" + 'mouse-face 'mode-line-highlight + 'local-map (gdb-make-header-line-mouse-map + 'mouse-1 (lambda () + (interactive) + (customize-variable-other-window + 'gdb-registers-filter-pattern-list)))))))) (define-derived-mode gdb-registers-mode gdb-parent-mode "Registers" "Major mode for gdb registers." @@ -4512,7 +4599,7 @@ overlay arrow in source buffer." (let ((frame (gdb-mi--field (gdb-mi--partial-output) 'frame))) (when frame (setq gdb-selected-frame (gdb-mi--field frame 'func)) - (setq gdb-selected-file (gdb-mi--field frame 'fullname)) + (setq gdb-selected-file (file-local-name (gdb-mi--field frame 'fullname))) (setq gdb-frame-number (gdb-mi--field frame 'level)) (setq gdb-frame-address (gdb-mi--field frame 'addr)) (let ((line (gdb-mi--field frame 'line))) diff --git a/lisp/progmodes/glasses.el b/lisp/progmodes/glasses.el index a0f5d36bb65..cd92175bd61 100644 --- a/lisp/progmodes/glasses.el +++ b/lisp/progmodes/glasses.el @@ -321,10 +321,6 @@ separators (like underscores) at places they belong to." (remove-hook 'write-file-functions 'glasses-convert-to-unreadable t))))) - -;;; Announce - (provide 'glasses) - ;;; glasses.el ends here diff --git a/lisp/progmodes/grep.el b/lisp/progmodes/grep.el index d6ee8bb4236..b2a9b3e3206 100644 --- a/lisp/progmodes/grep.el +++ b/lisp/progmodes/grep.el @@ -88,9 +88,9 @@ To make grep highlight matches even into a pipe, you need the option `always' that forces grep to use `--color=always' to unconditionally output escape sequences. -In interactive usage, the actual value of this variable is set up -by `grep-compute-defaults' when the default value is `auto-detect'. -To change the default value, use \\[customize] or call the function +If the value is `auto-detect' (the default), `grep' will call +`grep-compute-defaults' to compute the value. To change the +default value, use \\[customize] or call the function `grep-apply-setting'." :type '(choice (const :tag "Do not highlight matches with grep markers" nil) (const :tag "Highlight matches with grep markers" t) @@ -279,57 +279,39 @@ See `compilation-error-screen-columns'." (define-key map "}" 'compilation-next-file) (define-key map "\t" 'compilation-next-error) (define-key map [backtab] 'compilation-previous-error) - - ;; Set up the menu-bar - (define-key map [menu-bar grep] - (cons "Grep" (make-sparse-keymap "Grep"))) - - (define-key map [menu-bar grep grep-find-toggle-abbreviation] - '(menu-item "Toggle command abbreviation" - grep-find-toggle-abbreviation - :help "Toggle showing verbose command options")) - (define-key map [menu-bar grep compilation-separator3] '("----")) - (define-key map [menu-bar grep compilation-kill-compilation] - '(menu-item "Kill Grep" kill-compilation - :help "Kill the currently running grep process")) - (define-key map [menu-bar grep compilation-separator2] '("----")) - (define-key map [menu-bar grep compilation-compile] - '(menu-item - "Compile..." compile - :help - "Compile the program including the current buffer. Default: run `make'")) - (define-key map [menu-bar grep compilation-rgrep] - '(menu-item "Recursive grep..." rgrep - :help "User-friendly recursive grep in directory tree")) - (define-key map [menu-bar grep compilation-lgrep] - '(menu-item "Local grep..." lgrep - :help "User-friendly grep in a directory")) - (define-key map [menu-bar grep compilation-grep-find] - '(menu-item "Grep via Find..." grep-find - :help "Run grep via find, with user-specified args")) - (define-key map [menu-bar grep compilation-grep] - '(menu-item - "Another grep..." grep - :help - "Run grep, with user-specified args, and collect output in a buffer.")) - (define-key map [menu-bar grep compilation-recompile] - '(menu-item "Repeat grep" recompile - :help "Run grep again")) - (define-key map [menu-bar grep compilation-separator1] '("----")) - (define-key map [menu-bar grep compilation-first-error] - '(menu-item - "First Match" first-error - :help "Restart at the first match, visit corresponding location")) - (define-key map [menu-bar grep compilation-previous-error] - '(menu-item "Previous Match" previous-error - :help "Visit the previous match and corresponding location")) - (define-key map [menu-bar grep compilation-next-error] - '(menu-item "Next Match" next-error - :help "Visit the next match and corresponding location")) map) "Keymap for grep buffers. `compilation-minor-mode-map' is a cdr of this.") +(easy-menu-define grep-menu-map grep-mode-map + "Menu for grep buffers." + '("Grep" + ["Next Match" next-error + :help "Visit the next match and corresponding location"] + ["Previous Match" previous-error + :help "Visit the previous match and corresponding location"] + ["First Match" first-error + :help "Restart at the first match, visit corresponding location"] + "----" + ["Repeat grep" recompile + :help "Run grep again"] + ["Another grep..." grep + :help "Run grep, with user-specified args, and collect output in a buffer."] + ["Grep via Find..." grep-find + :help "Run grep via find, with user-specified args"] + ["Local grep..." lgrep + :help "User-friendly grep in a directory"] + ["Recursive grep..." rgrep + :help "User-friendly recursive grep in directory tree"] + ["Compile..." compile + :help "Compile the program including the current buffer. Default: run `make'"] + "----" + ["Kill Grep" kill-compilation + :help "Kill the currently running grep process"] + "----" + ["Toggle command abbreviation" grep-find-toggle-abbreviation + :help "Toggle showing verbose command options"])) + (defvar grep-mode-tool-bar-map ;; When bootstrapping, tool-bar-map is not properly initialized yet, ;; so don't do anything. @@ -407,7 +389,7 @@ Notice that using \\[next-error] or \\[compile-goto-error] modifies (and mbeg (next-single-property-change mbeg 'font-lock-face nil end)))) (when mend - (- mend beg)))))) + (- mend beg 1)))))) nil nil (3 '(face nil display ":"))) ("^Binary file \\(.+\\) matches" 1 nil nil 0 1)) @@ -491,7 +473,7 @@ buffer `default-directory'." (1 (if (eq (char-after (match-beginning 1)) ?\0) `(face nil display ,(match-string 2))))) ;; Hide excessive part of rgrep command - ("^find \\(\\. -type d .*\\\\)\\)" + ("^find \\(\\(?:-H \\)?\\. -type d .*\\(?:\\\\)\\|\")\"\\)\\)" (1 (if grep-find-abbreviate grep-find-abbreviate-properties '(face nil abbreviated-command t)))) ;; Hide excessive part of lgrep command @@ -714,11 +696,12 @@ The value depends on `grep-command', `grep-template', (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. + ;; The "grep --help" exit status varies; pay no attention to it. + (grep-probe grep-program '(nil t nil "--help")) + (goto-char (point-min)) + (and (let ((case-fold-search nil)) + (re-search-forward (rx "--color" (not (in "a-z"))) nil t)) + ;; Windows and DOS pipes fail `isatty' detection in Grep. (if (memq system-type '(windows-nt ms-dos)) 'always 'auto))))) @@ -792,25 +775,24 @@ The value depends on `grep-command', `grep-template', (let ((gcmd (format "%s <C> %s <R>" grep-program grep-options)) (null (if grep-use-null-device - (format "%s " (null-device)) - ""))) - (cond ((eq grep-find-use-xargs 'gnu) - (format "%s <D> <X> -type f <F> -print0 | \"%s\" -0 %s" - find-program xargs-program gcmd)) - ((eq grep-find-use-xargs 'gnu-sort) - (format "%s <D> <X> -type f <F> -print0 | sort -z | \"%s\" -0 %s" - find-program xargs-program gcmd)) - ((eq grep-find-use-xargs 'exec) - (format "%s <D> <X> -type f <F> -exec %s %s %s%s" - find-program gcmd quot-braces null quot-scolon)) - ((eq grep-find-use-xargs 'exec-plus) - (format "%s <D> <X> -type f <F> -exec %s %s%s +" - find-program gcmd null quot-braces)) - (t - (format "%s <D> <X> -type f <F> -print | \"%s\" %s" - find-program xargs-program gcmd)))))))) - - ;; Save defaults for this host. + (format "%s " (null-device)) + ""))) + (cond ((eq grep-find-use-xargs 'gnu) + (format "%s -H <D> <X> -type f <F> -print0 | \"%s\" -0 %s" + find-program xargs-program gcmd)) + ((eq grep-find-use-xargs 'gnu-sort) + (format "%s -H <D> <X> -type f <F> -print0 | sort -z | \"%s\" -0 %s" + find-program xargs-program gcmd)) + ((eq grep-find-use-xargs 'exec) + (format "%s -H <D> <X> -type f <F> -exec %s %s %s%s" + find-program gcmd quot-braces null quot-scolon)) + ((eq grep-find-use-xargs 'exec-plus) + (format "%s -H <D> <X> -type f <F> -exec %s %s%s +" + find-program gcmd null quot-braces)) + (t + (format "%s -H <D> <X> -type f <F> -print | \"%s\" %s" + find-program xargs-program gcmd)))))))) + ;; Save defaults for this host. (setq grep-host-defaults-alist (delete (assq host-id grep-host-defaults-alist) grep-host-defaults-alist)) @@ -933,7 +915,10 @@ list is empty)." (if current-prefix-arg default grep-command) 'grep-history (if current-prefix-arg nil default)))))) - + ;; If called non-interactively, also compute the defaults if we + ;; haven't already. + (when (eq grep-highlight-matches 'auto-detect) + (grep-compute-defaults)) (grep--save-buffers) ;; Setting process-setup-function makes exit-message-function work ;; even when async processes aren't supported. @@ -1149,13 +1134,13 @@ command before it's run." (and grep-find-ignored-files (concat " --exclude=" (mapconcat - #'(lambda (ignore) - (cond ((stringp ignore) - (shell-quote-argument ignore)) - ((consp ignore) - (and (funcall (car ignore) dir) - (shell-quote-argument - (cdr ignore)))))) + (lambda (ignore) + (cond ((stringp ignore) + (shell-quote-argument ignore)) + ((consp ignore) + (and (funcall (car ignore) dir) + (shell-quote-argument + (cdr ignore)))))) grep-find-ignored-files " --exclude="))) (and (eq grep-use-directories-skip t) @@ -1289,13 +1274,13 @@ command before it's run." ;; we should use shell-quote-argument here " -name " (mapconcat - #'(lambda (ignore) - (cond ((stringp ignore) - (shell-quote-argument ignore)) - ((consp ignore) - (and (funcall (car ignore) dir) - (shell-quote-argument - (cdr ignore)))))) + (lambda (ignore) + (cond ((stringp ignore) + (shell-quote-argument ignore)) + ((consp ignore) + (and (funcall (car ignore) dir) + (shell-quote-argument + (cdr ignore)))))) grep-find-ignored-files " -o -name ") " " @@ -1361,6 +1346,13 @@ command before it's run." (grep-highlight-matches 'always)) (rgrep regexp files dir confirm))) +(defun grep-file-at-point (point) + "Return the name of the file at POINT a `grep-mode' buffer. +The returned file name is relative." + (when-let ((msg (get-text-property point 'compilation-message)) + (loc (compilation--message->loc msg))) + (caar (compilation--loc->file-struct loc)))) + ;;;###autoload (defalias 'rzgrep 'zrgrep) diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el index eb114acdabc..08814ebcaaa 100644 --- a/lisp/progmodes/gud.el +++ b/lisp/progmodes/gud.el @@ -50,6 +50,30 @@ (defvar hl-line-mode) (defvar hl-line-sticky-flag) +(declare-function gdb-tooltip-print "gdb-mi" (expr)) +(declare-function gdb-tooltip-print-1 "gdb-mi" (expr)) +(declare-function gud-pp "gdb-mi" (arg)) +(declare-function gdb-var-delete "gdb-mi" ()) +(declare-function speedbar-toggle-line-expansion "gud" ()) +(declare-function speedbar-edit-line "gud" ()) +;; FIXME: The declares below are necessary because we don't call `gud-def' +;; at toplevel, so the compiler doesn't know under which circumstances +;; they're defined. +(declare-function gud-statement "gud" (arg)) +(declare-function gud-until "gud" (arg)) +(declare-function gud-pv "gud" (arg)) +(declare-function gud-print "gud" (arg)) +(declare-function gud-down "gud" (arg)) +(declare-function gud-up "gud" (arg)) +(declare-function gud-jump "gud" (arg)) +(declare-function gud-finish "gud" (arg)) +(declare-function gud-cont "gud" (arg)) +(declare-function gud-next "gud" (arg)) +(declare-function gud-stepi "gud" (arg)) +(declare-function gud-step "gud" (arg)) +(declare-function gud-remove "gud" (arg)) +(declare-function gud-tbreak "gud" (arg)) +(declare-function gud-break "gud" (arg)) ;; ====================================================================== ;; GUD commands must be visible in C buffers visited by GUD @@ -64,10 +88,9 @@ pdb (Python), and jdb." (defcustom gud-key-prefix "\C-x\C-a" "Prefix of all GUD commands valid in C buffers." - :type 'key-sequence - :group 'gud) + :type 'key-sequence) -(global-set-key (vconcat gud-key-prefix "\C-l") 'gud-refresh) +(global-set-key (vconcat gud-key-prefix "\C-l") #'gud-refresh) ;; (define-key ctl-x-map " " 'gud-break); backward compatibility hack (defvar gud-marker-filter nil) @@ -151,10 +174,11 @@ Used to gray out relevant toolbar icons.") (or (not (gdb-show-run-p)) (bound-and-true-p gdb-active-process))))) - ([go] menu-item (if (bound-and-true-p gdb-active-process) - "Continue" "Run") gud-go + ([go] . (menu-item (if (bound-and-true-p gdb-active-process) + "Continue" "Run") + gud-go :visible (and (eq gud-minor-mode 'gdbmi) - (gdb-show-run-p))) + (gdb-show-run-p)))) ([stop] menu-item "Stop" gud-stop-subjob :visible (or (not (memq gud-minor-mode '(gdbmi pdb))) (and (eq gud-minor-mode 'gdbmi) @@ -186,13 +210,15 @@ Used to gray out relevant toolbar icons.") (bound-and-true-p gdb-active-process)) :visible (and (string-equal (buffer-local-value - 'gud-target-name gud-comint-buffer) "emacs") + 'gud-target-name gud-comint-buffer) + "emacs") (eq gud-minor-mode 'gdbmi))) - ([print*] menu-item (if (eq gud-minor-mode 'jdb) - "Dump object" - "Print Dereference") gud-pstar + ([print*] . (menu-item (if (eq gud-minor-mode 'jdb) + "Dump object" + "Print Dereference") + gud-pstar :enable (not gud-running) - :visible (memq gud-minor-mode '(gdbmi gdb jdb))) + :visible (memq gud-minor-mode '(gdbmi gdb jdb)))) ([print] menu-item "Print Expression" gud-print :enable (not gud-running)) ([watch] menu-item "Watch Expression" gud-watch @@ -294,6 +320,32 @@ Used to gray out relevant toolbar icons.") (tool-bar-local-item-from-menu (car x) (cdr x) map gud-minor-mode-map)))) +(defvar gud-gdb-repeat-map + (let ((map (make-sparse-keymap))) + (pcase-dolist (`(,key . ,cmd) '(("n" . gud-next) + ("s" . gud-step) + ("i" . gud-stepi) + ("c" . gud-cont) + ("l" . gud-refresh) + ("f" . gud-finish) + ("<" . gud-up) + (">" . gud-down))) + (define-key map key cmd)) + map) + "Keymap to repeat `gud-gdb' stepping instructions `C-x C-a C-n n n'. +Used in `repeat-mode'.") + +(defun gud-set-repeat-map-property (keymap-symbol) + "Set the `repeat-map' property of relevant gud commands to KEYMAP-SYMBOL. + +KEYMAP-SYMBOL is a symbol corresponding to some +`<FOO>-repeat-map', a keymap containing gud commands that may be +repeated when `repeat-mode' is on." + (map-keymap-internal (lambda (_ cmd) + (put cmd 'repeat-map keymap-symbol)) + (symbol-value keymap-symbol))) + + (defun gud-file-name (f) "Transform a relative file name to an absolute file name. Uses `gud-<MINOR-MODE>-directories' to find the source files." @@ -333,7 +385,7 @@ Uses `gud-<MINOR-MODE>-directories' to find the source files." (eq gud-minor-mode 'gdbmi)) (make-local-variable 'gdb-define-alist) (unless gdb-define-alist (gdb-create-define-alist)) - (add-hook 'after-save-hook 'gdb-create-define-alist nil t)) + (add-hook 'after-save-hook #'gdb-create-define-alist nil t)) (make-local-variable 'gud-keep-buffer)) buf))) @@ -380,8 +432,8 @@ we're in the GUD buffer)." `(gud-call ,cmd arg) ;; Unused lexical warning if cmd does not use "arg". cmd)))) - ,(if key `(local-set-key ,(concat "\C-c" key) ',func)) - ,(if key `(global-set-key (vconcat gud-key-prefix ,key) ',func)))) + ,(if key `(local-set-key ,(concat "\C-c" key) #',func)) + ,(if key `(global-set-key (vconcat gud-key-prefix ,key) #',func)))) ;; Where gud-display-frame should put the debugging arrow; a cons of ;; (filename . line-number). This is set by the marker-filter, which scans @@ -447,12 +499,12 @@ The value t means that there is no stack, and we are in display-file mode.") "Install those variables used by speedbar to enhance gud/gdb." (unless gud-speedbar-key-map (setq gud-speedbar-key-map (speedbar-make-specialized-keymap)) - (define-key gud-speedbar-key-map "j" 'speedbar-edit-line) - (define-key gud-speedbar-key-map "e" 'speedbar-edit-line) - (define-key gud-speedbar-key-map "\C-m" 'speedbar-edit-line) - (define-key gud-speedbar-key-map " " 'speedbar-toggle-line-expansion) - (define-key gud-speedbar-key-map "D" 'gdb-var-delete) - (define-key gud-speedbar-key-map "p" 'gud-pp)) + (define-key gud-speedbar-key-map "j" #'speedbar-edit-line) + (define-key gud-speedbar-key-map "e" #'speedbar-edit-line) + (define-key gud-speedbar-key-map "\C-m" #'speedbar-edit-line) + (define-key gud-speedbar-key-map " " #'speedbar-toggle-line-expansion) + (define-key gud-speedbar-key-map "D" #'gdb-var-delete) + (define-key gud-speedbar-key-map "p" #'gud-pp)) (speedbar-add-expansion-list '("GUD" gud-speedbar-menu-items gud-speedbar-key-map @@ -622,8 +674,7 @@ required by the caller." (defcustom gud-gud-gdb-command-name "gdb --fullname" "Default command to run an executable under GDB in text command mode. The option \"--fullname\" must be included in this value." - :type 'string - :group 'gud) + :type 'string) (defvar gud-gdb-marker-regexp ;; This used to use path-separator instead of ":"; @@ -785,11 +836,13 @@ the buffer in which this command was invoked." (gud-def gud-until "until %l" "\C-u" "Continue to current line.") (gud-def gud-run "run" nil "Run the program.") + (gud-set-repeat-map-property 'gud-gdb-repeat-map) + (add-hook 'completion-at-point-functions #'gud-gdb-completion-at-point nil 'local) - (setq-local gud-gdb-completion-function 'gud-gdb-completions) + (setq-local gud-gdb-completion-function #'gud-gdb-completions) - (local-set-key "\C-i" 'completion-at-point) + (local-set-key "\C-i" #'completion-at-point) (setq comint-prompt-regexp "^(.*gdb[+]?) *") (setq paragraph-start comint-prompt-regexp) (setq gdb-first-prompt t) @@ -984,6 +1037,18 @@ SKIP is the number of chars to skip on each line, it defaults to 0." (defvar gud-sdb-lastfile nil) +(defvar gud-sdb-repeat-map + (let ((map (make-sparse-keymap))) + (pcase-dolist (`(,key . ,cmd) '(("n" . gud-next) + ("s" . gud-step) + ("i" . gud-stepi) + ("c" . gud-cont) + ("l" . gud-refresh))) + (define-key map key cmd)) + map) + "Keymap to repeat `sdb' stepping instructions `C-x C-a C-n n n'. +Used in `repeat-mode'.") + (defun gud-sdb-marker-filter (string) (setq gud-marker-acc (if gud-marker-acc (concat gud-marker-acc string) string)) @@ -1054,6 +1119,8 @@ and source-file directory for your debugger." (gud-def gud-cont "c" "\C-r" "Continue with display.") (gud-def gud-print "%e/" "\C-p" "Evaluate C expression at point.") + (gud-set-repeat-map-property 'gud-sdb-repeat-map) + (setq comint-prompt-regexp "\\(^\\|\n\\)\\*") (setq paragraph-start comint-prompt-regexp) (run-hooks 'sdb-mode-hook) @@ -1074,8 +1141,7 @@ The file names should be absolute, or relative to the directory containing the executable being debugged." :type '(choice (const :tag "Current Directory" nil) (repeat :value ("") - directory)) - :group 'gud) + directory))) (defun gud-dbx-massage-args (_file args) (nconc (let ((directories gud-dbx-directories) @@ -1213,6 +1279,23 @@ whereby $stopformat=1 produces an output format compatible with ;; whereby `set $stopformat=1' reportedly produces output compatible ;; with `gud-dbx-marker-filter', which we prefer. +(defvar gud-dbx-repeat-map + (let ((map (make-sparse-keymap))) + (pcase-dolist (`(,key . ,cmd) '(("n" . gud-next) + ("s" . gud-step) + ("i" . gud-stepi) + ("c" . gud-cont) + ("l" . gud-refresh) + ("<" . gud-up) + (">" . gud-down))) + (define-key map key cmd)) + (when (or gud-mips-p + gud-irix-p) + (define-key map "f" 'gud-finish)) + map) + "Keymap to repeat `dbx' stepping instructions `C-x C-a C-n n n'. +Used in `repeat-mode'.") + ;; The process filter is also somewhat ;; unreliable, sometimes not spotting the markers; I don't know ;; whether there's anything that can be done about that.] @@ -1360,6 +1443,8 @@ and source-file directory for your debugger." (gud-def gud-print "print %e" "\C-p" "Evaluate C expression at point.") (gud-def gud-run "run" nil "Run the program.") + (gud-set-repeat-map-property 'gud-dbx-repeat-map) + (setq comint-prompt-regexp "^[^)\n]*dbx) *") (setq paragraph-start comint-prompt-regexp) (run-hooks 'dbx-mode-hook) @@ -1371,6 +1456,21 @@ and source-file directory for your debugger." ;; History of argument lists passed to xdb. (defvar gud-xdb-history nil) +(defvar gud-xdb-repeat-map + (let ((map (make-sparse-keymap))) + (pcase-dolist (`(,key . ,cmd) '(("n" . gud-next) + ("s" . gud-step) + ("i" . gud-stepi) + ("c" . gud-cont) + ("l" . gud-refresh) + ("f" . gud-finish) + ("<" . gud-up) + (">" . gud-down))) + (define-key map key cmd)) + map) + "Keymap to repeat `xdb' stepping instructions `C-x C-a C-n n n'. +Used in `repeat-mode'.") + (defcustom gud-xdb-directories nil "A list of directories that xdb should search for source code. If nil, only source files in the program directory @@ -1380,8 +1480,7 @@ The file names should be absolute, or relative to the directory containing the executable being debugged." :type '(choice (const :tag "Current Directory" nil) (repeat :value ("") - directory)) - :group 'gud) + directory))) (defun gud-xdb-massage-args (_file args) (nconc (let ((directories gud-xdb-directories) @@ -1437,6 +1536,8 @@ directories if your program contains sources from more than one directory." (gud-def gud-finish "bu\\t" "\C-f" "Finish executing current function.") (gud-def gud-print "p %e" "\C-p" "Evaluate C expression at point.") + (gud-set-repeat-map-property 'gud-xdb-repeat-map) + (setq comint-prompt-regexp "^>") (setq paragraph-start comint-prompt-regexp) (run-hooks 'xdb-mode-hook)) @@ -1447,6 +1548,17 @@ directories if your program contains sources from more than one directory." ;; History of argument lists passed to perldb. (defvar gud-perldb-history nil) +(defvar gud-perldb-repeat-map + (let ((map (make-sparse-keymap))) + (pcase-dolist (`(,key . ,cmd) '(("n" . gud-next) + ("s" . gud-step) + ("c" . gud-cont) + ("l" . gud-refresh))) + (define-key map key cmd)) + map) + "Keymap to repeat `perldb' stepping instructions `C-x C-a C-n n n'. +Used in `repeat-mode'.") + (defun gud-perldb-massage-args (_file args) "Convert a command line as would be typed normally to run perldb into one that invokes an Emacs-enabled debugging session. @@ -1563,8 +1675,7 @@ into one that invokes an Emacs-enabled debugging session. (defcustom gud-perldb-command-name "perl -d" "Default command to execute a Perl script under debugger." - :type 'string - :group 'gud) + :type 'string) ;;;###autoload (defun perldb (command-line) @@ -1590,6 +1701,7 @@ and source-file directory for your debugger." (gud-def gud-print "p %e" "\C-p" "Evaluate perl expression at point.") (gud-def gud-until "c %l" "\C-u" "Continue to current line.") + (gud-set-repeat-map-property 'gud-perldb-repeat-map) (setq comint-prompt-regexp "^ DB<+[0-9]+>+ ") (setq paragraph-start comint-prompt-regexp) @@ -1618,6 +1730,20 @@ and source-file directory for your debugger." (defvar gud-pdb-marker-regexp-start "^> ") +(defvar gud-pdb-repeat-map + (let ((map (make-sparse-keymap))) + (pcase-dolist (`(,key . ,cmd) '(("n" . gud-next) + ("s" . gud-step) + ("c" . gud-cont) + ("l" . gud-refresh) + ("f" . gud-finish) + ("<" . gud-up) + (">" . gud-down))) + (define-key map key cmd)) + map) + "Keymap to repeat `pdb' stepping instructions `C-x C-a C-n n n'. +Used in `repeat-mode'.") + ;; There's no guarantee that Emacs will hand the filter the entire ;; marker at once; it could be broken up across several strings. We ;; might even receive a big chunk with several markers in it. If we @@ -1677,8 +1803,7 @@ and source-file directory for your debugger." (if (executable-find "pdb") "pdb" "python -m pdb") "Command that executes the Python debugger." :version "27.1" - :type 'string - :group 'gud) + :type 'string) ;;;###autoload (defun pdb (command-line) @@ -1708,6 +1833,8 @@ directory and source-file directory for your debugger." (gud-def gud-print "p %e" "\C-p" "Evaluate Python expression at point.") (gud-def gud-statement "!%e" "\C-e" "Execute Python statement at point.") + (gud-set-repeat-map-property 'gud-pdb-repeat-map) + ;; (setq comint-prompt-regexp "^(.*pdb[+]?) *") (setq comint-prompt-regexp "^(Pdb) *") (setq paragraph-start comint-prompt-regexp) @@ -1721,6 +1848,19 @@ directory and source-file directory for your debugger." (defvar gud-guiler-lastfile nil) +(defvar gud-guiler-repeat-map + (let ((map (make-sparse-keymap))) + (pcase-dolist (`(,key . ,cmd) '(("n" . gud-next) + ("s" . gud-step) + ("l" . gud-refresh) + ("f" . gud-finish) + ("<" . gud-up) + (">" . gud-down))) + (define-key map key cmd)) + map) + "Keymap to repeat `guiler' stepping instructions `C-x C-a C-n n n'. +Used in `repeat-mode'.") + (defun gud-guiler-marker-filter (string) (setq gud-marker-acc (if gud-marker-acc (concat gud-marker-acc string) string)) @@ -1759,8 +1899,7 @@ directory and source-file directory for your debugger." "File name for executing the Guile debugger. This should be an executable on your path, or an absolute file name." :version "25.1" - :type 'string - :group 'gud) + :type 'string) ;;;###autoload (defun guiler (command-line) @@ -1787,6 +1926,8 @@ and source-file directory for your debugger." (gud-def gud-down ",down" ">" "Down one stack frame.") (gud-def gud-print "%e" "\C-p" "Evaluate Guile expression at point.") + (gud-set-repeat-map-property 'gud-guiler-repeat-map) + (setq comint-prompt-regexp "^scheme@([^>]+> ") (setq paragraph-start comint-prompt-regexp) (run-hooks 'guiler-mode-hook)) @@ -1883,8 +2024,7 @@ and source-file directory for your debugger." (defcustom gud-jdb-command-name "jdb" "Command that executes the Java debugger." - :type 'string - :group 'gud) + :type 'string) (defcustom gud-jdb-use-classpath t "If non-nil, search for Java source files in classpath directories. @@ -1899,8 +2039,7 @@ and parsing all Java files for class information. Set to nil to use `gud-jdb-directories' to scan java sources for class information on jdb startup (original method)." - :type 'boolean - :group 'gud) + :type 'boolean) (defvar gud-jdb-classpath nil "Java/jdb classpath directories list. @@ -2175,9 +2314,9 @@ extension EXTN. Normally EXTN is given as the regular expression (setq gud-jdb-analysis-buffer (get-buffer-create " *gud-jdb-scratch*")) (prog1 (apply - 'nconc + #'nconc (mapcar - 'gud-jdb-build-class-source-alist-for-file + #'gud-jdb-build-class-source-alist-for-file sources)) (kill-buffer gud-jdb-analysis-buffer) (setq gud-jdb-analysis-buffer nil))) @@ -2234,6 +2373,21 @@ extension EXTN. Normally EXTN is given as the regular expression ;; Note: Reset to this value every time a prompt is seen (defvar gud-jdb-lowest-stack-level 999) +(defvar gud-jdb-repeat-map + (let ((map (make-sparse-keymap))) + (pcase-dolist (`(,key . ,cmd) '(("n" . gud-next) + ("s" . gud-step) + ("i" . gud-stepi) + ("c" . gud-cont) + ("f" . gud-finish) + ("<" . gud-up) + (">" . gud-down) + ("l" . gud-refresh))) + (define-key map key cmd)) + map) + "Keymap to repeat `jdb' stepping instructions `C-x C-a C-n n n'. +Used in `repeat-mode'.") + (defun gud-jdb-find-source-using-classpath (p) "Find source file corresponding to fully qualified class P. Convert P from jdb's output, converted to a pathname @@ -2244,13 +2398,14 @@ relative to a classpath directory." ;; name relative to classpath (filename (concat - (mapconcat 'identity + (mapconcat #'identity (split-string ;; Eliminate any subclass references in the class ;; name string. These start with a "$" (if (string-match "\\$.*" p) (replace-match "" t t p) p) - "\\.") "/") + "\\.") + "/") ".java")) (cplist (append gud-jdb-sourcepath gud-jdb-classpath)) found-file) @@ -2272,7 +2427,7 @@ during jdb initialization depending on the value of "Parse the classpath list and convert each item to an absolute pathname." (mapcar (lambda (s) (if (string-match "[/\\]$" s) (replace-match "" nil nil s) s)) - (mapcar 'file-truename + (mapcar #'file-truename (split-string string (concat "[ \t\n\r,\"" path-separator "]+"))))) @@ -2441,6 +2596,8 @@ gud, see `gud-mode'." (gud-def gud-print "print %e" "\C-p" "Print value of expression at point.") (gud-def gud-pstar "dump %e" nil "Print all object information at point.") + (gud-set-repeat-map-property 'gud-jdb-repeat-map) + (setq comint-prompt-regexp "^> \\|^[^ ]+\\[[0-9]+\\] ") (setq paragraph-start comint-prompt-regexp) (run-hooks 'jdb-mode-hook) @@ -2451,7 +2608,7 @@ gud, see `gud-mode'." (if (string-match "-attach" command-line) (gud-call "classpath")) (fset 'gud-jdb-find-source - 'gud-jdb-find-source-using-classpath)) + #'gud-jdb-find-source-using-classpath)) ;; Else create and bind the class/source association list as well ;; as the source file list. @@ -2459,8 +2616,8 @@ gud, see `gud-mode'." (gud-jdb-build-class-source-alist (setq gud-jdb-source-files (gud-jdb-build-source-files-list gud-jdb-directories - "\\.java$")))) - (fset 'gud-jdb-find-source 'gud-jdb-find-source-file))) + "\\.java\\'")))) + (fset 'gud-jdb-find-source #'gud-jdb-find-source-file))) ;; ;; End of debugger-specific information @@ -2571,7 +2728,7 @@ Commands: \\{gud-mode-map}" (setq mode-line-process '(":%s")) - (define-key (current-local-map) "\C-c\C-l" 'gud-refresh) + (define-key (current-local-map) "\C-c\C-l" #'gud-refresh) (setq-local gud-last-frame nil) (if (boundp 'tool-bar-map) ; not --without-x (setq-local tool-bar-map gud-tool-bar-map)) @@ -2580,11 +2737,10 @@ Commands: (setq-local comint-input-ignoredups t) (make-local-variable 'paragraph-start) (setq-local gud-delete-prompt-marker (make-marker)) - (add-hook 'kill-buffer-hook 'gud-kill-buffer-hook nil t)) + (add-hook 'kill-buffer-hook #'gud-kill-buffer-hook nil t)) (defcustom gud-chdir-before-run t "Non-nil if GUD should `cd' to the debugged executable." - :group 'gud :type 'boolean) ;; Perform initializations common to all debuggers. @@ -2648,7 +2804,7 @@ Commands: (setq w (cdr w))) ;; Tramp has already been loaded if we are here. (if w (setcar w (setq file (file-local-name file))))) - (apply 'make-comint (concat "gud" filepart) program nil + (apply #'make-comint (concat "gud" filepart) program nil (if massage-args (funcall massage-args file args) args)) ;; Since comint clobbered the mode, we don't set it until now. (gud-mode) @@ -2658,8 +2814,8 @@ Commands: (if find-file (setq-local gud-find-file find-file)) (setq gud-last-last-frame nil) - (set-process-filter (get-buffer-process (current-buffer)) 'gud-filter) - (set-process-sentinel (get-buffer-process (current-buffer)) 'gud-sentinel) + (set-process-filter (get-buffer-process (current-buffer)) #'gud-filter) + (set-process-sentinel (get-buffer-process (current-buffer)) #'gud-sentinel) (gud-set-buffer)) (defun gud-set-buffer () @@ -2994,7 +3150,7 @@ Obeying it means displaying in another window the specified file and line." (buffer-substring (region-beginning) (region-end)) (apply gud-find-expr-function args)))) (save-match-data - (if (string-match "\n" expr) + (if (string-search "\n" expr) (error "Expression must not include a newline")) (with-current-buffer gud-comint-buffer (save-excursion @@ -3180,10 +3336,11 @@ class of the file (using s to separate nested class ids)." (while (and cplist (not class-found)) (if (string-match (car cplist) f) (setq class-found - (mapconcat 'identity + (mapconcat #'identity (split-string (substring f (+ (match-end 0) 1)) - "/") "."))) + "/") + "."))) (setq cplist (cdr cplist))) ;; if f is visited by a java(cc-mode) buffer, walk up the ;; syntactic information chain and collect any 'inclass @@ -3222,7 +3379,7 @@ class of the file (using s to separate nested class ids)." )) (string-match (concat (car nclass) "$") class-found) (setq class-found - (replace-match (mapconcat 'identity nclass "$") + (replace-match (mapconcat #'identity nclass "$") t t class-found))))) (if (not class-found) (message "gud-find-class: class for file %s not found!" f)) @@ -3356,7 +3513,7 @@ Treats actions as defuns." (setq-local outline-regexp "[ \t]") (setq-local imenu-generic-expression '((nil "^define[ \t]+\\(\\w+\\)" 1))) - (setq-local indent-line-function 'gdb-script-indent-line) + (setq-local indent-line-function #'gdb-script-indent-line) (setq-local beginning-of-defun-function #'gdb-script-beginning-of-defun) (setq-local end-of-defun-function @@ -3387,14 +3544,14 @@ Treats actions as defuns." (require 'tooltip) (if gud-tooltip-mode (progn - (add-hook 'change-major-mode-hook 'gud-tooltip-change-major-mode) - (add-hook 'pre-command-hook 'tooltip-hide) - (add-hook 'tooltip-functions 'gud-tooltip-tips) - (define-key global-map [mouse-movement] 'gud-tooltip-mouse-motion)) - (unless tooltip-mode (remove-hook 'pre-command-hook 'tooltip-hide) - (remove-hook 'change-major-mode-hook 'gud-tooltip-change-major-mode) - (remove-hook 'tooltip-functions 'gud-tooltip-tips) - (define-key global-map [mouse-movement] 'ignore))) + (add-hook 'change-major-mode-hook #'gud-tooltip-change-major-mode) + (add-hook 'pre-command-hook #'tooltip-hide) + (add-hook 'tooltip-functions #'gud-tooltip-tips) + (define-key global-map [mouse-movement] #'gud-tooltip-mouse-motion)) + (unless tooltip-mode (remove-hook 'pre-command-hook #'tooltip-hide) + (remove-hook 'change-major-mode-hook #'gud-tooltip-change-major-mode) + (remove-hook 'tooltip-functions #'gud-tooltip-tips) + (define-key global-map [mouse-movement] #'ignore))) (gud-tooltip-activate-mouse-motions-if-enabled) (if (and gud-comint-buffer (buffer-name gud-comint-buffer); gud-comint-buffer might be killed @@ -3411,15 +3568,14 @@ Treats actions as defuns." (make-local-variable 'gdb-define-alist) (gdb-create-define-alist) (add-hook 'after-save-hook - 'gdb-create-define-alist nil t)))))) + #'gdb-create-define-alist nil t)))))) (kill-local-variable 'gdb-define-alist) - (remove-hook 'after-save-hook 'gdb-create-define-alist t)))) + (remove-hook 'after-save-hook #'gdb-create-define-alist t)))) (defcustom gud-tooltip-modes '(gud-mode c-mode c++-mode fortran-mode python-mode) "List of modes for which to enable GUD tooltips." :type '(repeat (symbol :tag "Major mode")) - :group 'gud :group 'tooltip) (defcustom gud-tooltip-display @@ -3431,13 +3587,11 @@ Forms in the list are combined with AND. The default is to display only tooltips in the buffer containing the overlay arrow." :type 'sexp :risky t - :group 'gud :group 'tooltip) (defcustom gud-tooltip-echo-area nil "Use the echo area instead of frames for GUD tooltips." :type 'boolean - :group 'gud :group 'tooltip) (make-obsolete-variable 'gud-tooltip-echo-area @@ -3447,12 +3601,12 @@ only tooltips in the buffer containing the overlay arrow." (defun gud-tooltip-change-major-mode () "Function added to `change-major-mode-hook' when tooltip mode is on." - (add-hook 'post-command-hook 'gud-tooltip-activate-mouse-motions-if-enabled)) + (add-hook 'post-command-hook #'gud-tooltip-activate-mouse-motions-if-enabled)) (defun gud-tooltip-activate-mouse-motions-if-enabled () "Reconsider for all buffers whether mouse motion events are desired." (remove-hook 'post-command-hook - 'gud-tooltip-activate-mouse-motions-if-enabled) + #'gud-tooltip-activate-mouse-motions-if-enabled) (dolist (buffer (buffer-list)) (with-current-buffer buffer (if (and gud-tooltip-mode @@ -3561,7 +3715,7 @@ This function must return nil if it doesn't handle EVENT." (posn-point (event-end event)) (or (and (eq gud-minor-mode 'gdbmi) (not gdb-active-process)) (progn (setq gud-tooltip-event event) - (eval (cons 'and gud-tooltip-display))))) + (eval (cons 'and gud-tooltip-display) t)))) (let ((expr (tooltip-expr-to-print event))) (when expr (if (and (eq gud-minor-mode 'gdbmi) @@ -3591,10 +3745,10 @@ so they have been disabled.")) (gdb-input (concat "server macro expand " expr "\n") - `(lambda () (gdb-tooltip-print-1 ,expr))) + (lambda () (gdb-tooltip-print-1 expr))) (gdb-input (concat cmd "\n") - `(lambda () (gdb-tooltip-print ,expr)))) + (lambda () (gdb-tooltip-print expr)))) (add-function :override (process-filter process) #'gud-tooltip-process-output) (gud-basic-call cmd)) diff --git a/lisp/progmodes/hideif.el b/lisp/progmodes/hideif.el index 923f85fd4dd..4a1da62c7e9 100644 --- a/lisp/progmodes/hideif.el +++ b/lisp/progmodes/hideif.el @@ -55,10 +55,10 @@ ;; Use M-x hide-ifdef-undef (C-c @ u) to undefine a symbol. ;; ;; If you define or undefine a symbol while hide-ifdef-mode is in effect, -;; the display will be updated. Only the define list for the current -;; buffer will be affected. You can save changes to the local define -;; list with hide-ifdef-set-define-alist. This adds entries -;; to hide-ifdef-define-alist. +;; the display will be updated. The global define list hide-ifdef-env +;; is affected accordingly. You can save changes to this globally define +;; list with hide-ifdef-set-define-alist. This adds entries to +;; hide-ifdef-define-alist. ;; ;; If you have defined a hide-ifdef-mode-hook, you can set ;; up a list of symbols that may be used by hide-ifdefs as in the @@ -68,10 +68,19 @@ ;; (lambda () ;; (unless hide-ifdef-define-alist ;; (setq hide-ifdef-define-alist -;; '((list1 ONE TWO) -;; (list2 TWO THREE)))) +;; '((list1 (ONE . 1) (TWO . 2)) +;; (list2 (TWO . 2) (THREE . 3))))) ;; (hide-ifdef-use-define-alist 'list2))) ; use list2 by default ;; +;; Currently recursive #include is not yet supported, a quick and reliable +;; way is to let the compiler generates all the #include-d defined macros +;; into a file, then open it in Emacs with hide-ifdefs (C-c @ h). +;; Take gcc and hello.c for example, hello.c #include-s <stdio.h>: +;; +;; $ gcc -dM -E hello.c -o hello.hh +;; +;; Then, open hello.hh and perform hide-ifdefs. +;; ;; You can call hide-ifdef-use-define-alist (C-c @ U) at any time to specify ;; another list to use. ;; @@ -99,7 +108,11 @@ ;; Extensively modified by Daniel LaLiberte (while at Gould). ;; ;; Extensively modified by Luke Lee in 2013 to support complete C expression -;; evaluation and argumented macro expansion. +;; evaluation and argumented macro expansion; C++11, C++14, C++17, GCC +;; extension literals and gcc/clang matching behaviours are supported in 2021. +;; Various floating point types and operations are also supported but the +;; actual precision is limited by the Emacs internal floating representation, +;; which is the C data type "double" or IEEE binary64 format. ;;; Code: @@ -136,7 +149,10 @@ :type '(choice (const nil) string) :version "25.1") -(defcustom hide-ifdef-expand-reinclusion-protection t +(define-obsolete-variable-alias 'hide-ifdef-expand-reinclusion-protection + 'hide-ifdef-expand-reinclusion-guard "28.1") + +(defcustom hide-ifdef-expand-reinclusion-guard 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: @@ -161,7 +177,7 @@ outermost #if is always visible." (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." +Effective only if `hide-ifdef-expand-reinclusion-guard' is t." :type 'regexp :version "25.1") @@ -195,6 +211,21 @@ Effective only if `hide-ifdef-expand-reinclusion-protection' is t." :type 'key-sequence :version "27.1") +(defcustom hide-ifdef-verbose nil + "Show some defining symbols on hiding for a visible feedback." + :type 'boolean + :version "28.1") + +(defcustom hide-ifdef-evalulate-enter-hook nil + "Hook function to be called when entering `hif-evaluate-macro'." + :type 'hook + :version "28.1") + +(defcustom hide-ifdef-evalulate-leave-hook nil + "Hook function to be called when leaving `hif-evaluate-macro'." + :type 'hook + :version "28.1") + (defvar hide-ifdef-mode-map ;; Set up the mode's main map, which leads via the prefix key to the submap. (let ((map (make-sparse-keymap))) @@ -306,9 +337,9 @@ Several variables affect how the hiding is done: ;; (default-value 'hide-ifdef-env)) (setq 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. - (setq-local hide-ifdef-expand-reinclusion-protection - (default-value 'hide-ifdef-expand-reinclusion-protection)) + ;; thus would like `hide-ifdef-expand-reinclusion-guard' to be nil. + (setq-local hide-ifdef-expand-reinclusion-guard + (default-value 'hide-ifdef-expand-reinclusion-guard)) (setq-local hide-ifdef-hiding (default-value 'hide-ifdef-hiding)) (setq-local hif-outside-read-only buffer-read-only) @@ -330,23 +361,42 @@ Several variables affect how the hiding is done: (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." +prevent accidental clearance. +When prefixed, it swaps current symbols with the backup ones." (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." - (interactive) - (hif-show-ifdef-region (point-min) (point-max))) + (if current-prefix-arg + (if hide-ifdef-env-backup + (when (y-or-n-p (format + "Restore all %d #defined symbols just cleared? " + (length hide-ifdef-env-backup))) + (let ((tmp hide-ifdef-env-backup)) + (setq hide-ifdef-env hide-ifdef-env-backup) + (setq hide-ifdef-env-backup tmp)) + (message "Backup symbols restored.")) + (message "No backup symbol to restore.")) + (when (y-or-n-p (format "Clear all %d #defined symbols? " + (length hide-ifdef-env))) + (if hide-ifdef-env ;; backup only if not empty + (setq hide-ifdef-env-backup hide-ifdef-env)) + (setq hide-ifdef-env nil) + (message "All defined symbols cleared." )))) + +(defun hif-show-all (&optional start end) + "Show all of the text in the current buffer. +If there is a marked region from START to END it only shows the symbols within." + (interactive + (if (use-region-p) + (list (region-beginning) (region-end)) + (list (point-min) (point-max)))) + (hif-show-ifdef-region + (or start (point-min)) (or end (point-max)))) ;; By putting this on after-revert-hook, we arrange that it only ;; does anything when revert-buffer avoids turning off the mode. ;; (That can happen in VC.) (defun hif-after-revert-function () (and hide-ifdef-mode hide-ifdef-hiding - (hide-ifdefs t))) + (hide-ifdefs nil nil t))) (add-hook 'after-revert-hook 'hif-after-revert-function) (defun hif-end-of-line () @@ -427,9 +477,17 @@ Everything including these lines is made invisible." ;;===%%SF%% evaluation (Start) === +(defun hif-eval (form) + "Evaluate hideif internal representation." + (let ((val (eval form))) + (if (stringp val) + (or (get-text-property 0 'hif-value val) + val) + val))) + ;; It is not useful to set this to anything but `eval'. ;; In fact, the variable might as well be eliminated. -(defvar hide-ifdef-evaluator 'eval +(defvar hide-ifdef-evaluator #'hif-eval "The function to use to evaluate a form. The evaluator is given a canonical form and returns t if text under that form should be displayed.") @@ -442,23 +500,42 @@ that form should be displayed.") "Prepend (VAR VALUE) pair to `hide-ifdef-env'." (setq hide-ifdef-env (cons (cons var value) hide-ifdef-env))) +(defconst hif-predefine-alist + '((__LINE__ . hif-__LINE__) + (__FILE__ . hif-__FILE__) + (__COUNTER__ . hif-__COUNTER__) + (__cplusplus . hif-__cplusplus) + (__DATE__ . hif-__DATE__) + (__TIME__ . hif-__TIME__) + (__STDC__ . hif-__STDC__) + (__STDC_VERSION__ . hif-__STDC_VERSION__) + (__STDC_HOST__ . hif-__STDC_HOST__) + (__BASE_FILE__ . hif-__FILE__))) + (declare-function semantic-c-hideif-lookup "semantic/bovine/c" (var)) (declare-function semantic-c-hideif-defined "semantic/bovine/c" (var)) (defun hif-lookup (var) (or (when (bound-and-true-p semantic-c-takeover-hideif) (semantic-c-hideif-lookup var)) - (let ((val (assoc var hide-ifdef-env))) + (let ((val (assq var hide-ifdef-env))) (if val (cdr val) - hif-undefined-symbol)))) + (if (setq val (assq var hif-predefine-alist)) + (funcall (cdr val)) + hif-undefined-symbol))))) (defun hif-defined (var) - (cond - ((bound-and-true-p semantic-c-takeover-hideif) - (semantic-c-hideif-defined var)) - ((assoc var hide-ifdef-env) 1) - (t 0))) + (let (def) + (cond + ((bound-and-true-p semantic-c-takeover-hideif) + (semantic-c-hideif-defined var)) + ;; Here we can't use hif-lookup as an empty definition like `#define EMPTY' + ;; is considered defined but is evaluated as `nil'. + ((assq var hide-ifdef-env) 1) + ((and (setq def (assq var hif-predefine-alist)) + (funcall (cdr def))) 1) + (t 0)))) ;;===%%SF%% evaluation (End) === @@ -484,7 +561,7 @@ that form should be displayed.") (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 + (concat hif-white-regexp "\\(" hif-id-regexp "\\)" "\\(" "(" hif-white-regexp "\\(" hif-id-regexp "\\)?" hif-white-regexp @@ -493,6 +570,75 @@ that form should be displayed.") ")" "\\)?" )) +;; The point here is *NOT* to do "syntax error checking" for C(++) compiler, but +;; to parse and recognize *already valid* numeric literals. Therefore we don't +;; need to worry if number like "0x12'" is invalid, leave it to the compiler. +;; Otherwise, the runtime performance of hideif would be poor. +;; +;; GCC fixed-point literal extension: +;; +;; ‘ullk’ or ‘ULLK’ for unsigned long long _Accum and _Sat unsigned long long _Accum +;; ‘ullr’ or ‘ULLR’ for unsigned long long _Fract and _Sat unsigned long long _Fract +;; +;; ‘llk’ or ‘LLK’ for long long _Accum and _Sat long long _Accum +;; ‘llr’ or ‘LLR’ for long long _Fract and _Sat long long _Fract +;; ‘uhk’ or ‘UHK’ for unsigned short _Accum and _Sat unsigned short _Accum +;; ‘ulk’ or ‘ULK’ for unsigned long _Accum and _Sat unsigned long _Accum +;; ‘uhr’ or ‘UHR’ for unsigned short _Fract and _Sat unsigned short _Fract +;; ‘ulr’ or ‘ULR’ for unsigned long _Fract and _Sat unsigned long _Fract +;; +;; ‘lk’ or ‘LK’ for long _Accum and _Sat long _Accum +;; ‘lr’ or ‘LR’ for long _Fract and _Sat long _Fract +;; ‘uk’ or ‘UK’ for unsigned _Accum and _Sat unsigned _Accum +;; ‘ur’ or ‘UR’ for unsigned _Fract and _Sat unsigned _Fract +;; ‘hk’ or ‘HK’ for short _Accum and _Sat short _Accum +;; ‘hr’ or ‘HR’ for short _Fract and _Sat short _Fract +;; +;; ‘r’ or ‘R’ for _Fract and _Sat _Fract +;; ‘k’ or ‘K’ for _Accum and _Sat _Accum + +;; C++14 also include '0b' for binary and "'" as separator +(defconst hif-numtype-suffix-regexp + ;; "\\(ll[uU]\\|LL[uU]\\|[uU]?ll\\|[uU]?LL\\|[lL][uU]\\|[uU][lL]\\|[uUlLfF]\\)" + (concat + "\\(\\(ll[uU]\\|LL[uU]\\|[uU]?ll\\|[uU]?LL\\|[lL][uU]\\|[uU][lL]\\|" + "[uU][hH]\\)[kKrR]?\\|" ; GCC fixed-point extension + "[dD][dDfFlL]\\|" ; GCC floating-point extension + "[uUlLfF]\\)")) +(defconst hif-bin-regexp + (concat "[+-]?0[bB]\\([01']+\\)" + hif-numtype-suffix-regexp "?")) +(defconst hif-hex-regexp + (concat "[+-]?0[xX]\\([[:xdigit:]']+\\)" + hif-numtype-suffix-regexp "?")) +(defconst hif-oct-regexp + (concat "[+-]?0[0-7']+" + hif-numtype-suffix-regexp "?")) +(defconst hif-dec-regexp + (concat "[+-]?\\(0\\|[1-9][0-9']*\\)" + hif-numtype-suffix-regexp "?")) + +(defconst hif-decfloat-regexp + ;; `hif-string-to-decfloat' relies on the number and ordering of parentheses + (concat + "\\(?:" + "\\([+-]?[0-9]+\\)\\([eE][+-]?[0-9]+\\)?[dD]?[fFlL]?" + "\\|\\([+-]?[0-9]+\\)\\.\\([eE][+-]?[0-9]+\\)?[dD]?[dDfFlL]?" + "\\|\\([+-]?[0-9]*\\.[0-9]+\\)\\([eE][+-]?[0-9]+\\)?[dD]?[dDfFlL]?" + "\\)")) + +;; C++17 hexadecimal floating point literal +(defconst hif-hexfloat-regexp + ;; `hif-string-to-hexfloat' relies on the ordering of regexp groupings + (concat + "[+-]?\\(?:" + "0[xX]\\([[:xdigit:]']+\\)[pP]\\([+-]?[0-9']+\\)[fFlL]?" + "\\|" + "0[xX]\\([[:xdigit:]']+\\)\\.[pP]\\([+-]?[0-9']+\\)[fFlL]?" + "\\|" + "0[xX]\\([[:xdigit:]']*\\)\\.\\([[:xdigit:]']+\\)[pP]\\([+-]?[0-9']+\\)[fFlL]?" + "\\)")) + ;; Store the current token and the whole token list during parsing. ;; Bound dynamically. (defvar hif-token) @@ -530,29 +676,113 @@ that form should be displayed.") (":" . hif-colon) ("," . hif-comma) ("#" . hif-stringify) - ("..." . hif-etc))) + ("..." . hif-etc) + ("defined" . hif-defined))) (defconst hif-valid-token-list (mapcar 'cdr hif-token-alist)) (defconst hif-token-regexp - (concat (regexp-opt (mapcar 'car hif-token-alist)) - "\\|0x[[:xdigit:]]+\\.?[[:xdigit:]]*" - "\\|[0-9]+\\.?[0-9]*" ;; decimal/octal - "\\|\\w+")) - -(defconst hif-string-literal-regexp "\\(\"\\(?:[^\"\\]\\|\\\\.\\)*\"\\)") + ;; The ordering of regexp grouping is crutial to `hif-strtok' + (concat + ;; hex/binary: + "\\([+-]?0[xXbB]\\([[:xdigit:]']+\\)?\\.?\\([[:xdigit:]']+\\)?\\([pP]\\([+-]?[0-9]+\\)\\)?" + hif-numtype-suffix-regexp "?\\)" + ;; decimal/octal: + "\\|\\(\\([+-]?[0-9']+\\(\\.[0-9']*\\)?\\)\\([eE][+-]?[0-9]+\\)?" + hif-numtype-suffix-regexp "?\\)" + "\\|" (regexp-opt (mapcar 'car hif-token-alist) t) + "\\|\\(\\w+\\)")) + +;; C++11 Unicode string literals (L"" u8"" u"" U"" R"" LR"" u8R"" uR"") +(defconst hif-unicode-prefix-regexp "\\(?:u8R?\\|[uUL]R?\\|R\\)") +(defconst hif-string-literal-regexp + (concat hif-unicode-prefix-regexp "?" + "\\(\"\\(?:[^\"\\]\\|\\\\.\\)*\"\\)")) + +;; matching and conversion + +(defun hif-full-match (regexp string) + "A full REGEXP match of STRING instead of partially match." + (string-match (concat "\\`" regexp "\\'") string)) + +(defun hif-is-number (string) + "Check if STRING is a valid C(++) numeric literal." + (or (hif-full-match hif-dec-regexp string) + (hif-full-match hif-hex-regexp string) + (hif-full-match hif-oct-regexp string) + (hif-full-match hif-bin-regexp string))) + +(defun hif-is-float (string) + "Check if STRING is a valid C(++) floating point literal." + (or (hif-full-match hif-decfloat-regexp string) + (hif-full-match hif-hexfloat-regexp string))) + +(defun hif-delete-char-in-string (char string) + "Delete CHAR in STRING inplace." + (let ((i (length string)) + (s nil)) + (while (> i 0) + (setq i (1- i)) + (unless (eq (aref string i) char) + (setq s (cons (aref string i) s)))) + (concat s))) + +(defun hif-string-to-decfloat (string &optional fix exp) + "Convert a C(++) decimal floating formatted string into float. +Assuming we've just regexp-matched with `hif-decfloat-regexp' and it matched. +if REMATCH is t, do a rematch." + ;; In elisp `(string-to-number "01.e2")' will return 1 instead of the expected + ;; 100.0; therefore we need to write our own. + ;; This function relies on the regexp groups of `hif-dexfloat-regexp' + (if (or fix exp) + (setq fix (hif-delete-char-in-string ?' fix) + exp (hif-delete-char-in-string ?' exp)) + ;; rematch + (setq string (hif-delete-char-in-string ?' string)) + (hif-full-match hif-decfloat-regexp string) + (setq fix (or (match-string 1 string) + (match-string 3 string) + (match-string 5 string)) + exp (or (match-string 2 string) + (match-string 4 string) + (match-string 6 string)))) + (setq fix (string-to-number fix) + exp (if (zerop (length exp)) ;; nil or "" + 0 (string-to-number (substring-no-properties exp 1)))) + (* fix (expt 10 exp))) + +(defun hif-string-to-hexfloat (string &optional int fra exp) + "Convert a C++17 hex float formatted string into float. +Assuming we've just regexp-matched with `hif-hexfloat-regexp' and it matched. +if REMATCH is t, do a rematch." + ;; This function relies on the regexp groups of `hif-hexfloat-regexp' + (let ((negate (if (eq ?- (aref string 0)) -1.0 1.0))) + (if (or int fra exp) + (setq int (hif-delete-char-in-string ?' int) + fra (hif-delete-char-in-string ?' fra) + exp (hif-delete-char-in-string ?' exp)) + (setq string (hif-delete-char-in-string ?' string)) + (hif-full-match hif-hexfloat-regexp string) + (setq int (or (match-string 1 string) + (match-string 3 string) + (match-string 5 string)) + fra (or (match-string 2 string) + (match-string 4 string) + (match-string 6 string)) + exp (match-string 7 string))) + (setq int (if (zerop (length int)) ;; nil or "" + 0 (string-to-number int 16)) + fra (if (zerop (length fra)) + 0 (/ (string-to-number fra 16) + (expt 16.0 (length fra)))) + exp (if (zerop (length exp)) + 0 (string-to-number exp))) + (* negate (+ int fra) (expt 2.0 exp)))) (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)))) + "Like `string-to-number', but it understands C(++) literals." + (setq string (hif-delete-char-in-string ?' string)) + (string-to-number string base)) ;; 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' @@ -562,52 +792,204 @@ that form should be displayed.") ;; Check the long comments before `hif-find-define' for more details. [lukelee] (defvar hif-simple-token-only) +(defsubst hif-is-white (c) + (memq c '(? ?\t ?\n ?\r))) + +(defun hif-strtok (string &optional rematch) + "Convert STRING into a hideif mode internal token. +Assuming we've just performed a `hif-token-regexp' lookup." + ;; This function relies on the regexp groups of `hif-token-regexp' + ;; New hideif internal number representation: a text string with `hif-value' + ;; property to keep its value. Strings without `hif-value' property is a + ;; normal C(++) string. This is mainly for stringification. The original + ;; implementation only keep the value thus a C++ number like octal 01234 + ;; will become "668" after being stringified instead of the expected "01234". + (let (bufstr m1 m3 m5 m6 m8 neg ch val dec) + (when rematch + (string-match hif-token-regexp string) + (setq bufstr string)) + + (cond + + ;; decimal/octal + ((match-string 8 bufstr) + (setq m6 (match-string 9 bufstr)) + (setq val + (if (or (setq m8 (match-string 11 bufstr)) + (match-string 10 bufstr)) ;; floating + ;; TODO: do we need to add 'hif-type property for + ;; type-checking, but this will slow things down + (hif-string-to-decfloat string m6 m8) + (setq ch (aref string 0)) + (hif-string-to-number + string + ;; octal begin with `0' + (if (and (> (length string) 1) + (or (eq ch ?0) + ;; -0... or +0... + (and (memq ch '(?- ?+)) + (eq (aref string 1) ?0)))) + 8 (setq dec 10))))) + ;; Decimal integer without sign and extension is identical to its + ;; string form, make it as simple as possible + (if (and dec + (null (match-string 12 bufstr)) ;; no extension like 'UL' + (not (memq ch '(?- ?+)))) + val + (add-text-properties 0 1 (list 'hif-value val) string) + string)) + + ;; hex/binary + ((match-string 1 bufstr) + (setq m3 (match-string 3 bufstr)) + (add-text-properties + 0 1 + (list 'hif-value + (if (or (setq m5 (match-string 5 bufstr)) + m3) + (hif-string-to-hexfloat + string + (match-string 2 bufstr) m3 m5) ;; hexfloat + (setq neg (if (eq (aref string 0) ?-) -1 1)) + (* neg + (hif-string-to-number + ;; (5-(-1))/2=3; (5-1)/2=2 + (substring-no-properties string (ash (- 5 neg) -1)) + ;; (3-(-1))/2=2; (3-1)/2=1 + (if (or (eq (setq ch (aref string (ash (- 3 neg) -1))) ?x) + (eq ch ?X)) ;; hex + 16 2))))) + string) string) + + ;; operator + ((setq m1 (match-string 14 bufstr)) + (cdr (assoc m1 hif-token-alist #'string-equal))) + + (t + (setq hif-simple-token-only nil) + (intern-safe string))))) + +(defun hif-backward-comment (&optional start end) + "If we're currently within a C(++) comment, skip them backwards." + ;; Ignore trailing white spaces after comment + (setq end (or end (point))) + (while (and (> (1- end) 1) + (hif-is-white (char-after (1- end)))) + (cl-decf end)) + (let ((p0 end) + p cmt ce ws we ;; ce:comment start, ws:white start, we whilte end + cmtlist) ;; pair of (start.end) of comments + (setq start (or start (progn (beginning-of-line) (point))) + p start) + (while (< (1+ p) end) + (if (char-equal ?/ (char-after p)) ; / + (if (char-equal ?/ (char-after (1+ p))) ; // + (progn + ;; merge whites immediately ahead + (setq ce (if (and we (= (1- p) we)) ws p)) + ;; scan for end of line + (while (and (< (cl-incf p) end) + (not (char-equal ?\n (char-after p))) + (not (char-equal ?\r (char-after p))))) + ;; Merge with previous comment if immediately followed + (push (cons (if (and cmtlist + (= (cdr (car cmtlist)) ce)) + (car (pop cmtlist)) ;; extend previous comment + ce) + p) + cmtlist)) + (when (char-equal ?* (char-after (1+ p))) ; /* + ;; merge whites immediately ahead + (setq ce (if (and we (= (1- p) we)) ws p)) + ;; Check if it immediately follows previous /*...*/ comment; + ;; if yes, extend and merge into previous comment + (setq cmt (if (and cmtlist + (= (cdr (car cmtlist)) ce)) + (car (pop cmtlist)) ;; extend previous comment + ce)) + (setq p (+ 2 p)) + ;; Scanning for `*/' + (catch 'break + (while (< (1+ p) end) + (if (not (and (char-equal ?* (char-after p)) + (char-equal ?/ (char-after (1+ p))))) + (cl-incf p) + ;; found `*/', mark end pos + (push (cons cmt (1+ (setq p (1+ p)))) cmtlist) + (throw 'break nil))) + ;; (1+ p) >= end + (push (cons cmt end) cmtlist)))) + ;; Trace most recent continuous white spaces before a comment + (if (char-equal ? (char-after p)) + (if (and ws (= we (1- p))) ;; continued + (setq we p) + (setq ws p + we p)) + (setq ws nil + we nil))) + (cl-incf p)) + ;; Goto beginning of the last comment, if we're within + (setq cmt (car cmtlist)) ;; last cmt + (setq cmt (if (and cmt + (>= p0 (car cmt)) + (<= p0 (cdr cmt))) + (car cmt) ;; beginning of the last comment + p0)) + ;; Ignore leading whites ahead of comment + (while (and (> (1- cmt) 1) + (hif-is-white (char-after (1- cmt)))) + (cl-decf cmt)) + (goto-char cmt))) + (defun hif-tokenize (start end) "Separate string between START and END into a list of tokens." - (let ((token-list nil)) + (let ((token-list nil) + (white-regexp "[ \t]+") + token) (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)) - - ((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-no-properties - (point) (match-end 0)))) + (save-restriction + ;; Narrow down to the focusing region so that the ending white spaces + ;; of that line will not be treated as a white, as `looking-at' won't + ;; look outside the restriction; otherwise it will note the last token + ;; or string as one with an `hif-space' property. + (setq end (hif-backward-comment start end)) + (narrow-to-region start end) + (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) + (setq token (substring-no-properties (match-string 1))) + (goto-char (match-end 0)) + (when (looking-at white-regexp) + (add-text-properties 0 1 '(hif-space t) token) + (goto-char (match-end 0))) + (push token token-list)) + + ((looking-at hif-token-regexp) (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 (like 1.23e4) - ;; 3. 098 is interpreted as octal conversion error - (if (string-match "0x\\([[:xdigit:]]+\\.?[[:xdigit:]]*\\)" - token) - (hif-string-to-number (match-string 1 token) 16)) ;; hex - (if (string-match "\\`0[0-9]+\\(\\.[0-9]+\\)?\\'" token) - (hif-string-to-number token 8)) ;; octal - (if (string-match "\\`[1-9][0-9]*\\(\\.[0-9]+\\)?\\'" - token) - (string-to-number token)) ;; decimal - (prog1 (intern token) - (setq hif-simple-token-only nil))) - token-list))) - - ((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))) + (setq token (hif-strtok + (substring-no-properties (match-string 0)))) + (push token token-list) + (when (looking-at white-regexp) + ;; We can't just append a space to the token string, otherwise + ;; `0xf0 ' ## `01' will become `0xf0 01' instead of the expected + ;; `0xf001', hence a standalone `hif-space' is placed instead. + (push 'hif-space token-list) + (goto-char (match-end 0)))) + + ((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))))))) + (if (eq 'hif-space (car token-list)) + (setq token-list (cdr token-list))) ;; remove trailing white space + (nreverse token-list)))) ;;------------------------------------------------------------------------ ;; Translate C preprocessor #if expressions using recursive descent. @@ -637,50 +1019,96 @@ that form should be displayed.") ;; | | ^= = | | ;; | Comma | , | left-to-right | -(defsubst hif-nexttoken () +(defun hif-nexttoken (&optional keep-space) "Pop the next token from token-list into the let variable `hif-token'." - (setq hif-token (pop hif-token-list))) + (let ((prevtoken hif-token)) + (while (progn + (setq hif-token (pop hif-token-list)) + (if keep-space ; keep only one space + (and (eq prevtoken 'hif-space) + (eq hif-token 'hif-space)) + (eq hif-token 'hif-space))))) + hif-token) + +(defun hif-split-signed-token () + "Split current numeric token into two (hif-plus/minus num)." + (let* (val ch0 head) + (when (and (stringp hif-token) + (setq val (get-text-property 0 'hif-value hif-token)) + ;; explicitly signed? + (memq (setq ch0 (aref hif-token 0)) '(?+ ?-))) + (if (eq ch0 ?+) + (setq head 'hif-plus) + (setq head 'hif-minus + val (- val))) + (setq hif-token (substring hif-token 1)) + (add-text-properties 0 1 (list 'hif-value val) hif-token) + (push hif-token hif-token-list) + (setq hif-token head)))) (defsubst hif-if-valid-identifier-p (id) (not (or (numberp id) - (stringp id)))) + (stringp id) + (and (atom id) + (eq 'defined 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 (nth 2 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))) + (if (memq 'hif-defined tokens) + (let* ((hif-token-list tokens) + hif-token + target + paren) + (setq tokens nil) ;; now it becomes the result + (while (hif-nexttoken t) ;; keep `hif-space' + (when (eq hif-token 'hif-defined) + ;; defined XXX, start ignoring `hif-space' + (hif-nexttoken) + (if (setq paren (eq hif-token 'hif-lparen)) + (hif-nexttoken)) + (if (not (hif-if-valid-identifier-p + (setq target hif-token))) + (error "`defined' followed by non-identifier: %S" target)) + (if (and paren + (not (eq (hif-nexttoken) 'hif-rparen))) + (error "missing right parenthesis for `defined'")) + (setq hif-token + (list 'hif-defined 'hif-lparen target 'hif-rparen))) + (push hif-token tokens)) + (nreverse tokens)) + tokens)) (define-obsolete-function-alias 'hif-flatten #'flatten-tree "27.1") -(defun hif-expand-token-list (tokens &optional macroname expand_list) +(defun hif-keep-single (l e) + "Prevent two or more consecutive E in list L." + (if (memq e l) + (let (prev curr result) + (while (progn + (setq prev curr + curr (car l) + l (cdr l)) + curr) + (unless (and (eq prev e) + (eq curr e)) + (push curr result))) + (nreverse result)) + l)) + +(defun hif-expand-token-list (tokens &optional macroname expand_list level) "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." +detecting self-reference. +Function-like macros with calling depth LEVEL 0 does not expand arguments, +this is to emulate the stringification behavior of C++ preprocessor." (catch 'self-referencing (let ((expanded nil) (remains (hif-define-operator (hif-token-concatenation (hif-token-stringification tokens)))) tok rep) + (setq level (if level level 0)) (if macroname (setq expand_list (cons macroname expand_list))) ;; Expanding all tokens till list exhausted @@ -699,21 +1127,31 @@ detecting self-reference." (if (and (listp rep) (eq (car rep) 'hif-define-macro)) ; A defined macro ;; Recursively expand it + ;; only in defined macro do we increase the nesting LEVEL (if (cadr rep) ; Argument list is not nil - (if (not (eq (car remains) 'hif-lparen)) + (if (not (or (eq (car remains) 'hif-lparen) + ;; hif-space hif-lparen + (and (eq (car remains) 'hif-space) + (eq (cadr remains) 'hif-lparen) + (setq remains (cdr remains))))) ;; 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 + ;; 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))) + (parmlist + (if (zerop level) + (hif-get-argument-list t) + (mapcar (lambda (a) + (hif-expand-token-list + a nil nil (1+ level))) + (hif-get-argument-list t)))) (result (hif-expand-token-list (hif-macro-supply-arguments tok parmlist) - tok expand_list))) + tok expand_list (1+ level)))) (setq remains (cons hif-token hif-token-list)) result)) ;; Argument list is nil, direct expansion @@ -745,16 +1183,20 @@ detecting self-reference." "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))) + (let ((hif-token-list (hif-expand-token-list token-list macroname nil)) + (hif-token nil)) (hif-nexttoken) (prog1 (and hif-token (hif-exprlist)) (if hif-token ; is there still a token? - (error "Error: unexpected token: %s" hif-token))))) + (error "Error: unexpected token at line %d: `%s'" + (line-number-at-pos) + (or (car (rassq hif-token hif-token-alist)) + 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))) @@ -824,7 +1266,7 @@ expr : or-expr | or-expr `?' expr `:' expr." (defun hif-eq-expr () "Parse an eq-expr : comp | eq-expr `=='|`!=' comp." (let ((result (hif-comp-expr)) - (eq-token nil)) + (eq-token nil)) (while (memq hif-token '(hif-equal hif-notequal)) (setq eq-token hif-token) (hif-nexttoken) @@ -857,7 +1299,9 @@ expr : or-expr | or-expr `?' expr `:' expr." math : muldiv | math `+'|`-' muldiv." (let ((result (hif-muldiv-expr)) (math-op nil)) - (while (memq hif-token '(hif-plus hif-minus)) + (while (or (memq hif-token '(hif-plus hif-minus)) + ;; One token lookahead + (hif-split-signed-token)) (setq math-op hif-token) (hif-nexttoken) (setq result (list math-op result (hif-muldiv-expr)))) @@ -876,7 +1320,7 @@ expr : or-expr | or-expr `?' expr `:' expr." (defun hif-factor () "Parse a factor. -factor : `!' factor | `~' factor | `(' expr `)' | `defined(' id `)' | +factor : `!' factor | `~' factor | `(' exprlist `)' | `defined(' id `)' | id `(' parmlist `)' | strings | id." (cond ((eq hif-token 'hif-not) @@ -908,10 +1352,14 @@ factor : `!' factor | `~' factor | `(' expr `)' | `defined(' id `)' | (hif-nexttoken) `(hif-defined (quote ,ident)))) + ((stringp hif-token) + (if (get-text-property 0 'hif-value hif-token) + ;; new hideif internal number format for string concatenation + (prog1 hif-token (hif-nexttoken)) + (hif-string-concatenation))) + ((numberp hif-token) (prog1 hif-token (hif-nexttoken))) - ((stringp hif-token) - (hif-string-concatenation)) ;; Unary plus/minus. ((memq hif-token '(hif-minus hif-plus)) @@ -924,12 +1372,12 @@ factor : `!' factor | `~' factor | `(' expr `)' | `defined(' id `)' | (hif-place-macro-invocation ident) `(hif-lookup (quote ,ident))))))) -(defun hif-get-argument-list () +(defun hif-get-argument-list (&optional keep-space) (let ((nest 0) (parmlist nil) ; A "token" list of parameters, will later be parsed (parm nil)) - (while (or (not (eq (hif-nexttoken) 'hif-rparen)) + (while (or (not (eq (hif-nexttoken keep-space) 'hif-rparen)) (/= nest 0)) (if (eq (car (last parm)) 'hif-comma) (setq parm nil)) @@ -945,7 +1393,7 @@ factor : `!' factor | `~' factor | `(' expr `)' | `defined(' id `)' | (push hif-token parm)) (push (nreverse parm) parmlist) ; Okay even if PARM is nil - (hif-nexttoken) ; Drop the `hif-rparen', get next token + (hif-nexttoken keep-space) ; Drop the `hif-rparen', get next token (nreverse parmlist))) (defun hif-place-macro-invocation (ident) @@ -973,10 +1421,21 @@ This macro cannot be evaluated alone without parameters input." (cond ((numberp a) (number-to-string a)) - ((atom a) - (symbol-name a)) ((stringp a) - (concat "\"" a "\"")) + ;; Remove properties here otherwise a string like "0x12 + 0x34" will be + ;; later evaluated as (0x12 + 0x34) and become 0x70. + ;; See also `hif-eval' and `hif-mathify'. + (concat (substring-no-properties a) + (if (get-text-property 0 'hif-space a) " "))) + ((atom a) + (if (memq a hif-valid-token-list) + (car (rassq a hif-token-alist)) + (if (eq a 'hif-space) + " " + (symbol-name a)))) + ((listp a) ;; stringify each element then concat + (cl-loop for e in a + concat (hif-stringify e))) (t (error "Invalid token to stringify")))) @@ -984,32 +1443,34 @@ This macro cannot be evaluated alone without parameters input." (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-token-concat (l) + "Concatenate a list of tokens into a longer token. +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 `+='...)." + (let ((str nil)) + (dolist (i l) + ;;(assert (not (eq i 'hif-space)) nil ;; debug + ;; "Internal error: should not be concatenating `hif-space'") + (setq str + (concat str + (if (memq i hif-valid-token-list) + (car (rassq i hif-token-alist)) + (hif-stringify i))))) + ;; Check if it's a number, if yes, return the number instead of a symbol. + ;; 'hif-value and 'hif-space properties are trimmed off by `hif-stringify' + (hif-strtok str t))) (defun hif-mathify (val) - "Treat VAL as a number: if it's t or nil, use 1 or 0." - (cond ((eq val t) 1) - ((null val) 0) - (t val))) + "Treat VAL as a hideif number: if it's t or nil, use 1 or 0." + (cond + ((stringp val) + (or (get-text-property 0 'hif-value val) + val)) + ((eq val t) 1) + ((null val) 0) + (t val))) (defun hif-conditional (a b c) (if (not (zerop (hif-mathify a))) (hif-mathify b) (hif-mathify c))) @@ -1053,49 +1514,108 @@ preprocessing token" (defalias 'hif-logxor (hif-mathify-binop logxor)) (defalias 'hif-logand (hif-mathify-binop logand)) +(defun hif-__LINE__ () + (line-number-at-pos)) + +(defun hif-__FILE__ () + (file-name-nondirectory (buffer-file-name))) + +(defvar hif-__COUNTER__ 0) +(defun hif-__COUNTER__ () + (prog1 hif-__COUNTER__ (cl-incf hif-__COUNTER__))) + +(defun hif-__cplusplus () + (and (string-match + "\\.c\\(c\\|xx\\|pp\\|\\+\\+\\)\\'" + (buffer-file-name)) + (memq major-mode '(c++-mode cc-mode cpp-mode)) + 201710)) + +(defun hif-__DATE__ () + (format-time-string "%Y/%m/%d")) + +(defun hif-__TIME__ () + (format-time-string "%H:%M:%S")) + +(defun hif-__STDC__ () 1) +(defun hif-__STDC_VERSION__ () 201710) +(defun hif-__STDC_HOST__ () 1) (defun hif-comma (&rest expr) "Evaluate a list of EXPR, return the result of the last item." (let ((result nil)) - (dolist (e expr) + (dolist (e expr result) (ignore-errors - (setq result (funcall hide-ifdef-evaluator e)))) - result)) + (setq result (funcall hide-ifdef-evaluator e)))))) (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))) + "Scan token list for `hif-stringify' (`#') token and stringify the next token." + (if (memq 'hif-stringify l) + (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)) + ;; no `#' presents + l)) (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))) + "Scan token list for `hif-token-concat' ('##') token and concatenate tokens." + (if (memq 'hif-token-concat l) + ;; Notice that after some substitutions, there could be more than + ;; one `hif-space' in a list. + (let ((items nil) + (tk nil) + (count 0) ; count of `##' + result) + (setq l (hif-keep-single l 'hif-space)) + (while (setq tk (car l)) + (if (not (eq tk 'hif-token-concat)) + ;; In reverse order so that we don't have to use `last' or + ;; `butlast' + (progn + (push tk result) + (setq l (cdr l))) + ;; First `##' met, start `##' sequence + ;; We only drop `hif-space' when doing token concatenation + (setq items nil + count 0) + (setq tk (pop result)) + (if (or (null tk) + (and (eq tk 'hif-space) + (null (setq tk (pop result))))) + (error "No token before `##' to concatenate") + (push tk items) ; first item, in reverse order + (setq tk 'hif-token-concat)) + (while (eq tk 'hif-token-concat) + (cl-incf count) + ;; 2+ item + (setq l (cdr l) + tk (car l)) + ;; only one 'hif-space could appear here + (if (eq tk 'hif-space) ; ignore it + (setq l (cdr l) + tk (car l))) + (if (or (null tk) + (eq tk 'hif-token-concat)) + (error + "No token after the %d-th `##' to concatenate at line %d" + count (line-number-at-pos)) + (push tk items) + (setq l (cdr l) + tk (car l)))) + ;; `##' sequence ended, concat them, then push into result + (push (hif-token-concat (nreverse items)) result))) + (nreverse result)) + ;; no need to reassemble the list if no `##' presents + l)) (defun hif-delimit (lis atom) (nconc (mapcan (lambda (l) (list l atom)) @@ -1105,7 +1625,7 @@ preprocessing token" ;; 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)) + (let* ((SA (assq macro-name hide-ifdef-env)) (macro (and SA (cdr SA) (eq (cadr SA) 'hif-define-macro) @@ -1156,11 +1676,14 @@ preprocessing token" formal macro-body)) (setq actual-parms (cdr actual-parms))) - ;; Replacement completed, flatten the whole token list - (setq macro-body (flatten-tree macro-body)) + ;; Replacement completed, stringifiy and concatenate the token list. + ;; Stringification happens must take place before flattening, otherwise + ;; only the first token will be stringified. + (setq macro-body + (flatten-tree (hif-token-stringification macro-body))) - ;; Stringification and token concatenation happens here - (hif-token-concatenation (hif-token-stringification macro-body))))) + ;; Token concatenation happens here, keep single 'hif-space + (hif-keep-single (hif-token-concatenation macro-body) 'hif-space)))) (defun hif-invoke (macro-name actual-parms) "Invoke a macro by expanding it, reparse macro-body and finally invoke it." @@ -1432,7 +1955,7 @@ Point is left unchanged." ;; A bit slimy. (defun hif-hide-line (point) - "Hide the line containing point. + "Hide the line containing POINT. Does nothing if `hide-ifdef-lines' is nil." (when hide-ifdef-lines (save-excursion @@ -1441,7 +1964,7 @@ Does nothing if `hide-ifdef-lines' is nil." (line-beginning-position) (progn (hif-end-of-line) (point)))))) -;; Hif-Possibly-Hide +;; 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 @@ -1484,7 +2007,7 @@ Does nothing if `hide-ifdef-lines' is nil." "Called at #ifX expression, this hides those parts that should be hidden. 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." +Refer to `hide-ifdef-expand-reinclusion-guard' for more details." ;; (message "hif-possibly-hide") (sit-for 1) (let* ((case-fold-search nil) (test (hif-canonicalize hif-ifx-regexp)) @@ -1564,23 +2087,83 @@ Refer to `hide-ifdef-expand-reinclusion-protection' for more details." (result (funcall hide-ifdef-evaluator expr))) result)) +(defun hif-display-macro (name def &optional result) + (if (and def + (listp def) + (eq (car def) 'hif-define-macro)) + (let ((cdef (concat "#define " name)) + (parmlist (cadr def)) + s) + (setq def (caddr def)) + ;; parmlist + (when parmlist + (setq cdef (concat cdef "(")) + (while (car parmlist) + (setq cdef (concat cdef (symbol-name (car parmlist)) + (if (cdr parmlist) ",")) + parmlist (cdr parmlist))) + (setq cdef (concat cdef ")"))) + (setq cdef (concat cdef " ")) + ;; body + (while def + (if (listp def) + (setq s (car def) + def (cdr def)) + (setq s def + def nil)) + (setq cdef + (concat cdef + (cond + ;;((setq tok (car (rassoc s hif-token-alist))) + ;; (concat tok (if (eq s 'hif-comma) " "))) + ((symbolp s) + (concat (hif-stringify s) + (if (eq s 'hif-comma) " "))) + ((stringp s) + (hif-stringify s)) + (t ;; (numberp s) + (format "%S" s)))))) + (if (and result + ;; eg: "#define RECURSIVE_SYMBOL RECURSIVE_SYMBOL" + (not (and (listp result) + (eq (car result) 'hif-define-macro)))) + (setq cdef (concat cdef + (if (integerp result) + (format "\n=> %S (%#x)" result result) + (format "\n=> %S" result))))) + (message "%s" cdef)) + (message "%S <= `%s'" def name))) + (defun hif-evaluate-macro (rstart rend) "Evaluate the macro expansion result for the active region. -If no region active, find the current #ifdefs and evaluate the result. +If no region is currently active, find the current #ifdef/#define and evaluate +the result; otherwise it looks for current word at point. Currently it supports only math calculations, strings or argumented macros can -not be expanded." +not be expanded. +This function by default ignores parsing error and return `false' on evaluating +runtime C(++) statements or tokens that normal C(++) preprocessor can't perform; +however, when this command is prefixed, it will display the error instead." (interactive - (if (use-region-p) - (list (region-beginning) (region-end)) - '(nil nil))) - (let ((case-fold-search nil)) + (if (not (use-region-p)) + '(nil nil) + (list (region-beginning) (region-end)))) + (run-hooks 'hide-ifdef-evalulate-enter-hook) + (let ((case-fold-search nil) + (currpnt (point)) + bounds) (save-excursion (unless (use-region-p) (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))) + (if (and (re-search-forward hif-macro-expr-prefix-regexp nil t) + (= (line-number-at-pos currpnt) (line-number-at-pos))) + (if (string= "define" (match-string 2)) + (re-search-forward hif-macroref-regexp nil t)) + (goto-char currpnt) + (setq bounds (bounds-of-thing-at-point 'word) + ;; TODO: BOUNDS need a C++ syntax word boundary finder + rstart (car bounds) + rend (cdr bounds)))) (let* ((start (or rstart (point))) (end (or rend (progn (hif-end-of-line) (point)))) (defined nil) @@ -1588,34 +2171,61 @@ not be expanded." (tokens (ignore-errors ; Prevent C statement things like ; 'do { ... } while (0)' (hif-tokenize start end))) + ;; Note that on evaluating we can't simply define the symbol + ;; even if we are currently at a #define line, as this #define + ;; might actually be wrapped up in a #if 0 block. We can only + ;; define that explicitly with `hide-ifdef-define'. (expr (or (and (<= (length tokens) 1) ; Simple token - (setq defined (assoc (car tokens) hide-ifdef-env)) + (setq defined + (or (assq (car tokens) hide-ifdef-env) + (assq (car tokens) hif-predefine-alist))) (setq simple (atom (hif-lookup (car tokens)))) (hif-lookup (car tokens))) (and tokens - (condition-case nil + (condition-case err (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 (%#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))) + ;; when prefixed, pass the error on for later + ;; `hide-ifdef-evaluator' + (if current-prefix-arg err)))))) + (exprstring (hif-stringify tokens)) + (result (condition-case err + (funcall hide-ifdef-evaluator expr) + ;; in case of arithmetic error or others + (error (error "Error: line %d %S when evaluating `%s'" + (line-number-at-pos) err exprstring))))) + (setq + result + (cond + ((= (length tokens) 0) + (message "`%s'" exprstring)) + ((= (length tokens) 1) ; Simple token + (if simple + (if defined + (hif-display-macro exprstring result) + (if (and (hif-is-number exprstring) + result (numberp result)) + (message "%S (%#x)" result result) + (if (and (hif-is-float exprstring) + result (numberp result)) + (message "%S (%s)" result exprstring) + (if (string-match hif-string-literal-regexp exprstring) + (message "%s" exprstring) + (message "`%s' is not defined" exprstring))))) + (if defined + (hif-display-macro exprstring (cdr defined) result) + (message "`%s' is not defined" exprstring)))) + ((integerp result) + (if (or (= 0 result) (= 1 result)) + (message "%S <= `%s'" result exprstring) + (message "%S (%#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)))) + (run-hooks 'hide-ifdef-evalulate-leave-hook) result)))) (defun hif-parse-macro-arglist (str) @@ -1667,6 +2277,8 @@ first arg will be `hif-etc'." ;; the performance I use this `hif-simple-token-only' to notify my code and ;; save the final [value] into symbol database. [lukelee] +(defvar hif-verbose-define-count 0) + (defun hif-find-define (&optional min max) "Parse texts and retrieve all defines within the region MIN and MAX." (interactive) @@ -1676,8 +2288,11 @@ first arg will be `hif-etc'." (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))))) + (parmlist (or (and (match-string 3) ; First arg id found + (delq 'hif-space + (hif-parse-macro-arglist (match-string 2)))) + (and (match-string 2) ; empty arglist + (list nil))))) (if defining ;; Ignore name (still need to return 't), or define the name (or (and hide-ifdef-exclude-define-regexp @@ -1689,6 +2304,14 @@ first arg will be `hif-etc'." (hif-simple-token-only nil) ; Dynamic binding (tokens (and name + (prog1 t + (cl-incf hif-verbose-define-count) + ;; only show 1/50 to not slow down to much + (if (and hide-ifdef-verbose + (= (% hif-verbose-define-count 50) 1)) + (message "[Line %d] defining %S" + (line-number-at-pos (point)) + (substring-no-properties name)))) ;; `hif-simple-token-only' is set/clear ;; only in this block (condition-case nil @@ -1700,8 +2323,10 @@ first arg will be `hif-etc'." ;; this will stop hideif from searching ;; for more #defines. (setq hif-simple-token-only t) - (buffer-substring-no-properties - start end))))) + (replace-regexp-in-string + "^[ \t]*\\|[ \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 @@ -1715,17 +2340,19 @@ first arg will be `hif-etc'." `(hif-define-macro ,parmlist ,tokens)))) (SA (and name - (assoc (intern name) hide-ifdef-env)))) + (assq (intern name) hide-ifdef-env)))) (and name (if SA (or (setcdr SA expr) t) - ;; Lazy evaluation, eval only if hif-lookup find it. + ;; 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)))))) + (intern-soft name) + (hif-undefine-symbol (intern name))) + t))) t)) @@ -1735,7 +2362,10 @@ first arg will be `hif-etc'." (save-excursion (save-restriction ;; (mark-region min max) ;; for debugging + (setq hif-verbose-define-count 0) + (forward-comment (point-max)) (while (hif-find-define min max) + (forward-comment (point-max)) (setf min (point))) (if max (goto-char max) (goto-char (point-max)))))) @@ -1743,24 +2373,33 @@ first arg will be `hif-etc'." (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 (let* ((case-fold-search t) ; Ignore case for `hide-ifdef-header-regexp' - (expand-header (and hide-ifdef-expand-reinclusion-protection + (expand-header (and hide-ifdef-expand-reinclusion-guard + (buffer-file-name) (string-match hide-ifdef-header-regexp (buffer-file-name)) (zerop hif-recurse-level))) (case-fold-search nil) min max) + (setq hif-__COUNTER__ 0) (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)))) + ;; Without this `condition-case' it would be easier to see which + ;; operation went wrong thru the backtrace `iff' user realize + ;; the underlying meaning of all hif-* operation; for example, + ;; `hif-shiftleft' refers to C(++) '<<' operator and floating + ;; operation arguments would be invalid. + (condition-case err + (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) + (error (error "Error: failed at line %d %S" + (line-number-at-pos) err)))))) ;;===%%SF%% hide-ifdef-hiding (End) === @@ -1821,13 +2460,17 @@ This allows #ifdef VAR to be hidden." 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))) + (if hide-ifdef-hiding (hide-ifdefs)) + (message "%s set to %s" var (or val 1))) (defun hif-undefine-symbol (var) - (setq hide-ifdef-env - (delete (assoc var hide-ifdef-env) hide-ifdef-env))) + (when (assq var hide-ifdef-env) + (setq hide-ifdef-env + (delete (assq var hide-ifdef-env) hide-ifdef-env)) + ;; We can override things in `hif-predefine-alist' so keep them + (unless (assq var hif-predefine-alist) + (unintern (symbol-name var) nil)) + t)) (defun hide-ifdef-undef (start end) "Undefine a VAR so that #ifdef VAR would not be included." @@ -1848,35 +2491,54 @@ This allows #ifdef VAR to be hidden." (if hide-ifdef-hiding (hide-ifdefs)) (message "`%S' undefined" sym)))) -(defun hide-ifdefs (&optional nomsg) +(defun hide-ifdefs (&optional start end 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. +Hiding will only be performed within the marked region if there is one. + Turn off hiding by calling `show-ifdefs'." - (interactive) - (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 () + (interactive + (if (use-region-p) + (list (region-beginning) (region-end)) + (list (point-min) (point-max)))) + + (setq current-prefix-arg (or hide-ifdef-lines current-prefix-arg)) + (save-restriction + (let* ((hide-ifdef-lines current-prefix-arg) + (outer-hide-ifdef-verbose hide-ifdef-verbose) + (hide-ifdef-verbose (and outer-hide-ifdef-verbose + (not (or nomsg (use-region-p))))) + (hide-start-time (current-time))) + (and hide-ifdef-verbose + (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) + (narrow-to-region (or start (point-min)) (or end (point-max))) + (hide-ifdef-guts) + (setq buffer-read-only + (or hide-ifdef-read-only hif-outside-read-only)) + (and hide-ifdef-verbose + (message "Hiding done, %.1f seconds elapsed" + (float-time (time-subtract (current-time) + hide-start-time))))))) + + +(defun show-ifdefs (&optional start end) "Cancel the effects of `hide-ifdef': show the contents of all #ifdefs." - (interactive) + (interactive + (if (use-region-p) + (list (region-beginning) (region-end)) + (list (point-min) (point-max)))) (setq buffer-read-only hif-outside-read-only) - (hif-show-all) + (hif-show-all (or start (point-min)) (or end (point-max))) (setq hide-ifdef-hiding nil)) @@ -1960,21 +2622,17 @@ With optional prefix argument ARG, also hide the #ifdefs themselves." ;;; definition alist support +;; The old implementation that match symbol only to 't is now considered +;; obsolete. (defvar hide-ifdef-define-alist nil "A global assoc list of pre-defined symbol lists.") -(defun hif-compress-define-list (env) - "Compress the define list ENV into a list of defined symbols only." - (let ((new-defs nil)) - (dolist (def env new-defs) - (if (hif-lookup (car def)) (push (car def) new-defs))))) - (defun hide-ifdef-set-define-alist (name) "Set the association for NAME to `hide-ifdef-env'." (interactive "SSet define list: ") - (push (cons name (hif-compress-define-list hide-ifdef-env)) - hide-ifdef-define-alist)) + (push (cons name hide-ifdef-env) + hide-ifdef-define-alist)) (defun hide-ifdef-use-define-alist (name) "Set `hide-ifdef-env' to the define list specified by NAME." @@ -1986,9 +2644,8 @@ With optional prefix argument ARG, also hide the #ifdefs themselves." (if (stringp name) (setq name (intern name))) (let ((define-list (assoc name hide-ifdef-define-alist))) (if define-list - (setq hide-ifdef-env - (mapcar (lambda (arg) (cons arg t)) - (cdr define-list))) + (setq hide-ifdef-env + (cdr define-list)) (error "No define list for %s" name)) (if hide-ifdef-hiding (hide-ifdefs)))) diff --git a/lisp/progmodes/hideshow.el b/lisp/progmodes/hideshow.el index 73d09e00591..b2557587c6c 100644 --- a/lisp/progmodes/hideshow.el +++ b/lisp/progmodes/hideshow.el @@ -232,13 +232,11 @@ (defcustom hs-hide-comments-when-hiding-all t "Hide the comments too when you do an `hs-hide-all'." - :type 'boolean - :group 'hideshow) + :type 'boolean) (defcustom hs-minor-mode-hook nil "Hook called when hideshow minor mode is activated or deactivated." :type 'hook - :group 'hideshow :version "21.1") (defcustom hs-isearch-open 'code @@ -254,8 +252,7 @@ This has effect only if `search-invisible' is set to `open'." :type '(choice (const :tag "open only code blocks" code) (const :tag "open only comment blocks" comment) (const :tag "open both code and comment blocks" t) - (const :tag "don't open any of them" nil)) - :group 'hideshow) + (const :tag "don't open any of them" nil))) ;;;###autoload (defvar hs-special-modes-alist @@ -313,7 +310,7 @@ a block), `hs-hide-all', `hs-hide-block' and `hs-hide-level'.") These commands include the toggling commands (when the result is to show a block), `hs-show-all' and `hs-show-block'.") -(defvar hs-set-up-overlay #'ignore +(defcustom hs-set-up-overlay #'ignore "Function called with one arg, OV, a newly initialized overlay. Hideshow puts a unique overlay on each range of text to be hidden in the buffer. Here is a simple example of how to use this variable: @@ -329,7 +326,9 @@ in the buffer. Here is a simple example of how to use this variable: This example shows how to get information from the overlay as well as how to set its `display' property. See `hs-make-overlay' and -info node `(elisp)Overlays'.") +info node `(elisp)Overlays'." + :type 'function + :version "28.1") ;;--------------------------------------------------------------------------- ;; internal variables diff --git a/lisp/progmodes/icon.el b/lisp/progmodes/icon.el index 933cb333dfb..e9a21d4a0cf 100644 --- a/lisp/progmodes/icon.el +++ b/lisp/progmodes/icon.el @@ -1,4 +1,4 @@ -;;; icon.el --- mode for editing Icon code +;;; icon.el --- mode for editing Icon code -*- lexical-binding: t -*- ;; Copyright (C) 1989, 2001-2021 Free Software Foundation, Inc. @@ -31,53 +31,48 @@ "Abbrev table in use in Icon-mode buffers.") (define-abbrev-table 'icon-mode-abbrev-table ()) -(defvar icon-mode-map () - "Keymap used in Icon mode.") -(if icon-mode-map - () +(defvar icon-mode-map (let ((map (make-sparse-keymap "Icon"))) - (setq icon-mode-map (make-sparse-keymap)) - (define-key icon-mode-map "{" 'electric-icon-brace) - (define-key icon-mode-map "}" 'electric-icon-brace) - (define-key icon-mode-map "\e\C-h" 'mark-icon-function) - (define-key icon-mode-map "\e\C-a" 'beginning-of-icon-defun) - (define-key icon-mode-map "\e\C-e" 'end-of-icon-defun) - (define-key icon-mode-map "\e\C-q" 'indent-icon-exp) - (define-key icon-mode-map "\177" 'backward-delete-char-untabify) - - (define-key icon-mode-map [menu-bar] (make-sparse-keymap "Icon")) - (define-key icon-mode-map [menu-bar icon] - (cons "Icon" map)) - (define-key map [beginning-of-icon-defun] '("Beginning of function" . beginning-of-icon-defun)) - (define-key map [end-of-icon-defun] '("End of function" . end-of-icon-defun)) - (define-key map [comment-region] '("Comment Out Region" . comment-region)) - (define-key map [indent-region] '("Indent Region" . indent-region)) - (define-key map [indent-line] '("Indent Line" . icon-indent-command)) - (put 'eval-region 'menu-enable 'mark-active) - (put 'comment-region 'menu-enable 'mark-active) - (put 'indent-region 'menu-enable 'mark-active))) - -(defvar icon-mode-syntax-table nil - "Syntax table in use in Icon-mode buffers.") + (define-key map "{" 'electric-icon-brace) + (define-key map "}" 'electric-icon-brace) + (define-key map "\e\C-h" 'mark-icon-function) + (define-key map "\e\C-a" 'beginning-of-icon-defun) + (define-key map "\e\C-e" 'end-of-icon-defun) + (define-key map "\e\C-q" 'indent-icon-exp) + (define-key map "\177" 'backward-delete-char-untabify) + map) + "Keymap used in Icon mode.") -(if icon-mode-syntax-table - () - (setq icon-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?\\ "\\" icon-mode-syntax-table) - (modify-syntax-entry ?# "<" icon-mode-syntax-table) - (modify-syntax-entry ?\n ">" icon-mode-syntax-table) - (modify-syntax-entry ?$ "." icon-mode-syntax-table) - (modify-syntax-entry ?/ "." icon-mode-syntax-table) - (modify-syntax-entry ?* "." icon-mode-syntax-table) - (modify-syntax-entry ?+ "." icon-mode-syntax-table) - (modify-syntax-entry ?- "." icon-mode-syntax-table) - (modify-syntax-entry ?= "." icon-mode-syntax-table) - (modify-syntax-entry ?% "." icon-mode-syntax-table) - (modify-syntax-entry ?< "." icon-mode-syntax-table) - (modify-syntax-entry ?> "." icon-mode-syntax-table) - (modify-syntax-entry ?& "." icon-mode-syntax-table) - (modify-syntax-entry ?| "." icon-mode-syntax-table) - (modify-syntax-entry ?\' "\"" icon-mode-syntax-table)) +(easy-menu-define icon-mode-menu icon-mode-map + "Menu for Icon mode." + '("Icon" + ["Beginning of function" beginning-of-icon-defun] + ["Comment Out Region" comment-region + :enable mark-active] + ["End of function" end-of-icon-defun] + ["Indent Line" icon-indent-command] + ["Indent Region" indent-region + :enable mark-active])) + +(defvar icon-mode-syntax-table + (let ((table (make-syntax-table))) + (modify-syntax-entry ?\\ "\\" table) + (modify-syntax-entry ?# "<" table) + (modify-syntax-entry ?\n ">" 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) + (modify-syntax-entry ?> "." table) + (modify-syntax-entry ?& "." table) + (modify-syntax-entry ?| "." table) + (modify-syntax-entry ?\' "\"" table) + table) + "Syntax table in use in Icon-mode buffers.") (defgroup icon nil "Mode for editing Icon code." @@ -86,42 +81,35 @@ (defcustom icon-indent-level 4 "Indentation of Icon statements with respect to containing block." - :type 'integer - :group 'icon) + :type 'integer) (defcustom icon-brace-imaginary-offset 0 "Imagined indentation of an Icon open brace that actually follows a statement." - :type 'integer - :group 'icon) + :type 'integer) (defcustom icon-brace-offset 0 "Extra indentation for braces, compared with other text in same context." - :type 'integer - :group 'icon) + :type 'integer) (defcustom icon-continued-statement-offset 4 "Extra indent for Icon lines not starting new statements." - :type 'integer - :group 'icon) + :type 'integer) (defcustom icon-continued-brace-offset 0 "Extra indent for Icon substatements that start with open-braces. This is in addition to `icon-continued-statement-offset'." - :type 'integer - :group 'icon) + :type 'integer) (defcustom icon-auto-newline nil "Non-nil means automatically newline before and after braces Icon code. This applies when braces are inserted." - :type 'boolean - :group 'icon) + :type 'boolean) (defcustom icon-tab-always-indent t "Non-nil means TAB in Icon mode should always reindent the current line. It will then reindent, regardless of where in the line point is when the TAB command is used." - :type 'boolean - :group 'icon) + :type 'boolean) (defvar icon-imenu-generic-expression '((nil "^[ \t]*procedure[ \t]+\\(\\sw+\\)[ \t]*(" 1)) @@ -209,12 +197,11 @@ with no args, if that value is non-nil." (progn (insert last-command-event) (icon-indent-line) - (if icon-auto-newline - (progn - (newline) - ;; (newline) may have done auto-fill - (setq insertpos (- (point) 2)) - (icon-indent-line))) + (when icon-auto-newline + (newline) + ;; (newline) may have done auto-fill + (setq insertpos (- (point) 2)) + (icon-indent-line)) (save-excursion (if insertpos (goto-char (1+ insertpos))) (delete-char -1)))) diff --git a/lisp/progmodes/idlw-complete-structtag.el b/lisp/progmodes/idlw-complete-structtag.el index 25bc5ad881b..6d2d402e358 100644 --- a/lisp/progmodes/idlw-complete-structtag.el +++ b/lisp/progmodes/idlw-complete-structtag.el @@ -1,4 +1,4 @@ -;;; idlw-complete-structtag.el --- Completion of structure tags. +;;; idlw-complete-structtag.el --- Completion of structure tags. -*- lexical-binding: t; -*- ;; Copyright (C) 2001-2021 Free Software Foundation, Inc. @@ -100,12 +100,11 @@ (defvar idlwave-sint-structtags nil) ;; Create the sintern type for structure talks -(declare-function idlwave-sintern-structtag "idlw-complete-structtag" t t) -(idlwave-new-sintern-type 'structtag) +(idlwave-new-sintern-type structtag) ;; Hook the plugin into idlwave -(add-to-list 'idlwave-complete-special 'idlwave-complete-structure-tag) -(add-hook 'idlwave-update-rinfo-hook 'idlwave-structtag-reset) +(add-hook 'idlwave-complete-functions #'idlwave-complete-structure-tag) +(add-hook 'idlwave-update-rinfo-hook #'idlwave-structtag-reset) ;;; The main code follows below (defvar idlwave-completion-help-info) diff --git a/lisp/progmodes/idlw-help.el b/lisp/progmodes/idlw-help.el index 2e7b0aa7ef1..c53b9a4775c 100644 --- a/lisp/progmodes/idlw-help.el +++ b/lisp/progmodes/idlw-help.el @@ -1,4 +1,4 @@ -;;; idlw-help.el --- HTML Help code for IDLWAVE +;;; idlw-help.el --- HTML Help code for IDLWAVE -*- lexical-binding: t; -*- ;; Copyright (C) 2000-2021 Free Software Foundation, Inc. ;; @@ -50,7 +50,6 @@ (defcustom idlwave-html-help-pre-v6 nil "Whether pre or post-v6.0 IDL help documents are being used." - :group 'idlwave-online-help :type 'boolean) (defvar idlwave-html-link-sep @@ -60,7 +59,6 @@ "The directory, relative to `idlwave-system-directory', where the IDL HTML help files live, for IDL 6.2 and later. This location, if found, is used in preference to the old `idlwave-html-help-location'." - :group 'idlwave-online-help :type 'directory) (defcustom idlwave-html-help-location @@ -69,7 +67,6 @@ is used in preference to the old `idlwave-html-help-location'." "/usr/local/etc/") "The directory where the idl_html_help/ dir lives. Obsolete for IDL 6.2 or later (see `idlwave-html-system-help-location')." - :group 'idlwave-online-help :type 'directory) (defvar idlwave-help-use-hh nil @@ -77,18 +74,15 @@ is used in preference to the old `idlwave-html-help-location'." (defcustom idlwave-help-use-assistant t "Whether to use the IDL Assistant as the help browser." - :group 'idlwave-online-help :type 'boolean) (defcustom idlwave-help-browser-function browse-url-browser-function "Function to use to display HTML help. Defaults to `browse-url-browser-function', which see." - :group 'idlwave-online-help :type 'function) (defcustom idlwave-help-browser-generic-program browse-url-generic-program "Program to run if using `browse-url-generic-program'." - :group 'idlwave-online-help :type '(choice (const nil) string)) ;; AFAICS, never used since it was introduced in 2004. @@ -96,7 +90,6 @@ Defaults to `browse-url-browser-function', which see." (if (boundp 'browse-url-generic-args) browse-url-generic-args "") "Program args to use if using `browse-url-generic-program'." - :group 'idlwave-online-help :type '(repeat string)) (defcustom idlwave-help-browser-is-local nil @@ -106,7 +99,6 @@ external programs. If the browser name contains \"-w3\", it is assumed to be local to Emacs. For other local browsers, this variable must be explicitly set non-nil in order for the variable `idlwave-help-use-dedicated-frame' to function." - :group 'idlwave-online-help :type 'boolean) (defvar idlwave-help-directory "" @@ -114,7 +106,6 @@ must be explicitly set non-nil in order for the variable (defcustom idlwave-help-use-dedicated-frame t "Non-nil means, use a separate frame for Online Help if possible." - :group 'idlwave-online-help :type 'boolean) (defcustom idlwave-help-frame-parameters @@ -123,14 +114,12 @@ must be explicitly set non-nil in order for the variable See also `idlwave-help-use-dedicated-frame'. If you do not set the frame width here, the value specified in `idlw-help.el' will be used." - :group 'idlwave-online-help :type '(repeat (cons symbol sexp))) (defcustom idlwave-max-popup-menu-items 20 "Maximum number of items per pane in popup menus. Currently only used for class selection during completion help." - :group 'idlwave-online-help :type 'integer) (defcustom idlwave-extra-help-function 'idlwave-help-with-source @@ -158,12 +147,10 @@ The default value for this function is `idlwave-help-with-source' which loads the routine source file into the help buffer. If you try to write a different function which accesses a special help file or so, it is probably a good idea to still call this function as a fallback." - :group 'idlwave-online-help :type 'symbol) (defcustom idlwave-help-fontify-source-code nil "Non-nil means, fontify source code displayed as help like normal code." - :group 'idlwave-online-help :type 'boolean) (defcustom idlwave-help-source-try-header t @@ -173,7 +160,6 @@ help text. When this variable is non-nil, we try to find a description of the help item in the first routine doclib header above the routine definition. If the variable is nil, or if we cannot find/parse the header, the routine definition is displayed instead." - :group 'idlwave-online-help :type 'boolean) @@ -181,20 +167,17 @@ definition is displayed instead." "A regexp for the heading word to search for in doclib headers which specifies the `name' section. Can be used for localization support." - :group 'idlwave-online-help :type 'regexp) (defcustom idlwave-help-doclib-keyword "KEYWORD" "A regexp for the heading word to search for in doclib headers which specifies the `keywords' section. Can be used for localization support." - :group 'idlwave-online-help :type 'regexp) (defface idlwave-help-link '((t :inherit link)) - "Face for highlighting links into IDLWAVE online help." - :group 'idlwave-online-help) + "Face for highlighting links into IDLWAVE online help.") (defvar idlwave-help-activate-links-aggressively nil "Obsolete variable.") @@ -219,20 +202,20 @@ support." (defvar idlwave-help-mode-map (let ((map (make-sparse-keymap))) - (define-key map "q" 'idlwave-help-quit) - (define-key map "w" 'widen) + (define-key map "q" #'idlwave-help-quit) + (define-key map "w" #'widen) (define-key map "\C-m" (lambda (arg) (interactive "p") (scroll-up arg))) - (define-key map " " 'scroll-up-command) - (define-key map [?\S-\ ] 'scroll-down-command) - (define-key map [delete] 'scroll-down-command) - (define-key map "h" 'idlwave-help-find-header) - (define-key map "H" 'idlwave-help-find-first-header) - (define-key map "." 'idlwave-help-toggle-header-match-and-def) - (define-key map "F" 'idlwave-help-fontify) - (define-key map "\M-?" 'idlwave-help-return-to-calling-frame) - (define-key map "x" 'idlwave-help-return-to-calling-frame) + (define-key map " " #'scroll-up-command) + (define-key map [?\S-\ ] #'scroll-down-command) + (define-key map [delete] #'scroll-down-command) + (define-key map "h" #'idlwave-help-find-header) + (define-key map "H" #'idlwave-help-find-first-header) + (define-key map "." #'idlwave-help-toggle-header-match-and-def) + (define-key map "F" #'idlwave-help-fontify) + (define-key map "\M-?" #'idlwave-help-return-to-calling-frame) + (define-key map "x" #'idlwave-help-return-to-calling-frame) map) "The keymap used in `idlwave-help-mode'.") @@ -374,7 +357,7 @@ It collects and prints the diagnostics messages." (setq idlwave-last-context-help-pos marker) (idlwave-do-context-help1 arg) (if idlwave-help-diagnostics - (message "%s" (mapconcat 'identity + (message "%s" (mapconcat #'identity (nreverse idlwave-help-diagnostics) "; ")))))) @@ -384,6 +367,12 @@ It collects and prints the diagnostics messages." (defvar idlwave-system-variables-alist) (defvar idlwave-executive-commands-alist) (defvar idlwave-system-class-info) +(defvar idlwave-query-class) +(defvar idlwave-force-class-query) +(defvar idlw-help-name) +(defvar idlw-help-kwd) +(defvar idlw-help-link) + (defun idlwave-do-context-help1 (&optional arg) "The work-horse version of `idlwave-context-help', which see." (save-excursion @@ -506,7 +495,7 @@ It collects and prints the diagnostics messages." ((and (memq cw '(function-keyword procedure-keyword)) (stringp this-word) (string-match "\\S-" this-word) - (not (string-match "!" this-word))) + (not (string-search "!" this-word))) (cond ((or (= (char-before beg) ?/) (save-excursion (goto-char end) (looking-at "[ \t]*="))) @@ -549,16 +538,16 @@ It collects and prints the diagnostics messages." (setq mod1 (append (list t) module)))) (if mod3 (condition-case nil - (apply 'idlwave-online-help mod1) + (apply #'idlwave-online-help mod1) (error (condition-case nil - (apply 'idlwave-online-help mod2) - (error (apply 'idlwave-online-help mod3))))) + (apply #'idlwave-online-help mod2) + (error (apply #'idlwave-online-help mod3))))) (if mod2 (condition-case nil - (apply 'idlwave-online-help mod1) - (error (apply 'idlwave-online-help mod2))) + (apply #'idlwave-online-help mod1) + (error (apply #'idlwave-online-help mod2))) (if mod1 - (apply 'idlwave-online-help mod1) + (apply #'idlwave-online-help mod1) (error "Don't know which item to show help for"))))))) (defun idlwave-do-mouse-completion-help (ev) @@ -660,7 +649,7 @@ Those words in `idlwave-completion-help-links' have links. The (props (list 'face 'idlwave-help-link)) (info idlwave-completion-help-info) ; global passed in (what (nth 0 info)) ; what was completed, or a func - (class (nth 3 info)) ; any class + ;; (class (nth 3 info)) ; any class word beg end doit) (goto-char (point-min)) (re-search-forward "possible completions are:" nil t) @@ -685,7 +674,7 @@ Those words in `idlwave-completion-help-links' have links. The ;; Arrange for this function to be called after completion (add-hook 'idlwave-completion-setup-hook - 'idlwave-highlight-linked-completions) + #'idlwave-highlight-linked-completions) (defvar idlwave-help-return-frame nil "The frame to return to from the help frame.") @@ -947,7 +936,7 @@ This function can be used as `idlwave-extra-help-function'." (point))) -(defun idlwave-help-find-routine-definition (name type class keyword) +(defun idlwave-help-find-routine-definition (name type class _keyword) "Find the definition of routine CLASS::NAME in current buffer. Returns the point of match if successful, nil otherwise. KEYWORD is ignored." @@ -967,7 +956,7 @@ KEYWORD is ignored." (defvar idlwave-doclib-start) (defvar idlwave-doclib-end) -(defun idlwave-help-find-in-doc-header (name type class keyword +(defun idlwave-help-find-in-doc-header (name _type class keyword &optional exact) "Find the requested help in the doc-header above point. @@ -1025,9 +1014,9 @@ If there is a match, we assume it is the keyword description." ":[ \t]*$\\)")) ;; Header start plus name - (header-re (concat "\\(" idlwave-doclib-start "\\).*\n" - "\\(^;+.*\n\\)*" - "\\(" name-re "\\)")) + ;; (header-re (concat "\\(" idlwave-doclib-start "\\).*\n" + ;; "\\(^;+.*\n\\)*" + ;; "\\(" name-re "\\)")) ;; A keywords section (kwds-re (concat ; forgiving "^;+\\*?[ \t]*" @@ -1095,8 +1084,8 @@ When DING is non-nil, ring the bell as well." (cons string idlwave-help-diagnostics)) (if ding (ding))))) -(defun idlwave-help-toggle-header-top-and-def (arg) - (interactive "P") +(defun idlwave-help-toggle-header-top-and-def (&optional _arg) + (interactive) (let (pos) (if idlwave-help-in-header ;; Header was the last thing displayed @@ -1119,8 +1108,8 @@ When DING is non-nil, ring the bell as well." (goto-char pos) (recenter 0))))) -(defun idlwave-help-find-first-header (arg) - (interactive "P") +(defun idlwave-help-find-first-header (&optional _arg) + (interactive) (let (pos) (save-excursion (goto-char (point-min)) @@ -1140,8 +1129,8 @@ When DING is non-nil, ring the bell as well." (setq idlwave-help-in-header nil) (idlwave-help-toggle-header-match-and-def arg 'top))) -(defun idlwave-help-toggle-header-match-and-def (arg &optional top) - (interactive "P") +(defun idlwave-help-toggle-header-match-and-def (&optional _arg top) + (interactive) (let ((args idlwave-help-args) pos) (if idlwave-help-in-header @@ -1150,7 +1139,7 @@ When DING is non-nil, ring the bell as well." (setq idlwave-help-in-header nil) (setq pos idlwave-help-def-pos)) ;; Try to display header - (setq pos (apply 'idlwave-help-find-in-doc-header + (setq pos (apply #'idlwave-help-find-in-doc-header (if top (list (car args) (nth 1 args) (nth 2 args) nil) args))) @@ -1184,7 +1173,7 @@ Useful when source code is displayed as help. See the option (with-no-warnings (font-lock-fontify-buffer)))))) -(defun idlwave-help-error (name type class keyword) +(defun idlwave-help-error (name _type class keyword) (error "Can't find help on %s%s %s" (or (and (or class name) (idlwave-make-full-name class name)) "<unknown>") @@ -1272,11 +1261,11 @@ IDL assistant.") (delete-process idlwave-help-assistant-socket)) (setq idlwave-help-assistant-process - (apply 'start-process + (apply #'start-process "IDL_ASSISTANT_PROC" nil command "-server" extra-args)) (set-process-filter idlwave-help-assistant-process - (lambda (proc string) + (lambda (_proc string) (setq port (string-to-number string)))) (unless (accept-process-output idlwave-help-assistant-process 15) (error "Failed binding IDL_ASSISTANT socket")) diff --git a/lisp/progmodes/idlw-shell.el b/lisp/progmodes/idlw-shell.el index 4bc52247d86..eb88f25dfd6 100644 --- a/lisp/progmodes/idlw-shell.el +++ b/lisp/progmodes/idlw-shell.el @@ -1,4 +1,4 @@ -;; idlw-shell.el --- run IDL as an inferior process of Emacs. -*- lexical-binding:t -*- +;;; idlw-shell.el --- run IDL as an inferior process of Emacs. -*- lexical-binding:t -*- ;; Copyright (C) 1999-2021 Free Software Foundation, Inc. @@ -729,7 +729,7 @@ IDL is currently stopped.") (defconst idlwave-shell-halt-messages-re - (mapconcat 'identity idlwave-shell-halt-messages "\\|") + (mapconcat #'identity idlwave-shell-halt-messages "\\|") "The regular expression computed from `idlwave-shell-halt-messages'.") (defconst idlwave-shell-trace-message-re @@ -934,8 +934,8 @@ IDL has currently stepped.") "[ \t\n]*\\'")) (when idlwave-shell-query-for-class - (add-to-list (make-local-variable 'idlwave-determine-class-special) - 'idlwave-shell-get-object-class) + (add-hook 'idlwave-determine-class-functions + #'idlwave-shell-get-object-class nil t) (setq idlwave-store-inquired-class t)) ;; Make sure comint-last-input-end does not go to beginning of @@ -950,10 +950,10 @@ IDL has currently stepped.") (setq idlwave-shell-default-directory default-directory) (setq idlwave-shell-hide-output nil) - (add-hook 'kill-buffer-hook 'idlwave-shell-kill-shell-buffer-confirm + (add-hook 'kill-buffer-hook #'idlwave-shell-kill-shell-buffer-confirm nil 'local) - (add-hook 'kill-buffer-hook 'idlwave-shell-delete-temp-files nil 'local) - (add-hook 'kill-emacs-hook 'idlwave-shell-delete-temp-files) + (add-hook 'kill-buffer-hook #'idlwave-shell-delete-temp-files nil 'local) + (add-hook 'kill-emacs-hook #'idlwave-shell-delete-temp-files) ;; Set the optional comint variables (when idlwave-shell-comint-settings @@ -962,12 +962,12 @@ IDL has currently stepped.") (set (make-local-variable (car entry)) (cdr entry))))) - (unless (memq 'comint-carriage-motion + (unless (memq #'comint-carriage-motion (default-value 'comint-output-filter-functions)) ;; Strip those pesky ctrl-m's. (add-hook 'comint-output-filter-functions (lambda (string) - (when (string-match "\r" string) + (when (string-search "\r" string) (let ((pmark (process-mark (get-buffer-process (current-buffer))))) (save-excursion @@ -976,18 +976,21 @@ IDL has currently stepped.") (while (search-forward "\r" pmark t) (delete-region (point) (line-beginning-position))))))) 'append 'local) - (add-hook 'comint-output-filter-functions 'comint-strip-ctrl-m nil 'local)) + (add-hook 'comint-output-filter-functions #'comint-strip-ctrl-m nil 'local)) ;; Python-mode, bundled with many Emacs installs, quite cavalierly ;; adds this function to the global default hook. It interferes ;; with overlay-arrows. - (remove-hook 'comint-output-filter-functions 'py-pdbtrack-track-stack-file) + ;; FIXME: We should fix this interference rather than globally turn it off. + (when (fboundp 'py-pdbtrack-track-stack-file) + (remove-hook 'comint-output-filter-functions + #'py-pdbtrack-track-stack-file)) ;; IDLWAVE syntax, and turn on abbreviations (set (make-local-variable 'comment-start) ";") (setq abbrev-mode t) - (add-hook 'post-command-hook 'idlwave-command-hook nil t) + (add-hook 'post-command-hook #'idlwave-command-hook nil t) ;; Read the command history? (when (and idlwave-shell-save-command-history @@ -1045,7 +1048,7 @@ IDL has currently stepped.") (setq idlwave-path-alist old-path-alist)))) (if (not (fboundp 'idl-shell)) - (fset 'idl-shell 'idlwave-shell)) + (defalias 'idl-shell #'idlwave-shell)) (defvar idlwave-shell-idl-wframe nil "Frame for displaying the IDL shell window.") @@ -1120,7 +1123,7 @@ See also the variable `idlwave-shell-prompt-pattern'. (and idlwave-shell-use-dedicated-frame (setq idlwave-shell-idl-wframe (selected-frame))) (add-hook 'idlwave-shell-sentinel-hook - 'save-buffers-kill-emacs t)) + #'save-buffers-kill-emacs t)) ;; A non-nil arg means, we want a dedicated frame. This will last ;; for the current editing session. @@ -1130,7 +1133,7 @@ See also the variable `idlwave-shell-prompt-pattern'. ;; Check if the process still exists. If not, create it. (unless (comint-check-proc (idlwave-shell-buffer)) (let* ((prg (or idlwave-shell-explicit-file-name "idl")) - (buf (apply 'make-comint + (buf (apply #'make-comint idlwave-shell-process-name prg nil (if (stringp idlwave-shell-command-line-options) (idlwave-split-string @@ -1138,8 +1141,8 @@ See also the variable `idlwave-shell-prompt-pattern'. idlwave-shell-command-line-options))) (process (get-buffer-process buf))) (setq idlwave-idlwave_routine_info-compiled nil) - (set-process-filter process 'idlwave-shell-filter) - (set-process-sentinel process 'idlwave-shell-sentinel) + (set-process-filter process #'idlwave-shell-filter) + (set-process-sentinel process #'idlwave-shell-sentinel) (set-buffer buf) (idlwave-shell-mode))) (let ((window (idlwave-display-buffer (idlwave-shell-buffer) nil @@ -1315,10 +1318,7 @@ See also the variable `idlwave-shell-input-mode-spells'." (setq idlwave-shell-char-mode-active 'exit)) ((string-match (nth 1 idlwave-shell-input-mode-spells) string) ;; Set a timer which will soon start the character loop - (if (fboundp 'start-itimer) - (start-itimer "IDLWAVE Char Mode" 'idlwave-shell-char-mode-loop 0.5 - nil nil t 'no-error) - (run-at-time 0.5 nil 'idlwave-shell-char-mode-loop 'no-error))))) + (run-at-time 0.5 nil #'idlwave-shell-char-mode-loop 'no-error)))) (defvar keyboard-quit) (defun idlwave-shell-char-mode-loop (&optional no-error) @@ -1396,7 +1396,7 @@ Otherwise just move the line. Move down unless UP is non-nil." (idlwave-shell-move-or-history nil arg)) (define-obsolete-function-alias 'idlwave-shell-comint-filter - 'comint-output-filter "25.1") + #'comint-output-filter "25.1") (defun idlwave-shell-is-running () "Return t if the shell process is running." @@ -1409,7 +1409,7 @@ Remove everything to the first newline, and all lines with % in front of them, with optional follow-on lines starting with two spaces. This works well enough, since any print output typically arrives before error messages, etc." - (setq output (substring output (string-match "\n" output))) + (setq output (substring output (string-search "\n" output))) (while (string-match "\\(\n\\|\\`\\)%.*\\(\n .*\\)*" output) (setq output (replace-match "" nil t output))) (unless @@ -1431,12 +1431,12 @@ and then calls `idlwave-shell-send-command' for any pending commands." (unwind-protect (progn ;; Ring the bell if necessary - (while (setq p (string-match "\C-G" string)) + (while (setq p (string-search "\C-G" string)) (ding) (aset string p ?\C-j )) (if idlwave-shell-hide-output (save-excursion - (while (setq p (string-match "\C-M" string)) + (while (setq p (string-search "\C-M" string)) (aset string p ?\ )) (set-buffer (get-buffer-create idlwave-shell-hidden-output-buffer)) @@ -1445,7 +1445,7 @@ and then calls `idlwave-shell-send-command' for any pending commands." (comint-output-filter proc string)) ;; Watch for magic - need to accumulate the current line ;; since it may not be sent all at once. - (if (string-match "\n" string) + (if (string-search "\n" string) (progn (if idlwave-shell-use-input-mode-magic (idlwave-shell-input-mode-magic @@ -1510,13 +1510,12 @@ and then calls `idlwave-shell-send-command' for any pending commands." proc filtered)))))) ;; Call the post-command hook - (if (listp idlwave-shell-post-command-hook) - (progn - ;;(message "Calling list") - ;;(prin1 idlwave-shell-post-command-hook) - (eval idlwave-shell-post-command-hook)) - ;;(message "Calling command function") - (funcall idlwave-shell-post-command-hook)) + (if (functionp idlwave-shell-post-command-hook) + ;;(message "Calling command function") + (funcall idlwave-shell-post-command-hook) + ;;(message "Calling list") + ;;(prin1 idlwave-shell-post-command-hook) + (eval idlwave-shell-post-command-hook t)) ;; Reset to default state for next command. ;; Also we do not want to find this prompt again. @@ -1690,7 +1689,7 @@ the above." (if bp (let ((cmd (idlwave-shell-bp-get bp 'cmd))) (if cmd ;; Execute any breakpoint command - (if (listp cmd) (eval cmd) (funcall cmd)))) + (if (functionp cmd) (funcall cmd) (eval cmd t)))) ;; A breakpoint that we did not know about - perhaps it was ;; set by the user... Let's update our list. (idlwave-shell-bp-query))) @@ -1819,7 +1818,7 @@ The size is given by `idlwave-shell-graphics-window-size'." (interactive "P") (let ((n (if n (prefix-numeric-value n) 0))) (idlwave-shell-send-command - (apply 'format "window,%d,xs=%d,ys=%d" + (apply #'format "window,%d,xs=%d,ys=%d" n idlwave-shell-graphics-window-size) nil (idlwave-shell-hide-p 'misc) nil t))) @@ -1891,7 +1890,7 @@ HEAP_GC, /VERBOSE" (while (string-match "^PATH:[ \t]*<\\(.*\\)>[ \t]*\n" path-string start) (push (match-string 1 path-string) dirs) (setq start (match-end 0))) - (setq dirs (mapcar 'file-name-as-directory dirs)) + (setq dirs (mapcar #'file-name-as-directory dirs)) (if (string-match "^SYSDIR:[ \t]*<\\(.*\\)>[ \t]*\n" path-string) (setq sysdir (file-name-as-directory (match-string 1 path-string)))) @@ -1938,13 +1937,14 @@ HEAP_GC, /VERBOSE" key (nth 4 specs) keys (if (and (stringp key) (not (string-match "\\` *\\'" key))) - (mapcar 'list + (mapcar #'list (delete "" (idlwave-split-string key " +"))))) (setq name (idlwave-sintern-routine-or-method name class t) class (idlwave-sintern-class class t) file (if (equal file "") nil file) keys (mapcar (lambda (x) - (list (idlwave-sintern-keyword (car x) t))) keys)) + (list (idlwave-sintern-keyword (car x) t))) + keys)) ;; In the following ignore routines already defined in buffers, ;; assuming that if the buffer stuff differs, it is a "new" @@ -2053,7 +2053,7 @@ Change the default directory for the process buffer to concur." (match-string 1 idlwave-shell-command-output))))) (defvar idlwave-sint-sysvars nil) -(idlwave-new-sintern-type 'execcomm) +(idlwave-new-sintern-type execcomm) (defun idlwave-shell-complete (&optional arg) "Do completion in the idlwave-shell buffer. @@ -2180,7 +2180,7 @@ overlays." (defun idlwave-shell-parse-stack-and-display () (let* ((lines (delete "" (idlwave-split-string idlwave-shell-command-output "^%"))) - (stack (delq nil (mapcar 'idlwave-shell-parse-line lines))) + (stack (delq nil (mapcar #'idlwave-shell-parse-line lines))) (nmax (1- (length stack))) (nmin 0) message) (cond @@ -2710,45 +2710,34 @@ Runs to the last statement and then steps 1 statement. Use the .out command." (interactive "P") (idlwave-shell-print arg 'help)) -(defmacro idlwave-shell-mouse-examine (help &optional ev) - "Create a function for generic examination of expressions." - `(lambda (event) - "Expansion function for expression examination." - (interactive "e") - (let* ((drag-track (fboundp 'mouse-drag-track)) - (transient-mark-mode t) - (tracker - ;; Emacs 22 no longer completes the drag with - ;; mouse-drag-region, without an additional - ;; event. mouse-drag-track does so. - (if drag-track 'mouse-drag-track 'mouse-drag-region))) - (funcall tracker event) - (idlwave-shell-print (if (region-active-p) '(4) nil) - ,help ,ev)))) - -;; Begin terrible hack section -- XEmacs tests for button2 explicitly -;; on drag events, calling drag-n-drop code if detected. Ughhh... -(defun idlwave-default-mouse-track-event-is-with-button (_event _n) - (declare (obsolete nil "28.1")) - t) - -(define-obsolete-function-alias 'idlwave-xemacs-hack-mouse-track 'ignore "27.1") +(defun idlwave-shell--mouse-examine (event help &optional ev) + "Expansion function for expression examination." + (let* ((transient-mark-mode t)) + (mouse-drag-track event) + (idlwave-shell-print (if (region-active-p) '(4) nil) + help ev))) + +(define-obsolete-function-alias + 'idlwave-default-mouse-track-event-is-with-button #'always "28.1") + +(define-obsolete-function-alias 'idlwave-xemacs-hack-mouse-track + #'ignore "27.1") ;;; End terrible hack section (defun idlwave-shell-mouse-print (event) "Print value of variable at the mouse position, with `print'." (interactive "e") - (funcall (idlwave-shell-mouse-examine nil) event)) + (idlwave-shell--mouse-examine event nil)) (defun idlwave-shell-mouse-help (event) "Print value of variable at the mouse position, with `help'." (interactive "e") - (funcall (idlwave-shell-mouse-examine 'help) event)) + (idlwave-shell--mouse-examine event 'help)) (defun idlwave-shell-examine-select (event) "Pop-up a list to select from for examining the expression." (interactive "e") - (funcall (idlwave-shell-mouse-examine nil event) event)) + (idlwave-shell--mouse-examine event nil event)) (defmacro idlwave-shell-examine (help) "Create a function for key-driven expression examination." @@ -2814,7 +2803,7 @@ from `idlwave-shell-examine-alist' via mini-buffer shortcut key." (setq beg (region-beginning) end (region-end))) (t - (idlwave-with-special-syntax + (with-syntax-table idlwave-find-symbol-syntax-table ;; Move to beginning of current or previous expression (if (looking-at "\\<\\|(") ;; At beginning of expression, don't move backwards unless @@ -2847,9 +2836,9 @@ from `idlwave-shell-examine-alist' via mini-buffer shortcut key." (move-overlay idlwave-shell-expression-overlay beg end (current-buffer)) (add-hook 'pre-command-hook - 'idlwave-shell-delete-expression-overlay)) + #'idlwave-shell-delete-expression-overlay)) (add-hook 'pre-command-hook - 'idlwave-shell-delete-output-overlay) + #'idlwave-shell-delete-output-overlay) ;; Remove empty or comment-only lines (while (string-match "\n[ \t]*\\(;.*\\)?\r*\n" expr) @@ -2881,7 +2870,7 @@ from `idlwave-shell-examine-alist' via mini-buffer shortcut key." ;; "Print") (idlwave-popup-select ev - (mapcar 'car idlwave-shell-examine-alist) + (mapcar #'car idlwave-shell-examine-alist) "Examine with")) idlwave-shell-examine-alist)))) (setq help (cdr help-cons)) @@ -2916,9 +2905,8 @@ from `idlwave-shell-examine-alist' via mini-buffer shortcut key." "Variable to hold the win/height pairs for all *Examine* windows.") (defvar idlwave-shell-examine-map (make-sparse-keymap)) -(define-key idlwave-shell-examine-map "q" 'idlwave-shell-examine-display-quit) -(define-key idlwave-shell-examine-map "c" 'idlwave-shell-examine-display-clear) - +(define-key idlwave-shell-examine-map "q" #'idlwave-shell-examine-display-quit) +(define-key idlwave-shell-examine-map "c" #'idlwave-shell-examine-display-clear) (defun idlwave-shell-check-compiled-and-display () "Check examine output for warning about undefined procedure/function." @@ -3347,9 +3335,10 @@ the breakpoint overlays." count nil condition disabled)))))) (setq idlwave-shell-bp-alist (cdr idlwave-shell-bp-alist)) ;; Update breakpoint data - (if (eq bp-re bp-re54) - (mapc 'idlwave-shell-update-bp old-bp-alist) - (mapc 'idlwave-shell-update-bp-command-only old-bp-alist)))) + (mapc (if (eq bp-re bp-re54) + #'idlwave-shell-update-bp + #'idlwave-shell-update-bp-command-only) + old-bp-alist))) ;; Update the breakpoint overlays (unless no-show (idlwave-shell-update-bp-overlays)) ;; Return the new list @@ -3484,7 +3473,7 @@ The actual line number for a breakpoint in IDL may be different from the line number used with the IDL breakpoint command. Looks for a new breakpoint index number in the list. This is considered the new breakpoint if the file name of frame matches." - (let ((obp-index (mapcar 'idlwave-shell-bp-get idlwave-shell-old-bp)) + (let ((obp-index (mapcar #'idlwave-shell-bp-get idlwave-shell-old-bp)) (bpl idlwave-shell-bp-alist)) (while (and (member (idlwave-shell-bp-get (car bpl)) obp-index) (setq bpl (cdr bpl)))) @@ -3510,7 +3499,7 @@ considered the new breakpoint if the file name of frame matches." (defvar idlwave-shell-debug-line-map (make-sparse-keymap)) (define-key idlwave-shell-debug-line-map [mouse-3] - 'idlwave-shell-mouse-active-bp) + #'idlwave-shell-mouse-active-bp) (defun idlwave-shell-update-bp-overlays () "Update the overlays which mark breakpoints in the source code. @@ -3532,7 +3521,7 @@ Existing overlays are recycled, in order to minimize consumption." (setq ov-alist idlwave-shell-bp-overlays idlwave-shell-bp-overlays (if idlwave-shell-bp-glyph - (mapcar 'list (mapcar 'car idlwave-shell-bp-glyph)) + (mapcar #'list (mapcar #'car idlwave-shell-bp-glyph)) (list (list 'bp)))) (while (setq bp (pop bp-list)) (save-excursion @@ -3568,7 +3557,7 @@ Existing overlays are recycled, in order to minimize consumption." (if help-list (concat " - " - (mapconcat 'identity help-list ", "))) + (mapconcat #'identity help-list ", "))) (if (and (not count) (not condition)) " (use mouse-3 for breakpoint actions)"))) (full-type (if disabled @@ -3962,73 +3951,73 @@ Otherwise, just expand the file name." ;;(define-key map "\M-?" 'comint-dynamic-list-completions) ;;(define-key map "\t" 'comint-dynamic-complete) - (define-key map "\C-w" 'comint-kill-region) - (define-key map "\t" 'idlwave-shell-complete) - (define-key map "\M-\t" 'idlwave-shell-complete) - (define-key map "\C-c\C-s" 'idlwave-shell) - (define-key map "\C-c?" 'idlwave-routine-info) - (define-key map "\C-g" 'idlwave-keyboard-quit) - (define-key map "\M-?" 'idlwave-context-help) + (define-key map "\C-w" #'comint-kill-region) + (define-key map "\t" #'idlwave-shell-complete) + (define-key map "\M-\t" #'idlwave-shell-complete) + (define-key map "\C-c\C-s" #'idlwave-shell) + (define-key map "\C-c?" #'idlwave-routine-info) + (define-key map "\C-g" #'idlwave-keyboard-quit) + (define-key map "\M-?" #'idlwave-context-help) (define-key map [(control meta ?\?)] - 'idlwave-help-assistant-help-with-topic) - (define-key map "\C-c\C-i" 'idlwave-update-routine-info) - (define-key map "\C-c\C-y" 'idlwave-shell-char-mode-loop) - (define-key map "\C-c\C-x" 'idlwave-shell-send-char) - (define-key map "\C-c=" 'idlwave-resolve) - (define-key map "\C-c\C-v" 'idlwave-find-module) - (define-key map "\C-c\C-k" 'idlwave-kill-autoloaded-buffers) + #'idlwave-help-assistant-help-with-topic) + (define-key map "\C-c\C-i" #'idlwave-update-routine-info) + (define-key map "\C-c\C-y" #'idlwave-shell-char-mode-loop) + (define-key map "\C-c\C-x" #'idlwave-shell-send-char) + (define-key map "\C-c=" #'idlwave-resolve) + (define-key map "\C-c\C-v" #'idlwave-find-module) + (define-key map "\C-c\C-k" #'idlwave-kill-autoloaded-buffers) (define-key map idlwave-shell-prefix-key - 'idlwave-shell-debug-map) - (define-key map [(up)] 'idlwave-shell-up-or-history) - (define-key map [(down)] 'idlwave-shell-down-or-history) + #'idlwave-shell-debug-map) + (define-key map [(up)] #'idlwave-shell-up-or-history) + (define-key map [(down)] #'idlwave-shell-down-or-history) (define-key idlwave-shell-mode-map [(shift mouse-3)] - 'idlwave-mouse-context-help) + #'idlwave-mouse-context-help) map) "Keymap for `idlwave-mode'.") (defvar idlwave-shell-electric-debug-mode-map (let ((map (make-sparse-keymap))) ;; A few extras in the electric debug map - (define-key map " " 'idlwave-shell-step) - (define-key map "+" 'idlwave-shell-stack-up) - (define-key map "=" 'idlwave-shell-stack-up) - (define-key map "-" 'idlwave-shell-stack-down) - (define-key map "_" 'idlwave-shell-stack-down) + (define-key map " " #'idlwave-shell-step) + (define-key map "+" #'idlwave-shell-stack-up) + (define-key map "=" #'idlwave-shell-stack-up) + (define-key map "-" #'idlwave-shell-stack-down) + (define-key map "_" #'idlwave-shell-stack-down) (define-key map "e" (lambda () (interactive) (idlwave-shell-print '(16)))) - (define-key map "q" 'idlwave-shell-retall) + (define-key map "q" #'idlwave-shell-retall) (define-key map "t" (lambda () (interactive) (idlwave-shell-send-command "help,/TRACE"))) - (define-key map [(control ??)] 'idlwave-shell-electric-debug-help) + (define-key map [(control ??)] #'idlwave-shell-electric-debug-help) (define-key map "x" (lambda (arg) (interactive "P") (idlwave-shell-print arg nil nil t))) map)) (defvar idlwave-shell-mode-prefix-map (make-sparse-keymap)) -(fset 'idlwave-shell-mode-prefix-map idlwave-shell-mode-prefix-map) +(defalias 'idlwave-shell-mode-prefix-map idlwave-shell-mode-prefix-map) (defvar idlwave-mode-prefix-map (make-sparse-keymap)) -(fset 'idlwave-mode-prefix-map idlwave-mode-prefix-map) +(defalias 'idlwave-mode-prefix-map idlwave-mode-prefix-map) (defun idlwave-shell-define-key-both (key hook) "Define a key in both the shell and buffer mode maps." (define-key idlwave-mode-map key hook) (define-key idlwave-shell-mode-map key hook)) -(define-key idlwave-mode-map "\C-c\C-y" 'idlwave-shell-char-mode-loop) -(define-key idlwave-mode-map "\C-c\C-x" 'idlwave-shell-send-char) +(define-key idlwave-mode-map "\C-c\C-y" #'idlwave-shell-char-mode-loop) +(define-key idlwave-mode-map "\C-c\C-x" #'idlwave-shell-send-char) ;; The mouse bindings for PRINT and HELP (idlwave-shell-define-key-both [(shift down-mouse-2)] - 'idlwave-shell-mouse-print) + #'idlwave-shell-mouse-print) (idlwave-shell-define-key-both [(control meta down-mouse-2)] - 'idlwave-shell-mouse-help) + #'idlwave-shell-mouse-help) (idlwave-shell-define-key-both [(control shift down-mouse-2)] - 'idlwave-shell-examine-select) + #'idlwave-shell-examine-select) ;; We need to turn off the button release events. -(idlwave-shell-define-key-both [(shift mouse-2)] 'ignore) -(idlwave-shell-define-key-both [(shift control mouse-2)] 'ignore) -(idlwave-shell-define-key-both [(control meta mouse-2)] 'ignore) +(idlwave-shell-define-key-both [(shift mouse-2)] #'ignore) +(idlwave-shell-define-key-both [(shift control mouse-2)] #'ignore) +(idlwave-shell-define-key-both [(control meta mouse-2)] #'ignore) ;; The following set of bindings is used to bind the debugging keys. @@ -4109,8 +4098,8 @@ Otherwise, just expand the file name." cmd)))) ; Enter the prefix map in two places. -(fset 'idlwave-debug-map idlwave-mode-prefix-map) -(fset 'idlwave-shell-debug-map idlwave-shell-mode-prefix-map) +(defalias 'idlwave-debug-map idlwave-mode-prefix-map) +(defalias 'idlwave-shell-debug-map idlwave-shell-mode-prefix-map) ;; The Electric Debug Minor Mode -------------------------------------------- @@ -4496,6 +4485,6 @@ static char * file[] = { (idlwave-toolbar-toggle)) (if idlwave-shell-use-toolbar - (add-hook 'idlwave-shell-mode-hook 'idlwave-toolbar-add-everywhere)) + (add-hook 'idlwave-shell-mode-hook #'idlwave-toolbar-add-everywhere)) ;;; idlw-shell.el ends here diff --git a/lisp/progmodes/idlw-toolbar.el b/lisp/progmodes/idlw-toolbar.el index 4bd0afb2ba1..d3f47fcf45e 100644 --- a/lisp/progmodes/idlw-toolbar.el +++ b/lisp/progmodes/idlw-toolbar.el @@ -1,4 +1,4 @@ -;;; idlw-toolbar.el --- a debugging toolbar for IDLWAVE +;;; idlw-toolbar.el --- a debugging toolbar for IDLWAVE -*- lexical-binding: t; -*- ;; Copyright (C) 1999-2021 Free Software Foundation, Inc. @@ -24,8 +24,8 @@ ;;; Commentary: -;; This file implements a debugging toolbar for IDLWAVE. It requires -;; Emacs or XEmacs with toolbar and xpm support. +;; This file implements a debugging toolbar for IDLWAVE. +;; It requires toolbar and xpm support. ;; New versions of IDLWAVE, documentation, and more information ;; available from: @@ -35,22 +35,16 @@ ;;; Code: (defun idlwave-toolbar-make-button (image) - (if (featurep 'xemacs) - (toolbar-make-button-list image) - (list 'image :type 'xpm :data image))) + (list 'image :type 'xpm :data image)) (defvar idlwave-toolbar) (defvar default-toolbar) (defvar idlwave-toolbar-is-possible) -(if (not (or (and (featurep 'xemacs) ; This is XEmacs - (featurep 'xpm) ; need xpm - (featurep 'toolbar)) ; ... and the toolbar - (and (not (featurep 'xemacs)) ; This is Emacs - (boundp 'tool-bar-button-margin) ; need toolbar - (fboundp 'image-type-available-p) ; need image stuff - (image-type-available-p 'xpm)) ; need xpm - )) +(if (not (and (boundp 'tool-bar-button-margin) ; need toolbar + (fboundp 'image-type-available-p) ; need image stuff + (image-type-available-p 'xpm)) ; need xpm + ) ;; oops - cannot do the toolbar (message "Sorry, IDLWAVE xpm toolbar cannot be used on this version of Emacs") ;; OK, we can define a toolbar @@ -873,23 +867,12 @@ static char * file[] = { ;; When the shell exits, arrange to remove the special toolbar everywhere. (add-hook 'idlwave-shell-cleanup-hook - 'idlwave-toolbar-remove-everywhere) + #'idlwave-toolbar-remove-everywhere) );; End can define toolbar -(defun idlwave-toolbar-add () - "Add the IDLWAVE toolbar if appropriate." - (if (and (featurep 'xemacs) ; This is a noop on Emacs - (boundp 'idlwave-toolbar-is-possible) - (derived-mode-p 'idlwave-mode 'idlwave-shell-mode)) - (set-specifier default-toolbar (cons (current-buffer) - idlwave-toolbar)))) - -(defun idlwave-toolbar-remove () - "Add the IDLWAVE toolbar if appropriate." - (if (and (featurep 'xemacs) ; This is a noop on Emacs - (boundp 'idlwave-toolbar-is-possible) - (derived-mode-p 'idlwave-mode 'idlwave-shell-mode)) - (remove-specifier default-toolbar (current-buffer)))) +(define-obsolete-function-alias 'idlwave-toolbar-add #'ignore "28.1") + +(define-obsolete-function-alias 'idlwave-toolbar-remove #'ignore "28.1") (defvar idlwave-shell-mode-map) (defvar idlwave-mode-map) @@ -898,57 +881,40 @@ static char * file[] = { "Add the toolbar in all appropriate buffers." (when (boundp 'idlwave-toolbar-is-possible) - ;; First make sure new buffers will get the toolbar - (add-hook 'idlwave-mode-hook 'idlwave-toolbar-add) ;; Then add it to all existing buffers - (if (featurep 'xemacs) - ;; For XEmacs, map over all buffers to add toolbar - (save-excursion - (mapcar (lambda (buf) - (set-buffer buf) - (idlwave-toolbar-add)) - (buffer-list))) - ;; For Emacs, add the key definitions to the mode maps - (mapc (lambda (x) - (let* ((icon (aref x 0)) - (func (aref x 1)) - (show (aref x 2)) - (help (aref x 3)) - (key (vector 'tool-bar func)) - (def (list 'menu-item - "" - func - :image (symbol-value icon) - :visible show - :help help))) - (define-key idlwave-mode-map key def) - (define-key idlwave-shell-mode-map key def))) - (reverse idlwave-toolbar))) + ;; For Emacs, add the key definitions to the mode maps + (mapc (lambda (x) + (let* ((icon (aref x 0)) + (func (aref x 1)) + (show (aref x 2)) + (help (aref x 3)) + (key (vector 'tool-bar func)) + (def (list 'menu-item + "" + func + :image (symbol-value icon) + :visible show + :help help))) + (define-key idlwave-mode-map key def) + (define-key idlwave-shell-mode-map key def))) + (reverse idlwave-toolbar)) (setq idlwave-toolbar-visible t))) (defun idlwave-toolbar-remove-everywhere () "Remove the toolbar in all appropriate buffers." ;; First make sure new buffers won't get the toolbar (when idlwave-toolbar-is-possible - (remove-hook 'idlwave-mode-hook 'idlwave-toolbar-add) ;; Then remove it in all existing buffers. - (if (featurep 'xemacs) - ;; For XEmacs, map over all buffers to remove toolbar - (save-excursion - (mapcar (lambda (buf) - (set-buffer buf) - (idlwave-toolbar-remove)) - (buffer-list))) - ;; For Emacs, remove the key definitions from the mode maps - (mapc (lambda (x) - (let* (;;(icon (aref x 0)) - (func (aref x 1)) - ;;(show (aref x 2)) - ;;(help (aref x 3)) - (key (vector 'tool-bar func))) - (define-key idlwave-mode-map key nil) - (define-key idlwave-shell-mode-map key nil))) - idlwave-toolbar)) + ;; For Emacs, remove the key definitions from the mode maps + (mapc (lambda (x) + (let* (;;(icon (aref x 0)) + (func (aref x 1)) + ;;(show (aref x 2)) + ;;(help (aref x 3)) + (key (vector 'tool-bar func))) + (define-key idlwave-mode-map key nil) + (define-key idlwave-shell-mode-map key nil))) + idlwave-toolbar) (setq idlwave-toolbar-visible nil))) (defun idlwave-toolbar-toggle (&optional force-on) @@ -956,11 +922,8 @@ static char * file[] = { (if idlwave-toolbar-visible (or force-on (idlwave-toolbar-remove-everywhere)) (idlwave-toolbar-add-everywhere)) - ;; Now make sure this - (if (featurep 'xemacs) - nil ; no action necessary, toolbar gets updated automatically - ;; On Emacs, redraw the frame to make sure the Toolbar is updated. - (redraw-frame))) + ;; On Emacs, redraw the frame to make sure the Toolbar is updated. + (redraw-frame)) (provide 'idlw-toolbar) (provide 'idlwave-toolbar) diff --git a/lisp/progmodes/idlwave.el b/lisp/progmodes/idlwave.el index e8e55ae96d1..55e712dd77d 100644 --- a/lisp/progmodes/idlwave.el +++ b/lisp/progmodes/idlwave.el @@ -1,4 +1,4 @@ -;; idlwave.el --- IDL editing mode for GNU Emacs +;;; idlwave.el --- IDL editing mode for GNU Emacs -*- lexical-binding: t; -*- ;; Copyright (C) 1999-2021 Free Software Foundation, Inc. @@ -781,7 +781,7 @@ definitions, use the command `list-abbrevs', for abbrevs that move point. Moving point is useful, for example, to place point between parentheses of expanded functions. -See `idlwave-check-abbrev'." +See `idlwave-modify-abbrev'." :group 'idlwave-abbrev-and-indent-action :type 'boolean) @@ -819,18 +819,19 @@ Has effect only if in abbrev-mode." ;; Example actions: ;; ;; Capitalize system vars -;; (idlwave-action-and-binding idlwave-sysvar '(capitalize-word 1) t) +;; (idlwave-action-and-binding idlwave-sysvar +;; (lambda (_) (capitalize-word 1)) t) ;; ;; Capitalize procedure name ;; (idlwave-action-and-binding "\\<\\(pro\\|function\\)\\>[ \t]*\\<" -;; '(capitalize-word 1) t) +;; (lambda (_) (capitalize-word 1)) t) ;; ;; Capitalize common block name ;; (idlwave-action-and-binding "\\<common\\>[ \t]+\\<" -;; '(capitalize-word 1) t) +;; (lambda (_) (capitalize-word 1)) t) ;; Capitalize label ;; (idlwave-action-and-binding (concat "^[ \t]*" idlwave-label) -;; '(capitalize-word -1) t) +;; (lambda (_) (capitalize-word 1)) t) (defvar idlwave-indent-action-table nil "Associated array containing action lists of search string (car), @@ -1121,91 +1122,101 @@ As a user, you should not set this to t.") "\\<\\(&&\\|and\\|b\\(egin\\|reak\\)\\|c\\(ase\\|o\\(mpile_opt\\|ntinue\\)\\)\\|do\\|e\\(lse\\|nd\\(case\\|else\\|for\\|if\\|rep\\|switch\\|while\\)?\\|q\\)\\|for\\(ward_function\\)?\\|g\\(oto\\|[et]\\)\\|i\\(f\\|nherits\\)\\|l[et]\\|mod\\|n\\(e\\|ot\\)\\|o\\(n_\\(error\\|ioerror\\)\\|[fr]\\)\\|re\\(peat\\|turn\\)\\|switch\\|then\\|until\\|while\\|xor\\|||\\)\\>") -(let* (;; Procedure declarations. Fontify keyword plus procedure name. - ;; Function declarations. Fontify keyword plus function name. - (pros-and-functions - '("\\<\\(function\\|pro\\)\\>[ \t]+\\(\\sw+\\(::\\sw+\\)?\\)" - (1 font-lock-keyword-face) - (2 font-lock-function-name-face nil t))) - - ;; Common blocks - (common-blocks - '("\\<\\(common\\)\\>[ \t]*\\(\\sw+\\)?[ \t]*,?" - (1 font-lock-keyword-face) ; "common" - (2 font-lock-constant-face nil t) ; block name - ("[ \t]*\\(\\sw+\\)[ ,]*" - ;; Start with point after block name and comma - nil nil (1 font-lock-variable-name-face)))) ; variable names - - ;; Batch files - (batch-files - '("^[ \t]*\\(@[^ \t\n]+\\)" (1 font-lock-string-face))) - - ;; Labels - (label - '("^[ \t]*\\([a-zA-Z]\\sw*:\\)" (1 font-lock-constant-face))) - - ;; The goto statement and its label - (goto - '("\\(goto\\)[ \t]*,[ \t]*\\([a-zA-Z]\\sw*\\)" - (1 font-lock-keyword-face) - (2 font-lock-constant-face))) - - ;; Tags in structure definitions. Note that this definition - ;; actually collides with labels, so we have to use the same - ;; face. It also matches named subscript ranges, - ;; e.g. vec{bottom:top]. No good way around this. - (structtag - '("\\<\\([a-zA-Z][a-zA-Z0-9_]*:\\)[^:]" (1 font-lock-constant-face))) - - ;; Structure names - (structname - '("\\({\\|\\<inherits\\s-\\)\\s-*\\([a-zA-Z][a-zA-Z0-9_]*\\)[},\t \n]" - (2 font-lock-function-name-face))) - - ;; Keyword parameters, like /xlog or ,xrange=[] - ;; This is anchored to the comma preceding the keyword. - ;; Treats continuation lines, works only during whole buffer - ;; fontification. Slow, use it only in fancy fontification. - (keyword-parameters - '("\\(,\\|[a-zA-Z0-9_](\\)[ \t]*\\(\\$[ \t]*\\(;.*\\)?\n\\([ \t]*\\(;.*\\)?\n\\)*[ \t]*\\)?\\(/[a-zA-Z_]\\sw*\\|[a-zA-Z_]\\sw*[ \t]*=\\)" - (6 font-lock-constant-face))) - - ;; System variables start with a bang. - (system-variables - '("\\(![a-zA-Z_0-9]+\\(\\.\\sw+\\)?\\)" - (1 font-lock-variable-name-face))) - - ;; Special and unusual operators (not used because too noisy) - ;; (special-operators - ;; '("[<>#]" (0 font-lock-keyword-face))) - - ;; All operators (not used because too noisy) - ;; (all-operators - ;; '("[-*^#+<>/]" (0 font-lock-keyword-face))) - - ;; Arrows with text property `idlwave-class' - (class-arrows - '(idlwave-match-class-arrows (0 idlwave-class-arrow-face)))) +(defmacro idlwave--dlet (binders &rest body) + "Like `dlet' but without warnings about non-prefixed var names." + (declare (indent 1) (debug let)) + (let ((vars (mapcar (lambda (binder) + (if (consp binder) (car binder) binder)) + binders))) + `(with-suppressed-warnings ((lexical ,@vars)) + (dlet ,binders ,@body)))) + +(idlwave--dlet + (;; Procedure declarations. Fontify keyword plus procedure name. + ;; Function declarations. Fontify keyword plus function name. + (pros-and-functions + '("\\<\\(function\\|pro\\)\\>[ \t]+\\(\\sw+\\(::\\sw+\\)?\\)" + (1 font-lock-keyword-face) + (2 font-lock-function-name-face nil t))) + + ;; Common blocks + (common-blocks + '("\\<\\(common\\)\\>[ \t]*\\(\\sw+\\)?[ \t]*,?" + (1 font-lock-keyword-face) ; "common" + (2 font-lock-constant-face nil t) ; block name + ("[ \t]*\\(\\sw+\\)[ ,]*" + ;; Start with point after block name and comma + nil nil (1 font-lock-variable-name-face)))) ; variable names + + ;; Batch files + (batch-files + '("^[ \t]*\\(@[^ \t\n]+\\)" (1 font-lock-string-face))) + + ;; Labels + (label + '("^[ \t]*\\([a-zA-Z]\\sw*:\\)" (1 font-lock-constant-face))) + + ;; The goto statement and its label + (goto + '("\\(goto\\)[ \t]*,[ \t]*\\([a-zA-Z]\\sw*\\)" + (1 font-lock-keyword-face) + (2 font-lock-constant-face))) + + ;; Tags in structure definitions. Note that this definition + ;; actually collides with labels, so we have to use the same + ;; face. It also matches named subscript ranges, + ;; e.g. vec{bottom:top]. No good way around this. + (structtag + '("\\<\\([a-zA-Z][a-zA-Z0-9_]*:\\)[^:]" (1 font-lock-constant-face))) + + ;; Structure names + (structname + '("\\({\\|\\<inherits\\s-\\)\\s-*\\([a-zA-Z][a-zA-Z0-9_]*\\)[},\t \n]" + (2 font-lock-function-name-face))) + + ;; Keyword parameters, like /xlog or ,xrange=[] + ;; This is anchored to the comma preceding the keyword. + ;; Treats continuation lines, works only during whole buffer + ;; fontification. Slow, use it only in fancy fontification. + (keyword-parameters + '("\\(,\\|[a-zA-Z0-9_](\\)[ \t]*\\(\\$[ \t]*\\(;.*\\)?\n\\([ \t]*\\(;.*\\)?\n\\)*[ \t]*\\)?\\(/[a-zA-Z_]\\sw*\\|[a-zA-Z_]\\sw*[ \t]*=\\)" + (6 font-lock-constant-face))) + + ;; System variables start with a bang. + (system-variables + '("\\(![a-zA-Z_0-9]+\\(\\.\\sw+\\)?\\)" + (1 font-lock-variable-name-face))) + + ;; Special and unusual operators (not used because too noisy) + ;; (special-operators + ;; '("[<>#]" (0 font-lock-keyword-face))) + + ;; All operators (not used because too noisy) + ;; (all-operators + ;; '("[-*^#+<>/]" (0 font-lock-keyword-face))) + + ;; Arrows with text property `idlwave-class' + (class-arrows + '(idlwave-match-class-arrows (0 idlwave-class-arrow-face)))) (defconst idlwave-font-lock-keywords-1 (list pros-and-functions batch-files) "Subdued level highlighting for IDLWAVE mode.") (defconst idlwave-font-lock-keywords-2 - (mapcar 'symbol-value idlwave-default-font-lock-items) + (mapcar #'symbol-value idlwave-default-font-lock-items) "Medium level highlighting for IDLWAVE mode.") (defconst idlwave-font-lock-keywords-3 - (list pros-and-functions - batch-files - idlwave-idl-keywords - label goto - structtag - structname - common-blocks - keyword-parameters - system-variables + (list pros-and-functions + batch-files + idlwave-idl-keywords + label goto + structtag + structname + common-blocks + keyword-parameters + system-variables class-arrows) "Gaudy level highlighting for IDLWAVE mode.")) @@ -1312,13 +1323,16 @@ blocks starting with a BEGIN statement. The matches must have associations (cons 'call (list (concat "\\(" idlwave-variable "\\) *= *" "\\(" idlwave-method-call "\\s *\\)?" idlwave-identifier - "\\s *(") nil)) + "\\s *(") + nil)) (cons 'call (list (concat "\\(" idlwave-method-call "\\s *\\)?" idlwave-identifier - "\\( *\\($\\|\\$\\)\\|\\s *,\\)") nil)) + "\\( *\\($\\|\\$\\)\\|\\s *,\\)") + nil)) (cons 'assign (list (concat - "\\(" idlwave-variable "\\) *=") nil))) + "\\(" idlwave-variable "\\) *=") + nil))) "Associated list of statement matching regular expressions. Each regular expression matches the start of an IDL statement. @@ -1333,10 +1347,6 @@ list order matters since matching an assignment statement exactly is not possible without parsing. Thus assignment statement become just the leftover unidentified statements containing an equal sign.") -;; FIXME: This var seems to only ever be set, but never actually used! -(defvar idlwave-fill-function 'auto-fill-function - "IDL mode auto fill function.") - (defvar idlwave-comment-indent-function 'comment-indent-function "IDL mode comment indent function.") @@ -1353,28 +1363,9 @@ Normally a space.") (defconst idlwave-mode-version "6.1_em22") -(defmacro idlwave-keyword-abbrev (&rest args) - "Creates a function for abbrev hooks to call `idlwave-check-abbrev' with args." - `(lambda () - ,(append '(idlwave-check-abbrev) args))) - -;; If I take the time I can replace idlwave-keyword-abbrev with -;; idlwave-code-abbrev and remove the quoted abbrev check from -;; idlwave-check-abbrev. Then, e.g, (idlwave-keyword-abbrev 0 t) becomes -;; (idlwave-code-abbrev idlwave-check-abbrev 0 t). In fact I should change -;; the name of idlwave-check-abbrev to something like idlwave-modify-abbrev. - -(defmacro idlwave-code-abbrev (&rest args) - "Creates a function for abbrev hooks that ensures abbrevs are not quoted. -Specifically, if the abbrev is in a comment or string it is unexpanded. -Otherwise ARGS forms a list that is evaluated." - ;; FIXME: it would probably be better to rely on the new :enable-function - ;; to enforce the "don't expand in comments or strings". - `(lambda () - ,(prin1-to-string args) ;; Puts the code in the doc string - (if (idlwave-quoted) - (progn (unexpand-abbrev) nil) - ,(append args)))) +(defun idlwave-keyword-abbrev (&rest args) + "Create a function for abbrev hooks to call `idlwave-modify-abbrev' with args." + (lambda () (append #'idlwave-modify-abbrev args))) (autoload 'idlwave-shell "idlw-shell" "Run an inferior IDL, with I/O through buffer `(idlwave-shell-buffer)'." t) @@ -1388,41 +1379,41 @@ Otherwise ARGS forms a list that is evaluated." (autoload 'idlwave-shell-run-region "idlw-shell" "Compile and run the region." t) -(fset 'idlwave-debug-map (make-sparse-keymap)) +(defalias 'idlwave-debug-map (make-sparse-keymap)) (defvar idlwave-mode-map (let ((map (make-sparse-keymap))) - (define-key map "\C-c " 'idlwave-hard-tab) - (define-key map [(control tab)] 'idlwave-hard-tab) - ;;(define-key map "\C-c\C- " 'idlwave-hard-tab) - (define-key map "'" 'idlwave-show-matching-quote) - (define-key map "\"" 'idlwave-show-matching-quote) - (define-key map "\C-g" 'idlwave-keyboard-quit) - (define-key map "\C-c;" 'idlwave-toggle-comment-region) - (define-key map "\C-\M-a" 'idlwave-beginning-of-subprogram) - (define-key map "\C-\M-e" 'idlwave-end-of-subprogram) - (define-key map "\C-c{" 'idlwave-beginning-of-block) - (define-key map "\C-c}" 'idlwave-end-of-block) - (define-key map "\C-c]" 'idlwave-close-block) - (define-key map [(meta control h)] 'idlwave-mark-subprogram) - (define-key map "\M-\C-n" 'idlwave-forward-block) - (define-key map "\M-\C-p" 'idlwave-backward-block) - (define-key map "\M-\C-d" 'idlwave-down-block) - (define-key map "\M-\C-u" 'idlwave-backward-up-block) - (define-key map "\M-\r" 'idlwave-split-line) - (define-key map "\M-\C-q" 'idlwave-indent-subprogram) - (define-key map "\C-c\C-p" 'idlwave-previous-statement) - (define-key map "\C-c\C-n" 'idlwave-next-statement) - ;; (define-key map "\r" 'idlwave-newline) - ;; (define-key map "\t" 'idlwave-indent-line) - (define-key map [(shift iso-lefttab)] 'idlwave-indent-statement) - (define-key map "\C-c\C-a" 'idlwave-auto-fill-mode) - (define-key map "\M-q" 'idlwave-fill-paragraph) - (define-key map "\M-s" 'idlwave-edit-in-idlde) - (define-key map "\C-c\C-h" 'idlwave-doc-header) - (define-key map "\C-c\C-m" 'idlwave-doc-modification) - (define-key map "\C-c\C-c" 'idlwave-case) - (define-key map "\C-c\C-d" 'idlwave-debug-map) + (define-key map "\C-c " #'idlwave-hard-tab) + (define-key map [(control tab)] #'idlwave-hard-tab) + ;;(define-key map "\C-c\C- " #'idlwave-hard-tab) + (define-key map "'" #'idlwave-show-matching-quote) + (define-key map "\"" #'idlwave-show-matching-quote) + (define-key map "\C-g" #'idlwave-keyboard-quit) + (define-key map "\C-c;" #'idlwave-toggle-comment-region) + (define-key map "\C-\M-a" #'idlwave-beginning-of-subprogram) + (define-key map "\C-\M-e" #'idlwave-end-of-subprogram) + (define-key map "\C-c{" #'idlwave-beginning-of-block) + (define-key map "\C-c}" #'idlwave-end-of-block) + (define-key map "\C-c]" #'idlwave-close-block) + (define-key map [(meta control h)] #'idlwave-mark-subprogram) + (define-key map "\M-\C-n" #'idlwave-forward-block) + (define-key map "\M-\C-p" #'idlwave-backward-block) + (define-key map "\M-\C-d" #'idlwave-down-block) + (define-key map "\M-\C-u" #'idlwave-backward-up-block) + (define-key map "\M-\r" #'idlwave-split-line) + (define-key map "\M-\C-q" #'idlwave-indent-subprogram) + (define-key map "\C-c\C-p" #'idlwave-previous-statement) + (define-key map "\C-c\C-n" #'idlwave-next-statement) + ;; (define-key map "\r" #'idlwave-newline) + ;; (define-key map "\t" #'idlwave-indent-line) + (define-key map [(shift iso-lefttab)] #'idlwave-indent-statement) + (define-key map "\C-c\C-a" #'auto-fill-mode) + (define-key map "\M-q" #'idlwave-fill-paragraph) + (define-key map "\M-s" #'idlwave-edit-in-idlde) + (define-key map "\C-c\C-h" #'idlwave-doc-header) + (define-key map "\C-c\C-m" #'idlwave-doc-modification) + (define-key map "\C-c\C-c" #'idlwave-case) + (define-key map "\C-c\C-d" #'idlwave-debug-map) (when (and (listp idlwave-shell-debug-modifiers) (not (equal idlwave-shell-debug-modifiers '()))) ;; Bind the debug commands also with the special modifiers. @@ -1431,38 +1422,39 @@ Otherwise ARGS forms a list that is evaluated." (delq 'shift (copy-sequence idlwave-shell-debug-modifiers)))) (define-key map (vector (append mods-noshift (list (if shift ?C ?c)))) - 'idlwave-shell-save-and-run) + #'idlwave-shell-save-and-run) (define-key map (vector (append mods-noshift (list (if shift ?B ?b)))) - 'idlwave-shell-break-here) + #'idlwave-shell-break-here) (define-key map (vector (append mods-noshift (list (if shift ?E ?e)))) - 'idlwave-shell-run-region))) - (define-key map "\C-c\C-d\C-c" 'idlwave-shell-save-and-run) - (define-key map "\C-c\C-d\C-b" 'idlwave-shell-break-here) - (define-key map "\C-c\C-d\C-e" 'idlwave-shell-run-region) - (define-key map "\C-c\C-f" 'idlwave-for) - ;; (define-key map "\C-c\C-f" 'idlwave-function) - ;; (define-key map "\C-c\C-p" 'idlwave-procedure) - (define-key map "\C-c\C-r" 'idlwave-repeat) - (define-key map "\C-c\C-w" 'idlwave-while) - (define-key map "\C-c\C-k" 'idlwave-kill-autoloaded-buffers) - (define-key map "\C-c\C-s" 'idlwave-shell) - (define-key map "\C-c\C-l" 'idlwave-shell-recenter-shell-window) - (define-key map "\C-c\C-b" 'idlwave-list-buffer-load-path-shadows) - (define-key map "\C-c\C-v" 'idlwave-find-module) - (define-key map "\C-c\C-t" 'idlwave-find-module-this-file) - (define-key map "\C-c?" 'idlwave-routine-info) - (define-key map "\M-?" 'idlwave-context-help) + #'idlwave-shell-run-region))) + (define-key map "\C-c\C-d\C-c" #'idlwave-shell-save-and-run) + (define-key map "\C-c\C-d\C-b" #'idlwave-shell-break-here) + (define-key map "\C-c\C-d\C-e" #'idlwave-shell-run-region) + (define-key map "\C-c\C-f" #'idlwave-for) + ;; (define-key map "\C-c\C-f" #'idlwave-function) + ;; (define-key map "\C-c\C-p" #'idlwave-procedure) + (define-key map "\C-c\C-r" #'idlwave-repeat) + (define-key map "\C-c\C-w" #'idlwave-while) + (define-key map "\C-c\C-k" #'idlwave-kill-autoloaded-buffers) + (define-key map "\C-c\C-s" #'idlwave-shell) + (define-key map "\C-c\C-l" #'idlwave-shell-recenter-shell-window) + (define-key map "\C-c\C-b" #'idlwave-list-buffer-load-path-shadows) + (define-key map "\C-c\C-v" #'idlwave-find-module) + (define-key map "\C-c\C-t" #'idlwave-find-module-this-file) + (define-key map "\C-c?" #'idlwave-routine-info) + (define-key map "\M-?" #'idlwave-context-help) (define-key map [(control meta ?\?)] - 'idlwave-help-assistant-help-with-topic) + #'idlwave-help-assistant-help-with-topic) ;; Pickup both forms of Esc/Meta binding - (define-key map [(meta tab)] 'idlwave-complete) - (define-key map [?\e?\t] 'idlwave-complete) - (define-key map "\M-\C-i" 'idlwave-complete) - (define-key map "\C-c\C-i" 'idlwave-update-routine-info) - (define-key map "\C-c=" 'idlwave-resolve) - (define-key map [(shift mouse-3)] 'idlwave-mouse-context-help) + ;; FIXME: Use `completion-at-point'! + (define-key map [(meta tab)] #'idlwave-complete) + (define-key map [?\e?\t] #'idlwave-complete) + (define-key map "\M-\C-i" #'idlwave-complete) + (define-key map "\C-c\C-i" #'idlwave-update-routine-info) + (define-key map "\C-c=" #'idlwave-resolve) + (define-key map [(shift mouse-3)] #'idlwave-mouse-context-help) map) "Keymap used in IDL mode.") @@ -1501,28 +1493,15 @@ Otherwise ARGS forms a list that is evaluated." st) "Syntax table that treats symbol characters as word characters.") -(defmacro idlwave-with-special-syntax (&rest body) - "Execute BODY with a different syntax table." - `(let ((saved-syntax (syntax-table))) - (unwind-protect - (progn - (set-syntax-table idlwave-find-symbol-syntax-table) - ,@body) - (set-syntax-table saved-syntax)))) - -;(defmacro idlwave-with-special-syntax1 (&rest body) -; "Execute BODY with a different syntax table." -; `(let ((saved-syntax (syntax-table))) -; (unwind-protect -; (progn -; (set-syntax-table idlwave-find-symbol-syntax-table) -; ,@body) -; (set-syntax-table saved-syntax)))) +;;(defmacro idlwave-with-special-syntax (&rest body) +;; "Execute BODY with `idlwave-find-symbol-syntax-table'." +;; `(with-syntax-table idlwave-find-symbol-syntax-table +;; ,@body)) (defun idlwave-action-and-binding (key cmd &optional select) "KEY and CMD are made into a key binding and an indent action. KEY is a string - same as for the `define-key' function. CMD is a -function of no arguments or a list to be evaluated. CMD is bound to +function of one argument. CMD is bound to KEY in `idlwave-mode-map' by defining an anonymous function calling `self-insert-command' followed by CMD. If KEY contains more than one character a binding will only be set if SELECT is `both'. @@ -1539,62 +1518,59 @@ Otherwise, if SELECT is non-nil then only an action is created. Some examples: No spaces before and 1 after a comma - (idlwave-action-and-binding \",\" \\='(idlwave-surround 0 1)) + (idlwave-action-and-binding \",\" (lambda (_) (idlwave-surround 0 1))) A minimum of 1 space before and after `=' (see `idlwave-expand-equal'). - (idlwave-action-and-binding \"=\" \\='(idlwave-expand-equal -1 -1)) + (idlwave-action-and-binding \"=\" (lambda (_) (idlwave-expand-equal -1 -1))) Capitalize system variables - action only - (idlwave-action-and-binding idlwave-sysvar \\='(capitalize-word 1) t)" + (idlwave-action-and-binding idlwave-sysvar (lambda (_) (capitalize-word 1) t))" (if (not (equal select 'noaction)) ;; Add action (let* ((table (if select 'idlwave-indent-action-table 'idlwave-indent-expand-table)) - (table-key (regexp-quote key)) - (cell (assoc table-key (eval table)))) - (if cell - ;; Replace action command - (setcdr cell cmd) - ;; New action - (set table (append (eval table) (list (cons table-key cmd))))))) + (table-key (regexp-quote key))) + (setf (alist-get table-key (symbol-value table) nil nil #'equal) cmd))) ;; Make key binding for action - (if (or (and (null select) (= (length key) 1)) - (equal select 'noaction) - (equal select 'both)) + (if (if (null select) (= (length key) 1) + (memq select '(noaction both))) + ;; FIXME: Use `post-self-insert-hook'! (define-key idlwave-mode-map key - `(lambda () - (interactive) - (self-insert-command 1) - ,(if (listp cmd) cmd (list cmd)))))) + (lambda () + (interactive) + (self-insert-command 1) + (if (functionp cmd) (funcall cmd nil) (eval cmd t)))))) ;; Set action and key bindings. ;; See description of the function `idlwave-action-and-binding'. ;; Automatically add spaces for the following characters ;; Actions for & are complicated by && -(idlwave-action-and-binding "&" 'idlwave-custom-ampersand-surround) +(idlwave-action-and-binding "&" #'idlwave-custom-ampersand-surround) ;; Automatically add spaces to equal sign if not keyword. This needs ;; to go ahead of > and <, so >= and <= will be treated correctly -(idlwave-action-and-binding "=" '(idlwave-expand-equal -1 -1)) +(idlwave-action-and-binding "=" (lambda (_) (idlwave-expand-equal -1 -1))) ;; Actions for > and < are complicated by >=, <=, and ->... -(idlwave-action-and-binding "<" '(idlwave-custom-ltgtr-surround nil)) -(idlwave-action-and-binding ">" '(idlwave-custom-ltgtr-surround 'gtr)) +(idlwave-action-and-binding "<" (lambda (a) (idlwave-custom-ltgtr-surround nil a))) +(idlwave-action-and-binding ">" (lambda (a) (idlwave-custom-ltgtr-surround t a))) -(idlwave-action-and-binding "," '(idlwave-surround 0 -1 1)) +(idlwave-action-and-binding "," (lambda (a) (idlwave-surround 0 -1 1 a))) ;;; ;;; Abbrev Section ;;; -;;; When expanding abbrevs and the abbrev hook moves backward, an extra -;;; space is inserted (this is the space typed by the user to expanded -;;; the abbrev). -;;; -(defvar idlwave-mode-abbrev-table nil - "Abbreviation table used for IDLWAVE mode.") -(define-abbrev-table 'idlwave-mode-abbrev-table ()) +;; When expanding abbrevs and the abbrev hook moves backward, an extra +;; space is inserted (this is the space typed by the user to expanded +;; the abbrev). +;; FIXME: This can be controlled with `no-self-insert' property. +;; +(define-abbrev-table 'idlwave-mode-abbrev-table () + "Abbreviation table used for IDLWAVE mode." + :enable-function (lambda () (not (idlwave-quoted)))) (defun idlwave-define-abbrev (name expansion hook &optional noprefix table) + ;; FIXME: `table' is never passed. "Define-abbrev with backward compatibility. If NOPREFIX is non-nil, don't prepend prefix character. Installs into @@ -1605,8 +1581,8 @@ If NOPREFIX is non-nil, don't prepend prefix character. Installs into expansion hook))) (condition-case nil - (apply 'define-abbrev (append args '(0 t))) - (error (apply 'define-abbrev args))))) + (apply #'define-abbrev (append args '(0 t))) + (error (apply #'define-abbrev args))))) (condition-case nil (modify-syntax-entry (string-to-char idlwave-abbrev-start-char) @@ -1616,15 +1592,15 @@ If NOPREFIX is non-nil, don't prepend prefix character. Installs into ;; ;; Templates ;; -(idlwave-define-abbrev "c" "" (idlwave-code-abbrev idlwave-case)) -(idlwave-define-abbrev "sw" "" (idlwave-code-abbrev idlwave-switch)) -(idlwave-define-abbrev "f" "" (idlwave-code-abbrev idlwave-for)) -(idlwave-define-abbrev "fu" "" (idlwave-code-abbrev idlwave-function)) -(idlwave-define-abbrev "pr" "" (idlwave-code-abbrev idlwave-procedure)) -(idlwave-define-abbrev "r" "" (idlwave-code-abbrev idlwave-repeat)) -(idlwave-define-abbrev "w" "" (idlwave-code-abbrev idlwave-while)) -(idlwave-define-abbrev "i" "" (idlwave-code-abbrev idlwave-if)) -(idlwave-define-abbrev "elif" "" (idlwave-code-abbrev idlwave-elif)) +(idlwave-define-abbrev "c" "" #'idlwave-case) +(idlwave-define-abbrev "sw" "" #'idlwave-switch) +(idlwave-define-abbrev "f" "" #'idlwave-for) +(idlwave-define-abbrev "fu" "" #'idlwave-function) +(idlwave-define-abbrev "pr" "" #'idlwave-procedure) +(idlwave-define-abbrev "r" "" #'idlwave-repeat) +(idlwave-define-abbrev "w" "" #'idlwave-while) +(idlwave-define-abbrev "i" "" #'idlwave-if) +(idlwave-define-abbrev "elif" "" #'idlwave-elif) ;; ;; Keywords, system functions, conversion routines ;; @@ -1639,15 +1615,15 @@ If NOPREFIX is non-nil, don't prepend prefix character. Installs into (idlwave-define-abbrev "cc" "complex()" (idlwave-keyword-abbrev 1)) (idlwave-define-abbrev "cd" "double()" (idlwave-keyword-abbrev 1)) (idlwave-define-abbrev "e" "else" (idlwave-keyword-abbrev 0 t)) -(idlwave-define-abbrev "ec" "endcase" 'idlwave-show-begin) -(idlwave-define-abbrev "es" "endswitch" 'idlwave-show-begin) -(idlwave-define-abbrev "ee" "endelse" 'idlwave-show-begin) -(idlwave-define-abbrev "ef" "endfor" 'idlwave-show-begin) -(idlwave-define-abbrev "ei" "endif else if" 'idlwave-show-begin) -(idlwave-define-abbrev "el" "endif else" 'idlwave-show-begin) -(idlwave-define-abbrev "en" "endif" 'idlwave-show-begin) -(idlwave-define-abbrev "er" "endrep" 'idlwave-show-begin) -(idlwave-define-abbrev "ew" "endwhile" 'idlwave-show-begin) +(idlwave-define-abbrev "ec" "endcase" #'idlwave-show-begin) +(idlwave-define-abbrev "es" "endswitch" #'idlwave-show-begin) +(idlwave-define-abbrev "ee" "endelse" #'idlwave-show-begin) +(idlwave-define-abbrev "ef" "endfor" #'idlwave-show-begin) +(idlwave-define-abbrev "ei" "endif else if" #'idlwave-show-begin) +(idlwave-define-abbrev "el" "endif else" #'idlwave-show-begin) +(idlwave-define-abbrev "en" "endif" #'idlwave-show-begin) +(idlwave-define-abbrev "er" "endrep" #'idlwave-show-begin) +(idlwave-define-abbrev "ew" "endwhile" #'idlwave-show-begin) (idlwave-define-abbrev "g" "goto," (idlwave-keyword-abbrev 0 t)) (idlwave-define-abbrev "h" "help," (idlwave-keyword-abbrev 0)) (idlwave-define-abbrev "k" "keyword_set()" (idlwave-keyword-abbrev 1)) @@ -1695,15 +1671,15 @@ If NOPREFIX is non-nil, don't prepend prefix character. Installs into (idlwave-define-abbrev "continue" "continue" (idlwave-keyword-abbrev 0 t) t) (idlwave-define-abbrev "do" "do" (idlwave-keyword-abbrev 0 t) t) (idlwave-define-abbrev "else" "else" (idlwave-keyword-abbrev 0 t) t) -(idlwave-define-abbrev "end" "end" 'idlwave-show-begin-check t) -(idlwave-define-abbrev "endcase" "endcase" 'idlwave-show-begin-check t) -(idlwave-define-abbrev "endelse" "endelse" 'idlwave-show-begin-check t) -(idlwave-define-abbrev "endfor" "endfor" 'idlwave-show-begin-check t) -(idlwave-define-abbrev "endif" "endif" 'idlwave-show-begin-check t) -(idlwave-define-abbrev "endrep" "endrep" 'idlwave-show-begin-check t) -(idlwave-define-abbrev "endswitch" "endswitch" 'idlwave-show-begin-check t) -(idlwave-define-abbrev "endwhi" "endwhi" 'idlwave-show-begin-check t) -(idlwave-define-abbrev "endwhile" "endwhile" 'idlwave-show-begin-check t) +(idlwave-define-abbrev "end" "end" #'idlwave-show-begin-check t) +(idlwave-define-abbrev "endcase" "endcase" #'idlwave-show-begin-check t) +(idlwave-define-abbrev "endelse" "endelse" #'idlwave-show-begin-check t) +(idlwave-define-abbrev "endfor" "endfor" #'idlwave-show-begin-check t) +(idlwave-define-abbrev "endif" "endif" #'idlwave-show-begin-check t) +(idlwave-define-abbrev "endrep" "endrep" #'idlwave-show-begin-check t) +(idlwave-define-abbrev "endswitch" "endswitch" #'idlwave-show-begin-check t) +(idlwave-define-abbrev "endwhi" "endwhi" #'idlwave-show-begin-check t) +(idlwave-define-abbrev "endwhile" "endwhile" #'idlwave-show-begin-check t) (idlwave-define-abbrev "eq" "eq" (idlwave-keyword-abbrev 0 t) t) (idlwave-define-abbrev "for" "for" (idlwave-keyword-abbrev 0 t) t) (idlwave-define-abbrev "function" "function" (idlwave-keyword-abbrev 0 t) t) @@ -1763,7 +1739,7 @@ The main features of this mode are Use \\[idlwave-fill-paragraph] to refill a paragraph inside a comment. The indentation of the second line of the paragraph relative to the first will be retained. Use - \\[idlwave-auto-fill-mode] to toggle auto-fill mode for these + \\[auto-fill-mode] to toggle auto-fill mode for these comments. When the variable `idlwave-fill-comment-line-only' is nil, code can also be auto-filled and auto-indented. @@ -1861,7 +1837,7 @@ The main features of this mode are (message "Emacs IDLWAVE mode version %s." idlwave-mode-version)) (setq idlwave-startup-message nil) - (set (make-local-variable 'indent-line-function) 'idlwave-indent-and-action) + (set (make-local-variable 'indent-line-function) #'idlwave-indent-and-action) (set (make-local-variable idlwave-comment-indent-function) #'idlwave-comment-hook) @@ -1875,7 +1851,7 @@ The main features of this mode are (setq abbrev-mode t) - (set (make-local-variable idlwave-fill-function) 'idlwave-auto-fill) + (set (make-local-variable 'normal-auto-fill-function) #'idlwave-auto-fill) (setq comment-end "") (set (make-local-variable 'comment-multi-line) nil) (set (make-local-variable 'paragraph-separate) @@ -1886,26 +1862,27 @@ The main features of this mode are ;; ChangeLog (set (make-local-variable 'add-log-current-defun-function) - 'idlwave-current-routine-fullname) + #'idlwave-current-routine-fullname) ;; Set tag table list to use IDLTAGS as file name. (if (boundp 'tag-table-alist) - (add-to-list 'tag-table-alist '("\\.pro$" . "IDLTAGS"))) + (add-to-list 'tag-table-alist '("\\.pro\\'" . "IDLTAGS"))) ;; Font-lock additions (set (make-local-variable 'font-lock-defaults) idlwave-font-lock-defaults) (set (make-local-variable 'font-lock-mark-block-function) - 'idlwave-mark-subprogram) + #'idlwave-mark-subprogram) (set (make-local-variable 'font-lock-fontify-region-function) - 'idlwave-font-lock-fontify-region) + #'idlwave-font-lock-fontify-region) ;; Imenu setup - (set (make-local-variable 'imenu-create-index-function) - 'imenu-default-create-index-function) + ;;(set (make-local-variable 'imenu-create-index-function) + ;; ;; FIXME: Why set it explicitly to the value it already has? + ;; #'imenu-default-create-index-function) (set (make-local-variable 'imenu-extract-index-name-function) - 'idlwave-unit-name) + #'idlwave-unit-name) (set (make-local-variable 'imenu-prev-index-position-function) - 'idlwave-prev-index-position) + #'idlwave-prev-index-position) ;; HideShow setup (add-to-list 'hs-special-modes-alist @@ -1916,12 +1893,12 @@ The main features of this mode are 'idlwave-forward-block nil)) ;; Make a local post-command-hook and add our hook to it - (add-hook 'post-command-hook 'idlwave-command-hook nil 'local) + (add-hook 'post-command-hook #'idlwave-command-hook nil 'local) ;; Make local hooks for buffer updates - (add-hook 'kill-buffer-hook 'idlwave-kill-buffer-update nil 'local) - (add-hook 'after-save-hook 'idlwave-save-buffer-update nil 'local) - (add-hook 'after-save-hook 'idlwave-revoke-license-to-kill nil 'local) + (add-hook 'kill-buffer-hook #'idlwave-kill-buffer-update nil 'local) + (add-hook 'after-save-hook #'idlwave-save-buffer-update nil 'local) + (add-hook 'after-save-hook #'idlwave-revoke-license-to-kill nil 'local) ;; Setup directories and file, if necessary (idlwave-setup) @@ -1974,29 +1951,27 @@ The main features of this mode are ;;; This stuff is experimental -(defvar idlwave-command-hook nil - "If non-nil, a list that can be evaluated using `eval'. +(defvar idlwave--command-function nil + "If non-nil, a function called from `post-command-hook'. It is evaluated in the lisp function `idlwave-command-hook' which is placed in `post-command-hook'.") (defun idlwave-command-hook () "Command run after every command. -Evaluates a non-nil value of the *variable* `idlwave-command-hook' and +Evaluates a non-nil value of the *variable* `idlwave--command-function' and sets the variable to zero afterwards." - (and idlwave-command-hook - (listp idlwave-command-hook) - (condition-case nil - (eval idlwave-command-hook) - (error nil))) - (setq idlwave-command-hook nil)) + (and idlwave--command-function + (with-demoted-errors "idlwave-command-hook: %S" + (funcall (prog1 idlwave--command-function + (setq idlwave--command-function nil)))))) ;;; End experiment ;; It would be better to use expand.el for better abbrev handling and ;; versatility. -(defun idlwave-check-abbrev (arg &optional reserved) - "Reverse abbrev expansion if in comment or string. +(defun idlwave-modify-abbrev (arg &optional reserved) + "Tweak the abbrev we just expanded. Argument ARG is the number of characters to move point backward if `idlwave-abbrev-move' is non-nil. If optional argument RESERVED is non-nil then the expansion @@ -2006,21 +1981,16 @@ Otherwise, the abbrev will be capitalized if `idlwave-abbrev-change-case' is non-nil, unless its value is `down' in which case the abbrev will be made into all lowercase. Returns non-nil if abbrev is left expanded." - (if (idlwave-quoted) - (progn (unexpand-abbrev) - nil) - (if (and reserved idlwave-reserved-word-upcase) - (upcase-region last-abbrev-location (point)) - (cond - ((equal idlwave-abbrev-change-case 'down) - (downcase-region last-abbrev-location (point))) - (idlwave-abbrev-change-case - (upcase-region last-abbrev-location (point))))) - (if (and idlwave-abbrev-move (> arg 0)) - (if (boundp 'post-command-hook) - (setq idlwave-command-hook (list 'backward-char (1+ arg))) - (backward-char arg))) - t)) + (if (and reserved idlwave-reserved-word-upcase) + (upcase-region last-abbrev-location (point)) + (cond + ((equal idlwave-abbrev-change-case 'down) + (downcase-region last-abbrev-location (point))) + (idlwave-abbrev-change-case + (upcase-region last-abbrev-location (point))))) + (if (and idlwave-abbrev-move (> arg 0)) + (setq idlwave--command-function (lambda () (backward-char (1+ arg))))) + t) (defun idlwave-in-comment () "Return t if point is inside a comment, nil otherwise." @@ -2047,7 +2017,7 @@ Returns point if comment found and nil otherwise." (backward-char 1) (point))))) -(define-obsolete-function-alias 'idlwave-region-active-p 'use-region-p "28.1") +(define-obsolete-function-alias 'idlwave-region-active-p #'use-region-p "28.1") (defun idlwave-show-matching-quote () "Insert quote and show matching quote if this is end of a string." @@ -2067,13 +2037,12 @@ Returns point if comment found and nil otherwise." (defun idlwave-show-begin-check () "Ensure that the previous word was a token before `idlwave-show-begin'. An END token must be preceded by whitespace." - (if (not (idlwave-quoted)) - (if - (save-excursion - (backward-word-strictly 1) - (backward-char 1) - (looking-at "[ \t\n\f]")) - (idlwave-show-begin)))) + (if + (save-excursion + (backward-word-strictly 1) + (backward-char 1) + (looking-at "[ \t\n\f]")) + (idlwave-show-begin))) (defun idlwave-show-begin () "Find the start of current block and blinks to it for a second. @@ -2088,7 +2057,7 @@ Also checks if the correct END statement has been used." begin-pos end-pos end end1 ) (if idlwave-reindent-end (idlwave-indent-line)) (setq last-abbrev-location (marker-position last-abbrev-marker)) - (when (and (idlwave-check-abbrev 0 t) + (when (and (idlwave-modify-abbrev 0 t) idlwave-show-block) (save-excursion ;; Move inside current block @@ -2178,11 +2147,11 @@ Also checks if the correct END statement has been used." (next-char (char-after (point))) (method-invoke (and gtr (eq prev-char ?-))) (len (if method-invoke 2 1))) - (unless (eq next-char ?=) + (unless (eq next-char ?=) ;; Key binding: pad only on left, to save for possible >=/<= (idlwave-surround -1 (if (or is-action method-invoke) -1) len)))) -(defun idlwave-surround (&optional before after length is-action) +(defun idlwave-surround (&optional before after length _is-action) "Surround the LENGTH characters before point with blanks. LENGTH defaults to 1. Optional arguments BEFORE and AFTER affect the behavior before and @@ -2578,7 +2547,7 @@ If there is no label point is not moved and nil is returned." (end (idlwave-find-key ":" 1 'nomark eos))) (if (and end (= (nth 0 (parse-partial-sexp start end)) 0) - (not (string-match "\\?" (buffer-substring start end))) + (not (string-search "?" (buffer-substring start end))) (not (string-match "^::" (buffer-substring end eos)))) (progn (forward-char) @@ -2641,7 +2610,7 @@ statement." (if st (append st (match-end 0)))))) -(defun idlwave-expand-equal (&optional before after is-action) +(defun idlwave-expand-equal (&optional before after _is-action) "Pad `=' with spaces. Two cases: Assignment statement, and keyword assignment. Which case is determined using `idlwave-start-of-substatement' and @@ -2749,10 +2718,10 @@ If the optional argument EXPAND is non-nil then the actions in ;; Before indenting, run action routines. ;; (if (and expand idlwave-do-actions) - (mapc 'idlwave-do-action idlwave-indent-expand-table)) + (mapc #'idlwave-do-action idlwave-indent-expand-table)) ;; (if idlwave-do-actions - (mapc 'idlwave-do-action idlwave-indent-action-table)) + (mapc #'idlwave-do-action idlwave-indent-action-table)) ;; ;; No longer expand abbrevs on the line. The user can do this ;; manually using expand-region-abbrevs. @@ -2781,18 +2750,19 @@ If the optional argument EXPAND is non-nil then the actions in (defun idlwave-do-action (action) "Perform an action repeatedly on a line. ACTION is a list (REG . FUNC). REG is a regular expression. FUNC is -either a function name to be called with `funcall' or a list to be -evaluated with `eval'. The action performed by FUNC should leave -point after the match for REG - otherwise an infinite loop may be -entered. FUNC is always passed a final argument of `is-action', so it +either a function which will be called with one argument `is-action' or +a list to be evaluated with `eval'. +The action performed by FUNC should leave point after the match for REG +- otherwise an infinite loop may be entered. +FUNC is always passed a final argument of `is-action', so it can discriminate between being run as an action, or a key binding." (let ((action-key (car action)) (action-routine (cdr action))) (beginning-of-line) (while (idlwave-look-at action-key) - (if (listp action-routine) - (eval (append action-routine '('is-action))) - (funcall action-routine 'is-action))))) + (if (functionp action-routine) + (funcall action-routine 'is-action) + (eval (append action-routine '('is-action)) t))))) (defun idlwave-indent-to (col &optional min) "Indent from point with spaces until column COL. @@ -3053,7 +3023,7 @@ Return value is the beginning of the match or (in case of failure) nil." (let ((case-fold-search t) (search-func (if (> dir 0) 're-search-forward 're-search-backward)) found) - (idlwave-with-special-syntax + (with-syntax-table idlwave-find-symbol-syntax-table (save-excursion (catch 'exit (while (funcall search-func key-re limit t) @@ -3181,7 +3151,7 @@ If successful leaves point after the match, otherwise, does not move point." (if cont (idlwave-end-of-statement) (end-of-line)) (point))) found) - (idlwave-with-special-syntax + (with-syntax-table idlwave-find-symbol-syntax-table (if beg (idlwave-beginning-of-statement)) (while (and (setq found (re-search-forward regexp eos t)) (idlwave-quoted)))) @@ -3465,25 +3435,7 @@ if `idlwave-auto-fill-split-string' is non-nil." (idlwave-indent-line)) ))))) -(defun idlwave-auto-fill-mode (arg) - "Toggle auto-fill mode for IDL mode. -With arg, turn auto-fill mode on if arg is positive. -In auto-fill mode, inserting a space at a column beyond `fill-column' -automatically breaks the line at a previous space." - (interactive "P") - (prog1 (set idlwave-fill-function - (if (if (null arg) - (not (symbol-value idlwave-fill-function)) - (> (prefix-numeric-value arg) 0)) - 'idlwave-auto-fill - nil)) - ;; update mode-line - (set-buffer-modified-p (buffer-modified-p)))) - -;(defun idlwave-fill-routine-call () -; "Fill a routine definition or statement, indenting appropriately." -; (let ((where (idlwave-where))))) - +(define-obsolete-function-alias 'idlwave-auto-fill-mode #'auto-fill-mode "28.1") (defun idlwave-doc-header (&optional nomark) "Insert a documentation header at the beginning of the unit. @@ -3578,6 +3530,7 @@ Calling from a program, arguments are START END." (defun idlwave-quoted () "Return t if point is in a comment or quoted string. Returns nil otherwise." + ;; FIXME: Use (nth 8 (synx-ppss))! (and (or (idlwave-in-comment) (idlwave-in-quote)) t)) (defun idlwave-in-quote () @@ -3858,7 +3811,7 @@ Intended for `after-save-hook'." (setq idlwave-outlawed-buffers (delq entry idlwave-outlawed-buffers))) ;; Remove this function from the hook. - (remove-hook 'after-save-hook 'idlwave-revoke-license-to-kill 'local))) + (remove-hook 'after-save-hook #'idlwave-revoke-license-to-kill 'local))) (defvar idlwave-path-alist) (defun idlwave-locate-lib-file (file) @@ -4098,10 +4051,10 @@ blank lines." (set (idlwave-sintern-set name 'class idlwave-sint-classes set)) (name))) -(defun idlwave-sintern-dir (dir &optional set) +(defun idlwave-sintern-dir (dir &optional _set) (car (or (member dir idlwave-sint-dirs) (setq idlwave-sint-dirs (cons dir idlwave-sint-dirs))))) -(defun idlwave-sintern-libname (name &optional set) +(defun idlwave-sintern-libname (name &optional _set) (car (or (member name idlwave-sint-libnames) (setq idlwave-sint-libnames (cons name idlwave-sint-libnames))))) @@ -4169,7 +4122,7 @@ the base of the directory." ;; Creating new sintern tables -(defun idlwave-new-sintern-type (tag) +(defmacro idlwave-new-sintern-type (tag) "Define a variable and a function to sintern the new type TAG. This defines the function `idlwave-sintern-TAG' and the variable `idlwave-sint-TAGs'." @@ -4177,15 +4130,15 @@ This defines the function `idlwave-sintern-TAG' and the variable (names (concat name "s")) (var (intern (concat "idlwave-sint-" names))) (func (intern (concat "idlwave-sintern-" name)))) - (set var nil) ; initial value of the association list - (fset func ; set the function - `(lambda (name &optional set) - (cond ((not (stringp name)) name) - ((cdr (assoc (downcase name) ,var))) - (set - (setq ,var (cons (cons (downcase name) name) ,var)) - name) - (name)))))) + `(progn + (defvar ,var nil) ; initial value of the association list + (defun ,func (name &optional set) + (cond ((not (stringp name)) name) + ((cdr (assoc (downcase name) ,var))) + (set + (push (cons (downcase name) name) ,var) + name) + (name)))))) (defun idlwave-reset-sintern-type (tag) "Reset the sintern variable associated with TAG." @@ -4296,12 +4249,12 @@ will re-read the catalog." "-l" (expand-file-name "~/.emacs") "-l" "idlwave" "-f" "idlwave-rescan-catalog-directories")) - (process (apply 'start-process "idlcat" + (process (apply #'start-process "idlcat" nil emacs args))) (setq idlwave-catalog-process process) (set-process-sentinel process - (lambda (pro why) + (lambda (_pro why) (when (string-match "finished" why) (setq idlwave-routines nil idlwave-system-routines nil @@ -4449,7 +4402,7 @@ information updated immediately, leave NO-CONCATENATE nil." (setq idlwave-load-rinfo-idle-timer (run-with-idle-timer idlwave-init-rinfo-when-idle-after - nil 'idlwave-load-rinfo-next-step))) + nil #'idlwave-load-rinfo-next-step))) (error nil)))) ;;------ XML Help routine info system @@ -4935,7 +4888,7 @@ Cache to disk for quick recovery." (setq idlwave-load-rinfo-idle-timer (run-with-idle-timer idlwave-init-rinfo-when-idle-after - nil 'idlwave-load-rinfo-next-step)))))) + nil #'idlwave-load-rinfo-next-step)))))) (defvar idlwave-after-load-rinfo-hook nil) @@ -5109,7 +5062,7 @@ Can run from `after-save-hook'." (error nil))) (push res routine-lists))))) ;; Concatenate the individual lists and return the result - (apply 'nconc routine-lists))) + (apply #'nconc routine-lists))) (defun idlwave-get-buffer-routine-info () "Scan the current buffer for routine info. Return (PRO-LIST FUNC-LIST)." @@ -5185,10 +5138,10 @@ Can run from `after-save-hook'." (if args (concat (if (string= type "function") "(" ", ") - (mapconcat 'identity args ", ") + (mapconcat #'identity args ", ") (if (string= type "function") ")" "")))) (if keywords - (cons nil (mapcar 'list keywords)) ;No help file + (cons nil (mapcar #'list keywords)) ;No help file nil)))) @@ -5246,7 +5199,7 @@ as last time - so no widget will pop up." (cons x (cdr path-entry)) (list x)))) (idlwave-expand-path idlwave-library-path)) - (mapcar 'list (idlwave-expand-path idlwave-library-path))))) + (mapcar #'list (idlwave-expand-path idlwave-library-path))))) ;; Ask the shell for the path and then run the widget (t @@ -5314,7 +5267,7 @@ directories and save the routine info. (widget-insert " ") (widget-create 'push-button :notify - (lambda (&rest ignore) + (lambda (&rest _ignore) (let ((path-list (widget-get idlwave-widget :path-dirs))) (dolist (x path-list) (unless (memq 'lib (cdr x)) @@ -5324,7 +5277,7 @@ directories and save the routine info. (widget-insert " ") (widget-create 'push-button :notify - (lambda (&rest ignore) + (lambda (&rest _ignore) (let ((path-list (widget-get idlwave-widget :path-dirs))) (dolist (x path-list) (idlwave-path-alist-remove-flag x 'user)) @@ -5332,7 +5285,7 @@ directories and save the routine info. "Deselect All") (widget-insert " ") (widget-create 'push-button - :notify (lambda (&rest ignore) + :notify (lambda (&rest _ignore) (kill-buffer (current-buffer))) "Quit") (widget-insert "\n\n") @@ -5340,7 +5293,7 @@ directories and save the routine info. (widget-insert "Select Directories: \n") (setq idlwave-widget - (apply 'widget-create + (apply #'widget-create 'checklist :value (delq nil (mapcar (lambda (x) (if (memq 'user (cdr x)) @@ -5352,7 +5305,8 @@ directories and save the routine info. (list 'item (if (memq 'lib (cdr x)) (concat "[LIB] " (car x) ) - (car x)))) dirs-list))) + (car x)))) + dirs-list))) (widget-put idlwave-widget :path-dirs dirs-list) (widget-insert "\n") (use-local-map widget-keymap) @@ -5360,14 +5314,14 @@ directories and save the routine info. (goto-char (point-min)) (delete-other-windows)) -(defun idlwave-delete-user-catalog-file (&rest ignore) +(defun idlwave-delete-user-catalog-file (&rest _ignore) (if (yes-or-no-p (format "Delete file %s " idlwave-user-catalog-file)) (progn (delete-file idlwave-user-catalog-file) (message "%s has been deleted" idlwave-user-catalog-file)))) -(defun idlwave-widget-scan-user-lib-files (&rest ignore) +(defun idlwave-widget-scan-user-lib-files (&rest _ignore) ;; Call `idlwave-scan-user-lib-files' with data taken from the widget. (let* ((widget idlwave-widget) (selected-dirs (widget-value widget)) @@ -5517,7 +5471,7 @@ be set to nil to disable library catalog scanning." (let ((dirs (if idlwave-library-path (idlwave-expand-path idlwave-library-path) - (mapcar 'car idlwave-path-alist))) + (mapcar #'car idlwave-path-alist))) (old-libname "") dir-entry dir catalog all-routines) (if message-base (message "%s" message-base)) @@ -5730,11 +5684,10 @@ end (defvar idlwave-completion-help-info nil) (defvar idlwave-completion-help-links nil) (defvar idlwave-current-obj_new-class nil) -(defvar idlwave-complete-special nil) -(defvar method-selector) -(defvar class-selector) -(defvar type-selector) -(defvar super-classes) +(defvar idlwave--method-selector) +(defvar idlwave--class-selector) +(defvar idlwave--type-selector) +(defvar idlwave--super-classes) (defun idlwave-complete (&optional arg module class) "Complete a function, procedure or keyword name at point. @@ -5815,8 +5768,7 @@ When we force a method or a method keyword, CLASS can specify the class." (idlwave-complete-filename)) ;; Check for any special completion functions - ((and idlwave-complete-special - (idlwave-call-special idlwave-complete-special))) + ((run-hook-with-args-until-success 'idlwave-complete-functions)) ((null what) (error "Nothing to complete here")) @@ -5829,22 +5781,26 @@ When we force a method or a method keyword, CLASS can specify the class." ((eq what 'procedure) ;; Complete a procedure name (let* ((cw-list (nth 3 where-list)) - (class-selector (idlwave-determine-class cw-list 'pro)) - (super-classes (unless (idlwave-explicit-class-listed cw-list) - (idlwave-all-class-inherits class-selector))) - (isa (concat "procedure" (if class-selector "-method" ""))) - (type-selector 'pro)) + (idlwave--class-selector (idlwave-determine-class cw-list 'pro)) + (idlwave--super-classes + (unless (idlwave-explicit-class-listed cw-list) + (idlwave-all-class-inherits idlwave--class-selector))) + (isa (concat "procedure" + (if idlwave--class-selector "-method" ""))) + (idlwave--type-selector 'pro)) (setq idlwave-completion-help-info - (list 'routine nil type-selector class-selector nil super-classes)) + (list 'routine nil + idlwave--type-selector idlwave--class-selector + nil idlwave--super-classes)) (idlwave-complete-in-buffer - 'procedure (if class-selector 'method 'routine) + 'procedure (if idlwave--class-selector 'method 'routine) (idlwave-routines) 'idlwave-selector (format "Select a %s name%s" isa - (if class-selector + (if idlwave--class-selector (format " (class is %s)" - (if (eq class-selector t) - "unknown" class-selector)) + (if (eq idlwave--class-selector t) + "unknown" idlwave--class-selector)) "")) isa 'idlwave-attach-method-classes 'idlwave-add-file-link-selector))) @@ -5852,22 +5808,25 @@ When we force a method or a method keyword, CLASS can specify the class." ((eq what 'function) ;; Complete a function name (let* ((cw-list (nth 3 where-list)) - (class-selector (idlwave-determine-class cw-list 'fun)) - (super-classes (unless (idlwave-explicit-class-listed cw-list) - (idlwave-all-class-inherits class-selector))) - (isa (concat "function" (if class-selector "-method" ""))) - (type-selector 'fun)) + (idlwave--class-selector (idlwave-determine-class cw-list 'fun)) + (idlwave--super-classes + (unless (idlwave-explicit-class-listed cw-list) + (idlwave-all-class-inherits idlwave--class-selector))) + (isa (concat "function" (if idlwave--class-selector "-method" ""))) + (idlwave--type-selector 'fun)) (setq idlwave-completion-help-info - (list 'routine nil type-selector class-selector nil super-classes)) + (list 'routine nil + idlwave--type-selector idlwave--class-selector + nil idlwave--super-classes)) (idlwave-complete-in-buffer - 'function (if class-selector 'method 'routine) + 'function (if idlwave--class-selector 'method 'routine) (idlwave-routines) 'idlwave-selector (format "Select a %s name%s" isa - (if class-selector + (if idlwave--class-selector (format " (class is %s)" - (if (eq class-selector t) - "unknown" class-selector)) + (if (eq idlwave--class-selector t) + "unknown" idlwave--class-selector)) "")) isa 'idlwave-attach-method-classes 'idlwave-add-file-link-selector))) @@ -5880,11 +5839,12 @@ When we force a method or a method keyword, CLASS can specify the class." ;; Complete a procedure keyword (let* ((where (nth 3 where-list)) (name (car where)) - (method-selector name) - (type-selector 'pro) + (idlwave--method-selector name) + (idlwave--type-selector 'pro) (class (idlwave-determine-class where 'pro)) - (class-selector class) - (super-classes (idlwave-all-class-inherits class-selector)) + (idlwave--class-selector class) + (idlwave--super-classes (idlwave-all-class-inherits + idlwave--class-selector)) (isa (format "procedure%s-keyword" (if class "-method" ""))) (entry (idlwave-best-rinfo-assq name 'pro class (idlwave-routines))) @@ -5894,11 +5854,13 @@ When we force a method or a method keyword, CLASS can specify the class." (error "Nothing known about procedure %s" (idlwave-make-full-name class name))) (setq list (idlwave-fix-keywords name 'pro class list - super-classes system)) + idlwave--super-classes system)) (unless list (error "No keywords available for procedure %s" (idlwave-make-full-name class name))) (setq idlwave-completion-help-info - (list 'keyword name type-selector class-selector entry super-classes)) + (list 'keyword name + idlwave--type-selector idlwave--class-selector + entry idlwave--super-classes)) (idlwave-complete-in-buffer 'keyword 'keyword list nil (format "Select keyword for procedure %s%s" @@ -5913,11 +5875,12 @@ When we force a method or a method keyword, CLASS can specify the class." ;; Complete a function keyword (let* ((where (nth 3 where-list)) (name (car where)) - (method-selector name) - (type-selector 'fun) + (idlwave--method-selector name) + (idlwave--type-selector 'fun) (class (idlwave-determine-class where 'fun)) - (class-selector class) - (super-classes (idlwave-all-class-inherits class-selector)) + (idlwave--class-selector class) + (idlwave--super-classes (idlwave-all-class-inherits + idlwave--class-selector)) (isa (format "function%s-keyword" (if class "-method" ""))) (entry (idlwave-best-rinfo-assq name 'fun class (idlwave-routines))) @@ -5928,7 +5891,7 @@ When we force a method or a method keyword, CLASS can specify the class." (error "Nothing known about function %s" (idlwave-make-full-name class name))) (setq list (idlwave-fix-keywords name 'fun class list - super-classes system)) + idlwave--super-classes system)) ;; OBJ_NEW: Messages mention the proper Init method (setq msg-name (if (and (null class) (string= (upcase name) "OBJ_NEW")) @@ -5938,7 +5901,9 @@ When we force a method or a method keyword, CLASS can specify the class." (unless list (error "No keywords available for function %s" msg-name)) (setq idlwave-completion-help-info - (list 'keyword name type-selector class-selector nil super-classes)) + (list 'keyword name + idlwave--type-selector idlwave--class-selector + nil idlwave--super-classes)) (idlwave-complete-in-buffer 'keyword 'keyword list nil (format "Select keyword for function %s%s" msg-name @@ -5950,7 +5915,9 @@ When we force a method or a method keyword, CLASS can specify the class." (t (error "This should not happen (idlwave-complete)"))))) -(defvar idlwave-complete-special nil +(define-obsolete-variable-alias 'idlwave-complete-special + 'idlwave-complete-functions "28.1") +(defvar idlwave-complete-functions nil "List of special completion functions. These functions are called for each completion. Each function must check if its own special completion context is present. If yes, it @@ -5960,6 +5927,7 @@ complete other contexts will be done. If the function returns nil, other completions will be tried.") (defun idlwave-call-special (functions &rest args) + (declare (obsolete run-hook-with-args-until-success "28.1")) (let ((funcs functions) fun ret) (catch 'exit @@ -6002,9 +5970,9 @@ other completions will be tried.") (list nil-list nil-list 'procedure nil-list nil)) ((eq what 'procedure-keyword) - (let* ((class-selector nil) - (super-classes nil) - (type-selector 'pro) + (let* ((idlwave--class-selector nil) + (idlwave--super-classes nil) + (idlwave--type-selector 'pro) (pro (or module (idlwave-completing-read "Procedure: " (idlwave-routines) 'idlwave-selector)))) @@ -6016,9 +5984,9 @@ other completions will be tried.") (list nil-list nil-list 'function nil-list nil)) ((eq what 'function-keyword) - (let* ((class-selector nil) - (super-classes nil) - (type-selector 'fun) + (let* ((idlwave--class-selector nil) + (idlwave--super-classes nil) + (idlwave--type-selector 'fun) (func (or module (idlwave-completing-read "Function: " (idlwave-routines) 'idlwave-selector)))) @@ -6031,12 +5999,14 @@ other completions will be tried.") ((eq what 'procedure-method-keyword) (let* ((class (idlwave-determine-class class-list 'pro)) - (class-selector class) - (super-classes (idlwave-all-class-inherits class-selector)) - (type-selector 'pro) + (idlwave--class-selector class) + (idlwave--super-classes (idlwave-all-class-inherits + idlwave--class-selector)) + (idlwave--type-selector 'pro) (pro (or module (idlwave-completing-read - (format "Procedure in %s class: " class-selector) + (format "Procedure in %s class: " + idlwave--class-selector) (idlwave-routines) 'idlwave-selector)))) (setq pro (idlwave-sintern-method pro)) (list nil-list nil-list 'procedure-keyword @@ -6047,12 +6017,14 @@ other completions will be tried.") ((eq what 'function-method-keyword) (let* ((class (idlwave-determine-class class-list 'fun)) - (class-selector class) - (super-classes (idlwave-all-class-inherits class-selector)) - (type-selector 'fun) + (idlwave--class-selector class) + (idlwave--super-classes (idlwave-all-class-inherits + idlwave--class-selector)) + (idlwave--type-selector 'fun) (func (or module (idlwave-completing-read - (format "Function in %s class: " class-selector) + (format "Function in %s class: " + idlwave--class-selector) (idlwave-routines) 'idlwave-selector)))) (setq func (idlwave-sintern-method func)) (list nil-list nil-list 'function-keyword @@ -6069,14 +6041,14 @@ other completions will be tried.") (unwind-protect (progn (setq-default completion-ignore-case t) - (apply 'completing-read args)) + (apply #'completing-read args)) (setq-default completion-ignore-case old-value)))) (defvar idlwave-shell-default-directory) (defun idlwave-complete-filename () "Use the comint stuff to complete a file name." (require 'comint) - (let* ((comint-file-name-chars "~/A-Za-z0-9+@:_.$#%={}\\-") + (dlet ((comint-file-name-chars "~/A-Za-z0-9+@:_.$#%={}\\-") (comint-completion-addsuffix nil) (default-directory (if (and (boundp 'idlwave-shell-default-directory) @@ -6110,7 +6082,7 @@ other completions will be tried.") (defun idlwave-rinfo-assq-any-class (name type class list) ;; Return the first matching method on the inheritance list (let* ((classes (cons class (idlwave-all-class-inherits class))) - class rtn) + rtn) ;; class (while classes (if (setq rtn (idlwave-rinfo-assq name type (pop classes) list)) (setq classes nil))) @@ -6127,7 +6099,7 @@ syslib files." list)) syslibp) (when (> (length twins) 1) - (setq twins (sort twins 'idlwave-routine-entry-compare-twins)) + (setq twins (sort twins #'idlwave-routine-entry-compare-twins)) (if (and (null keep-system) (eq 'system (car (nth 3 (car twins)))) (setq syslibp (idlwave-any-syslib (cdr twins))) @@ -6174,7 +6146,7 @@ If yes, return the index (>=1)." TYPE is `fun' or `pro'. When TYPE is not specified, both procedures and functions will be considered." (if (null method) - (mapcar 'car (idlwave-class-alist)) + (mapcar #'car (idlwave-class-alist)) (let (rtn) (mapc (lambda (x) (and (nth 2 x) @@ -6228,9 +6200,11 @@ INFO is as returned by `idlwave-what-function' or `-procedure'." (save-excursion (goto-char apos) (looking-at "->[a-zA-Z][a-zA-Z0-9$_]*::"))))) -(defvar idlwave-determine-class-special nil - "List of special functions for determining class. -Must accept two arguments: `apos' and `info'.") +(define-obsolete-variable-alias 'idlwave-determine-class-special + 'idlwave-determine-class-functions "28.1") +(defvar idlwave-determine-class-functions nil + "Special hook to determine a class. +The functions should accept one argument, APOS.") (defun idlwave-determine-class (info type) ;; Determine the class of a routine call. @@ -6275,10 +6249,10 @@ Must accept two arguments: `apos' and `info'.") ;; Before prompting, try any special class determination routines (when (and (eq t class) - idlwave-determine-class-special (not force-query)) (setq special-class - (idlwave-call-special idlwave-determine-class-special apos)) + (run-hook-with-args-until-success + 'idlwave-determine-class-functions apos)) (if special-class (setq class (idlwave-sintern-class special-class) store idlwave-store-inquired-class))) @@ -6287,7 +6261,7 @@ Must accept two arguments: `apos' and `info'.") (when (and (eq class t) (or force-query query)) (setq class-alist - (mapcar 'list (idlwave-all-method-classes (car info) type))) + (mapcar #'list (idlwave-all-method-classes (car info) type))) (setq class (idlwave-sintern-class (cond @@ -6321,10 +6295,10 @@ Must accept two arguments: `apos' and `info'.") (t class)))) (defun idlwave-selector (a) - (and (eq (nth 1 a) type-selector) - (or (and (nth 2 a) (eq class-selector t)) - (eq (nth 2 a) class-selector) - (memq (nth 2 a) super-classes)))) + (and (eq (nth 1 a) idlwave--type-selector) + (or (and (nth 2 a) (eq idlwave--class-selector t)) + (eq (nth 2 a) idlwave--class-selector) + (memq (nth 2 a) idlwave--super-classes)))) (defun idlwave-add-file-link-selector (a) ;; Record a file link, if any, for the tested names during selection. @@ -6442,7 +6416,7 @@ ARROW: Location of the arrow" func-point (cnt 0) func arrow-start class) - (idlwave-with-special-syntax + (with-syntax-table idlwave-find-symbol-syntax-table (save-restriction (save-excursion (narrow-to-region (max 1 (or bound 0)) (point-max)) @@ -6472,7 +6446,7 @@ ARROW: Location of the arrow" (goto-char pos)) (throw 'exit nil))))))) -(defun idlwave-what-procedure (&optional bound) +(defun idlwave-what-procedure (&optional _bound) ;; Find out if point is within the argument list of a procedure. ;; The return value is ("procedure-name" class arrow-pos (point)). @@ -6562,10 +6536,10 @@ This function is not general, can only be used for completion stuff." (throw 'exit nil))) (t (throw 'exit (preceding-char)))))))) -(defvar idlwave-complete-after-success-form nil - "A form to evaluate after successful completion.") -(defvar idlwave-complete-after-success-form-force nil - "A form to evaluate after completion selection in *Completions* buffer.") +(defvar idlwave--complete-after-success-function #'ignore + "A function to evaluate after successful completion.") +(defvar idlwave--complete-after-success-force-function #'ignore + "A function to evaluate after completion selection in *Completions* buffer.") (defconst idlwave-completion-mark (make-marker) "A mark pointing to the beginning of the completion string.") @@ -6590,12 +6564,12 @@ accumulate information on matching completions." (skip-chars-backward "a-zA-Z0-9_$") (setq slash (eq (preceding-char) ?/) beg (point) - idlwave-complete-after-success-form - (list 'idlwave-after-successful-completion - (list 'quote type) slash beg) - idlwave-complete-after-success-form-force - (list 'idlwave-after-successful-completion - (list 'quote type) slash (list 'quote 'force)))) + idlwave--complete-after-success-function + (lambda () (idlwave-after-successful-completion + type slash beg)) + idlwave--complete-after-success-force-function + (lambda () (idlwave-after-successful-completion + type slash 'force)))) ;; Try a completion (setq part (buffer-substring beg end) @@ -6699,19 +6673,20 @@ accumulate information on matching completions." ;; 'class-tag, for class tags, and otherwise for methods. ;; SHOW-CLASSES is the value of `idlwave-completion-show-classes'. (if (or (null show-classes) ; don't want to see classes - (null class-selector) ; not a method call + (null idlwave--class-selector) ; not a method call (and - (stringp class-selector) ; the class is already known - (not super-classes))) ; no possibilities for inheritance + (stringp idlwave--class-selector) ; the class is already known + (not idlwave--super-classes))) ; no possibilities for inheritance ;; In these cases, we do not have to do anything list (let* ((do-prop (>= show-classes 0)) (do-buf (not (= show-classes 0))) - (do-dots t) - (inherit (if (and (not (eq type 'class-tag)) super-classes) - (cons class-selector super-classes))) + ;; (do-dots t) + (inherit (if (and (not (eq type 'class-tag)) idlwave--super-classes) + (cons idlwave--class-selector idlwave--super-classes))) (max (abs show-classes)) - (lmax (if do-dots (apply 'max (mapcar 'length list)))) + (lmax ;; (if do-dots + (apply #'max (mapcar #'length list))) ;;) classes nclasses class-info space) (mapcar (lambda (x) @@ -6720,13 +6695,14 @@ accumulate information on matching completions." ;; Just one class for tags (setq classes (list - (idlwave-class-or-superclass-with-tag class-selector x))) + (idlwave-class-or-superclass-with-tag + idlwave--class-selector x))) ;; Multiple classes for method or method-keyword (setq classes (if (eq type 'kwd) (idlwave-all-method-keyword-classes - method-selector x type-selector) - (idlwave-all-method-classes x type-selector))) + idlwave--method-selector x idlwave--type-selector) + (idlwave-all-method-classes x idlwave--type-selector))) (if inherit (setq classes (delq nil @@ -6734,22 +6710,22 @@ accumulate information on matching completions." classes))))) (setq nclasses (length classes)) ;; Make the separator between item and class-info - (if do-dots - (setq space (concat " " (make-string (- lmax (length x)) ?.))) - (setq space " ")) + ;; (if do-dots + (setq space (concat " " (make-string (- lmax (length x)) ?.))) + ;; (setq space " ")) (if do-buf ;; We do want info in the buffer (if (<= nclasses max) (setq class-info (concat space - "<" (mapconcat 'identity classes ",") ">")) + "<" (mapconcat #'identity classes ",") ">")) (setq class-info (format "%s<%d classes>" space nclasses))) (setq class-info nil)) (when do-prop ;; We do want properties (setq x (copy-sequence x)) (put-text-property 0 (length x) - 'help-echo (mapconcat 'identity classes " ") + 'help-echo (mapconcat #'identity classes " ") x)) (if class-info (list x class-info) @@ -6839,7 +6815,7 @@ sort the list before displaying." (nth 2 last-command)) (progn (select-window win) - (eval idlwave-complete-after-success-form)) + (funcall idlwave--complete-after-success-function)) (set-window-start cwin (point-min))))) (and message (message "%s" message))) (select-window win)))) @@ -6882,7 +6858,7 @@ sort the list before displaying." (skip-chars-backward "a-zA-Z0-9_") (point)))) (remove-text-properties beg (point) '(face nil)))) - (eval idlwave-complete-after-success-form-force)) + (funcall idlwave--complete-after-success-force-function)) (defun idlwave-keyboard-quit () (interactive) @@ -6990,16 +6966,15 @@ If these don't exist, a letter in the string is automatically selected." (defun idlwave-local-value (var &optional buffer) "Return the value of VAR in BUFFER, but only if VAR is local to BUFFER." - (with-current-buffer (or buffer (current-buffer)) - (and (local-variable-p var (current-buffer)) - (symbol-value var)))) + (when (local-variable-p var buffer) + (buffer-local-value var (or buffer (current-buffer))))) (defvar idlwave-completion-map nil "Keymap for `completion-list-mode' with `idlwave-complete'.") -(defun idlwave-default-choose-completion (&rest args) - "Execute `default-choose-completion' and then restore the win-conf." - (apply 'idlwave-choose 'default-choose-completion args)) +;; (defun idlwave-default-choose-completion (&rest args) +;; "Execute `default-choose-completion' and then restore the win-conf." +;; (apply #'idlwave-choose #'default-choose-completion args)) (define-obsolete-function-alias 'idlwave-display-completion-list-emacs #'idlwave-display-completion-list-1 "28.1") @@ -7021,14 +6996,14 @@ If these don't exist, a letter in the string is automatically selected." "Replace `choose-completion' in OLD-MAP." (let ((new-map (copy-keymap old-map))) (substitute-key-definition - 'choose-completion 'idlwave-choose-completion new-map) - (define-key new-map [mouse-3] 'idlwave-mouse-completion-help) + #'choose-completion #'idlwave-choose-completion new-map) + (define-key new-map [mouse-3] #'idlwave-mouse-completion-help) new-map)) (defun idlwave-choose-completion (&rest args) "Choose the completion that point is in or next to." (interactive (list last-nonmenu-event)) - (apply 'idlwave-choose 'choose-completion args)) + (apply #'idlwave-choose #'choose-completion args)) (define-obsolete-function-alias 'idlwave-mouse-choose-completion #'idlwave-choose-completion "28.1") @@ -7278,8 +7253,8 @@ class/struct definition." (defun idlwave-all-class-tags (class) "Return a list of native and inherited tags in CLASS." (condition-case err - (apply 'append (mapcar 'idlwave-class-tags - (cons class (idlwave-all-class-inherits class)))) + (apply #'append (mapcar #'idlwave-class-tags + (cons class (idlwave-all-class-inherits class)))) (error (idlwave-class-tag-reset) (error "%s" (error-message-string err))))) @@ -7369,10 +7344,9 @@ property indicating the link is added." (defvar idlwave-current-class-tags nil) (defvar idlwave-current-native-class-tags nil) (defvar idlwave-sint-class-tags nil) -(declare-function idlwave-sintern-class-tag "idlwave" t t) -(idlwave-new-sintern-type 'class-tag) -(add-to-list 'idlwave-complete-special 'idlwave-complete-class-structure-tag) -(add-hook 'idlwave-update-rinfo-hook 'idlwave-class-tag-reset) +(idlwave-new-sintern-type class-tag) +(add-hook 'idlwave-complete-functions #'idlwave-complete-class-structure-tag) +(add-hook 'idlwave-update-rinfo-hook #'idlwave-class-tag-reset) (defun idlwave-complete-class-structure-tag () "Complete a structure tag on a `self' argument in an object method." @@ -7384,25 +7358,26 @@ property indicating the link is added." (skip-chars-backward "a-zA-Z0-9._$") (and (< (point) (- pos 4)) (looking-at "self\\."))) - (let* ((class-selector (nth 2 (idlwave-current-routine))) - (super-classes (idlwave-all-class-inherits class-selector))) + (let* ((idlwave--class-selector (nth 2 (idlwave-current-routine))) + (idlwave--super-classes (idlwave-all-class-inherits + idlwave--class-selector))) ;; Check if we are in a class routine - (unless class-selector + (unless idlwave--class-selector (error "Not in a method procedure or function")) ;; Check if we need to update the "current" class - (if (not (equal class-selector idlwave-current-tags-class)) - (idlwave-prepare-class-tag-completion class-selector)) + (if (not (equal idlwave--class-selector idlwave-current-tags-class)) + (idlwave-prepare-class-tag-completion idlwave--class-selector)) (setq idlwave-completion-help-info (list 'idlwave-complete-class-structure-tag-help (idlwave-sintern-routine - (concat class-selector "__define")) + (concat idlwave--class-selector "__define")) nil)) ;; FIXME: idlwave-cpl-bold doesn't seem used anywhere. - (let ((idlwave-cpl-bold idlwave-current-native-class-tags)) + (let ((_idlwave-cpl-bold idlwave-current-native-class-tags)) (idlwave-complete-in-buffer 'class-tag 'class-tag idlwave-current-class-tags nil - (format "Select a tag of class %s" class-selector) + (format "Select a tag of class %s" idlwave--class-selector) "class tag" 'idlwave-attach-class-tag-classes)) t) ; return t to skip other completions @@ -7420,7 +7395,7 @@ property indicating the link is added." (list (idlwave-sintern-class-tag x 'set))) (idlwave-all-class-tags class))) (setq idlwave-current-native-class-tags - (mapcar 'downcase (idlwave-class-tags class)))) + (mapcar #'downcase (idlwave-class-tags class)))) ;=========================================================================== ;; @@ -7429,13 +7404,11 @@ property indicating the link is added." (defvar idlwave-sint-sysvars nil) (defvar idlwave-sint-sysvartags nil) -(declare-function idlwave-sintern-sysvar "idlwave" t t) -(declare-function idlwave-sintern-sysvartag "idlwave" t t) -(idlwave-new-sintern-type 'sysvar) -(idlwave-new-sintern-type 'sysvartag) -(add-to-list 'idlwave-complete-special 'idlwave-complete-sysvar-or-tag) -(add-hook 'idlwave-update-rinfo-hook 'idlwave-sysvars-reset) -(add-hook 'idlwave-after-load-rinfo-hook 'idlwave-sintern-sysvar-alist) +(idlwave-new-sintern-type sysvar) +(idlwave-new-sintern-type sysvartag) +(add-hook 'idlwave-complete-functions #'idlwave-complete-sysvar-or-tag) +(add-hook 'idlwave-update-rinfo-hook #'idlwave-sysvars-reset) +(add-hook 'idlwave-after-load-rinfo-hook #'idlwave-sintern-sysvar-alist) (defun idlwave-complete-sysvar-or-tag () @@ -7591,7 +7564,7 @@ associated TAG, if any." (let ((text idlwave-shell-command-output) (start 0) (old idlwave-system-variables-alist) - var tags type name class link old-entry) + var tags link old-entry) ;; type name class (setq idlwave-system-variables-alist nil) (while (string-match "^IDLWAVE-SYSVAR: !\\([a-zA-Z0-9_$]+\\)\\( \\(.*\\)\\)?" text start) @@ -7611,7 +7584,8 @@ associated TAG, if any." (cdr (assq (idlwave-sintern-sysvartag x) (cdr (assq 'tags old-entry)))))) - tags)) link) + tags)) + link) idlwave-system-variables-alist))) ;; Keep the old value if query was not successful (setq idlwave-system-variables-alist @@ -7627,15 +7601,6 @@ associated TAG, if any." (put-text-property (match-beginning 0) (match-end 0) 'face 'font-lock-string-face)))))) -(defun idlwave-uniquify (list) - (let ((ht (make-hash-table :size (length list) :test 'equal))) - (delq nil - (mapcar (lambda (x) - (unless (gethash x ht) - (puthash x t ht) - x)) - list)))) - (defun idlwave-after-successful-completion (type slash &optional verify) "Add `=' or `(' after successful completion of keyword and function. Restore the pre-completion window configuration if possible." @@ -7700,7 +7665,7 @@ itself." (setq this-command last-command) (idlwave-do-mouse-completion-help ev)) -(defun idlwave-routine-info (&optional arg external) +(defun idlwave-routine-info (&optional arg _external) "Display a routines calling sequence and list of keywords. When point is on the name a function or procedure, or in the argument list of a function or procedure, this command displays a help buffer with @@ -7712,9 +7677,9 @@ arg, the class property is cleared out." (interactive "P") (idlwave-routines) - (if (string-match "->" (buffer-substring - (max (point-min) (1- (point))) - (min (+ 2 (point)) (point-max)))) + (if (string-search "->" (buffer-substring + (max (point-min) (1- (point))) + (min (+ 2 (point)) (point-max)))) ;; Cursor is on an arrow (if (get-text-property (point) 'idlwave-class) ;; arrow has class property @@ -7737,7 +7702,7 @@ arg, the class property is cleared out." (idlwave-force-class-query (equal arg '(4))) (module (idlwave-what-module))) (if (car module) - (apply 'idlwave-display-calling-sequence + (apply #'idlwave-display-calling-sequence (idlwave-fix-module-if-obj_new module)) (error "Don't know which calling sequence to show"))))) @@ -7820,7 +7785,7 @@ force class query for object methods." (name (idlwave-completing-read (if (or (not this-buffer) (assoc default list)) - (format "Module (Default %s): " default) + (format-prompt "Module" default) (format "Module in this file: ")) list)) type class) @@ -7954,7 +7919,7 @@ Used by `idlwave-routine-info' and `idlwave-find-module'." (stringp class)) (list (car module) (nth 1 module) - (apply 'idlwave-find-inherited-class module)) + (apply #'idlwave-find-inherited-class module)) module))) (defun idlwave-find-inherited-class (name type class) @@ -7979,7 +7944,7 @@ appropriate Init method." (setq string (buffer-substring (point) pos)) (string-match "obj_new([^'\"]*['\"]\\([a-zA-Z0-9_]+\\)" string))) - (let ((name "Init") + (let (;; (name "Init") (class (match-string 1 string))) (setq module (list (idlwave-sintern-method "Init") 'fun @@ -7992,7 +7957,8 @@ appropriate Init method." Translate OBJ_NEW, adding all super-class keywords, or all keywords from all classes if CLASS equals t. If SYSTEM is non-nil, don't demand _EXTRA in the keyword list." - (let ((case-fold-search t)) + (let ((case-fold-search t) + (idlwave--super-classes super-classes)) ;; If this is the OBJ_NEW function, try to figure out the class and use ;; the keywords from the corresponding INIT method. @@ -8013,7 +7979,8 @@ demand _EXTRA in the keyword list." (idlwave-sintern-method "INIT") 'fun class - (idlwave-routines)) 'do-link)))))) + (idlwave-routines)) + 'do-link)))))) ;; If the class is t, combine all keywords of all methods NAME (when (eq class t) @@ -8030,7 +7997,7 @@ demand _EXTRA in the keyword list." ;; If we have inheritance, add all keywords from superclasses, if ;; the user indicated that method in `idlwave-keyword-class-inheritance' (when (and - super-classes + idlwave--super-classes idlwave-keyword-class-inheritance (stringp class) (or @@ -8045,7 +8012,7 @@ demand _EXTRA in the keyword list." (cl-loop for entry in (idlwave-routines) do (and (nth 2 entry) ; non-nil class - (memq (nth 2 entry) super-classes) ; an inherited class + (memq (nth 2 entry) idlwave--super-classes) ;an inherited class (eq (nth 1 entry) type) ; correct type (eq (car entry) name) ; correct name (mapc (lambda (k) (add-to-list 'keywords k)) @@ -8095,16 +8062,16 @@ If we do not know about MODULE, just return KEYWORD literally." (defvar idlwave-rinfo-mouse-map (let ((map (make-sparse-keymap))) - (define-key map [mouse-2] 'idlwave-mouse-active-rinfo) - (define-key map [(shift mouse-2)] 'idlwave-mouse-active-rinfo-shift) - (define-key map [mouse-3] 'idlwave-mouse-active-rinfo-right) - (define-key map " " 'idlwave-active-rinfo-space) - (define-key map "q" 'idlwave-quit-help) + (define-key map [mouse-2] #'idlwave-mouse-active-rinfo) + (define-key map [(shift mouse-2)] #'idlwave-mouse-active-rinfo-shift) + (define-key map [mouse-3] #'idlwave-mouse-active-rinfo-right) + (define-key map " " #'idlwave-active-rinfo-space) + (define-key map "q" #'idlwave-quit-help) map)) (defvar idlwave-rinfo-map (let ((map (make-sparse-keymap))) - (define-key map "q" 'idlwave-quit-help) + (define-key map "q" #'idlwave-quit-help) map)) (defvar idlwave-popup-source nil) @@ -8151,7 +8118,7 @@ If we do not know about MODULE, just return KEYWORD literally." (data (list name type class (current-buffer) nil initial-class)) (face 'idlwave-help-link) beg props win cnt total) - ;; Fix keywords, but don't add chained super-classes, since these + ;; Fix keywords, but don't add chained idlwave--super-classes, since these ;; are shown separately for that super-class (setq keywords (idlwave-fix-keywords name type class keywords)) (cond @@ -8336,7 +8303,7 @@ to it." (add-text-properties beg (point) (list 'face 'bold))) (when (and file (not (equal file ""))) (setq beg (point)) - (insert (apply 'abbreviate-file-name (list file))) + (insert (apply #'abbreviate-file-name (list file))) (if file-props (add-text-properties beg (point) file-props))))) @@ -8441,9 +8408,9 @@ was pressed." idlwave-keyword-completion-adds-equal) (insert "="))))) -(defun idlwave-list-buffer-load-path-shadows (&optional arg) +(defun idlwave-list-buffer-load-path-shadows (&optional _arg) "List the load path shadows of all routines defined in current buffer." - (interactive "P") + (interactive) (idlwave-routines) (if (derived-mode-p 'idlwave-mode) (idlwave-list-load-path-shadows @@ -8451,13 +8418,13 @@ was pressed." "in current buffer") (error "Current buffer is not in idlwave-mode"))) -(defun idlwave-list-shell-load-path-shadows (&optional arg) +(defun idlwave-list-shell-load-path-shadows (&optional _arg) "List the load path shadows of all routines compiled under the shell. This is very useful for checking an IDL application. Just compile the application, do RESOLVE_ALL, and `C-c C-i' to compile all referenced routines and update IDLWAVE internal info. Then check for shadowing with this command." - (interactive "P") + (interactive) (cond ((or (not (fboundp 'idlwave-shell-is-running)) (not (idlwave-shell-is-running))) @@ -8468,15 +8435,15 @@ with this command." (idlwave-list-load-path-shadows nil idlwave-compiled-routines "in the shell")))) -(defun idlwave-list-all-load-path-shadows (&optional arg) +(defun idlwave-list-all-load-path-shadows (&optional _arg) "List the load path shadows of all routines known to IDLWAVE." - (interactive "P") + (interactive) (idlwave-list-load-path-shadows nil nil "globally")) (defvar idlwave-sort-prefer-buffer-info t "Internal variable used to influence `idlwave-routine-twin-compare'.") -(defun idlwave-list-load-path-shadows (arg &optional special-routines loc) +(defun idlwave-list-load-path-shadows (_arg &optional special-routines loc) "List the routines which are defined multiple times. Search the information IDLWAVE has about IDL routines for multiple definitions. @@ -8525,12 +8492,12 @@ can be used to detect possible name clashes during this process." (lambda (ev) (interactive "e") (mouse-set-point ev) - (apply 'idlwave-do-find-module + (apply #'idlwave-do-find-module (get-text-property (point) 'find-args)))) (define-key keymap [(return)] (lambda () (interactive) - (apply 'idlwave-do-find-module + (apply #'idlwave-do-find-module (get-text-property (point) 'find-args)))) (message "Compiling list...( 0%%)") (with-current-buffer (get-buffer-create "*Shadows*") @@ -8606,6 +8573,10 @@ ENTRY will also be returned, as the first item of this list." (push candidate twins)) (cons entry (nreverse twins)))) +;; Bound in idlwave-study-twins,idlwave-routine-entry-compare-twins. +(defvar idlwave-twin-class) +(defvar idlwave-twin-name) + (defun idlwave-study-twins (entries) "Return dangerous twins of first entry in ENTRIES. Dangerous twins are routines with same name, but in different files on @@ -8618,7 +8589,7 @@ routines, and may have been scanned." (type (nth 1 entry)) ; Must be bound for (idlwave-twin-class (nth 2 entry)) ; idlwave-routine-twin-compare (cnt 0) - source type type-cons file alist syslibp key) + source type-cons file alist syslibp key) (while (setq entry (pop entries)) (cl-incf cnt) (setq source (nth 3 entry) @@ -8654,12 +8625,12 @@ routines, and may have been scanned." (when (and (idlwave-syslib-scanned-p) (setq entry (assoc 'system alist))) (setcar entry 'builtin)) - (sort alist 'idlwave-routine-twin-compare))) + (sort alist #'idlwave-routine-twin-compare))) ;; FIXME: Dynamically scoped vars need to use the `idlwave-' prefix. ;; (defvar type) -(define-obsolete-function-alias 'idlwave-xor 'xor "27.1") +(define-obsolete-function-alias 'idlwave-xor #'xor "27.1") (defun idlwave-routine-entry-compare (a b) "Compare two routine info entries for sorting. @@ -8690,7 +8661,7 @@ names and path locations." "Compare two routine entries, under the assumption that they are twins. This basically calls `idlwave-routine-twin-compare' with the correct args." (let* ((idlwave-twin-name (car a)) - (type (nth 1 a)) + ;; (type (nth 1 a)) (idlwave-twin-class (nth 2 a)) ; used in idlwave-routine-twin-compare (asrc (nth 3 a)) (atype (car asrc)) @@ -8706,10 +8677,6 @@ This basically calls `idlwave-routine-twin-compare' with the correct args." (list (file-truename bfile) bfile (list btype)) (list btype bfile (list btype)))))) -;; Bound in idlwave-study-twins,idlwave-routine-entry-compare-twins. -(defvar idlwave-twin-class) -(defvar idlwave-twin-name) - (defun idlwave-routine-twin-compare (a b) "Compare two routine twin entries for sorting. In here, A and B are not normal routine info entries, but special @@ -8809,9 +8776,7 @@ This expects NAME TYPE IDLWAVE-TWIN-CLASS to be bound to the right values." (defun idlwave-path-alist-add-flag (list-entry flag) "Add a flag to the path list entry, if not set." - (let ((flags (cdr list-entry))) - (add-to-list 'flags flag) - (setcdr list-entry flags))) + (cl-pushnew flag (cdr list-entry) :test #'equal)) (defun idlwave-path-alist-remove-flag (list-entry flag) "Remove a flag to the path list entry, if set." @@ -8920,8 +8885,8 @@ Assumes that point is at the beginning of the unit as found by ["(Un)Comment Region" idlwave-toggle-comment-region t] ["Continue/Split line" idlwave-split-line t] "--" - ["Toggle Auto Fill" idlwave-auto-fill-mode :style toggle - :selected (symbol-value idlwave-fill-function)]) + ["Toggle Auto Fill" auto-fill-mode :style toggle + :selected auto-fill-function]) ("Templates" ["Procedure" idlwave-procedure t] ["Function" idlwave-function t] @@ -9069,7 +9034,7 @@ With arg, list all abbrevs with the corresponding hook. This function was written since `list-abbrevs' looks terrible for IDLWAVE mode." (interactive "P") - (let ((table (symbol-value 'idlwave-mode-abbrev-table)) + (let ((table idlwave-mode-abbrev-table) abbrevs str rpl func fmt (len-str 0) (len-rpl 0)) (mapatoms @@ -9127,6 +9092,9 @@ This function was written since `list-abbrevs' looks terrible for IDLWAVE mode." ;; Run the hook (run-hooks 'idlwave-load-hook) +;; Obsolete. +(define-obsolete-function-alias 'idlwave-uniquify #'seq-uniq "28.1") + (provide 'idlwave) ;;; idlwave.el ends here diff --git a/lisp/progmodes/inf-lisp.el b/lisp/progmodes/inf-lisp.el index ac230596240..e69a9ff394e 100644 --- a/lisp/progmodes/inf-lisp.el +++ b/lisp/progmodes/inf-lisp.el @@ -1,7 +1,6 @@ -;;; inf-lisp.el --- an inferior-lisp mode +;;; inf-lisp.el --- an inferior-lisp mode -*- lexical-binding: t -*- -;; Copyright (C) 1988, 1993-1994, 2001-2021 Free Software Foundation, -;; Inc. +;; Copyright (C) 1988-2021 Free Software Foundation, Inc. ;; Author: Olin Shivers <shivers@cs.cmu.edu> ;; Keywords: processes, lisp @@ -23,13 +22,13 @@ ;;; Commentary: -;; Hacked from tea.el by Olin Shivers (shivers@cs.cmu.edu). 8/88 +;; Hacked from tea.el by Olin Shivers (shivers@cs.cmu.edu). 8/88 ;; This file defines a lisp-in-a-buffer package (inferior-lisp mode) ;; built on top of comint mode. This version is more featureful, ;; robust, and uniform than the Emacs 18 version. The key bindings are ;; also more compatible with the bindings of Hemlock and Zwei (the -;; Lisp Machine emacs). +;; Lisp Machine Emacs). ;; Since this mode is built on top of the general command-interpreter-in- ;; a-buffer mode (comint mode), it shares a common base functionality, @@ -40,19 +39,19 @@ ;; the hooks available for customizing it, see the file comint.el. ;; For further information on inferior-lisp mode, see the comments below. -;; Needs fixin: +;; Needs fixing: ;; The load-file/compile-file default mechanism could be smarter -- it ;; doesn't know about the relationship between filename extensions and -;; whether the file is source or executable. If you compile foo.lisp +;; whether the file is source or executable. If you compile foo.lisp ;; with compile-file, then the next load-file should use foo.bin for -;; the default, not foo.lisp. This is tricky to do right, particularly +;; the default, not foo.lisp. This is tricky to do right, particularly ;; because the extension for executable files varies so much (.o, .bin, ;; .lbin, .mo, .vo, .ao, ...). ;; ;; It would be nice if inferior-lisp (and inferior scheme, T, ...) modes ;; had a verbose minor mode wherein sending or compiling defuns, etc. ;; would be reflected in the transcript with suitable comments, e.g. -;; ";;; redefining fact". Several ways to do this. Which is right? +;; ";;; redefining fact". Several ways to do this. Which is right? ;; ;; When sending text from a source file to a subprocess, the process-mark can ;; move off the window, so you can lose sight of the process interactions. @@ -63,6 +62,7 @@ (require 'comint) (require 'lisp-mode) +(require 'shell) (defgroup inferior-lisp nil @@ -76,25 +76,24 @@ Input matching this regexp is not saved on the input history in Inferior Lisp mode. Default is whitespace followed by 0 or 1 single-letter colon-keyword \(as in :a, :c, etc.)" - :type 'regexp - :group 'inferior-lisp) + :type 'regexp) (defvar inferior-lisp-mode-map (let ((map (copy-keymap comint-mode-map))) (set-keymap-parent map lisp-mode-shared-map) - (define-key map "\C-x\C-e" 'lisp-eval-last-sexp) - (define-key map "\C-c\C-l" 'lisp-load-file) - (define-key map "\C-c\C-k" 'lisp-compile-file) - (define-key map "\C-c\C-a" 'lisp-show-arglist) - (define-key map "\C-c\C-d" 'lisp-describe-sym) - (define-key map "\C-c\C-f" 'lisp-show-function-documentation) - (define-key map "\C-c\C-v" 'lisp-show-variable-documentation) + (define-key map "\C-x\C-e" #'lisp-eval-last-sexp) + (define-key map "\C-c\C-l" #'lisp-load-file) + (define-key map "\C-c\C-k" #'lisp-compile-file) + (define-key map "\C-c\C-a" #'lisp-show-arglist) + (define-key map "\C-c\C-d" #'lisp-describe-sym) + (define-key map "\C-c\C-f" #'lisp-show-function-documentation) + (define-key map "\C-c\C-v" #'lisp-show-variable-documentation) map)) (easy-menu-define inferior-lisp-menu inferior-lisp-mode-map - "Inferior Lisp Menu" + "Inferior Lisp Menu." '("Inf-Lisp" ["Eval Last Sexp" lisp-eval-last-sexp t] "--" @@ -108,20 +107,20 @@ mode. Default is whitespace followed by 0 or 1 single-letter colon-keyword ;;; These commands augment Lisp mode, so you can process Lisp code in ;;; the source files. -(define-key lisp-mode-map "\M-\C-x" 'lisp-eval-defun) ; GNU convention -(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) -(define-key lisp-mode-map "\C-c\C-k" 'lisp-compile-file) ; "kompile" file -(define-key lisp-mode-map "\C-c\C-a" 'lisp-show-arglist) -(define-key lisp-mode-map "\C-c\C-d" 'lisp-describe-sym) -(define-key lisp-mode-map "\C-c\C-f" 'lisp-show-function-documentation) -(define-key lisp-mode-map "\C-c\C-v" 'lisp-show-variable-documentation) +(define-key lisp-mode-map "\M-\C-x" #'lisp-eval-defun) ; GNU convention +(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) +(define-key lisp-mode-map "\C-c\C-k" #'lisp-compile-file) ; "kompile" file +(define-key lisp-mode-map "\C-c\C-a" #'lisp-show-arglist) +(define-key lisp-mode-map "\C-c\C-d" #'lisp-describe-sym) +(define-key lisp-mode-map "\C-c\C-f" #'lisp-show-function-documentation) +(define-key lisp-mode-map "\C-c\C-v" #'lisp-show-variable-documentation) ;; This function exists for backwards compatibility. @@ -134,29 +133,27 @@ mode. Default is whitespace followed by 0 or 1 single-letter colon-keyword ;;; (with-eval-after-load 'inf-lisp 'inferior-lisp-install-letter-bindings) ;;;You can modify this function to install just the bindings you want." (defun inferior-lisp-install-letter-bindings () - (define-key lisp-mode-map "\C-ce" 'lisp-eval-defun-and-go) - (define-key lisp-mode-map "\C-cr" 'lisp-eval-region-and-go) - (define-key lisp-mode-map "\C-cc" 'lisp-compile-defun-and-go) - (define-key lisp-mode-map "\C-cz" 'switch-to-lisp) - (define-key lisp-mode-map "\C-cl" 'lisp-load-file) - (define-key lisp-mode-map "\C-ck" 'lisp-compile-file) - (define-key lisp-mode-map "\C-ca" 'lisp-show-arglist) - (define-key lisp-mode-map "\C-cd" 'lisp-describe-sym) - (define-key lisp-mode-map "\C-cf" 'lisp-show-function-documentation) - (define-key lisp-mode-map "\C-cv" 'lisp-show-variable-documentation) - - (define-key inferior-lisp-mode-map "\C-cl" 'lisp-load-file) - (define-key inferior-lisp-mode-map "\C-ck" 'lisp-compile-file) - (define-key inferior-lisp-mode-map "\C-ca" 'lisp-show-arglist) - (define-key inferior-lisp-mode-map "\C-cd" 'lisp-describe-sym) - (define-key inferior-lisp-mode-map "\C-cf" 'lisp-show-function-documentation) - (define-key inferior-lisp-mode-map "\C-cv" - 'lisp-show-variable-documentation)) + (define-key lisp-mode-map "\C-ce" #'lisp-eval-defun-and-go) + (define-key lisp-mode-map "\C-cr" #'lisp-eval-region-and-go) + (define-key lisp-mode-map "\C-cc" #'lisp-compile-defun-and-go) + (define-key lisp-mode-map "\C-cz" #'switch-to-lisp) + (define-key lisp-mode-map "\C-cl" #'lisp-load-file) + (define-key lisp-mode-map "\C-ck" #'lisp-compile-file) + (define-key lisp-mode-map "\C-ca" #'lisp-show-arglist) + (define-key lisp-mode-map "\C-cd" #'lisp-describe-sym) + (define-key lisp-mode-map "\C-cf" #'lisp-show-function-documentation) + (define-key lisp-mode-map "\C-cv" #'lisp-show-variable-documentation) + + (define-key inferior-lisp-mode-map "\C-cl" #'lisp-load-file) + (define-key inferior-lisp-mode-map "\C-ck" #'lisp-compile-file) + (define-key inferior-lisp-mode-map "\C-ca" #'lisp-show-arglist) + (define-key inferior-lisp-mode-map "\C-cd" #'lisp-describe-sym) + (define-key inferior-lisp-mode-map "\C-cf" #'lisp-show-function-documentation) + (define-key inferior-lisp-mode-map "\C-cv" #'lisp-show-variable-documentation)) (defcustom inferior-lisp-program "lisp" "Program name for invoking an inferior Lisp in Inferior Lisp mode." - :type 'string - :group 'inferior-lisp) + :type 'string) (defcustom inferior-lisp-load-command "(load \"%s\")\n" "Format-string for building a Lisp expression to load a file. @@ -166,8 +163,7 @@ to load that file. The default works acceptably on most Lisps. The string \"(progn (load \\\"%s\\\" :verbose nil :print t) (values))\\n\" produces cosmetically superior output for this application, but it works only in Common Lisp." - :type 'string - :group 'inferior-lisp) + :type 'string) (defcustom inferior-lisp-prompt "^[^> \n]*>+:? *" "Regexp to recognize prompts in the Inferior Lisp mode. @@ -182,10 +178,9 @@ More precise choices: Lucid Common Lisp: \"^\\\\(>\\\\|\\\\(->\\\\)+\\\\) *\" franz: \"^\\\\(->\\\\|<[0-9]*>:\\\\) *\" kcl: \"^>+ *\"" - :type 'regexp - :group 'inferior-lisp) + :type 'regexp) -(defvar inferior-lisp-buffer nil "*The current inferior-lisp process buffer. +(defvar inferior-lisp-buffer nil "*The current `inferior-lisp' process buffer. MULTIPLE PROCESS SUPPORT =========================================================================== @@ -295,15 +290,20 @@ to continue it." "Run an inferior Lisp process, input and output via buffer `*inferior-lisp*'. If there is a process already running in `*inferior-lisp*', just switch to that buffer. + With argument, allows you to edit the command line (default is value of `inferior-lisp-program'). Runs the hooks from `inferior-lisp-mode-hook' (after the `comint-mode-hook' is run). + +If any parts of the command name contains spaces, they should be +quoted using shell quote syntax. + \(Type \\[describe-mode] in the process buffer for a list of commands.)" (interactive (list (if current-prefix-arg (read-string "Run lisp: " inferior-lisp-program) inferior-lisp-program))) (if (not (comint-check-proc "*inferior-lisp*")) - (let ((cmdlist (split-string cmd))) + (let ((cmdlist (split-string-shell-command cmd))) (set-buffer (apply (function make-comint) "inferior-lisp" (car cmdlist) nil (cdr cmdlist))) (inferior-lisp-mode))) @@ -330,18 +330,18 @@ Prefix argument means switch to the Lisp buffer afterwards." (if and-go (switch-to-lisp t))) (defun lisp-compile-string (string) - "Send the string to the inferior Lisp process to be compiled and executed." + "Send STRING to the inferior Lisp process to be compiled and executed." (comint-send-string (inferior-lisp-proc) (format "(funcall (compile nil (lambda () %s)))\n" string))) (defun lisp-eval-string (string) - "Send the string to the inferior Lisp process to be executed." + "Send STRING to the inferior Lisp process to be executed." (comint-send-string (inferior-lisp-proc) (concat string "\n"))) (defun lisp-do-defun (do-string do-region) "Send the current defun to the inferior Lisp process. -The actually processing is done by `do-string' and `do-region' +The actually processing is done by DO-STRING and DO-REGION which determine whether the code is compiled before evaluation. DEFVAR forms reset the variables to the init values." (save-excursion @@ -448,7 +448,7 @@ With argument, positions cursor at end of buffer." ;;; (let ((name-start (point))) ;;; (forward-sexp 1) ;;; (process-send-string "inferior-lisp" -;;; (format "(compile '%s #'(lambda " +;;; (format "(compile '%s (lambda " ;;; (buffer-substring name-start ;;; (point))))) ;;; (let ((body-start (point))) @@ -464,7 +464,7 @@ With argument, positions cursor at end of buffer." ;;; (interactive "r") ;;; (save-excursion ;;; (goto-char start) (end-of-defun) (beginning-of-defun) ; error check -;;; (if (< (point) start) (error "region begins in middle of defun")) +;;; (if (< (point) start) (error "Region begins in middle of defun")) ;;; (goto-char start) ;;; (let ((s start)) ;;; (end-of-defun) @@ -487,12 +487,11 @@ describing the last `lisp-load-file' or `lisp-compile-file' command.") If it's loaded into a buffer that is in one of these major modes, it's considered a Lisp source file by `lisp-load-file' and `lisp-compile-file'. Used by these commands to determine defaults." - :type '(repeat symbol) - :group 'inferior-lisp) + :type '(repeat symbol)) (defun lisp-load-file (file-name) "Load a Lisp file into the inferior Lisp process." - (interactive (comint-get-source "Load Lisp file: " lisp-prev-l/c-dir/file + (interactive (comint-get-source "Load Lisp file" lisp-prev-l/c-dir/file lisp-source-modes nil)) ; nil because LOAD ; doesn't need an exact name (comint-check-source file-name) ; Check to see if buffer needs saved. @@ -505,7 +504,7 @@ Used by these commands to determine defaults." (defun lisp-compile-file (file-name) "Compile a Lisp file in the inferior Lisp process." - (interactive (comint-get-source "Compile Lisp file: " lisp-prev-l/c-dir/file + (interactive (comint-get-source "Compile Lisp file" lisp-prev-l/c-dir/file lisp-source-modes nil)) ; nil = don't need ; suffix .lisp (comint-check-source file-name) ; Check to see if buffer needs saved. @@ -596,7 +595,7 @@ See variable `lisp-function-doc-command'." (format lisp-function-doc-command fn))) (defun lisp-show-variable-documentation (var) - "Send a command to the inferior Lisp to give documentation for function FN. + "Send a command to the inferior Lisp to give documentation for variable VAR. See variable `lisp-var-doc-command'." (interactive (lisp-symprompt "Variable doc" (lisp-var-at-pt))) (comint-proc-query (inferior-lisp-proc) (format lisp-var-doc-command var))) @@ -625,8 +624,8 @@ See variable `lisp-describe-sym-command'." (error "No Lisp subprocess; see variable `inferior-lisp-buffer'")))) -;;; Do the user's customization... -;;;=============================== +;; Obsolete. + (defvar inferior-lisp-load-hook nil "This hook is run when the library `inf-lisp' is loaded.") (make-obsolete-variable 'inferior-lisp-load-hook diff --git a/lisp/progmodes/js.el b/lisp/progmodes/js.el index cdf6536fc7e..c2481f6095a 100644 --- a/lisp/progmodes/js.el +++ b/lisp/progmodes/js.el @@ -282,7 +282,7 @@ Match group 1 is the name of the macro.") "continue" "debugger" "default" "delete" "do" "else" "enum" "export" "extends" "final" "finally" "for" "function" "goto" "if" "implements" "import" "in" - "instanceof" "interface" "native" "new" "package" + "instanceof" "interface" "native" "new" "of" "package" "private" "protected" "public" "return" "static" "super" "switch" "synchronized" "throw" "throws" "transient" "try" "typeof" "var" "void" "let" @@ -427,22 +427,19 @@ Match group 1 is the name of the macro.") (defcustom js-indent-level 4 "Number of spaces for each indentation step in `js-mode'." :type 'integer - :safe 'integerp - :group 'js) + :safe 'integerp) (defcustom js-expr-indent-offset 0 "Number of additional spaces for indenting continued expressions. The value must be no less than minus `js-indent-level'." :type 'integer - :safe 'integerp - :group 'js) + :safe 'integerp) (defcustom js-paren-indent-offset 0 "Number of additional spaces for indenting expressions in parentheses. The value must be no less than minus `js-indent-level'." :type 'integer :safe 'integerp - :group 'js :version "24.1") (defcustom js-square-indent-offset 0 @@ -450,7 +447,6 @@ The value must be no less than minus `js-indent-level'." The value must be no less than minus `js-indent-level'." :type 'integer :safe 'integerp - :group 'js :version "24.1") (defcustom js-curly-indent-offset 0 @@ -458,7 +454,6 @@ The value must be no less than minus `js-indent-level'." The value must be no less than minus `js-indent-level'." :type 'integer :safe 'integerp - :group 'js :version "24.1") (defcustom js-switch-indent-offset 0 @@ -466,26 +461,22 @@ The value must be no less than minus `js-indent-level'." The value must not be negative." :type 'integer :safe 'integerp - :group 'js :version "24.4") (defcustom js-flat-functions nil "Treat nested functions as top-level functions in `js-mode'. This applies to function movement, marking, and so on." - :type 'boolean - :group 'js) + :type 'boolean) (defcustom js-indent-align-list-continuation t "Align continuation of non-empty ([{ lines in `js-mode'." :version "26.1" :type 'boolean - :safe 'booleanp - :group 'js) + :safe 'booleanp) (defcustom js-comment-lineup-func #'c-lineup-C-comments "Lineup function for `cc-mode-style', for C comments in `js-mode'." - :type 'function - :group 'js) + :type 'function) (defcustom js-enabled-frameworks js--available-frameworks "Frameworks recognized by `js-mode'. @@ -493,30 +484,27 @@ To improve performance, you may turn off some frameworks you seldom use, either globally or on a per-buffer basis." :type (cons 'set (mapcar (lambda (x) (list 'const x)) - js--available-frameworks)) - :group 'js) + js--available-frameworks))) (defcustom js-js-switch-tabs (and (memq system-type '(darwin)) t) "Whether `js-mode' should display tabs while selecting them. This is useful only if the windowing system has a good mechanism for preventing Firefox from stealing the keyboard focus." - :type 'boolean - :group 'js) + :type 'boolean) (defcustom js-js-tmpdir - "~/.emacs.d/js/js" + (locate-user-emacs-file "js/js") "Temporary directory used by `js-mode' to communicate with Mozilla. This directory must be readable and writable by both Mozilla and Emacs." :type 'directory - :group 'js) + :version "28.1") (defcustom js-js-timeout 5 "Reply timeout for executing commands in Mozilla via `js-mode'. The value is given in seconds. Increase this value if you are getting timeout messages." - :type 'integer - :group 'js) + :type 'integer) (defcustom js-indent-first-init nil "Non-nil means specially indent the first variable declaration's initializer. @@ -557,8 +545,7 @@ don't indent the first one's initializer; otherwise, indent it. bar = 2;" :version "25.1" :type '(choice (const nil) (const t) (const dynamic)) - :safe 'symbolp - :group 'js) + :safe 'symbolp) (defcustom js-chain-indent nil "Use \"chained\" indentation. @@ -571,8 +558,7 @@ then the \".\"s will be lined up: " :version "26.1" :type 'boolean - :safe 'booleanp - :group 'js) + :safe 'booleanp) (defcustom js-jsx-detect-syntax t "When non-nil, automatically detect whether JavaScript uses JSX. @@ -581,8 +567,7 @@ t. The detection strategy can be customized by adding elements to `js-jsx-regexps', which see." :version "27.1" :type 'boolean - :safe 'booleanp - :group 'js) + :safe 'booleanp) (defcustom js-jsx-syntax nil "When non-nil, parse JavaScript with consideration for JSX syntax. @@ -600,8 +585,7 @@ When `js-mode' is already enabled, you should call It is set to be buffer-local (and t) when in `js-jsx-mode'." :version "27.1" :type 'boolean - :safe 'booleanp - :group 'js) + :safe 'booleanp) (defcustom js-jsx-align->-with-< t "When non-nil, “>” will be indented to the opening “<” in JSX. @@ -625,8 +609,7 @@ When this is disabled, JSX indentation looks like this: />" :version "27.1" :type 'boolean - :safe 'booleanp - :group 'js) + :safe 'booleanp) (defcustom js-jsx-indent-level nil "When non-nil, indent JSX by this value, instead of like JS. @@ -655,8 +638,7 @@ indentation looks like this (different): :version "27.1" :type '(choice integer (const :tag "Not Set" nil)) - :safe (lambda (x) (or (null x) (integerp x))) - :group 'js) + :safe (lambda (x) (or (null x) (integerp x)))) ;; This is how indentation behaved out-of-the-box until Emacs 27. JSX ;; indentation was controlled with `sgml-basic-offset', which defaults ;; to 2, whereas `js-indent-level' defaults to 4. Users who had the @@ -685,8 +667,7 @@ indentation looks like this: This variable is like `sgml-attribute-offset'." :version "27.1" :type 'integer - :safe 'integerp - :group 'js) + :safe 'integerp) ;;; KeyMap @@ -1079,7 +1060,7 @@ Return the pitem of the function we went to the beginning of." (t (js--beginning-of-defun-nested)))))) -(defun js--flush-caches (&optional beg ignored) +(defun js--flush-caches (&optional beg _ignored) "Flush the `js-mode' syntax cache after position BEG. BEG defaults to `point-min', meaning to flush the entire cache." (interactive) @@ -1359,7 +1340,6 @@ LIMIT defaults to point." (defun js--end-of-defun-nested () "Helper function for `js-end-of-defun'." - (message "test") (let* (pitem (this-end (save-excursion (and (setq pitem (js--beginning-of-defun-nested)) @@ -1493,11 +1473,10 @@ LIMIT defaults to point." "Helper function for building `js--font-lock-keywords'. Create a byte-compiled function for matching a concatenation of REGEXPS, but only if FRAMEWORK is in `js-enabled-frameworks'." - (setq regexps (apply #'concat regexps)) - (byte-compile - `(lambda (limit) - (when (memq (quote ,framework) js-enabled-frameworks) - (re-search-forward ,regexps limit t))))) + (let ((regexp (apply #'concat regexps))) + (lambda (limit) + (when (memq framework js-enabled-frameworks) + (re-search-forward regexp limit t))))) (defvar-local js--tmp-location nil) @@ -2881,7 +2860,11 @@ return nil." ((nth 3 parse-status) 0) ; inside string ((when (and js-jsx-syntax (not js-jsx--indent-col)) (save-excursion (js-jsx--indentation parse-status)))) - ((eq (char-after) ?#) 0) + ((and (eq (char-after) ?#) + (save-excursion + (forward-char 1) + (looking-at-p cpp-font-lock-keywords-source-directives))) + 0) ((save-excursion (js--beginning-of-macro)) 4) ;; Indent array comprehension continuation lines specially. ((let ((bracket (nth 1 parse-status)) @@ -3719,8 +3702,7 @@ Otherwise, use the current value of `process-mark'." Strings and numbers are JSON-encoded. Lists (including nil) are made into JavaScript array literals and their contents encoded with `js--js-encode-value'." - (cond ((stringp x) (json-encode-string x)) - ((numberp x) (json-encode-number x)) + (cond ((or (stringp x) (numberp x)) (json-encode x)) ((symbolp x) (format "{objid:%S}" (symbol-name x))) ((js--js-handle-p x) @@ -4198,8 +4180,9 @@ browser, respectively." "style" "") cmds))) - (eval (list 'with-js - (cons 'js-list (nreverse cmds)))))) + (eval `(with-js + (js-list ,@(nreverse cmds))) + t))) (command-hook () @@ -4410,7 +4393,8 @@ If one hasn't been set, or if it's stale, prompt for a new one." (with-temp-buffer (insert js--js-inserter) (insert "(") - (insert (json-encode-list defun-info)) + (let ((standard-output (current-buffer))) + (json--print-list defun-info)) (insert ",\n") (insert defun-body) (insert "\n)") @@ -4674,4 +4658,4 @@ one of the aforementioned options instead of using this mode." (provide 'js) -;; js.el ends here +;;; js.el ends here diff --git a/lisp/progmodes/ld-script.el b/lisp/progmodes/ld-script.el index c4ea8e158d8..485e64e2492 100644 --- a/lisp/progmodes/ld-script.el +++ b/lisp/progmodes/ld-script.el @@ -35,8 +35,7 @@ (defvar ld-script-location-counter-face 'ld-script-location-counter) (defface ld-script-location-counter '((t :weight bold :inherit font-lock-builtin-face)) - "Face for location counter in GNU ld script." - :group 'ld-script) + "Face for location counter in GNU ld script.") ;; Syntax rules (defvar ld-script-mode-syntax-table diff --git a/lisp/progmodes/m4-mode.el b/lisp/progmodes/m4-mode.el index 99f4be38721..d9c09f6fe6b 100644 --- a/lisp/progmodes/m4-mode.el +++ b/lisp/progmodes/m4-mode.el @@ -60,12 +60,34 @@ If m4 is not in your PATH, set this to an absolute file name." ;;or ;;(defconst m4-program-options '("--prefix-builtins")) +;; Needed at compile-time for `m4-font-lock-keywords' below. +(eval-and-compile + (defconst m4--macro-list + ;; From (info "(m4) Macro index") + '("__file__" "__gnu__" "__line__" "__os2__" "__program__" "__unix__" + "__windows__" "argn" "array" "array_set" "builtin" "capitalize" + "changecom" "changequote" "changeword" "cleardivert" "cond" "copy" + "curry" "debugfile" "debugmode" "decr" "define" "define_blind" + "defn" "divert" "divnum" "dnl" "downcase" "dquote" "dquote_elt" + "dumpdef" "errprint" "esyscmd" "eval" "example" "exch" + "fatal_error" "file" "foreach" "foreachq" "forloop" "format" "gnu" + "ifdef" "ifelse" "include" "incr" "index" "indir" "join" "joinall" + "len" "line" "m4exit" "m4wrap" "maketemp" "mkstemp" "nargs" "os2" + "patsubst" "popdef" "pushdef" "quote" "regexp" "rename" "reverse" + "shift" "sinclude" "stack_foreach" "stack_foreach_lifo" + "stack_foreach_sep" "stack_foreach_sep_lifo" "substr" "syscmd" + "sysval" "traceoff" "traceon" "translit" "undefine" "undivert" + "unix" "upcase" "windows") + "List of valid m4 macros for M4 mode.")) + (defvar m4-font-lock-keywords - '(("\\(\\_<\\(m4_\\)?dnl\\_>\\).*$" (0 font-lock-comment-face t)) - ("\\$[*#@0-9]" . font-lock-variable-name-face) - ("\\$@" . font-lock-variable-name-face) - ("\\$\\*" . font-lock-variable-name-face) - ("\\_<\\(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\\)\\|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\\)\\)\\_>" . font-lock-keyword-face)) + (eval-when-compile + `(("\\(\\_<\\(m4_\\)?dnl\\_>\\).*$" (0 font-lock-comment-face t)) + ("\\$[*#@0-9]" . font-lock-variable-name-face) + ("\\$@" . font-lock-variable-name-face) + ("\\$\\*" . font-lock-variable-name-face) + (,(concat "\\_<\\(m4_\\)?" (regexp-opt m4--macro-list) "\\_>") + . font-lock-keyword-face))) "Default `font-lock-keywords' for M4 mode.") (defcustom m4-mode-hook nil @@ -100,22 +122,22 @@ If m4 is not in your PATH, set this to an absolute file name." (string-to-syntax ".")))))) (defvar m4-mode-map - (let ((map (make-sparse-keymap)) - (menu-map (make-sparse-keymap))) + (let ((map (make-sparse-keymap))) (define-key map "\C-c\C-b" 'm4-m4-buffer) (define-key map "\C-c\C-r" 'm4-m4-region) (define-key map "\C-c\C-c" 'comment-region) - (define-key map [menu-bar m4-mode] (cons "M4" menu-map)) - (define-key menu-map [m4c] - '(menu-item "Comment Region" comment-region - :help "Comment Region")) - (define-key menu-map [m4b] - '(menu-item "M4 Buffer" m4-m4-buffer - :help "Send contents of the current buffer to m4")) - (define-key menu-map [m4r] - '(menu-item "M4 Region" m4-m4-region - :help "Send contents of the current region to m4")) - map)) + map) + "Keymap for M4 Mode.") + +(easy-menu-define m4-mode-menu m4-mode-map + "Menu for M4 Mode." + '("M4" + ["M4 Region" m4-m4-region + :help "Send contents of the current region to m4"] + ["M4 Buffer" m4-m4-buffer + :help "Send contents of the current buffer to m4"] + ["Comment Region" comment-region + :help "Comment Region"])) (defun m4-m4-buffer () "Send contents of the current buffer to m4." @@ -155,22 +177,4 @@ If m4 is not in your PATH, set this to an absolute file name." ;;stuff to play with for debugging ;(char-to-string (char-syntax ?`)) -;;;how I generate the nasty looking regexps at the top -;;;(make-regexp '("builtin" "changecom" "changequote" "changeword" "debugfile" -;;; "debugmode" "decr" "define" "defn" "divert" "divnum" "dnl" -;;; "dumpdef" "errprint" "esyscmd" "eval" "file" "format" "gnu" -;;; "ifdef" "ifelse" "include" "incr" "index" "indir" "len" "line" -;;; "m4exit" "m4wrap" "maketemp" "patsubst" "popdef" "pushdef" "regexp" -;;; "shift" "sinclude" "substr" "syscmd" "sysval" "traceoff" "traceon" -;;; "translit" "undefine" "undivert" "unix")) -;;;(make-regexp '("m4_builtin" "m4_changecom" "m4_changequote" "m4_changeword" -;;; "m4_debugfile" "m4_debugmode" "m4_decr" "m4_define" "m4_defn" -;;; "m4_divert" "m4_divnum" "m4_dnl" "m4_dumpdef" "m4_errprint" -;;; "m4_esyscmd" "m4_eval" "m4_file" "m4_format" "m4_ifdef" "m4_ifelse" -;;; "m4_include" "m4_incr" "m4_index" "m4_indir" "m4_len" "m4_line" -;;; "m4_m4exit" "m4_m4wrap" "m4_maketemp" "m4_patsubst" "m4_popdef" -;;; "m4_pushdef" "m4_regexp" "m4_shift" "m4_sinclude" "m4_substr" -;;; "m4_syscmd" "m4_sysval" "m4_traceoff" "m4_traceon" "m4_translit" -;;; "m4_m4_undefine" "m4_undivert")) - ;;; m4-mode.el ends here diff --git a/lisp/progmodes/make-mode.el b/lisp/progmodes/make-mode.el index e382d6edcd2..df17b87c013 100644 --- a/lisp/progmodes/make-mode.el +++ b/lisp/progmodes/make-mode.el @@ -101,14 +101,12 @@ (defface makefile-space '((((class color)) (:background "hotpink")) (t (:reverse-video t))) - "Face to use for highlighting leading spaces in Font-Lock mode." - :group 'makefile) + "Face to use for highlighting leading spaces in Font-Lock mode.") (defface makefile-targets ;; This needs to go along both with foreground and background colors (i.e. shell) '((t (:inherit font-lock-function-name-face))) "Face to use for additionally highlighting rule targets in Font-Lock mode." - :group 'makefile :version "22.1") (defface makefile-shell @@ -116,7 +114,6 @@ ;;'((((class color) (min-colors 88) (background light)) (:background "seashell1")) ;; (((class color) (min-colors 88) (background dark)) (:background "seashell4"))) "Face to use for additionally highlighting Shell commands in Font-Lock mode." - :group 'makefile :version "22.1") (defface makefile-makepp-perl @@ -124,19 +121,16 @@ (((class color) (background dark)) (:background "DarkBlue")) (t (:reverse-video t))) "Face to use for additionally highlighting Perl code in Font-Lock mode." - :group 'makefile :version "22.1") (defcustom makefile-browser-buffer-name "*Macros and Targets*" "Name of the macro- and target browser buffer." - :type 'string - :group 'makefile) + :type 'string) (defcustom makefile-target-colon ":" "String to append to all target names inserted by `makefile-insert-target'. \":\" or \"::\" are common values." - :type 'string - :group 'makefile) + :type 'string) (defcustom makefile-macro-assign " = " "String to append to all macro names inserted by `makefile-insert-macro'. @@ -144,70 +138,58 @@ The normal value should be \" = \", since this is what standard make expects. However, newer makes such as dmake allow a larger variety of different macro assignments, so you might prefer to use \" += \" or \" := \" ." - :type 'string - :group 'makefile) + :type 'string) (defcustom makefile-electric-keys nil "If non-nil, Makefile mode should install electric keybindings. Default is nil." - :type 'boolean - :group 'makefile) + :type 'boolean) (defcustom makefile-use-curly-braces-for-macros-p nil "Controls the style of generated macro references. Non-nil means macro references should use curly braces, like `${this}'. nil means use parentheses, like `$(this)'." - :type 'boolean - :group 'makefile) + :type 'boolean) (defcustom makefile-tab-after-target-colon t "If non-nil, insert a TAB after a target colon. Otherwise, a space is inserted. The default is t." - :type 'boolean - :group 'makefile) + :type 'boolean) (defcustom makefile-browser-leftmost-column 10 "Number of blanks to the left of the browser selection mark." - :type 'integer - :group 'makefile) + :type 'integer) (defcustom makefile-browser-cursor-column 10 "Column the cursor goes to when it moves up or down in the Makefile browser." - :type 'integer - :group 'makefile) + :type 'integer) (defcustom makefile-backslash-column 48 "Column in which `makefile-backslash-region' inserts backslashes." - :type 'integer - :group 'makefile) + :type 'integer) (defcustom makefile-backslash-align t "If non-nil, `makefile-backslash-region' will align backslashes." - :type 'boolean - :group 'makefile) + :type 'boolean) (defcustom makefile-browser-selected-mark "+ " "String used to mark selected entries in the Makefile browser." - :type 'string - :group 'makefile) + :type 'string) (defcustom makefile-browser-unselected-mark " " "String used to mark unselected entries in the Makefile browser." - :type 'string - :group 'makefile) + :type 'string) (defcustom makefile-browser-auto-advance-after-selection-p t "If non-nil, cursor will move after item is selected in Makefile browser." - :type 'boolean - :group 'makefile) + :type 'boolean) (defcustom makefile-pickup-everything-picks-up-filenames-p nil "If non-nil, `makefile-pickup-everything' picks up filenames as targets. This means it calls `makefile-pickup-filenames-as-targets'. Otherwise filenames are omitted." - :type 'boolean - :group 'makefile) + :type 'boolean) (defcustom makefile-cleanup-continuations nil "If non-nil, automatically clean up continuation lines when saving. @@ -215,13 +197,11 @@ A line is cleaned up by removing all whitespace following a trailing backslash. This is done silently. IMPORTANT: Please note that enabling this option causes Makefile mode to MODIFY A FILE WITHOUT YOUR CONFIRMATION when \"it seems necessary\"." - :type 'boolean - :group 'makefile) + :type 'boolean) (defcustom makefile-mode-hook nil "Normal hook run by `makefile-mode'." - :type 'hook - :group 'makefile) + :type 'hook) (defvar makefile-browser-hook '()) @@ -240,8 +220,7 @@ to MODIFY A FILE WITHOUT YOUR CONFIRMATION when \"it seems necessary\"." "List of special targets. You will be offered to complete on one of those in the minibuffer whenever you enter a \".\" at the beginning of a line in `makefile-mode'." - :type '(repeat string) - :group 'makefile) + :type '(repeat string)) (put 'makefile-special-targets-list 'risky-local-variable t) (defcustom makefile-runtime-macros-list @@ -250,8 +229,7 @@ you enter a \".\" at the beginning of a line in `makefile-mode'." If you insert a macro reference using `makefile-insert-macro-ref', the name of the macro is checked against this list. If it can be found its name will not be enclosed in { } or ( )." - :type '(repeat (list string)) - :group 'makefile) + :type '(repeat (list string))) ;; Note that the first big subexpression is used by font lock. Note ;; that if you change this regexp you might have to fix the imenu @@ -279,7 +257,7 @@ not be enclosed in { } or ( )." "Regex used to highlight makepp rule action lines in font lock mode.") (defconst makefile-bsdmake-rule-action-regex - (replace-regexp-in-string "-@" "-+@" makefile-rule-action-regex) + (string-replace "-@" "-+@" makefile-rule-action-regex) "Regex used to highlight BSD rule action lines in font lock mode.") ;; Note that the first and second subexpression is used by font lock. Note @@ -294,7 +272,7 @@ not be enclosed in { } or ( )." "Regex used to find macro assignment lines in a makefile.") (defconst makefile-var-use-regex - "[^$]\\$[({]\\([-a-zA-Z0-9_.]+\\|[@%<?^+*][FD]?\\)" + "\\(^\\|[^$]\\)\\$[({]\\([-a-zA-Z0-9_.]+\\|[@%<?^+*][FD]?\\)" "Regex used to find $(macro) uses in a makefile.") (defconst makefile-ignored-files-in-pickup-regex @@ -368,7 +346,7 @@ not be enclosed in { } or ( )." (3 font-lock-builtin-face prepend t)) ;; Variable references even in targets/strings/comments. - (,var 1 font-lock-variable-name-face prepend) + (,var 2 font-lock-variable-name-face prepend) ;; Automatic variable references and single character variable references, ;; but not shell variables references. @@ -380,11 +358,10 @@ not be enclosed in { } or ( )." ,@(if keywords ;; Fontify conditionals and includes. `((,(concat "^\\(?: [ \t]*\\)?" - (replace-regexp-in-string + (string-replace " " "[ \t]+" (if (eq (car keywords) t) - (replace-regexp-in-string "-" "[_-]" - (regexp-opt (cdr keywords) t)) + (string-replace "-" "[_-]" (regexp-opt (cdr keywords) t)) (regexp-opt keywords t))) "\\>[ \t]*\\([^: \t\n#]*\\)") (1 font-lock-keyword-face) (2 font-lock-variable-name-face)))) @@ -563,8 +540,7 @@ not be enclosed in { } or ( )." (defcustom makefile-brave-make "make" "How to invoke make, for `makefile-query-targets'. This should identify a `make' command that can handle the `-q' option." - :type 'string - :group 'makefile) + :type 'string) (defvaralias 'makefile-query-one-target-method 'makefile-query-one-target-method-function) @@ -584,13 +560,11 @@ The function must satisfy this calling convention: * It must return the integer value 0 (zero) if the given target should be considered up-to-date in the context of the given makefile, any nonzero integer value otherwise." - :type 'function - :group 'makefile) + :type 'function) (defcustom makefile-up-to-date-buffer-name "*Makefile Up-to-date overview*" "Name of the Up-to-date overview buffer." - :type 'string - :group 'makefile) + :type 'string) ;;; --- end of up-to-date-overview configuration ------------------ @@ -598,8 +572,7 @@ The function must satisfy this calling convention: "Abbrev table in use in Makefile buffers.") (defvar makefile-mode-map - (let ((map (make-sparse-keymap)) - (opt-map (make-sparse-keymap))) + (let ((map (make-sparse-keymap))) ;; set up the keymap (define-key map "\C-c:" 'makefile-insert-target-ref) (if makefile-electric-keys @@ -624,72 +597,62 @@ The function must satisfy this calling convention: (define-key map "\M-p" 'makefile-previous-dependency) (define-key map "\M-n" 'makefile-next-dependency) (define-key map "\e\t" 'completion-at-point) - - ;; Make menus. - (define-key map [menu-bar makefile-mode] - (cons "Makefile" (make-sparse-keymap "Makefile"))) - - (define-key map [menu-bar makefile-mode makefile-type] - (cons "Switch Makefile Type" opt-map)) - (define-key opt-map [makefile-makepp-mode] - '(menu-item "Makepp" makefile-makepp-mode - :help "An adapted `makefile-mode' that knows about makepp" - :button (:radio . (eq major-mode 'makefile-makepp-mode)))) - (define-key opt-map [makefile-imake-mode] - '(menu-item "Imake" makefile-imake-mode - :help "An adapted `makefile-mode' that knows about imake" - :button (:radio . (eq major-mode 'makefile-imake-mode)))) - (define-key opt-map [makefile-mode] - '(menu-item "Classic" makefile-mode - :help "`makefile-mode' with no special functionality" - :button (:radio . (eq major-mode 'makefile-mode)))) - (define-key opt-map [makefile-bsdmake-mode] - '(menu-item "BSD" makefile-bsdmake-mode - :help "An adapted `makefile-mode' that knows about BSD make" - :button (:radio . (eq major-mode 'makefile-bsdmake-mode)))) - (define-key opt-map [makefile-automake-mode] - '(menu-item "Automake" makefile-automake-mode - :help "An adapted `makefile-mode' that knows about automake" - :button (:radio . (eq major-mode 'makefile-automake-mode)))) - (define-key opt-map [makefile-gmake-mode] - '(menu-item "GNU make" makefile-gmake-mode - :help "An adapted `makefile-mode' that knows about GNU make" - :button (:radio . (eq major-mode 'makefile-gmake-mode)))) - (define-key map [menu-bar makefile-mode browse] - '(menu-item "Pop up Makefile Browser" makefile-switch-to-browser - ;; XXX: this needs a better string, the function is not documented... - :help "Pop up Makefile Browser")) - (define-key map [menu-bar makefile-mode overview] - '(menu-item "Up To Date Overview" makefile-create-up-to-date-overview - :help "Create a buffer containing an overview of the state of all known targets")) - ;; Target related - (define-key map [menu-bar makefile-mode separator1] '("----")) - (define-key map [menu-bar makefile-mode pickup-file] - '(menu-item "Pick File Name as Target" makefile-pickup-filenames-as-targets - :help "Scan the current directory for filenames to use as targets")) - (define-key map [menu-bar makefile-mode function] - '(menu-item "Insert GNU make function" makefile-insert-gmake-function - :help "Insert a GNU make function call")) - (define-key map [menu-bar makefile-mode pickup] - '(menu-item "Find Targets and Macros" makefile-pickup-everything - :help "Notice names of all macros and targets in Makefile")) - (define-key map [menu-bar makefile-mode complete] - '(menu-item "Complete Target or Macro" completion-at-point - :help "Perform completion on Makefile construct preceding point")) - (define-key map [menu-bar makefile-mode backslash] - '(menu-item "Backslash Region" makefile-backslash-region - :help "Insert, align, or delete end-of-line backslashes on the lines in the region")) - ;; Motion - (define-key map [menu-bar makefile-mode separator] '("----")) - (define-key map [menu-bar makefile-mode prev] - '(menu-item "Move to Previous Dependency" makefile-previous-dependency - :help "Move point to the beginning of the previous dependency line")) - (define-key map [menu-bar makefile-mode next] - '(menu-item "Move to Next Dependency" makefile-next-dependency - :help "Move point to the beginning of the next dependency line")) map) "The keymap that is used in Makefile mode.") +(easy-menu-define makefile-mode-menu makefile-mode-map + "Menu for Makefile mode." + '("Makefile" + ;; Motion + ["Move to Next Dependency" makefile-next-dependency + :help "Move point to the beginning of the next dependency line"] + ["Move to Previous Dependency" makefile-previous-dependency + :help "Move point to the beginning of the previous dependency line"] + "----" + ;; Target related + ["Backslash Region" makefile-backslash-region + :help "Insert, align, or delete end-of-line backslashes on the lines in the region"] + ["Complete Target or Macro" completion-at-point + :help "Perform completion on Makefile construct preceding point"] + ["Find Targets and Macros" makefile-pickup-everything + :help "Notice names of all macros and targets in Makefile"] + ["Insert GNU make function" makefile-insert-gmake-function + :help "Insert a GNU make function call"] + ["Pick File Name as Target" makefile-pickup-filenames-as-targets + :help "Scan the current directory for filenames to use as targets"] + "----" + ;; Other. + ["Up To Date Overview" makefile-create-up-to-date-overview + :help "Create a buffer containing an overview of the state of all known targets"] + ["Pop up Makefile Browser" makefile-switch-to-browser + ;; XXX: this needs a better string, the function is not documented... + :help "Pop up Makefile Browser"] + ("Switch Makefile Type" + ["GNU make" makefile-gmake-mode + :help "An adapted `makefile-mode' that knows about GNU make" + :style radio + :selected (eq major-mode 'makefile-gmake-mode)] + ["Automake" makefile-automake-mode + :help "An adapted `makefile-mode' that knows about automake" + :style radio + :selected (eq major-mode 'makefile-automake-mode)] + ["BSD" makefile-bsdmake-mode + :help "An adapted `makefile-mode' that knows about BSD make" + :style radio + :selected (eq major-mode 'makefile-bsdmake-mode)] + ["Classic" makefile-mode + :help "`makefile-mode' with no special functionality" + :style radio + :selected (eq major-mode 'makefile-mode)] + ["Imake" makefile-imake-mode + :help "An adapted `makefile-mode' that knows about imake" + :style radio + :selected (eq major-mode 'makefile-imake-mode)] + ["Makepp" makefile-makepp-mode + :help "An adapted `makefile-mode' that knows about makepp" + :style radio + :selected (eq major-mode 'makefile-makepp-mode)]))) + (defvar makefile-browser-map (let ((map (make-sparse-keymap))) diff --git a/lisp/progmodes/meta-mode.el b/lisp/progmodes/meta-mode.el index 9da968c8314..50268446025 100644 --- a/lisp/progmodes/meta-mode.el +++ b/lisp/progmodes/meta-mode.el @@ -88,8 +88,6 @@ ;;; Code: -(require 'easymenu) - (defgroup meta-font nil "Major mode for editing Metafont or MetaPost sources." :link '(custom-group-link :tag "Font Lock Faces group" font-lock-faces) @@ -109,44 +107,31 @@ "\\(def\\|let\\|mode_def\\|vardef\\)") (macro-keywords-2 "\\(primarydef\\|secondarydef\\|tertiarydef\\)") -;(make-regexp -; '("expr" "suffix" "text" "primary" "secondary" "tertiary") t) (args-keywords - (concat "\\(expr\\|primary\\|s\\(econdary\\|uffix\\)\\|" - "te\\(rtiary\\|xt\\)\\)")) -;(make-regexp -; '("boolean" "color" "numeric" "pair" "path" "pen" "picture" -; "string" "transform" "newinternal") t) + (eval-when-compile + (regexp-opt + '("expr" "suffix" "text" "primary" "secondary" "tertiary") + t))) (type-keywords - (concat "\\(boolean\\|color\\|n\\(ewinternal\\|umeric\\)\\|" - "p\\(a\\(ir\\|th\\)\\|en\\|icture\\)\\|string\\|" - "transform\\)")) -;(make-regexp -; '("for" "forever" "forsuffixes" "endfor" -; "step" "until" "upto" "downto" "thru" "within" -; "iff" "if" "elseif" "else" "fi" "exitif" "exitunless" -; "let" "def" "vardef" "enddef" "mode_def" -; "true" "false" "known" "unknown" "and" "or" "not" -; "save" "interim" "inner" "outer" "relax" -; "begingroup" "endgroup" "expandafter" "scantokens" -; "generate" "input" "endinput" "end" "bye" -; "message" "errmessage" "errhelp" "special" "numspecial" -; "readstring" "readfrom" "write") t) + (eval-when-compile + (regexp-opt + '("boolean" "color" "numeric" "pair" "path" "pen" "picture" + "string" "transform" "newinternal") + t))) (syntactic-keywords - (concat "\\(and\\|b\\(egingroup\\|ye\\)\\|" - "d\\(ef\\|ownto\\)\\|e\\(lse\\(\\|if\\)" - "\\|nd\\(\\|def\\|for\\|group\\|input\\)" - "\\|rr\\(help\\|message\\)" - "\\|x\\(it\\(if\\|unless\\)\\|pandafter\\)\\)\\|" - "f\\(alse\\|i\\|or\\(\\|ever\\|suffixes\\)\\)\\|" - "generate\\|i\\(ff?\\|n\\(ner\\|put\\|terim\\)\\)\\|" - "known\\|let\\|m\\(essage\\|ode_def\\)\\|" - "n\\(ot\\|umspecial\\)\\|o\\(r\\|uter\\)\\|" - "re\\(ad\\(from\\|string\\)\\|lax\\)\\|" - "s\\(ave\\|cantokens\\|pecial\\|tep\\)\\|" - "t\\(hru\\|rue\\)\\|" - "u\\(n\\(known\\|til\\)\\|pto\\)\\|" - "vardef\\|w\\(ithin\\|rite\\)\\)")) + (eval-when-compile + (regexp-opt + '("for" "forever" "forsuffixes" "endfor" + "step" "until" "upto" "downto" "thru" "within" + "iff" "if" "elseif" "else" "fi" "exitif" "exitunless" + "let" "def" "vardef" "enddef" "mode_def" + "true" "false" "known" "unknown" "and" "or" "not" + "save" "interim" "inner" "outer" "relax" + "begingroup" "endgroup" "expandafter" "scantokens" + "generate" "input" "endinput" "end" "bye" + "message" "errmessage" "errhelp" "special" "numspecial" + "readstring" "readfrom" "write") + t))) ) (list ;; embedded TeX code in btex ... etex @@ -463,25 +448,21 @@ If the list was changed, sort the list and remove duplicates first." (defcustom meta-indent-level 2 "Indentation of begin-end blocks in Metafont or MetaPost mode." - :type 'integer - :group 'meta-font) + :type 'integer) (defcustom meta-left-comment-regexp "%%+" "Regexp matching comments that should be placed on the left margin." - :type 'regexp - :group 'meta-font) + :type 'regexp) (defcustom meta-right-comment-regexp nil "Regexp matching comments that should be placed on the right margin." :type '(choice regexp - (const :tag "None" nil)) - :group 'meta-font) + (const :tag "None" nil))) (defcustom meta-ignore-comment-regexp "%[^%]" "Regexp matching comments whose indentation should not be touched." - :type 'regexp - :group 'meta-font) + :type 'regexp) (defcustom meta-begin-environment-regexp @@ -489,22 +470,19 @@ If the list was changed, sort the list and remove duplicates first." "def\\|for\\(\\|ever\\|suffixes\\)\\|if\\|mode_def\\|" "primarydef\\|secondarydef\\|tertiarydef\\|vardef\\)") "Regexp matching the beginning of environments to be indented." - :type 'regexp - :group 'meta-font) + :type 'regexp) (defcustom meta-end-environment-regexp (concat "\\(end\\(char\\|def\\|f\\(ig\\|or\\)\\|gr\\(aph\\|oup\\)\\)" "\\|fi\\)") "Regexp matching the end of environments to be indented." - :type 'regexp - :group 'meta-font) + :type 'regexp) (defcustom meta-within-environment-regexp ; (concat "\\(e\\(lse\\(\\|if\\)\\|xit\\(if\\|unless\\)\\)\\)") (concat "\\(else\\(\\|if\\)\\)") "Regexp matching keywords within environments not to be indented." - :type 'regexp - :group 'meta-font) + :type 'regexp) (defun meta-comment-indent () @@ -689,14 +667,12 @@ If the list was changed, sort the list and remove duplicates first." (concat "\\(begin\\(char\\|fig\\|logochar\\)\\|def\\|mode_def\\|" "primarydef\\|secondarydef\\|tertiarydef\\|vardef\\)") "Regexp matching beginning of defuns in Metafont or MetaPost mode." - :type 'regexp - :group 'meta-font) + :type 'regexp) (defcustom meta-end-defun-regexp (concat "\\(end\\(char\\|def\\|fig\\)\\)") "Regexp matching the end of defuns in Metafont or MetaPost mode." - :type 'regexp - :group 'meta-font) + :type 'regexp) (defun meta-beginning-of-defun (&optional arg) @@ -893,24 +869,21 @@ The environment marked is the one that contains point or follows point." (defcustom meta-mode-load-hook nil "Hook evaluated when first loading Metafont or MetaPost mode." - :type 'hook - :group 'meta-font) + :type 'hook) (make-obsolete-variable 'meta-mode-load-hook "use `with-eval-after-load' instead." "28.1") (defcustom meta-common-mode-hook nil "Hook evaluated by both `metafont-mode' and `metapost-mode'." - :type 'hook - :group 'meta-font) + :type 'hook) (defcustom metafont-mode-hook nil "Hook evaluated by `metafont-mode' after `meta-common-mode-hook'." - :type 'hook - :group 'meta-font) + :type 'hook) + (defcustom metapost-mode-hook nil "Hook evaluated by `metapost-mode' after `meta-common-mode-hook'." - :type 'hook - :group 'meta-font) + :type 'hook) @@ -969,9 +942,6 @@ The environment marked is the one that contains point or follows point." (list (list "\\<\\(\\sw+\\)" 1 'meta-symbol-list) (list "" 'ispell-complete-word)))) - -;;; Just in case ... - (provide 'meta-mode) (run-hooks 'meta-mode-load-hook) diff --git a/lisp/progmodes/modula2.el b/lisp/progmodes/modula2.el index a77a4e2b216..a8d644dba0e 100644 --- a/lisp/progmodes/modula2.el +++ b/lisp/progmodes/modula2.el @@ -1,4 +1,4 @@ -;;; modula2.el --- Modula-2 editing support package +;;; modula2.el --- Modula-2 editing support package -*- lexical-binding: t -*- ;; Author: Michael Schmidt <michael@pbinfo.UUCP> ;; Tom Perrine <Perrin@LOGICON.ARPA> @@ -51,62 +51,57 @@ (defcustom m2-compile-command "m2c" "Command to compile Modula-2 programs." - :type 'string - :group 'modula2) + :type 'string) (defcustom m2-link-command "m2l" "Command to link Modula-2 programs." - :type 'string - :group 'modula2) + :type 'string) (defcustom m2-link-name nil "Name of the Modula-2 executable." - :type '(choice (const nil) string) - :group 'modula2) + :type '(choice (const nil) string)) (defcustom m2-end-comment-column 75 "Column for aligning the end of a comment, in Modula-2." - :type 'integer - :group 'modula2) + :type 'integer) ;;; Added by TEP (defvar m2-mode-map (let ((map (make-sparse-keymap))) ;; FIXME: Many of those bindings are contrary to coding conventions. - (define-key map "\C-cb" 'm2-begin) - (define-key map "\C-cc" 'm2-case) - (define-key map "\C-cd" 'm2-definition) - (define-key map "\C-ce" 'm2-else) - (define-key map "\C-cf" 'm2-for) - (define-key map "\C-ch" 'm2-header) - (define-key map "\C-ci" 'm2-if) - (define-key map "\C-cm" 'm2-module) - (define-key map "\C-cl" 'm2-loop) - (define-key map "\C-co" 'm2-or) - (define-key map "\C-cp" 'm2-procedure) - (define-key map "\C-c\C-w" 'm2-with) - (define-key map "\C-cr" 'm2-record) - (define-key map "\C-cs" 'm2-stdio) - (define-key map "\C-ct" 'm2-type) - (define-key map "\C-cu" 'm2-until) - (define-key map "\C-cv" 'm2-var) - (define-key map "\C-cw" 'm2-while) - (define-key map "\C-cx" 'm2-export) - (define-key map "\C-cy" 'm2-import) - (define-key map "\C-c{" 'm2-begin-comment) - (define-key map "\C-c}" 'm2-end-comment) - (define-key map "\C-c\C-z" 'suspend-emacs) - (define-key map "\C-c\C-v" 'm2-visit) - (define-key map "\C-c\C-t" 'm2-toggle) - (define-key map "\C-c\C-l" 'm2-link) - (define-key map "\C-c\C-c" 'm2-compile) + (define-key map "\C-cb" #'m2-begin) + (define-key map "\C-cc" #'m2-case) + (define-key map "\C-cd" #'m2-definition) + (define-key map "\C-ce" #'m2-else) + (define-key map "\C-cf" #'m2-for) + (define-key map "\C-ch" #'m2-header) + (define-key map "\C-ci" #'m2-if) + (define-key map "\C-cm" #'m2-module) + (define-key map "\C-cl" #'m2-loop) + (define-key map "\C-co" #'m2-or) + (define-key map "\C-cp" #'m2-procedure) + (define-key map "\C-c\C-w" #'m2-with) + (define-key map "\C-cr" #'m2-record) + (define-key map "\C-cs" #'m2-stdio) + (define-key map "\C-ct" #'m2-type) + (define-key map "\C-cu" #'m2-until) + (define-key map "\C-cv" #'m2-var) + (define-key map "\C-cw" #'m2-while) + (define-key map "\C-cx" #'m2-export) + (define-key map "\C-cy" #'m2-import) + (define-key map "\C-c{" #'m2-begin-comment) + (define-key map "\C-c}" #'m2-end-comment) + (define-key map "\C-c\C-z" #'suspend-emacs) + (define-key map "\C-c\C-v" #'m2-visit) + (define-key map "\C-c\C-t" #'m2-toggle) + (define-key map "\C-c\C-l" #'m2-link) + (define-key map "\C-c\C-c" #'m2-compile) map) "Keymap used in Modula-2 mode.") (defcustom m2-indent 5 "This variable gives the indentation in Modula-2 mode." - :type 'integer - :group 'modula2) + :type 'integer) (put 'm2-indent 'safe-local-variable (lambda (v) (or (null v) (integerp v)))) @@ -206,7 +201,10 @@ ((zerop (length tok)) (let ((forward-sexp-function nil)) (condition-case nil - (forward-sexp -1) + (let ((p (point))) + (forward-sexp -1) + (when (= p (point)) + (setq res ":"))) (scan-error (setq res ":"))))) ((member tok '("|" "OF" "..")) (setq res ":-case")) ((member tok '(":" "END" ";" "BEGIN" "VAR" "RECORD" "PROCEDURE")) diff --git a/lisp/progmodes/octave.el b/lisp/progmodes/octave.el index ddcc6f5450e..b1a5f301587 100644 --- a/lisp/progmodes/octave.el +++ b/lisp/progmodes/octave.el @@ -215,9 +215,15 @@ newline or semicolon after an else or end keyword." (concat "[^#%\n]*\\(" octave-continuation-marker-regexp "\\)\\s-*\\(\\s<.*\\)?$")) -;; Char \ is considered a bad decision for continuing a line. (defconst octave-continuation-string "..." - "Character string used for Octave continuation lines.") + "Character string used for Octave continuation lines. +Joins current line with following line, except within +double-quoted strings, where `octave-string-continuation-marker' +is used instead.") + +(defconst octave-string-continuation-marker "\\" + "Line continuation marker for double-quoted Octave strings. +Non-string statements use `octave-continuation-string'.") (defvar octave-mode-imenu-generic-expression (list @@ -454,7 +460,8 @@ Non-nil means always go to the next Octave code line after sending." (smie-rule-parent octave-block-offset) ;; For (invalid) code between switch and case. ;; (if (smie-rule-parent-p "switch") 4) - nil)))) + nil)) + ('(:after . "=") (smie-rule-parent octave-block-offset)))) (defun octave-indent-comment () "A function for `smie-indent-functions' (which see)." @@ -485,8 +492,8 @@ Non-nil means always go to the next Octave code line after sending." 'font-lock-keyword-face) ;; Note: 'end' also serves as the last index in an indexing expression, ;; and 'enumerate' is also a function. - ;; Ref: http://www.mathworks.com/help/matlab/ref/end.html - ;; Ref: http://www.mathworks.com/help/matlab/ref/enumeration.html + ;; Ref: https://www.mathworks.com/help/matlab/ref/end.html + ;; Ref: https://www.mathworks.com/help/matlab/ref/enumeration.html (list (lambda (limit) (while (re-search-forward "\\_<en\\(?:d\\|umeratio\\(n\\)\\)\\_>" limit 'move) @@ -888,7 +895,7 @@ startup file, `~/.emacs-octave'." (defun inferior-octave-completion-at-point () "Return the data to complete the Octave symbol at point." ;; https://debbugs.gnu.org/14300 - (unless (string-match-p "/" (or (comint--match-partial-filename) "")) + (unless (string-search "/" (or (comint--match-partial-filename) "")) (let ((beg (save-excursion (skip-syntax-backward "w_" (comint-line-beginning-position)) (point))) @@ -1032,11 +1039,11 @@ directory and makes this the current buffer's default directory." (looking-at regexp))) (defun octave-maybe-insert-continuation-string () - (if (or (octave-in-comment-p) - (save-excursion - (beginning-of-line) - (looking-at octave-continuation-regexp))) - nil + (declare (obsolete nil "28.1")) + (unless (or (octave-in-comment-p) + (save-excursion + (beginning-of-line) + (looking-at octave-continuation-regexp))) (delete-horizontal-space) (insert (concat " " octave-continuation-string)))) @@ -1218,23 +1225,22 @@ q: Don't fix\n" func file)) (defun octave-indent-new-comment-line (&optional soft) "Break Octave line at point, continuing comment if within one. Insert `octave-continuation-string' before breaking the line -unless inside a list. Signal an error if within a single-quoted -string." +unless inside a list. If within a double-quoted string, insert +`octave-string-continuation-marker' instead. Signal an error if +within a single-quoted string." (interactive) (funcall comment-line-break-function soft)) (defun octave--indent-new-comment-line (orig &rest args) - (cond - ((octave-in-comment-p) nil) - ((eq (octave-in-string-p) ?') - (error "Cannot split a single-quoted string")) - ((eq (octave-in-string-p) ?\") - (insert octave-continuation-string)) - (t - (delete-horizontal-space) - (unless (and (cadr (syntax-ppss)) - (eq (char-after (cadr (syntax-ppss))) ?\()) - (insert " " octave-continuation-string)))) + (pcase (syntax-ppss) + ((app ppss-string-terminator ?\') + (user-error "Cannot split a single-quoted string")) + ((app ppss-string-terminator ?\") + (insert octave-string-continuation-marker)) + ((pred (not ppss-comment-depth)) + (delete-horizontal-space) + (unless (octave-smie--in-parens-p) + (insert " " octave-continuation-string)))) (apply orig args) (indent-according-to-mode)) @@ -1663,9 +1669,7 @@ code line." (define-button-type 'octave-help-function 'follow-link t - 'action (lambda (b) - (octave-help - (buffer-substring (button-start b) (button-end b))))) + 'action (lambda (b) (octave-help (button-label b)))) (defvar octave-help-mode-map (let ((map (make-sparse-keymap))) @@ -1766,8 +1770,8 @@ sentence." (insert "\nRetry with ") (insert-text-button "'-all'" 'follow-link t - 'action #'(lambda (_b) - (octave-lookfor str '-all))) + 'action (lambda (_b) + (octave-lookfor str '-all))) (insert ".\n")) (octave-help-mode))))) diff --git a/lisp/progmodes/pascal.el b/lisp/progmodes/pascal.el index 59f90d7293b..e6e6e40aa19 100644 --- a/lisp/progmodes/pascal.el +++ b/lisp/progmodes/pascal.el @@ -199,38 +199,32 @@ (defcustom pascal-indent-level 3 "Indentation of Pascal statements with respect to containing block." - :type 'integer - :group 'pascal) + :type 'integer) (defcustom pascal-case-indent 2 "Indentation for case statements." - :type 'integer - :group 'pascal) + :type 'integer) (defcustom pascal-auto-newline nil "Non-nil means automatically insert newlines in certain cases. These include after semicolons and after the punctuation mark after an `end'." - :type 'boolean - :group 'pascal) + :type 'boolean) (defcustom pascal-indent-nested-functions t "Non-nil means nested functions are indented." - :type 'boolean - :group 'pascal) + :type 'boolean) (defcustom pascal-tab-always-indent t "Non-nil means TAB in Pascal mode should always reindent the current line. If this is nil, TAB inserts a tab if it is at the end of the line and follows non-whitespace text." - :type 'boolean - :group 'pascal) + :type 'boolean) (defcustom pascal-auto-endcomments t "Non-nil means automatically insert comments after certain `end's. Specifically, this is done after the ends of case statements and functions. The name of the function or case is included between the braces." - :type 'boolean - :group 'pascal) + :type 'boolean) (defcustom pascal-auto-lineup '(all) "List of contexts where auto lineup of :'s or ='s should be done. @@ -243,8 +237,7 @@ will do all lineups." (const :tag "Everything" all) (const :tag "Parameter lists" paramlist) (const :tag "Declarations" declaration) - (const :tag "Case statements" case)) - :group 'pascal) + (const :tag "Case statements" case))) (defvar pascal-toggle-completions nil "If non-nil, `pascal-complete-word' tries all possible completions. @@ -260,8 +253,7 @@ completions.") These include integer, real, char, etc. The types defined within the Pascal program are handled in another way, and should not be added to this list." - :type '(repeat (string :tag "Keyword")) - :group 'pascal) + :type '(repeat (string :tag "Keyword"))) (defcustom pascal-start-keywords '("begin" "end" "function" "procedure" "repeat" "until" "while" @@ -270,8 +262,7 @@ are handled in another way, and should not be added to this list." These are keywords such as begin, repeat, until, readln. The procedures and variables defined within the Pascal program are handled in another way, and should not be added to this list." - :type '(repeat (string :tag "Keyword")) - :group 'pascal) + :type '(repeat (string :tag "Keyword"))) (defcustom pascal-separator-keywords '("downto" "else" "mod" "div" "then") @@ -279,8 +270,7 @@ are handled in another way, and should not be added to this list." These are keywords such as downto, else, mod, then. Variables and function names defined within the Pascal program are handled in another way, and should not be added to this list." - :type '(repeat (string :tag "Keyword")) - :group 'pascal) + :type '(repeat (string :tag "Keyword"))) ;;; diff --git a/lisp/progmodes/perl-mode.el b/lisp/progmodes/perl-mode.el index 0120e4a7cd1..4e14c30bc5d 100644 --- a/lisp/progmodes/perl-mode.el +++ b/lisp/progmodes/perl-mode.el @@ -98,8 +98,7 @@ (defface perl-non-scalar-variable '((t :inherit font-lock-variable-name-face :underline t)) "Face used for non-scalar variables." - :version "28.1" - :group 'perl) + :version "28.1") (defvar perl-mode-abbrev-table nil "Abbrev table in use in perl-mode buffers.") @@ -171,14 +170,22 @@ ;; (1 font-lock-constant-face) (2 font-lock-variable-name-face nil t)) ;; ;; Fontify function and package names in declarations. - ("\\<\\(package\\|sub\\)\\>[ \t]*\\(\\sw+\\)?" + ("\\<\\(package\\|sub\\)\\>[ \t]*\\(\\(?:\\sw\\|::\\)+\\)?" (1 font-lock-keyword-face) (2 font-lock-function-name-face nil t)) - ("\\(^\\|[^$@%&\\]\\)\\<\\(import\\|no\\|require\\|use\\)\\>[ \t]*\\(\\sw+\\)?" + ("\\(?:^\\|[^$@%&\\]\\)\\<\\(import\\|no\\|require\\|use\\)\\>[ \t]*\\(\\(?:\\sw\\|::\\)+\\)?" (1 font-lock-keyword-face) (2 font-lock-constant-face nil t))) "Subdued level highlighting for Perl mode.") (defconst perl-font-lock-keywords-2 (append + '(;; Fontify function, variable and file name references. They have to be + ;; handled first because they might conflict with keywords. + ("&\\(\\sw+\\(::\\sw+\\)*\\)" 1 font-lock-function-name-face) + ;; Additionally fontify non-scalar variables. `perl-non-scalar-variable' + ;; will underline them by default. + ("[$*]{?\\(\\sw+\\(::\\sw+\\)*\\)" 1 font-lock-variable-name-face) + ("\\([@%]\\|\\$#\\)\\(\\sw+\\(::\\sw+\\)*\\)" + (2 'perl-non-scalar-variable))) perl-font-lock-keywords-1 `( ;; Fontify keywords, except those fontified otherwise. ,(concat "\\<" @@ -188,16 +195,7 @@ "\\>") ;; ;; Fontify declarators and prefixes as types. - ("\\<\\(has\\|local\\|my\\|our\\|state\\)\\>" . font-lock-type-face) ; declarators - ;; - ;; Fontify function, variable and file name references. - ("&\\(\\sw+\\(::\\sw+\\)*\\)" 1 font-lock-function-name-face) - ;; Additionally fontify non-scalar variables. `perl-non-scalar-variable' - ;; will underline them by default. - ;;'("[$@%*][#{]?\\(\\sw+\\)" 1 font-lock-variable-name-face) - ("[$*]{?\\(\\sw+\\(::\\sw+\\)*\\)" 1 font-lock-variable-name-face) - ("\\([@%]\\|\\$#\\)\\(\\sw+\\(::\\sw+\\)*\\)" - (2 'perl-non-scalar-variable)) + ("\\<\\(has\\|local\\|my\\|our\\|state\\)\\>" . font-lock-keyword-face) ; declarators ("<\\(\\sw+\\)>" 1 font-lock-constant-face) ;; ;; Fontify keywords with/and labels as we do in `c++-font-lock-keywords'. @@ -286,7 +284,7 @@ (put-text-property (match-beginning 2) (match-end 2) 'syntax-table (string-to-syntax "\"")) (perl-syntax-propertize-special-constructs end))))) - ("\\(^\\|[?:.,;=!~({[ \t]\\)\\([msy]\\|q[qxrw]?\\|tr\\)\\>\\s-*\\(?:\\([^])}>= \n\t]\\)\\|\\(?3:=\\)[^>]\\)" + ("\\(^\\|[?:.,;=|&!~({[ \t]\\|=>\\)\\([msy]\\|q[qxrw]?\\|tr\\)\\>\\(?:\\s-\\|\n\\)*\\(?:\\([^])}>= \n\t]\\)\\|\\(?3:=\\)[^>]\\)" ;; Nasty cases: ;; /foo/m $a->m $#m $m @m %m ;; \s (appears often in regexps). @@ -640,7 +638,6 @@ This is a non empty list of strings, the checker tool possibly followed by required arguments. Once launched it will receive the Perl source to be checked as its standard input." :version "26.1" - :group 'perl :type '(repeat string)) (defvar-local perl--flymake-proc nil) diff --git a/lisp/progmodes/prog-mode.el b/lisp/progmodes/prog-mode.el index d88d3505586..a8b608b018a 100644 --- a/lisp/progmodes/prog-mode.el +++ b/lisp/progmodes/prog-mode.el @@ -41,8 +41,25 @@ :type 'hook :options '(flyspell-prog-mode abbrev-mode flymake-mode display-line-numbers-mode - prettify-symbols-mode) - :group 'prog-mode) + prettify-symbols-mode)) + +(defun prog-context-menu (menu) + (when (featurep 'xref) + (define-key-after menu [prog-separator] menu-bar-separator + 'mark-whole-buffer) + (define-key-after menu [xref-find-def] + '(menu-item "Find Definition" xref-find-definitions-at-mouse + :visible (save-excursion + (mouse-set-point last-input-event) + (xref-backend-identifier-at-point (xref-find-backend))) + :help "Find definition of function or variable") + 'prog-separator) + (define-key-after menu [xref-pop] + '(menu-item "Back Definition" xref-pop-marker-stack + :visible (not (xref-marker-stack-empty-p)) + :help "Back to the position of the last search") + 'xref-find-def)) + menu) (defvar prog-mode-map (let ((map (make-sparse-keymap))) @@ -166,8 +183,7 @@ on the symbol." :version "25.1" :type '(choice (const :tag "Never unprettify" nil) (const :tag "Unprettify when point is inside" t) - (const :tag "Unprettify when point is inside or at right edge" right-edge)) - :group 'prog-mode) + (const :tag "Unprettify when point is inside or at right edge" right-edge))) (defun prettify-symbols--post-command-hook () (cl-labels ((get-prop-as-list @@ -251,6 +267,7 @@ support it." "Major mode for editing programming language source code." (setq-local require-final-newline mode-require-final-newline) (setq-local parse-sexp-ignore-comments t) + (add-hook 'context-menu-functions 'prog-context-menu 10 t) ;; Any programming language is always written left to right. (setq bidi-paragraph-direction 'left-to-right)) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index abe563bec04..4620ea8f47e 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -1,7 +1,7 @@ ;;; project.el --- Operations on the current project -*- lexical-binding: t; -*- ;; Copyright (C) 2015-2021 Free Software Foundation, Inc. -;; Version: 0.5.4 +;; Version: 0.6.1 ;; Package-Requires: ((emacs "26.1") (xref "1.0.2")) ;; This is a GNU ELPA :core package. Avoid using functionality that @@ -106,7 +106,7 @@ ;; ;; - Write a new function that will determine the current project ;; based on the directory and add it to `project-find-functions' -;; (which see) using `add-hook'. It is a good idea to depend on the +;; (which see) using `add-hook'. It is a good idea to depend on the ;; directory only, and not on the current major mode, for example. ;; Because the usual expectation is that all files in the directory ;; belong to the same project (even if some/most of them are ignored). @@ -201,20 +201,27 @@ of the project instance object." (when maybe-prompt (if pr (project-remember-project pr) - (project--remove-from-project-list directory) + (project--remove-from-project-list + directory "Project `%s' not found; removed from list") (setq pr (cons 'transient directory)))) pr)) (defun project--find-in-directory (dir) (run-hook-with-args-until-success 'project-find-functions dir)) +(defvar project--within-roots-fallback nil) + (cl-defgeneric project-root (project) "Return root directory of the current project. It usually contains the main build file, dependencies configuration file, etc. Though neither is mandatory. -The directory name must be absolute." +The directory name must be absolute.") + +(cl-defmethod project-root (project + &context (project--within-roots-fallback + (eql nil))) (car (project-roots project))) (cl-defgeneric project-roots (project) @@ -226,7 +233,8 @@ and the rest should be possible to express through ;; FIXME: Can we specify project's version here? ;; FIXME: Could we make this affect cl-defmethod calls too? (declare (obsolete project-root "0.3.0")) - (list (project-root project))) + (let ((project--within-roots-fallback t)) + (list (project-root project)))) ;; FIXME: Add MODE argument, like in `ede-source-paths'? (cl-defgeneric project-external-roots (_project) @@ -288,11 +296,11 @@ to find the list of ignores for each directory." ;; Make sure ~/ etc. in local directory name is ;; expanded and not left for the shell command ;; to interpret. - (localdir (file-local-name (expand-file-name dir))) - (command (format "%s %s %s -type f %s -print0" + (localdir (file-name-unquote (file-local-name (expand-file-name dir)))) + (command (format "%s -H %s %s -type f %s -print0" find-program - ;; In case DIR is a symlink. - (file-name-as-directory localdir) + (shell-quote-argument + (directory-file-name localdir)) ; Bug#48471 (xref--find-ignores-arguments ignores localdir) (if files (concat (shell-quote-argument "(") @@ -303,16 +311,25 @@ to find the list of ignores for each directory." (concat " -o " find-name-arg " ")) " " (shell-quote-argument ")")) - "")))) + ""))) + (output (with-output-to-string + (with-current-buffer standard-output + (let ((status + (process-file-shell-command command nil t))) + (unless (zerop status) + (error "File listing failed: %s" (buffer-string)))))))) (project--remote-file-names - (sort (split-string (shell-command-to-string command) "\0" t) + (sort (split-string output "\0" t) #'string<)))) (defun project--remote-file-names (local-files) - "Return LOCAL-FILES as if they were on the system of `default-directory'." + "Return LOCAL-FILES as if they were on the system of `default-directory'. +Also quote LOCAL-FILES if `default-directory' is quoted." (let ((remote-id (file-remote-p default-directory))) (if (not remote-id) - local-files + (if (file-name-quoted-p default-directory) + (mapcar #'file-name-quote local-files) + local-files) (mapcar (lambda (file) (concat remote-id file)) local-files)))) @@ -724,13 +741,14 @@ requires quoting, e.g. `\\[quoted-insert]<space>'." (interactive (list (project--read-regexp))) (require 'xref) (require 'grep) - (let* ((pr (project-current t)) + (let* ((caller-dir default-directory) + (pr (project-current t)) (default-directory (project-root pr)) (files (if (not current-prefix-arg) (project-files pr) (let ((dir (read-directory-name "Base directory: " - nil default-directory t))) + caller-dir nil t))) (project--files-in-directory dir nil (grep-read-files regexp)))))) @@ -774,9 +792,12 @@ pattern to search for." (user-error "No matches for: %s" regexp)) xrefs)) +(defvar project-regexp-history-variable 'grep-regexp-history) + (defun project--read-regexp () - (let ((sym (thing-at-point 'symbol))) - (read-regexp "Find regexp" (and sym (regexp-quote sym))))) + (let ((sym (thing-at-point 'symbol t))) + (read-regexp "Find regexp" (and sym (regexp-quote sym)) + project-regexp-history-variable))) ;;;###autoload (defun project-find-file () @@ -858,23 +879,16 @@ PREDICATE, HIST, and DEFAULT have the same meaning as in (defun project--completing-read-strict (prompt collection &optional predicate hist default) - ;; Tried both expanding the default before showing the prompt, and - ;; removing it when it has no matches. Neither seems natural - ;; enough. Removal is confusing; early expansion makes the prompt - ;; too long. - (let* ((new-prompt (if (and default (not (string-equal default ""))) - (format "%s (default %s): " prompt default) - (format "%s: " prompt))) - (res (completing-read new-prompt - collection predicate t - nil ;; initial-input - hist default))) - (when (and (equal res default) - (not (test-completion res collection predicate))) - (setq res - (completing-read (format "%s: " prompt) - collection predicate t res hist nil))) - res)) + (minibuffer-with-setup-hook + (lambda () + (setq-local minibuffer-default-add-function + (lambda () + (let ((minibuffer-default default)) + (minibuffer-default-add-completions))))) + (completing-read (format "%s: " prompt) + collection predicate 'confirm + nil + hist))) ;;;###autoload (defun project-dired () @@ -897,14 +911,10 @@ With \\[universal-argument] prefix arg, create a new inferior shell buffer even if one already exists." (interactive) (let* ((default-directory (project-root (project-current t))) - (default-project-shell-name - (concat "*" (file-name-nondirectory - (directory-file-name - (file-name-directory default-directory))) - "-shell*")) + (default-project-shell-name (project-prefixed-buffer-name "shell")) (shell-buffer (get-buffer default-project-shell-name))) (if (and shell-buffer (not current-prefix-arg)) - (pop-to-buffer shell-buffer) + (pop-to-buffer-same-window shell-buffer) (shell (generate-new-buffer-name default-project-shell-name))))) ;;;###autoload @@ -917,14 +927,10 @@ if one already exists." (interactive) (defvar eshell-buffer-name) (let* ((default-directory (project-root (project-current t))) - (eshell-buffer-name - (concat "*" (file-name-nondirectory - (directory-file-name - (file-name-directory default-directory))) - "-eshell*")) + (eshell-buffer-name (project-prefixed-buffer-name "eshell")) (eshell-buffer (get-buffer eshell-buffer-name))) (if (and eshell-buffer (not current-prefix-arg)) - (pop-to-buffer eshell-buffer) + (pop-to-buffer-same-window eshell-buffer) (eshell t)))) ;;;###autoload @@ -973,12 +979,34 @@ loop using the command \\[fileloop-continue]." (defvar compilation-read-command) (declare-function compilation-read-command "compile") +(defun project-prefixed-buffer-name (mode) + (concat "*" + (file-name-nondirectory + (directory-file-name default-directory)) + "-" + (downcase mode) + "*")) + +(defcustom project-compilation-buffer-name-function nil + "Function to compute the name of a project compilation buffer. +If non-nil, it overrides `compilation-buffer-name-function' for +`project-compile'." + :version "28.1" + :group 'project + :type '(choice (const :tag "Default" nil) + (const :tag "Prefixed with root directory name" + project-prefixed-buffer-name) + (function :tag "Custom function"))) + ;;;###autoload (defun project-compile () "Run `compile' in the project root." (declare (interactive-only compile)) (interactive) - (let ((default-directory (project-root (project-current t)))) + (let ((default-directory (project-root (project-current t))) + (compilation-buffer-name-function + (or project-compilation-buffer-name-function + compilation-buffer-name-function))) (call-interactively #'compile))) (defun project--read-project-buffer () @@ -1085,11 +1113,16 @@ current project, it will be killed." (defun project--buffer-list (pr) "Return the list of all buffers in project PR." - (let (bufs) + (let ((conn (file-remote-p (project-root pr))) + bufs) (dolist (buf (buffer-list)) - (when (equal pr - (with-current-buffer buf - (project-current))) + ;; For now we go with the assumption that a project must reside + ;; entirely on one host. We might relax that in the future. + (when (and (equal conn + (file-remote-p (buffer-local-value 'default-directory buf))) + (equal pr + (with-current-buffer buf + (project-current)))) (push buf bufs))) (nreverse bufs))) @@ -1210,17 +1243,27 @@ Save the result in `project-list-file' if the list of projects has changed." (push (list dir) project--list) (project--write-project-list)))) -(defun project--remove-from-project-list (pr-dir) - "Remove directory PR-DIR of a missing project from the project list. +(defun project--remove-from-project-list (project-root report-message) + "Remove directory PROJECT-ROOT of a missing project from the project list. If the directory was in the list before the removal, save the result in `project-list-file'. Announce the project's removal -from the list." +from the list using REPORT-MESSAGE, which is a format string +passed to `message' as its first argument." (project--ensure-read-project-list) - (when-let ((ent (assoc pr-dir project--list))) + (when-let ((ent (assoc project-root project--list))) (setq project--list (delq ent project--list)) - (message "Project `%s' not found; removed from list" pr-dir) + (message report-message project-root) (project--write-project-list))) +;;;###autoload +(defun project-remove-known-project (project-root) + "Remove directory PROJECT-ROOT from the project list. +PROJECT-ROOT is the root directory of a known project listed in +the project list." + (interactive (list (project-prompt-project-dir))) + (project--remove-from-project-list + project-root "Project `%s' removed from known projects")) + (defun project-prompt-project-dir () "Prompt the user for a directory that is one of the known project roots. The project is chosen among projects known from the project list, @@ -1255,7 +1298,6 @@ It's also possible to enter an arbitrary directory not in the list." ;;; Project switching -;;;###autoload (defcustom project-switch-commands '((project-find-file "Find file") (project-find-regexp "Find regexp") @@ -1272,6 +1314,7 @@ to distinguish the menu entries in the dispatch menu. If KEY is absent, COMMAND must be bound in `project-prefix-map', and the key is looked up in that map." :version "28.1" + :group 'project :package-version '(project . "0.6.0") :type '(repeat (list @@ -1288,6 +1331,7 @@ listed in `project-switch-commands' and signal an error when others are invoked. Otherwise, all keys in `project-prefix-map' are legal even if they aren't listed in the dispatch menu." :type 'boolean + :group 'project :version "28.1") (defun project--keymap-prompt () @@ -1301,7 +1345,7 @@ are legal even if they aren't listed in the dispatch menu." key tmp))) (let ((key (if key (vector key) - (where-is-internal cmd project-prefix-map t)))) + (where-is-internal cmd (list project-prefix-map) t)))) (format "[%s] %s" (propertize (key-description key) 'face 'bold) label))) @@ -1317,28 +1361,36 @@ made from `project-switch-commands'. When called in a program, it will use the project corresponding to directory DIR." (interactive (list (project-prompt-project-dir))) - (let ((commands-menu - (mapcar - (lambda (row) - (if (characterp (car row)) - ;; Deprecated format. - ;; XXX: Add a warning about it? - (reverse row) - row)) - project-switch-commands)) - command) + (let* ((commands-menu + (mapcar + (lambda (row) + (if (characterp (car row)) + ;; Deprecated format. + ;; XXX: Add a warning about it? + (reverse row) + row)) + project-switch-commands)) + (commands-map + (let ((temp-map (make-sparse-keymap))) + (set-keymap-parent temp-map project-prefix-map) + (dolist (row commands-menu temp-map) + (when-let ((cmd (nth 0 row)) + (keychar (nth 2 row))) + (define-key temp-map (vector keychar) cmd))))) + command) (while (not command) - (let ((choice (read-event (project--keymap-prompt)))) - (when (setq command - (or (car - (seq-find (lambda (row) (equal choice (nth 2 row))) - commands-menu)) - (lookup-key project-prefix-map (vector choice)))) + (let* ((overriding-local-map commands-map) + (choice (read-key-sequence (project--keymap-prompt)))) + (when (setq command (lookup-key commands-map choice)) (unless (or project-switch-use-entire-map (assq command commands-menu)) ;; TODO: Add some hint to the prompt, like "key not ;; recognized" or something. - (setq command nil))))) + (setq command nil))) + (let ((global-command (lookup-key (current-global-map) choice))) + (when (memq global-command + '(keyboard-quit keyboard-escape-quit)) + (call-interactively global-command))))) (let ((default-directory dir) (project-current-inhibit-prompt t)) (call-interactively command)))) diff --git a/lisp/progmodes/prolog.el b/lisp/progmodes/prolog.el index 9f5f9ed6d3d..2e23c2e2cab 100644 --- a/lisp/progmodes/prolog.el +++ b/lisp/progmodes/prolog.el @@ -267,7 +267,6 @@ (require 'shell) ) -(require 'easymenu) (require 'align) (defgroup prolog nil @@ -1316,6 +1315,7 @@ With prefix argument ARG, restart the Prolog process if running before." (progn (process-send-string "prolog" "halt.\n") (while (get-process "prolog") (sit-for 0.1)))) + (prolog-ensure-process) (let ((buff (buffer-name))) (if (not (string= buff "*prolog*")) (prolog-goto-prolog-process-buffer)) @@ -1325,7 +1325,6 @@ With prefix argument ARG, restart the Prolog process if running before." prolog-use-sicstus-sd) (prolog-enable-sicstus-sd)) (prolog-mode-variables) - (prolog-ensure-process) )) (defun prolog-inferior-guess-flavor (&optional ignored) @@ -1350,56 +1349,57 @@ With prefix argument ARG, restart the Prolog process if running before." "If Prolog process is not running, run it. If the optional argument WAIT is non-nil, wait for Prolog prompt specified by the variable `prolog-prompt-regexp'." - (if (null (prolog-program-name)) - (error "This Prolog system has defined no interpreter.")) - (if (comint-check-proc "*prolog*") - () - (with-current-buffer (get-buffer-create "*prolog*") - (prolog-inferior-mode) - - ;; The "INFERIOR=yes" hack is for SWI-Prolog 7.2.3 and earlier, - ;; which assumes it is running under Emacs if either INFERIOR=yes or - ;; if EMACS is set to a nonempty value. The EMACS setting is - ;; obsolescent, so set INFERIOR. Newer versions of SWI-Prolog should - ;; know about INSIDE_EMACS (which replaced EMACS) and should not need - ;; this hack. - (let ((process-environment - (if (getenv "INFERIOR") - process-environment - (cons "INFERIOR=yes" process-environment)))) - (apply 'make-comint-in-buffer "prolog" (current-buffer) - (prolog-program-name) nil (prolog-program-switches))) - - (unless prolog-system - ;; Setup auto-detection. - (setq-local - prolog-system - ;; Force re-detection. - (let* ((proc (get-buffer-process (current-buffer))) - (pmark (and proc (marker-position (process-mark proc))))) - (cond - ((null pmark) (1- (point-min))) - ;; The use of insert-before-markers in comint.el together with - ;; the potential use of comint-truncate-buffer in the output - ;; filter, means that it's difficult to reliably keep track of - ;; the buffer position where the process's output started. - ;; If possible we use a marker at "start - 1", so that - ;; insert-before-marker at `start' won't shift it. And if not, - ;; we fall back on using a plain integer. - ((> pmark (point-min)) (copy-marker (1- pmark))) - (t (1- pmark))))) - (add-hook 'comint-output-filter-functions - 'prolog-inferior-guess-flavor nil t)) - (if wait - (progn - (goto-char (point-max)) - (while - (save-excursion - (not - (re-search-backward - (concat "\\(" (prolog-prompt-regexp) "\\)" "\\=") - nil t))) - (sit-for 0.1))))))) + (let ((pname (prolog-program-name)) + (pswitches (prolog-program-switches))) + (if (null pname) + (error "This Prolog system has defined no interpreter.")) + (unless (comint-check-proc "*prolog*") + (with-current-buffer (get-buffer-create "*prolog*") + (prolog-inferior-mode) + + ;; The "INFERIOR=yes" hack is for SWI-Prolog 7.2.3 and earlier, + ;; which assumes it is running under Emacs if either INFERIOR=yes or + ;; if EMACS is set to a nonempty value. The EMACS setting is + ;; obsolescent, so set INFERIOR. Newer versions of SWI-Prolog should + ;; know about INSIDE_EMACS (which replaced EMACS) and should not need + ;; this hack. + (let ((process-environment + (if (getenv "INFERIOR") + process-environment + (cons "INFERIOR=yes" process-environment)))) + (apply 'make-comint-in-buffer "prolog" (current-buffer) + pname nil pswitches)) + + (unless prolog-system + ;; Setup auto-detection. + (setq-local + prolog-system + ;; Force re-detection. + (let* ((proc (get-buffer-process (current-buffer))) + (pmark (and proc (marker-position (process-mark proc))))) + (cond + ((null pmark) (1- (point-min))) + ;; The use of insert-before-markers in comint.el together with + ;; the potential use of comint-truncate-buffer in the output + ;; filter, means that it's difficult to reliably keep track of + ;; the buffer position where the process's output started. + ;; If possible we use a marker at "start - 1", so that + ;; insert-before-marker at `start' won't shift it. And if not, + ;; we fall back on using a plain integer. + ((> pmark (point-min)) (copy-marker (1- pmark))) + (t (1- pmark))))) + (add-hook 'comint-output-filter-functions + 'prolog-inferior-guess-flavor nil t)) + (if wait + (progn + (goto-char (point-max)) + (while + (save-excursion + (not + (re-search-backward + (concat "\\(" (prolog-prompt-regexp) "\\)" "\\=") + nil t))) + (sit-for 0.1)))))))) (defun prolog-inferior-buffer (&optional dont-run) (or (get-buffer "*prolog*") @@ -2277,7 +2277,7 @@ between them)." ;(goto-char beg) (if (search-forward-regexp "^[ \t]*\\(%+\\|\\*+\\|/\\*+\\)[ \t]*" end t) - (replace-regexp-in-string "/" " " (buffer-substring beg (point))) + (string-replace "/" " " (buffer-substring beg (point))) (beginning-of-line) (when (search-forward-regexp "^[ \t]+" end t) (buffer-substring beg (point))))))))) diff --git a/lisp/progmodes/ps-mode.el b/lisp/progmodes/ps-mode.el index 15fd2e84393..67c034d0905 100644 --- a/lisp/progmodes/ps-mode.el +++ b/lisp/progmodes/ps-mode.el @@ -1,4 +1,4 @@ -;;; ps-mode.el --- PostScript mode for GNU Emacs +;;; ps-mode.el --- PostScript mode for GNU Emacs -*- lexical-binding: t; -*- ;; Copyright (C) 1999, 2001-2021 Free Software Foundation, Inc. @@ -39,7 +39,6 @@ "Peter Kleiweg <p.c.j.kleiweg@rug.nl>, bug-gnu-emacs@gnu.org") (require 'comint) -(require 'easymenu) (require 'smie) ;; Define core `PostScript' group. @@ -282,20 +281,20 @@ If nil, use `temporary-file-directory'." (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) + (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) + (define-key map "\177" #'ps-mode-backward-delete-char) map) "Local keymap to use in PostScript mode.") @@ -337,10 +336,10 @@ If nil, use `temporary-file-directory'." (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) + (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.") @@ -1093,7 +1092,7 @@ Use line numbers if `ps-run-error-line-numbers' is not nil." ;; -(add-hook 'kill-emacs-hook 'ps-run-cleanup) +(add-hook 'kill-emacs-hook #'ps-run-cleanup) (provide 'ps-mode) diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index afb96974b17..20299c20d28 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -54,14 +54,7 @@ ;; `python-nav-backward-statement', ;; `python-nav-beginning-of-statement', `python-nav-end-of-statement', ;; `python-nav-beginning-of-block', `python-nav-end-of-block' and -;; `python-nav-if-name-main' are included but no bound to any key. At -;; last but not least the specialized `python-nav-forward-sexp' allows -;; easy navigation between code blocks. If you prefer `cc-mode'-like -;; `forward-sexp' movement, setting `forward-sexp-function' to nil is -;; enough, You can do that using the `python-mode-hook': - -;; (add-hook 'python-mode-hook -;; (lambda () (setq forward-sexp-function nil))) +;; `python-nav-if-name-main' are included but no bound to any key. ;; Shell interaction: is provided and allows opening Python shells ;; inside Emacs and executing any block of code of your current buffer @@ -241,14 +234,12 @@ ;; 2) Add the following hook in your .emacs: ;; (add-hook 'python-mode-hook -;; #'(lambda () -;; (define-key python-mode-map "\C-m" 'newline-and-indent))) +;; (lambda () +;; (define-key python-mode-map "\C-m" 'newline-and-indent))) ;; I'd recommend the first one since you'll get the same behavior for ;; all modes out-of-the-box. -;;; TODO: - ;;; Code: (require 'ansi-color) @@ -3094,7 +3085,8 @@ t when called interactively." (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)) + (let* ((temp-file-name (with-current-buffer (process-buffer process) + (python-shell--save-temp-file string))) (file-name (or (buffer-file-name) temp-file-name))) (python-shell-send-file file-name process temp-file-name t)) (comint-send-string process string) @@ -3385,7 +3377,8 @@ 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)) + (process-buffer (python-shell-get-process-or-error msg)) + nil 'mark-for-redisplay)) (defun python-shell-send-setup-code () "Send all setup code for shell. @@ -3976,8 +3969,8 @@ Returns the tracked buffer." "Finish tracking." (python-pdbtrack-unset-tracked-buffer) (when python-pdbtrack-kill-buffers - (mapc #'(lambda (buffer) - (ignore-errors (kill-buffer buffer))) + (mapc (lambda (buffer) + (ignore-errors (kill-buffer buffer))) python-pdbtrack-buffers-to-kill)) (setq python-pdbtrack-buffers-to-kill nil)) @@ -4240,6 +4233,11 @@ JUSTIFY should be used (if applicable) as in `fill-paragraph'." (point))))) (num-quotes (python-syntax-count-quotes (char-after str-start-pos) str-start-pos)) + (str-line-start-pos + (save-excursion + (goto-char str-start-pos) + (beginning-of-line) + (point-marker))) (str-end-pos (save-excursion (goto-char (+ str-start-pos num-quotes)) @@ -4263,7 +4261,7 @@ JUSTIFY should be used (if applicable) as in `fill-paragraph'." ('symmetric (and multi-line-p (cons 1 1))))) (fill-paragraph-function)) (save-restriction - (narrow-to-region str-start-pos str-end-pos) + (narrow-to-region str-line-start-pos str-end-pos) (fill-paragraph justify)) (save-excursion (when (and (python-info-docstring-p) python-fill-docstring-style) @@ -5501,6 +5499,13 @@ By default messages are considered errors." :type '(alist :key-type (regexp) :value-type (symbol))) +(defcustom python-forward-sexp-function #'python-nav-forward-sexp + "Function to use when navigating between expressions." + :version "28.1" + :type '(choice (const :tag "Python blocks" python-nav-forward-sexp) + (const :tag "CC-mode like" nil) + function)) + (defvar-local python--flymake-proc nil) (defun python--flymake-parse-output (source proc report-fn) @@ -5598,7 +5603,7 @@ REPORT-FN is Flymake's callback function." (setq-local parse-sexp-lookup-properties t) (setq-local parse-sexp-ignore-comments t) - (setq-local forward-sexp-function #'python-nav-forward-sexp) + (setq-local forward-sexp-function python-forward-sexp-function) (setq-local font-lock-defaults `(,python-font-lock-keywords diff --git a/lisp/progmodes/ruby-mode.el b/lisp/progmodes/ruby-mode.el index e7f407b6367..c09f007a5ee 100644 --- a/lisp/progmodes/ruby-mode.el +++ b/lisp/progmodes/ruby-mode.el @@ -291,6 +291,7 @@ Only has effect when `ruby-use-smie' is nil." (defcustom ruby-encoding-map '((us-ascii . nil) ;; Do not put coding: us-ascii + (utf-8 . nil) ;; Default since Ruby 2.0 (shift-jis . cp932) ;; Emacs charset name of Shift_JIS (shift_jis . cp932) ;; MIME charset name of Shift_JIS (japanese-cp932 . cp932)) ;; Emacs charset name of CP932 @@ -331,7 +332,7 @@ It is used when `ruby-encoding-magic-comment-style' is set to `custom'." (require 'smie) ;; Here's a simplified BNF grammar, for reference: -;; http://www.cse.buffalo.edu/~regan/cse305/RubyBNF.pdf +;; https://www.cse.buffalo.edu/~regan/cse305/RubyBNF.pdf (defconst ruby-smie-grammar (smie-prec2->grammar (smie-merge-prec2s @@ -678,7 +679,7 @@ It is used when `ruby-encoding-magic-comment-style' is set to `custom'." (let ((index-alist '()) (case-fold-search nil) name next pos decl sing) (goto-char beg) - (while (re-search-forward "^\\s *\\(\\(class\\s +\\|\\(class\\s *<<\\s *\\)\\|module\\s +\\)\\([^(<\n ]+\\)\\|\\(def\\|alias\\)\\s +\\([^(\n ]+\\)\\)" end t) + (while (re-search-forward "^\\s *\\(\\(class\\s +\\|\\(class\\s *<<\\s *\\)\\|module\\s +\\)\\([^(<\n ]+\\)\\|\\(\\(?:\\(?:private\\|protected\\|public\\) +\\)?def\\|alias\\)\\s +\\([^(\n ]+\\)\\)" end t) (setq sing (match-beginning 3)) (setq decl (match-string 5)) (setq next (match-end 0)) @@ -688,7 +689,7 @@ It is used when `ruby-encoding-magic-comment-style' is set to `custom'." ((string= "alias" decl) (if prefix (setq name (concat prefix name))) (push (cons name pos) index-alist)) - ((string= "def" decl) + ((not (null decl)) (if prefix (setq name (cond @@ -760,7 +761,7 @@ The style of the comment is controlled by `ruby-encoding-magic-comment-style'." (defun ruby--detect-encoding () (if (eq ruby-insert-encoding-magic-comment 'always-utf8) - "utf-8" + 'utf-8 (let ((coding-system (or save-buffer-coding-system buffer-file-coding-system))) @@ -769,12 +770,11 @@ The style of the comment is controlled by `ruby-encoding-magic-comment-style'." (or (coding-system-get coding-system 'mime-charset) (coding-system-change-eol-conversion coding-system nil)))) (if coding-system - (symbol-name - (if ruby-use-encoding-map - (let ((elt (assq coding-system ruby-encoding-map))) - (if elt (cdr elt) coding-system)) - coding-system)) - "ascii-8bit")))) + (if ruby-use-encoding-map + (let ((elt (assq coding-system ruby-encoding-map))) + (if elt (cdr elt) coding-system)) + coding-system) + 'ascii-8bit)))) (defun ruby--encoding-comment-required-p () (or (eq ruby-insert-encoding-magic-comment 'always-utf8) @@ -796,7 +796,7 @@ The style of the comment is controlled by `ruby-encoding-magic-comment-style'." (unless (string= (match-string 2) coding-system) (goto-char (match-beginning 2)) (delete-region (point) (match-end 2)) - (insert coding-system))) + (insert (symbol-name coding-system)))) ((looking-at "\\s *#.*coding\\s *[:=]")) (t (when ruby-insert-encoding-magic-comment (ruby--insert-coding-comment coding-system)))) @@ -1788,8 +1788,8 @@ If the result is do-end block, it will always be multiline." (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)))) + (string-replace "\\\"" "\"" (replace-regexp-in-string "\\(\\`\\|[^\\]\\)'" "\\1\\\\'" content)) + (string-replace "\\'" "'" (replace-regexp-in-string "\\(\\`\\|[^\\]\\)\"" "\\1\\\\\"" content)))) (let ((orig-point (point))) (delete-region min max) (insert @@ -1802,12 +1802,12 @@ FEATURE-NAME is a relative file name, file extension is optional. This commands delegates to `gem which', which searches both installed gems and the standard library. When called interactively, defaults to the feature name in the `require' -statement around point." +or `gem' statement around point." (interactive) (unless feature-name (let ((init (save-excursion (forward-line 0) - (when (looking-at "require [\"']\\(.*\\)[\"']") + (when (looking-at "\\(?:require\\| *gem\\) [\"']\\(.*?\\)[\"']") (match-string 1))))) (setq feature-name (read-string "Feature name: " init)))) (let ((out @@ -2127,11 +2127,9 @@ It will be properly highlighted even when the call omits parens.") "loop" "open" "p" - "print" "printf" "proc" "putc" - "puts" "require" "require_relative" "spawn" @@ -2180,9 +2178,11 @@ It will be properly highlighted even when the call omits parens.") "fork" "global_variables" "local_variables" + "print" "private" "protected" "public" + "puts" "raise" "rand" "readline" @@ -2421,6 +2421,15 @@ If there is no Rubocop config file, Rubocop will be passed a flag report-fn args)) +(defconst ruby--prettify-symbols-alist + '(("<=" . ?≤) + (">=" . ?≥) + ("->" . ?→) + ("=>" . ?⇒) + ("::" . ?∷) + ("lambda" . ?λ)) + "Value for `prettify-symbols-alist' in `ruby-mode'.") + ;;;###autoload (define-derived-mode ruby-mode prog-mode "Ruby" "Major mode for editing Ruby code." @@ -2437,6 +2446,7 @@ If there is no Rubocop config file, Rubocop will be passed a flag (setq-local font-lock-defaults '((ruby-font-lock-keywords) nil nil ((?_ . "w")))) + (setq-local prettify-symbols-alist ruby--prettify-symbols-alist) (setq-local syntax-propertize-function #'ruby-syntax-propertize)) diff --git a/lisp/progmodes/scheme.el b/lisp/progmodes/scheme.el index f610efbfca5..57351a7308d 100644 --- a/lisp/progmodes/scheme.el +++ b/lisp/progmodes/scheme.el @@ -28,7 +28,7 @@ ;; the Lisp mode documented in the Emacs manual. `dsssl-mode' is a ;; variant of scheme-mode for editing DSSSL specifications for SGML ;; documents. [As of Apr 1997, some pointers for DSSSL may be found, -;; for instance, at <URL:http://www.sil.org/sgml/related.html#dsssl>.] +;; for instance, at <URL:https://www.sil.org/sgml/related.html#dsssl>.] ;; All these Lisp-ish modes vary basically in details of the language ;; syntax they highlight/indent/index, but dsssl-mode uses "^;;;" as ;; the page-delimiter since ^L isn't normally a valid SGML character. @@ -162,25 +162,26 @@ (defvar scheme-mode-line-process "") (defvar scheme-mode-map - (let ((smap (make-sparse-keymap)) - (map (make-sparse-keymap "Scheme"))) - (set-keymap-parent smap lisp-mode-shared-map) - (define-key smap [menu-bar scheme] (cons "Scheme" map)) - (define-key map [run-scheme] '("Run Inferior Scheme" . run-scheme)) - (define-key map [uncomment-region] - '("Uncomment Out Region" . (lambda (beg end) - (interactive "r") - (comment-region beg end '(4))))) - (define-key map [comment-region] '("Comment Out Region" . comment-region)) - (define-key map [indent-region] '("Indent Region" . indent-region)) - (define-key map [indent-line] '("Indent Line" . lisp-indent-line)) - (put 'comment-region 'menu-enable 'mark-active) - (put 'uncomment-region 'menu-enable 'mark-active) - (put 'indent-region 'menu-enable 'mark-active) - smap) + (let ((map (make-sparse-keymap))) + (set-keymap-parent map lisp-mode-shared-map) + map) "Keymap for Scheme mode. All commands in `lisp-mode-shared-map' are inherited by this map.") +(easy-menu-define scheme-mode-menu scheme-mode-map + "Menu for Scheme mode." + '("Scheme" + ["Indent Line" lisp-indent-line] + ["Indent Region" indent-region + :enable mark-active] + ["Comment Out Region" comment-region + :enable mark-active] + ["Uncomment Out Region" (lambda (beg end) + (interactive "r") + (comment-region beg end '(4))) + :enable mark-active] + ["Run Inferior Scheme" run-scheme])) + ;; Used by cmuscheme (defun scheme-mode-commands (map) ;;(define-key map "\t" 'indent-for-tab-command) ; default @@ -215,8 +216,7 @@ Blank lines separate paragraphs. Semicolons start comments. (defcustom scheme-mit-dialect t "If non-nil, scheme mode is specialized for MIT Scheme. Set this to nil if you normally use another dialect." - :type 'boolean - :group 'scheme) + :type 'boolean) (defcustom dsssl-sgml-declaration "<!DOCTYPE style-sheet PUBLIC \"-//James Clark//DTD DSSSL Style Sheet//EN\"> @@ -226,26 +226,22 @@ If it is defined as a string this will be inserted into an empty buffer which is in `dsssl-mode'. It is typically James Clark's style-sheet doctype, as required for Jade." :type '(choice (string :tag "Specified string") - (const :tag "None" :value nil)) - :group 'scheme) + (const :tag "None" :value nil))) (defcustom scheme-mode-hook nil "Normal hook run when entering `scheme-mode'. See `run-hooks'." - :type 'hook - :group 'scheme) + :type 'hook) (defcustom dsssl-mode-hook nil "Normal hook run when entering `dsssl-mode'. See `run-hooks'." - :type 'hook - :group 'scheme) + :type 'hook) ;; This is shared by cmuscheme and xscheme. (defcustom scheme-program-name "scheme" "Program invoked by the `run-scheme' command." - :type 'string - :group 'scheme) + :type 'string) (defvar dsssl-imenu-generic-expression ;; Perhaps this should also look for the style-sheet DTD tags. I'm @@ -303,7 +299,9 @@ See `run-hooks'." (concat "(" (regexp-opt '("begin" "call-with-current-continuation" "call/cc" - "call-with-input-file" "call-with-output-file" "case" "cond" + "call-with-input-file" "call-with-output-file" + "call-with-port" + "case" "cond" "do" "else" "for-each" "if" "lambda" "λ" "let" "let*" "let-syntax" "letrec" "letrec-syntax" ;; R6RS library subforms. @@ -429,12 +427,10 @@ that variable's value is a string." '(1 font-lock-keyword-face) '(4 font-lock-function-name-face)) (cons - (concat "(\\(" - ;; (make-regexp '("case" "cond" "else" "if" "lambda" - ;; "let" "let*" "letrec" "and" "or" "map" "with-mode")) - "and\\|c\\(ase\\|ond\\)\\|else\\|if\\|" - "l\\(ambda\\|et\\(\\|\\*\\|rec\\)\\)\\|map\\|or\\|with-mode" - "\\)\\>") + (concat "(" (regexp-opt + '("case" "cond" "else" "if" "lambda" + "let" "let*" "letrec" "and" "or" "map" "with-mode") + 'words)) 1) ;; DSSSL syntax '("(\\(element\\|mode\\|declare-\\w+\\)\\>[ \t]*\\(\\sw+\\)" @@ -548,6 +544,7 @@ indentation." (put 'library 'scheme-indent-function 1) ; R6RS (put 'call-with-input-file 'scheme-indent-function 1) +(put 'call-with-port 'scheme-indent-function 1) (put 'with-input-from-file 'scheme-indent-function 1) (put 'with-input-from-port 'scheme-indent-function 1) (put 'call-with-output-file 'scheme-indent-function 1) diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el index f588ad99c9d..b6674731ddf 100644 --- a/lisp/progmodes/sh-script.el +++ b/lisp/progmodes/sh-script.el @@ -403,8 +403,7 @@ This is buffer-local in every such buffer.") "Syntax-table used in Shell-Script mode. See `sh-feature'.") (defvar sh-mode-map - (let ((map (make-sparse-keymap)) - (menu-map (make-sparse-keymap))) + (let ((map (make-sparse-keymap))) (define-key map "\C-c(" 'sh-function) (define-key map "\C-c\C-w" 'sh-while) (define-key map "\C-c\C-u" 'sh-until) @@ -434,74 +433,57 @@ This is buffer-local in every such buffer.") (define-key map "\C-c:" 'sh-set-shell) (define-key map [remap backward-sentence] 'sh-beginning-of-command) (define-key map [remap forward-sentence] 'sh-end-of-command) - (define-key map [menu-bar sh-script] (cons "Sh-Script" menu-map)) - (define-key menu-map [smie-config-guess] - '(menu-item "Learn buffer indentation" smie-config-guess - :help "Learn how to indent the buffer the way it currently is.")) - (define-key menu-map [smie-config-show-indent] - '(menu-item "Show indentation" smie-config-show-indent - :help "Show the how the current line would be indented")) - (define-key menu-map [smie-config-set-indent] - '(menu-item "Set indentation" smie-config-set-indent - :help "Set the indentation for the current line")) - - (define-key menu-map [sh-pair] - '(menu-item "Insert braces and quotes in pairs" - electric-pair-mode - :button (:toggle . (bound-and-true-p electric-pair-mode)) - :help "Inserting a brace or quote automatically inserts the matching pair")) - - (define-key menu-map [sh-s0] '("--")) - ;; Insert - (define-key menu-map [sh-function] - '(menu-item "Function..." sh-function - :help "Insert a function definition")) - (define-key menu-map [sh-add] - '(menu-item "Addition..." sh-add - :help "Insert an addition of VAR and prefix DELTA for Bourne (type) shell")) - (define-key menu-map [sh-until] - '(menu-item "Until Loop" sh-until - :help "Insert an until loop")) - (define-key menu-map [sh-repeat] - '(menu-item "Repeat Loop" sh-repeat - :help "Insert a repeat loop definition")) - (define-key menu-map [sh-while] - '(menu-item "While Loop" sh-while - :help "Insert a while loop")) - (define-key menu-map [sh-getopts] - '(menu-item "Options Loop" sh-while-getopts - :help "Insert a while getopts loop.")) - (define-key menu-map [sh-indexed-loop] - '(menu-item "Indexed Loop" sh-indexed-loop - :help "Insert an indexed loop from 1 to n.")) - (define-key menu-map [sh-select] - '(menu-item "Select Statement" sh-select - :help "Insert a select statement ")) - (define-key menu-map [sh-if] - '(menu-item "If Statement" sh-if - :help "Insert an if statement")) - (define-key menu-map [sh-for] - '(menu-item "For Loop" sh-for - :help "Insert a for loop")) - (define-key menu-map [sh-case] - '(menu-item "Case Statement" sh-case - :help "Insert a case/switch statement")) - (define-key menu-map [sh-s1] '("--")) - (define-key menu-map [sh-exec] - '(menu-item "Execute region" sh-execute-region - :help "Pass optional header and region to a subshell for noninteractive execution")) - (define-key menu-map [sh-exec-interpret] - '(menu-item "Execute script..." executable-interpret - :help "Run script with user-specified args, and collect output in a buffer")) - (define-key menu-map [sh-set-shell] - '(menu-item "Set shell type..." sh-set-shell - :help "Set this buffer's shell to SHELL (a string)")) - (define-key menu-map [sh-backslash-region] - '(menu-item "Backslash region" sh-backslash-region - :help "Insert, align, or delete end-of-line backslashes on the lines in the region.")) map) "Keymap used in Shell-Script mode.") +(easy-menu-define sh-mode-menu sh-mode-map + "Menu for Shell-Script mode." + '("Sh-Script" + ["Backslash region" sh-backslash-region + :help "Insert, align, or delete end-of-line backslashes on the lines in the region."] + ["Set shell type..." sh-set-shell + :help "Set this buffer's shell to SHELL (a string)"] + ["Execute script..." executable-interpret + :help "Run script with user-specified args, and collect output in a buffer"] + ["Execute region" sh-execute-region + :help "Pass optional header and region to a subshell for noninteractive execution"] + "---" + ;; Insert + ["Case Statement" sh-case + :help "Insert a case/switch statement"] + ["For Loop" sh-for + :help "Insert a for loop"] + ["If Statement" sh-if + :help "Insert an if statement"] + ["Select Statement" sh-select + :help "Insert a select statement "] + ["Indexed Loop" sh-indexed-loop + :help "Insert an indexed loop from 1 to n."] + ["Options Loop" sh-while-getopts + :help "Insert a while getopts loop."] + ["While Loop" sh-while + :help "Insert a while loop"] + ["Repeat Loop" sh-repeat + :help "Insert a repeat loop definition"] + ["Until Loop" sh-until + :help "Insert an until loop"] + ["Addition..." sh-add + :help "Insert an addition of VAR and prefix DELTA for Bourne (type) shell"] + ["Function..." sh-function + :help "Insert a function definition"] + "---" + ;; Other + ["Insert braces and quotes in pairs" electric-pair-mode + :style toggle + :selected (bound-and-true-p electric-pair-mode) + :help "Inserting a brace or quote automatically inserts the matching pair"] + ["Set indentation" smie-config-set-indent + :help "Set the indentation for the current line"] + ["Show indentation" smie-config-show-indent + :help "Show the how the current line would be indented"] + ["Learn buffer indentation" smie-config-guess + :help "Learn how to indent the buffer the way it currently is."])) + (defvar sh-skeleton-pair-default-alist '((?\( _ ?\)) (?\)) (?\[ ?\s _ ?\s ?\]) (?\]) (?{ _ ?}) (?\})) @@ -1550,6 +1532,7 @@ with your script for an edit-interpret-debug cycle." (setq-local add-log-current-defun-function #'sh-current-defun-name) (add-hook 'completion-at-point-functions #'sh-completion-at-point-function nil t) + (setq-local outline-regexp "###") ;; Parse or insert magic number for exec, and set all variables depending ;; on the shell thus determined. (sh-set-shell @@ -1614,6 +1597,8 @@ This adds rules for comments and assignments." ;;; Completion +(defvar sh--completion-keywords '("if" "while" "until" "for")) + (defun sh--vars-before-point () (save-excursion (let ((vars ())) @@ -1635,7 +1620,7 @@ This adds rules for comments and assignments." (sh--vars-before-point)) (locate-file-completion-table exec-path exec-suffixes string pred t) - '("if" "while" "until" "for")))) + sh--completion-keywords))) (complete-with-action action cmds string pred))) (defun sh-completion-at-point-function () @@ -1646,9 +1631,17 @@ This adds rules for comments and assignments." (start (point))) (cond ((eq (char-before) ?$) - (list start end (sh--vars-before-point))) + (list start end (sh--vars-before-point) + :company-kind (lambda (_) 'variable))) ((sh-smie--keyword-p) - (list start end #'sh--cmd-completion-table)))))) + (list start end #'sh--cmd-completion-table + :company-kind + (lambda (s) + (cond + ((member s sh--completion-keywords) 'keyword) + ((string-suffix-p "=" s) 'variable) + (t 'function))) + )))))) ;;; Indentation and navigation with SMIE. @@ -2200,6 +2193,8 @@ Point should be before the newline." When used interactively, insert the proper starting #!-line, and make the visited file executable via `executable-set-magic', perhaps querying depending on the value of `executable-query'. +(If given a prefix (i.e., `C-u') don't insert any starting #! +line.) When this function is called noninteractively, INSERT-FLAG (the third argument) controls whether to insert a #!-line and think about making @@ -2223,7 +2218,7 @@ whose value is the shell name (don't quote it)." '("csh" "rc" "sh")) nil nil nil nil sh-shell-file) (eq executable-query 'function) - t)) + (not current-prefix-arg))) (if (string-match "\\.exe\\'" shell) (setq shell (substring shell 0 (match-beginning 0)))) (setq sh-shell (sh-canonicalize-shell shell)) @@ -2678,7 +2673,7 @@ t means to return a list of all possible completions of STRING. (or sh-shell-variables-initialized (sh-shell-initialize-variables)) (nconc (mapcar (lambda (var) - (substring var 0 (string-match "=" var))) + (substring var 0 (string-search "=" var))) process-environment) sh-shell-variables)))) (complete-with-action code vars string predicate))) @@ -2985,7 +2980,7 @@ The document is bounded by `sh-here-document-word'." (define-minor-mode sh-electric-here-document-mode "Make << insert a here document skeleton." - nil nil nil + :lighter nil (if sh-electric-here-document-mode (add-hook 'post-self-insert-hook #'sh--maybe-here-document nil t) (remove-hook 'post-self-insert-hook #'sh--maybe-here-document t))) diff --git a/lisp/progmodes/simula.el b/lisp/progmodes/simula.el index a863e7eb4b4..7c0de9fc359 100644 --- a/lisp/progmodes/simula.el +++ b/lisp/progmodes/simula.el @@ -1,4 +1,4 @@ -;;; simula.el --- SIMULA 87 code editing commands for Emacs +;;; simula.el --- SIMULA 87 code editing commands for Emacs -*- lexical-binding: t; -*- ;; Copyright (C) 1992, 1994, 1996, 2001-2021 Free Software Foundation, ;; Inc. @@ -51,16 +51,15 @@ the run of whitespace at the beginning of the line.") "Non-nil means TAB in SIMULA mode should always reindent the current line. Otherwise TAB indents only when point is within the run of whitespace at the beginning of the line." - :type 'boolean - :group 'simula) + :type 'boolean) +(make-obsolete-variable 'simula-tab-always-indent 'tab-always-indent "28.1") (defconst simula-indent-level-default 3 "Indentation of SIMULA statements with respect to containing block.") (defcustom simula-indent-level simula-indent-level-default "Indentation of SIMULA statements with respect to containing block." - :type 'integer - :group 'simula) + :type 'integer) (defconst simula-substatement-offset-default 3 @@ -68,8 +67,7 @@ the run of whitespace at the beginning of the line." (defcustom simula-substatement-offset simula-substatement-offset-default "Extra indentation after DO, THEN, ELSE, WHEN and OTHERWISE." - :type 'integer - :group 'simula) + :type 'integer) (defconst simula-continued-statement-offset-default 3 "Extra indentation for lines not starting a statement or substatement. @@ -83,16 +81,14 @@ the previous line of the statement.") If value is a list, each line in a multipleline continued statement will have the car of the list extra indentation with respect to the previous line of the statement." - :type 'integer - :group 'simula) + :type 'integer) (defconst simula-label-offset-default -4711 "Offset of SIMULA label lines relative to usual indentation.") (defcustom simula-label-offset simula-label-offset-default "Offset of SIMULA label lines relative to usual indentation." - :type 'integer - :group 'simula) + :type 'integer) (defconst simula-if-indent-default '(0 . 0) "Extra indentation of THEN and ELSE with respect to the starting IF. @@ -103,8 +99,7 @@ extra ELSE indentation. IF after ELSE is indented as the starting IF.") "Extra indentation of THEN and ELSE with respect to the starting IF. Value is a cons cell, the car is extra THEN indentation and the cdr extra ELSE indentation. IF after ELSE is indented as the starting IF." - :type '(cons integer integer) - :group 'simula) + :type '(cons integer integer)) (defconst simula-inspect-indent-default '(0 . 0) "Extra indentation of WHEN and OTHERWISE with respect to the INSPECT. @@ -115,16 +110,14 @@ and the cdr extra OTHERWISE indentation.") "Extra indentation of WHEN and OTHERWISE with respect to the INSPECT. Value is a cons cell, the car is extra WHEN indentation and the cdr extra OTHERWISE indentation." - :type '(cons integer integer) - :group 'simula) + :type '(cons integer integer)) (defconst simula-electric-indent-default nil "Non-nil means `simula-indent-line' function may reindent previous line.") (defcustom simula-electric-indent simula-electric-indent-default "Non-nil means `simula-indent-line' function may reindent previous line." - :type 'boolean - :group 'simula) + :type 'boolean) (defconst simula-abbrev-keyword-default 'upcase "Specify how to convert case for SIMULA keywords. @@ -135,8 +128,7 @@ Value is one of the symbols `upcase', `downcase', `capitalize', "Specify how to convert case for SIMULA keywords. Value is one of the symbols `upcase', `downcase', `capitalize', \(as in) `abbrev-table' or nil if they should not be changed." - :type '(choice (const upcase) (const downcase) (const capitalize)(const nil)) - :group 'simula) + :type '(choice (const upcase) (const downcase) (const capitalize)(const nil))) (defconst simula-abbrev-stdproc-default 'abbrev-table "Specify how to convert case for standard SIMULA procedure and class names. @@ -148,18 +140,33 @@ Value is one of the symbols `upcase', `downcase', `capitalize', Value is one of the symbols `upcase', `downcase', `capitalize', \(as in) `abbrev-table', or nil if they should not be changed." :type '(choice (const upcase) (const downcase) (const capitalize) - (const abbrev-table) (const nil)) - :group 'simula) + (const abbrev-table) (const nil))) (defcustom simula-abbrev-file nil "File with extra abbrev definitions for use in SIMULA mode. These are used together with the standard abbrev definitions for SIMULA. Please note that the standard definitions are required for SIMULA mode to function correctly." - :type '(choice file (const nil)) - :group 'simula) - -(defvar simula-mode-syntax-table nil + :type '(choice file (const nil))) + +(defvar simula-mode-syntax-table + (let ((st (copy-syntax-table (standard-syntax-table)))) + (modify-syntax-entry ?! "<" st) + (modify-syntax-entry ?$ "." st) + (modify-syntax-entry ?% "< b" st) + (modify-syntax-entry ?\n "> b" 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) + st) "Syntax table in SIMULA mode buffers.") (defconst simula-syntax-propertize-function @@ -248,90 +255,45 @@ for SIMULA mode to function correctly." ["Forward Statement" simula-next-statement t] ["Backward Up Level" simula-backward-up-level t] ["Forward Down Statement" simula-forward-down-level t]) - "Lucid Emacs menu for SIMULA mode.") - -(if simula-mode-syntax-table - () - (setq simula-mode-syntax-table (copy-syntax-table (standard-syntax-table))) - (modify-syntax-entry ?! "<" simula-mode-syntax-table) - (modify-syntax-entry ?$ "." simula-mode-syntax-table) - (modify-syntax-entry ?% "< b" simula-mode-syntax-table) - (modify-syntax-entry ?\n "> b" simula-mode-syntax-table) - (modify-syntax-entry ?' "\"" simula-mode-syntax-table) - (modify-syntax-entry ?\( "()" simula-mode-syntax-table) - (modify-syntax-entry ?\) ")(" simula-mode-syntax-table) - (modify-syntax-entry ?\; ">" simula-mode-syntax-table) - (modify-syntax-entry ?\[ "." simula-mode-syntax-table) - (modify-syntax-entry ?\\ "." simula-mode-syntax-table) - (modify-syntax-entry ?\] "." simula-mode-syntax-table) - (modify-syntax-entry ?_ "_" simula-mode-syntax-table) - (modify-syntax-entry ?\| "." simula-mode-syntax-table) - (modify-syntax-entry ?\{ "." simula-mode-syntax-table) - (modify-syntax-entry ?\} "." simula-mode-syntax-table)) + "Emacs menu for SIMULA mode.") (defvar simula-mode-map (let ((map (make-sparse-keymap))) - (define-key map "\C-c\C-u" 'simula-backward-up-level) - (define-key map "\C-c\C-p" 'simula-previous-statement) - (define-key map "\C-c\C-d" 'simula-forward-down-level) - (define-key map "\C-c\C-n" 'simula-next-statement) - ;; (define-key map "\C-c\C-g" 'simula-goto-definition) - ;; (define-key map "\C-c\C-h" 'simula-standard-help) - (define-key map "\177" 'backward-delete-char-untabify) - (define-key map ":" 'simula-electric-label) - (define-key map "\e\C-q" 'simula-indent-exp) - (define-key map "\t" 'simula-indent-command) - - (define-key map [menu-bar simula] - (cons "SIMULA" (make-sparse-keymap "SIMULA"))) - (define-key map [menu-bar simula indent-exp] - '("Indent Expression" . simula-indent-exp)) - (define-key map [menu-bar simula indent-line] - '("Indent Line" . simula-indent-command)) - (define-key map [menu-bar simula separator-navigate] - '("--")) - (define-key map [menu-bar simula backward-stmt] - '("Previous Statement" . simula-previous-statement)) - (define-key map [menu-bar simula forward-stmt] - '("Next Statement" . simula-next-statement)) - (define-key map [menu-bar simula backward-up] - '("Backward Up Level" . simula-backward-up-level)) - (define-key map [menu-bar simula forward-down] - '("Forward Down Statement" . simula-forward-down-level)) - - (put 'simula-next-statement 'menu-enable '(not (eobp))) - (put 'simula-previous-statement 'menu-enable '(not (bobp))) - (put 'simula-forward-down-level 'menu-enable '(not (eobp))) - (put 'simula-backward-up-level 'menu-enable '(not (bobp))) - (put 'simula-indent-command 'menu-enable '(not buffer-read-only)) - (put 'simula-indent-exp 'menu-enable '(not buffer-read-only)) - - ;; RMS: mouse-3 should not select this menu. mouse-3's global - ;; definition is useful in SIMULA mode and we should not interfere - ;; with that. The menu is mainly for beginners, and for them, - ;; the menubar requires less memory than a special click. - ;; in Lucid Emacs, we want the menu to popup when the 3rd button is - ;; hit. In 19.10 and beyond this is done automatically if we put - ;; the menu on mode-popup-menu variable, see c-common-init [cc-mode.el] - ;;(if (not (boundp 'mode-popup-menu)) - ;; (define-key simula-mode-map 'button3 'simula-popup-menu)) + (define-key map "\C-c\C-u" #'simula-backward-up-level) + (define-key map "\C-c\C-p" #'simula-previous-statement) + (define-key map "\C-c\C-d" #'simula-forward-down-level) + (define-key map "\C-c\C-n" #'simula-next-statement) + ;; (define-key map "\C-c\C-g" #'simula-goto-definition) + ;; (define-key map "\C-c\C-h" #'simula-standard-help) + (define-key map "\177" #'backward-delete-char-untabify) + (define-key map ":" #'simula-electric-label) + (define-key map "\e\C-q" #'simula-indent-exp) + ;; (define-key map "\t" #'simula-indent-command) map) "Keymap used in `simula-mode'.") -;; menus for Lucid -(defun simula-popup-menu (_e) - "Pops up the SIMULA menu." - (interactive "@e") - (popup-menu (cons (concat mode-name " Mode Commands") simula-mode-menu))) +(easy-menu-define simula-mode-menu simula-mode-map + "Menu for `simula-mode'." + '("SIMULA" + ["Forward Down Statement" simula-forward-down-level + :enable (not (eobp))] + ["Backward Up Level" simula-backward-up-level + :enable (not (bobp))] + ["Next Statement" simula-next-statement + :enable (not (eobp))] + ["Previous Statement" simula-previous-statement + :enable (not (bobp))] + "---" + ;; ["Indent Line" simula-indent-command + ;; :enable (not buffer-read-only)] + ["Indent Expression" simula-indent-exp + :enable (not buffer-read-only)])) ;;;###autoload (define-derived-mode simula-mode prog-mode "Simula" "Major mode for editing SIMULA code. \\{simula-mode-map} Variables controlling indentation style: - `simula-tab-always-indent' - Non-nil means TAB in SIMULA mode should always reindent the current line, - regardless of where in the line point is when the TAB command is used. `simula-indent-level' Indentation of SIMULA statements with respect to containing block. `simula-substatement-offset' @@ -369,7 +331,7 @@ with no arguments, if that value is non-nil." ;; (setq-local end-comment-column 75) (setq-local paragraph-start "[ \t]*$\\|\f") (setq-local paragraph-separate paragraph-start) - (setq-local indent-line-function 'simula-indent-line) + (setq-local indent-line-function #'simula-indent-line) (setq-local comment-start "! ") (setq-local comment-end " ;") (setq-local comment-start-skip "!+ *") @@ -449,6 +411,7 @@ A numeric argument, regardless of its value, means indent rigidly all the lines of the SIMULA statement after point so that this line becomes properly indented. The relative indentation among the lines of the statement are preserved." + (declare (obsolete indent-for-tab-command "28.1")) (interactive "P") (let ((case-fold-search t)) (if (or whole-exp simula-tab-always-indent @@ -1598,20 +1561,8 @@ If not nil and not t, move to limit of search and return nil." (simula-install-standard-abbrevs)) ;; Hilit mode support. -(when (fboundp 'hilit-set-mode-patterns) - (when (and (boundp 'hilit-patterns-alist) - (not (assoc 'simula-mode hilit-patterns-alist))) - (hilit-set-mode-patterns - 'simula-mode - '( - ("^%\\([ \t\f].*\\)?$" nil comment) - ("^%include\\>" nil include) - ("\"[^\"\n]*\"\\|'.'\\|'![0-9]+!'" nil string) - ("\\<\\(ACTIVATE\\|AFTER\\|AND\\|ARRAY\\|AT\\|BEFORE\\|BEGIN\\|BOOLEAN\\|CHARACTER\\|CLASS\\|DELAY\\|DO\\|ELSE\\|END\\|EQ\\|EQV\\|EXTERNAL\\|FALSE\\|FOR\\|GE\\|GO\\|GOTO\\|GT\\|HIDDEN\\|IF\\|IMP\\|IN\\|INNER\\|INSPECT\\|INTEGER\\|IS\\|LABEL\\|LE\\|LONG\\|LT\\|NAME\\|NE\\|NEW\\|NONE\\|NOT\\|NOTEXT\\|OR\\|OTHERWISE\\|PRIOR\\|PROCEDURE\\|PROTECTED\\|QUA\\|REACTIVATE\\|REAL\\|REF\\|SHORT\\|STEP\\|SWITCH\\|TEXT\\|THEN\\|THIS\\|TO\\|TRUE\\|UNTIL\\|VALUE\\|VIRTUAL\\|WHEN\\|WHILE\\)\\>" nil keyword) - ("!\\|\\<COMMENT\\>" ";" comment)) - nil 'case-insensitive))) -;; defuns for submitting bug reports +;; obsolete (defconst simula-mode-help-address "bug-gnu-emacs@gnu.org" "Address accepting submission of `simula-mode' bug reports.") @@ -1620,7 +1571,13 @@ If not nil and not t, move to limit of search and return nil." "24.4") (define-obsolete-function-alias 'simula-submit-bug-report - 'report-emacs-bug "24.4") + #'report-emacs-bug "24.4") + +(defun simula-popup-menu (_e) + "Pops up the SIMULA menu." + (declare (obsolete simula-mode-menu "28.1")) + (interactive "@e") + (popup-menu (cons (concat mode-name " Mode Commands") simula-mode-menu))) (provide 'simula) diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el index f1f4d61324b..d144d68b571 100644 --- a/lisp/progmodes/sql.el +++ b/lisp/progmodes/sql.el @@ -484,6 +484,7 @@ file. Since that is a plaintext file, this could be dangerous." :prompt-regexp "^[[:alnum:]_]*=[#>] " :prompt-length 5 :prompt-cont-regexp "^[[:alnum:]_]*[-(][#>] " + :statement sql-postgres-statement-starters :input-filter sql-remove-tabs-filter :terminator ("\\(^\\s-*\\\\g\\|;\\)" . "\\g")) @@ -997,20 +998,6 @@ for the first time." :version "24.1" :type 'hook) -;; Customization for ANSI - -(defcustom sql-ansi-statement-starters - (regexp-opt '("create" "alter" "drop" - "select" "insert" "update" "delete" "merge" - "grant" "revoke")) - "Regexp of keywords that start SQL commands. - -All products share this list; products should define a regexp to -identify additional keywords in a variable defined by -the :statement feature." - :version "24.1" - :type 'regexp) - ;; Customization for Oracle (defcustom sql-oracle-program "sqlplus" @@ -1033,12 +1020,6 @@ You will find the file in your Orant\\bin directory." :type 'sql-login-params :version "24.1") -(defcustom sql-oracle-statement-starters - (regexp-opt '("declare" "begin" "with")) - "Additional statement starting keywords in Oracle." - :version "24.1" - :type 'string) - (defcustom sql-oracle-scan-on t "Non-nil if placeholders should be replaced in Oracle SQLi. @@ -1502,6 +1483,26 @@ Based on `comint-mode-map'.") table) "Syntax table used in `sql-mode' and `sql-interactive-mode'.") +;; Motion Function Keywords + +(defvar sql-ansi-statement-starters + (regexp-opt '("create" "alter" "drop" + "select" "insert" "update" "delete" "merge" + "grant" "revoke")) + "Regexp of keywords that start SQL commands. + +All products share this list; products should define a regexp to +identify additional keywords in a variable defined by +the :statement feature.") + +(defvar sql-oracle-statement-starters + (regexp-opt '("declare" "begin" "with")) + "Additional statement-starting keywords in Oracle.") + +(defvar sql-postgres-statement-starters + (regexp-opt '("with")) + "Additional statement-starting keywords in Postgres.") + ;; Font lock support (defvar sql-mode-font-lock-object-name @@ -1545,9 +1546,7 @@ statement. The format of variable should be a valid ;; `sql-font-lock-keywords-builder' function and follow the ;; implementation pattern used for the other products in this file. -(eval-when-compile - (defvar sql-mode-ansi-font-lock-keywords) - (setq sql-mode-ansi-font-lock-keywords nil)) +(defvar sql-mode-ansi-font-lock-keywords) (eval-and-compile (defun sql-font-lock-keywords-builder (face boundaries &rest keywords) @@ -1574,7 +1573,7 @@ statement. The format of variable should be a valid face))) (defun sql-regexp-abbrev (keyword) - (let ((brk (string-match "[~]" keyword)) + (let ((brk (string-search "~" keyword)) (len (length keyword)) (sep "\\(?:") re i) @@ -2992,7 +2991,7 @@ displayed." ;; (defconst sql-smie-grammar ;; (smie-prec2->grammar ;; (smie-bnf->prec2 -;; ;; Partly based on http://www.h2database.com/html/grammar.html +;; ;; Partly based on https://www.h2database.com/html/grammar.html ;; '((cmd ("SELECT" select-exp "FROM" select-table-exp) ;; ) ;; (select-exp ("*") (exp) (exp "AS" column-alias)) @@ -3725,8 +3724,7 @@ to avoid deleting non-prompt output." ;; If we've found all the expected prompts, stop looking (if (= sql-output-newline-count 0) - (setq sql-output-newline-count nil - oline (concat "\n" oline)) + (setq sql-output-newline-count nil) ;; Still more possible prompts, leave them for the next pass (setq sql-preoutput-hold oline @@ -3771,6 +3769,8 @@ to avoid deleting non-prompt output." (with-current-buffer sql-buffer (when sql-debug-send (message ">>SQL> %S" s)) + (insert "\n") + (comint-set-process-mark) ;; Send the string (trim the trailing whitespace) (sql-input-sender (get-buffer-process (current-buffer)) s) @@ -3843,7 +3843,7 @@ to avoid deleting non-prompt output." (defun sql-remove-tabs-filter (str) "Replace tab characters with spaces." - (replace-regexp-in-string "\t" " " str nil t)) + (string-replace "\t" " " str)) (defun sql-toggle-pop-to-buffer-after-send-region (&optional value) "Toggle `sql-pop-to-buffer-after-send-region'. @@ -3864,7 +3864,7 @@ If given the optional parameter VALUE, sets "If non-nil, display messages related to the use of redirection.") (defun sql-str-literal (s) - (concat "'" (replace-regexp-in-string "[']" "''" s) "'")) + (concat "'" (string-replace "[']" "''" s) "'")) (defun sql-redirect (sqlbuf command &optional outbuf save-prior) "Execute the SQL command and send output to OUTBUF. @@ -5608,7 +5608,7 @@ The default value disables the internal pager." (provide 'sql) -;;; sql.el ends here - ; LocalWords: sql SQL SQLite sqlite Sybase Informix MySQL ; LocalWords: Postgres SQLServer SQLi + +;;; sql.el ends here diff --git a/lisp/progmodes/tcl.el b/lisp/progmodes/tcl.el index 82e1343e057..f6a50bf1a88 100644 --- a/lisp/progmodes/tcl.el +++ b/lisp/progmodes/tcl.el @@ -1413,7 +1413,7 @@ Prefix argument means switch to the Tcl buffer afterwards." (list ;; car because comint-get-source returns a list holding the ;; filename. - (car (comint-get-source "Load Tcl file: " + (car (comint-get-source "Load Tcl file" (or (and (derived-mode-p 'tcl-mode) (buffer-file-name)) @@ -1433,7 +1433,7 @@ If an inferior Tcl process exists, it is killed first. Prefix argument means switch to the Tcl buffer afterwards." (interactive (list - (car (comint-get-source "Restart with Tcl file: " + (car (comint-get-source "Restart with Tcl file" (or (and (derived-mode-p 'tcl-mode) (buffer-file-name)) diff --git a/lisp/progmodes/vera-mode.el b/lisp/progmodes/vera-mode.el index c2e1719d54a..4622256bb9c 100644 --- a/lisp/progmodes/vera-mode.el +++ b/lisp/progmodes/vera-mode.el @@ -5,7 +5,7 @@ ;; Author: Reto Zimmermann <reto@gnu.org> ;; Version: 2.28 ;; Keywords: languages vera -;; WWW: http://www.iis.ee.ethz.ch/~zimmi/emacs/vera-mode.html +;; WWW: https://guest.iis.ee.ethz.ch/~zimmi/emacs/vera-mode.html ;; Yoni Rabkin <yoni@rabkins.net> contacted the maintainer of this ;; file on 18/3/2008, and the maintainer agreed that when a bug is @@ -119,8 +119,6 @@ If nil, TAB always indents current line." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Menu -(require 'easymenu) - (easy-menu-define vera-mode-menu vera-mode-map "Menu keymap for Vera Mode." '("Vera" @@ -251,7 +249,7 @@ Add a description of the problem and include a reproducible test case. Feel free to send questions and enhancement requests to <reto@gnu.org>. Official distribution is at -URL `http://www.iis.ee.ethz.ch/~zimmi/emacs/vera-mode.html' +URL `https://www.iis.ee.ethz.ch/~zimmi/emacs/vera-mode.html' The Vera Mode Maintainer diff --git a/lisp/progmodes/verilog-mode.el b/lisp/progmodes/verilog-mode.el index f934ef7a80e..7c8ccea065e 100644 --- a/lisp/progmodes/verilog-mode.el +++ b/lisp/progmodes/verilog-mode.el @@ -9,7 +9,7 @@ ;; Keywords: languages ;; The "Version" is the date followed by the decimal rendition of the Git ;; commit hex. -;; Version: 2021.02.02.263931197 +;; Version: 2021.04.12.188864585 ;; Yoni Rabkin <yoni@rabkins.net> contacted the maintainer of this ;; file on 19/3/2008, and the maintainer agreed that when a bug is @@ -124,7 +124,7 @@ ;; ;; This variable will always hold the version number of the mode -(defconst verilog-mode-version "2021-02-02-fbb453d-vpo-GNU" +(defconst verilog-mode-version "2021-04-12-b41d849-vpo-GNU" "Version of this Verilog mode.") (defconst verilog-mode-release-emacs t "If non-nil, this version of Verilog mode was released with Emacs itself.") @@ -134,7 +134,7 @@ (interactive) (message "Using verilog-mode version %s" verilog-mode-version)) -(defmacro verilog--supressed-warnings (warnings &rest body) +(defmacro verilog--suppressed-warnings (warnings &rest body) (declare (indent 1) (debug t)) (cond ((fboundp 'with-suppressed-warnings) @@ -290,7 +290,7 @@ STRING should be given if the last search was by `string-match' on STRING." (concat open (mapconcat 'regexp-quote strings "\\|") close))) ) ;; Emacs. - (defalias 'verilog-regexp-opt 'regexp-opt))) + (defalias 'verilog-regexp-opt #'regexp-opt))) ;; emacs >=22 has looking-back, but older emacs and xemacs don't. ;; This function is lifted directly from emacs's subr.el @@ -300,7 +300,7 @@ STRING should be given if the last search was by `string-match' on STRING." (eval-and-compile (cond ((fboundp 'looking-back) - (defalias 'verilog-looking-back 'looking-back)) + (defalias 'verilog-looking-back #'looking-back)) (t (defun verilog-looking-back (regexp limit &optional greedy) "Return non-nil if text before point matches regular expression REGEXP. @@ -340,14 +340,14 @@ wherever possible, since it is slow." (cond ((fboundp 'restore-buffer-modified-p) ;; Faster, as does not update mode line when nothing changes - (defalias 'verilog-restore-buffer-modified-p 'restore-buffer-modified-p)) + (defalias 'verilog-restore-buffer-modified-p #'restore-buffer-modified-p)) (t - (defalias 'verilog-restore-buffer-modified-p 'set-buffer-modified-p)))) + (defalias 'verilog-restore-buffer-modified-p #'set-buffer-modified-p)))) (eval-and-compile (cond ((fboundp 'quit-window) - (defalias 'verilog-quit-window 'quit-window)) + (defalias 'verilog-quit-window #'quit-window)) (t (defun verilog-quit-window (_kill-ignored window) "Quit WINDOW and bury its buffer. KILL-IGNORED is ignored." @@ -379,7 +379,7 @@ wherever possible, since it is slow." ;; Added in Emacs 25.1 (condition-case nil (unless (fboundp 'forward-word-strictly) - (defalias 'forward-word-strictly 'forward-word)) + (defalias 'forward-word-strictly #'forward-word)) (error nil))) (eval-when-compile @@ -1483,48 +1483,48 @@ If set will become buffer local.") (defvar verilog-mode-map (let ((map (make-sparse-keymap))) - (define-key map ";" 'electric-verilog-semi) - (define-key map [(control 59)] 'electric-verilog-semi-with-comment) - (define-key map ":" 'electric-verilog-colon) + (define-key map ";" #'electric-verilog-semi) + (define-key map [(control 59)] #'electric-verilog-semi-with-comment) + (define-key map ":" #'electric-verilog-colon) ;;(define-key map "=" 'electric-verilog-equal) - (define-key map "`" 'electric-verilog-tick) - (define-key map "\t" 'electric-verilog-tab) - (define-key map "\r" 'electric-verilog-terminate-line) + (define-key map "`" #'electric-verilog-tick) + (define-key map "\t" #'electric-verilog-tab) + (define-key map "\r" #'electric-verilog-terminate-line) ;; backspace/delete key bindings - (define-key map [backspace] 'backward-delete-char-untabify) + (define-key map [backspace] #'backward-delete-char-untabify) (unless (boundp 'delete-key-deletes-forward) ; XEmacs variable - (define-key map [delete] 'delete-char) - (define-key map [(meta delete)] 'kill-word)) - (define-key map "\M-\C-b" 'electric-verilog-backward-sexp) - (define-key map "\M-\C-f" 'electric-verilog-forward-sexp) - (define-key map "\M-\r" 'electric-verilog-terminate-and-indent) + (define-key map [delete] #'delete-char) + (define-key map [(meta delete)] #'kill-word)) + (define-key map "\M-\C-b" #'electric-verilog-backward-sexp) + (define-key map "\M-\C-f" #'electric-verilog-forward-sexp) + (define-key map "\M-\r" #'electric-verilog-terminate-and-indent) (define-key map "\M-\t" (if (fboundp 'completion-at-point) - 'completion-at-point 'verilog-complete-word)) + #'completion-at-point #'verilog-complete-word)) (define-key map "\M-?" (if (fboundp 'completion-help-at-point) - 'completion-help-at-point 'verilog-show-completions)) + #'completion-help-at-point #'verilog-show-completions)) ;; Note \C-c and letter are reserved for users - (define-key map "\C-c`" 'verilog-lint-off) - (define-key map "\C-c*" 'verilog-delete-auto-star-implicit) - (define-key map "\C-c?" 'verilog-diff-auto) - (define-key map "\C-c\C-r" 'verilog-label-be) - (define-key map "\C-c\C-i" 'verilog-pretty-declarations) - (define-key map "\C-c=" 'verilog-pretty-expr) - (define-key map "\C-c\C-b" 'verilog-submit-bug-report) - (define-key map "\C-c/" 'verilog-star-comment) - (define-key map "\C-c\C-c" 'verilog-comment-region) - (define-key map "\C-c\C-u" 'verilog-uncomment-region) + (define-key map "\C-c`" #'verilog-lint-off) + (define-key map "\C-c*" #'verilog-delete-auto-star-implicit) + (define-key map "\C-c?" #'verilog-diff-auto) + (define-key map "\C-c\C-r" #'verilog-label-be) + (define-key map "\C-c\C-i" #'verilog-pretty-declarations) + (define-key map "\C-c=" #'verilog-pretty-expr) + (define-key map "\C-c\C-b" #'verilog-submit-bug-report) + (define-key map "\C-c/" #'verilog-star-comment) + (define-key map "\C-c\C-c" #'verilog-comment-region) + (define-key map "\C-c\C-u" #'verilog-uncomment-region) (when (featurep 'xemacs) - (define-key map [(meta control h)] 'verilog-mark-defun) - (define-key map "\M-\C-a" 'verilog-beg-of-defun) - (define-key map "\M-\C-e" 'verilog-end-of-defun)) - (define-key map "\C-c\C-d" 'verilog-goto-defun) - (define-key map "\C-c\C-k" 'verilog-delete-auto) - (define-key map "\C-c\C-a" 'verilog-auto) - (define-key map "\C-c\C-s" 'verilog-auto-save-compile) - (define-key map "\C-c\C-p" 'verilog-preprocess) - (define-key map "\C-c\C-z" 'verilog-inject-auto) - (define-key map "\C-c\C-e" 'verilog-expand-vector) - (define-key map "\C-c\C-h" 'verilog-header) + (define-key map [(meta control h)] #'verilog-mark-defun) + (define-key map "\M-\C-a" #'verilog-beg-of-defun) + (define-key map "\M-\C-e" #'verilog-end-of-defun)) + (define-key map "\C-c\C-d" #'verilog-goto-defun) + (define-key map "\C-c\C-k" #'verilog-delete-auto) + (define-key map "\C-c\C-a" #'verilog-auto) + (define-key map "\C-c\C-s" #'verilog-auto-save-compile) + (define-key map "\C-c\C-p" #'verilog-preprocess) + (define-key map "\C-c\C-z" #'verilog-inject-auto) + (define-key map "\C-c\C-e" #'verilog-expand-vector) + (define-key map "\C-c\C-h" #'verilog-header) map) "Keymap used in Verilog mode.") @@ -1969,7 +1969,11 @@ To call on \\[verilog-auto], set `verilog-auto-delete-trailing-whitespace'." (unless (bolp) (insert "\n")))) (defvar compile-command) +;; These are known to be from other packages and may not be defined +(defvar diff-command) +;; There are known to be from newer versions of Emacs (defvar create-lockfiles) ; Emacs 24 +(defvar which-func-modes) ;; compilation program (defun verilog-set-compile-command () @@ -2009,9 +2013,10 @@ portion, will be substituted." (t (set (make-local-variable 'compile-command) (if verilog-tool - (if (string-match "%s" (eval verilog-tool)) - (format (eval verilog-tool) (or buffer-file-name "")) - (concat (eval verilog-tool) " " (or buffer-file-name ""))) + (let ((cmd (symbol-value verilog-tool))) + (if (string-match "%s" cmd) + (format cmd (or buffer-file-name "")) + (concat cmd " " (or buffer-file-name "")))) "")))) (verilog-modify-compile-command)) @@ -2098,7 +2103,7 @@ find the errors." (interactive) (when (boundp 'compilation-error-regexp-alist-alist) (when (not (assoc 'verilog-xl-1 compilation-error-regexp-alist-alist)) - (mapcar + (mapc (lambda (item) (push (car item) compilation-error-regexp-alist) (push item compilation-error-regexp-alist-alist)) @@ -3602,7 +3607,7 @@ inserted using a single call to `verilog-insert'." ;; More searching (defun verilog-declaration-end () - (search-forward ";")) + (search-forward ";" nil t)) (defun verilog-single-declaration-end (limit) "Returns pos where current (single) declaration statement ends. @@ -5107,7 +5112,6 @@ primitive or interface named NAME." (;- task/function/initial et cetera t - (match-end 0) (goto-char (match-end 0)) (setq there (point)) (setq err nil) @@ -5455,8 +5459,7 @@ becomes: (let* ((code (match-string 2)) (file (match-string 3)) (line (match-string 4)) - (buffer (get-file-buffer file)) - dir filename) + (buffer (get-file-buffer file))) (unless buffer (progn (setq buffer @@ -5468,9 +5471,8 @@ becomes: (read-file-name (format "Find this error in: (default %s) " file) - dir file t)))) - (if (file-directory-p name) - (setq name (expand-file-name filename name))) + nil ;; dir + file t)))) (setq buffer (and (file-exists-p name) (find-file-noselect name)))))))) @@ -5550,7 +5552,7 @@ FILENAME to find directory to run in, or defaults to `buffer-file-name'." ;; 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 - (verilog--supressed-warnings + (verilog--suppressed-warnings ((interactive-only font-lock-fontify-buffer)) (font-lock-fontify-buffer)))))))) @@ -5613,12 +5615,11 @@ Save the result unless optional NO-SAVE is t." ;; Process the files (mapc (lambda (buf) (when (buffer-file-name buf) - (save-excursion - (if (not (file-exists-p (buffer-file-name buf))) - (error - "File not found: %s" (buffer-file-name buf))) - (message "Processing %s" (buffer-file-name buf)) - (set-buffer buf) + (if (not (file-exists-p (buffer-file-name buf))) + (error + "File not found: %s" (buffer-file-name buf))) + (message "Processing %s" (buffer-file-name buf)) + (with-current-buffer buf (funcall funref) (verilog-star-cleanup) (when (and (not no-save) @@ -6648,14 +6649,9 @@ Return >0 for nested struct." (defun verilog-at-close-struct-p () "If at the } that closes a struct, return true." - (if (and - (equal (char-after) ?\}) - (verilog-in-struct-p)) - ;; true - (save-excursion - (if (looking-at "}\\(?:\\s-*\\w+\\s-*\\)?;") 1)) - ;; false - nil)) + (and (equal (char-after) ?\}) + (verilog-in-struct-p) + (looking-at "}\\(?:\\s-*\\w+\\s-*\\(?:,\\s-*\\w+\\s-*\\)*\\)?;"))) (defun verilog-parenthesis-depth () "Return non zero if in parenthetical-expression." @@ -6860,16 +6856,19 @@ Only look at a few lines to determine indent level." (indent-line-to val))) (t (goto-char here) - (let ((val)) - (verilog-beg-of-statement-1) - (if (and (< (point) here) - (verilog-re-search-forward "=[ \t]*" here 'move) - ;; not at a |=>, #=#, or [=n] operator - (not (string-match "\\[=.\\|#=#\\||=>" - (or (buffer-substring (- (point) 2) (1+ (point))) - "")))) ; don't let buffer over/under-run spoil the party - (setq val (current-column)) - (setq val (eval (cdr (assoc type verilog-indent-alist))))) + (verilog-beg-of-statement-1) + (let ((val + (if (and (< (point) here) + (verilog-re-search-forward "=[ \t]*" here 'move) + ;; not at a |=>, #=#, or [=n] operator + (not (string-match "\\[=.\\|#=#\\||=>" + (or (buffer-substring + (- (point) 2) (1+ (point))) + ;; Don't let buffer over/under + ;; run spoil the party. + "")))) + (current-column) + (eval (cdr (assoc type verilog-indent-alist)))))) (goto-char here) (indent-line-to val)))))) @@ -7305,7 +7304,8 @@ BASEIND is the base indent to offset everything." (if (verilog-re-search-backward (or (and verilog-indent-declaration-macros verilog-declaration-re-1-macro) - verilog-declaration-re-1-no-macro) lim t) + verilog-declaration-re-1-no-macro) + lim t) (progn (goto-char (match-end 0)) (skip-chars-forward " \t") @@ -7423,9 +7423,7 @@ BEG and END." ;; (defvar verilog-str nil) (defvar verilog-all nil) -(defvar verilog-pred nil) (defvar verilog-buffer-to-use nil) -(defvar verilog-flag nil) (defvar verilog-toggle-completions nil "True means \\<verilog-mode-map>\\[verilog-complete-word] should try all possible completions one by one. Repeated use of \\[verilog-complete-word] will show you all of them. @@ -7556,27 +7554,25 @@ will be completed at runtime and should not be added to this list.") TYPE is `module', `tf' for task or function, or t if unknown." (if (string= verilog-str "") (setq verilog-str "[a-zA-Z_]")) - (let ((verilog-str (concat (cond - ((eq type 'module) "\\<\\(module\\|connectmodule\\)\\s +") - ((eq type 'tf) "\\<\\(task\\|function\\)\\s +") - (t "\\<\\(task\\|function\\|module\\|connectmodule\\)\\s +")) - "\\<\\(" verilog-str "[a-zA-Z0-9_.]*\\)\\>")) + (let ((verilog-str + (concat (cond + ((eq type 'module) "\\<\\(module\\|connectmodule\\)\\s +") + ((eq type 'tf) "\\<\\(task\\|function\\)\\s +") + (t "\\<\\(task\\|function\\|module\\|connectmodule\\)\\s +")) + "\\<\\(" verilog-str "[a-zA-Z0-9_.]*\\)\\>")) match) - (if (not (looking-at verilog-defun-re)) - (verilog-re-search-backward verilog-defun-re nil t)) - (forward-char 1) + (save-excursion + (if (not (looking-at verilog-defun-re)) + (verilog-re-search-backward verilog-defun-re nil t)) + (forward-char 1) - ;; Search through all reachable functions - (goto-char (point-min)) - (while (verilog-re-search-forward verilog-str (point-max) t) - (progn (setq match (buffer-substring (match-beginning 2) - (match-end 2))) - (if (or (null verilog-pred) - (funcall verilog-pred match)) - (setq verilog-all (cons match verilog-all))))) - (if (match-beginning 0) - (goto-char (match-beginning 0))))) + ;; Search through all reachable functions + (goto-char (point-min)) + (while (verilog-re-search-forward verilog-str (point-max) t) + (setq match (buffer-substring (match-beginning 2) + (match-end 2))) + (setq verilog-all (cons match verilog-all)))))) (defun verilog-get-completion-decl (end) "Macro for searching through current declaration (var, type or const) @@ -7594,9 +7590,7 @@ for matches of `str' and adding the occurrence tp `all' through point END." (not (match-end 1))) (setq match (buffer-substring (match-beginning 0) (match-end 0))) (if (string-match (concat "\\<" verilog-str) match) - (if (or (null verilog-pred) - (funcall verilog-pred match)) - (setq verilog-all (cons match verilog-all))))) + (setq verilog-all (cons match verilog-all)))) (forward-line 1))) verilog-all) @@ -7611,28 +7605,25 @@ for matches of `str' and adding the occurrence tp `all' through point END." (defun verilog-keyword-completion (keyword-list) "Give list of all possible completions of keywords in KEYWORD-LIST." - (mapcar (lambda (s) - (if (string-match (concat "\\<" verilog-str) s) - (if (or (null verilog-pred) - (funcall verilog-pred s)) - (setq verilog-all (cons s verilog-all))))) - keyword-list)) - - -(defun verilog-completion (verilog-str verilog-pred verilog-flag) - "Function passed to `completing-read', `try-completion' or `all-completions'. -Called to get completion on VERILOG-STR. If VERILOG-PRED is non-nil, it -must be a function to be called for every match to check if this should -really be a match. If VERILOG-FLAG is t, the function returns a list of -all possible completions. If VERILOG-FLAG is nil it returns a string, -the longest possible completion, or t if VERILOG-STR is an exact match. -If VERILOG-FLAG is `lambda', the function returns t if VERILOG-STR is an -exact match, nil otherwise." - (save-excursion - (let ((verilog-all nil)) - ;; Set buffer to use for searching labels. This should be set - ;; within functions which use verilog-completions - (set-buffer verilog-buffer-to-use) + (dolist (s keyword-list) + (if (string-match (concat "\\<" verilog-str) s) + (push s verilog-all)))) + + +(defun verilog-completion (str pred flag) + "Completion table for Verilog tokens. +Function passed to `completing-read', `try-completion' or `all-completions'. +Called to get completion on STR. +If FLAG is t, the function returns a list of all possible completions. +If FLAG is nil it returns a string, the longest possible completion, +or t if STR is an exact match. +If FLAG is `lambda', the function returns t if STR is an exact match, +nil otherwise." + (let ((verilog-str str) + (verilog-all nil)) + ;; Set buffer to use for searching labels. This should be set + ;; within functions which use verilog-completions + (with-current-buffer verilog-buffer-to-use ;; Determine what should be completed (let ((state (car (verilog-calculate-indent)))) @@ -7674,43 +7665,47 @@ exact match, nil otherwise." (verilog-keyword-completion verilog-separator-keywords)))) ;; Now we have built a list of all matches. Give response to caller - (verilog-completion-response)))) - -(defun verilog-completion-response () - (cond ((or (equal verilog-flag 'lambda) (null verilog-flag)) - ;; This was not called by all-completions - (if (null verilog-all) - ;; Return nil if there was no matching label - nil - ;; Get longest string common in the labels - ;; FIXME: Why not use `try-completion'? - (let* ((elm (cdr verilog-all)) - (match (car verilog-all)) - (min (length match)) - tmp) - (if (string= match verilog-str) - ;; Return t if first match was an exact match - (setq match t) - (while (not (null elm)) - ;; Find longest common string - (if (< (setq tmp (verilog-string-diff match (car elm))) min) - (progn - (setq min tmp) - (setq match (substring match 0 min)))) - ;; Terminate with match=t if this is an exact match - (if (string= (car elm) verilog-str) - (progn - (setq match t) - (setq elm nil)) - (setq elm (cdr elm))))) - ;; If this is a test just for exact match, return nil ot t - (if (and (equal verilog-flag 'lambda) (not (equal match 't))) - nil - match)))) - ;; If flag is t, this was called by all-completions. Return - ;; list of all possible completions - (verilog-flag - verilog-all))) + (verilog--complete-with-action flag verilog-all verilog-str pred)))) + + +(defalias 'verilog--complete-with-action + (if (fboundp 'complete-with-action) + #'complete-with-action + (lambda (flag collection string _predicate) + (cond ((or (equal flag 'lambda) (null flag)) + ;; This was not called by all-completions + (if (null collection) + ;; Return nil if there was no matching label + nil + ;; Get longest string common in the labels + (let* ((elm (cdr collection)) + (match (car collection)) + (min (length match)) + tmp) + (if (string= match string) + ;; Return t if first match was an exact match + (setq match t) + (while (not (null elm)) + ;; Find longest common string + (if (< (setq tmp (verilog-string-diff match (car elm))) + min) + (progn + (setq min tmp) + (setq match (substring match 0 min)))) + ;; Terminate with match=t if this is an exact match + (if (string= (car elm) string) + (progn + (setq match t) + (setq elm nil)) + (setq elm (cdr elm))))) + ;; If this is a test just for exact match, return nil ot t + (if (and (equal flag 'lambda) (not (equal match 't))) + nil + match)))) + ;; If flag is t, this was called by all-completions. Return + ;; list of all possible completions + (flag + collection))))) (defvar verilog-last-word-numb 0) (defvar verilog-last-word-shown nil) @@ -7728,7 +7723,7 @@ exact match, nil otherwise." (allcomp (if (and verilog-toggle-completions (string= verilog-last-word-shown verilog-str)) verilog-last-completions - (all-completions verilog-str 'verilog-completion)))) + (all-completions verilog-str #'verilog-completion)))) (list b e allcomp))) (defun verilog-complete-word () @@ -7744,9 +7739,7 @@ and `verilog-separator-keywords'.)" (verilog-str (buffer-substring b e)) (allcomp (nth 2 comp-info)) (match (if verilog-toggle-completions - "" (try-completion - verilog-str (mapcar (lambda (elm) - (cons elm 0)) allcomp))))) + "" (try-completion verilog-str allcomp)))) ;; Delete old string (delete-region b e) @@ -7818,39 +7811,38 @@ With optional second ARG non-nil, STR is the complete name of the instruction." (setq str (concat str "[a-zA-Z0-9_]*"))) (concat "^\\s-*\\(function\\|task\\|module\\)[ \t]+\\(?:\\(?:static\\|automatic\\)\\s-+\\)?\\(" str "\\)\\>")) -(defun verilog-comp-defun (verilog-str verilog-pred verilog-flag) - "Function passed to `completing-read', `try-completion' or `all-completions'. -Returns a completion on any function name based on VERILOG-STR prefix. If -VERILOG-PRED is non-nil, it must be a function to be called for every match -to check if this should really be a match. If VERILOG-FLAG is t, the -function returns a list of all possible completions. If it is nil it -returns a string, the longest possible completion, or t if VERILOG-STR is -an exact match. If VERILOG-FLAG is `lambda', the function returns t if -VERILOG-STR is an exact match, nil otherwise." - (save-excursion - (let ((verilog-all nil) - match) - - ;; Set buffer to use for searching labels. This should be set - ;; within functions which use verilog-completions - (set-buffer verilog-buffer-to-use) +(defun verilog-comp-defun (str pred flag) + "Completion table for function names. +Function passed to `completing-read', `try-completion' or `all-completions'. +Returns a completion on any function name based on STR prefix. +If FLAG is t, the function returns a list of all possible completions. +If it is nil it returns a string, the longest possible completion, +or t if STR is an exact match. +If FLAG is `lambda', the function returns t if STR is an exact match, +nil otherwise." + (let ((verilog-all nil) + (verilog-str str) + match) + + ;; Set buffer to use for searching labels. This should be set + ;; within functions which use verilog-completions + (with-current-buffer verilog-buffer-to-use (let ((verilog-str verilog-str)) ;; Build regular expression for functions - (if (string= verilog-str "") - (setq verilog-str (verilog-build-defun-re "[a-zA-Z_]")) - (setq verilog-str (verilog-build-defun-re verilog-str))) + (setq verilog-str + (verilog-build-defun-re (if (string= verilog-str "") + "[a-zA-Z_]" + verilog-str))) (goto-char (point-min)) ;; Build a list of all possible completions (while (verilog-re-search-forward verilog-str nil t) (setq match (buffer-substring (match-beginning 2) (match-end 2))) - (if (or (null verilog-pred) - (funcall verilog-pred match)) - (setq verilog-all (cons match verilog-all))))) + (setq verilog-all (cons match verilog-all)))) ;; Now we have built a list of all matches. Give response to caller - (verilog-completion-response)))) + (verilog--complete-with-action flag verilog-all verilog-str pred)))) (defun verilog-goto-defun () "Move to specified Verilog module/interface/task/function. @@ -7865,10 +7857,10 @@ If search fails, other files are checked based on ;; Do completion with default (completing-read (concat "Goto-Label: (default " default ") ") - 'verilog-comp-defun nil nil "") + #'verilog-comp-defun nil nil "") ;; There is no default value. Complete without it (completing-read "Goto-Label: " - 'verilog-comp-defun nil nil ""))) + #'verilog-comp-defun nil nil ""))) pt) ;; Make sure library paths are correct, in case need to resolve module (verilog-auto-reeval-locals) @@ -7927,10 +7919,9 @@ If search fails, other files are checked based on (tag (format "%3d" linenum)) (empty (make-string (length tag) ?\ )) tem) - (save-excursion - (setq tem (make-marker)) - (set-marker tem (point)) - (set-buffer standard-output) + (setq tem (make-marker)) + (set-marker tem (point)) + (with-current-buffer standard-output (setq occur-pos-list (cons tem occur-pos-list)) (or first (zerop nlines) (insert "--------\n")) @@ -8648,11 +8639,6 @@ Optional NUM-PARAM and MAX-PARAM check for a specific number of parameters." (defvar sigs-out-i) (defvar sigs-out-unk) (defvar sigs-temp) -;; These are known to be from other packages and may not be defined -(defvar diff-command) -;; There are known to be from newer versions of Emacs -(defvar create-lockfiles) -(defvar which-func-modes) (defun verilog-read-decls () "Compute signal declaration information for the current module at point. @@ -10099,7 +10085,7 @@ If undefined, and WING-IT, return just SYMBOL without the tick, else nil." ;; variable in only one buffer returns t in another. ;; This can confuse, so check for nil. ;; Namespace intentionally short for AUTOs and compatibility - (let ((val (eval (intern (concat "vh-" symbol))))) + (let ((val (symbol-value (intern (concat "vh-" symbol))))) (if (eq val nil) (if wing-it symbol nil) val)) @@ -10138,7 +10124,7 @@ This function is intended for use in AUTO_TEMPLATE Lisp expressions." ;; variable in only one buffer returns t in another. ;; This can confuse, so check for nil. ;; Namespace intentionally short for AUTOs and compatibility - (setq val (eval (intern (concat "vh-" symbol))))) + (setq val (symbol-value (intern (concat "vh-" symbol))))) (setq text (replace-match val nil nil text))) (t (setq ok nil))))) text) @@ -10493,7 +10479,7 @@ those clocking block's signals." ;; New scheme ;; Namespace intentionally short for AUTOs and compatibility (let* ((enumvar (intern (concat "venum-" enum)))) - (dolist (en (and (boundp enumvar) (eval enumvar))) + (dolist (en (and (boundp enumvar) (symbol-value enumvar))) (let ((sig (list en))) (unless (member sig out-list) (push sig out-list))))) @@ -10698,9 +10684,7 @@ When MODI is non-null, also add to modi-cache, for tracking." (verilog-insert "// " (verilog-sig-comment sig) "\n")) (setq sigs (cdr sigs))))) -(defvar indent-pt) ;; Local used by `verilog-insert-indent'. - -(defun verilog-insert-indent (&rest stuff) +(defun verilog--insert-indent (indent-pt &rest stuff) "Indent to position stored in local `indent-pt' variable, then insert STUFF. Presumes that any newlines end a list element." (let ((need-indent t)) @@ -10710,6 +10694,10 @@ Presumes that any newlines end a list element." (verilog-insert (car stuff)) (setq need-indent (string-match "\n$" (car stuff)) stuff (cdr stuff))))) + +(defmacro verilog-insert-indent (&rest stuff) + `(verilog--insert-indent indent-pt ,@stuff)) + ;;(let ((indent-pt 10)) (verilog-insert-indent "hello\n" "addon" "there\n")) (defun verilog-forward-or-insert-line () @@ -11518,7 +11506,8 @@ See the example in `verilog-auto-inout-modport'." (inst-name (nth 2 params)) (regexp (nth 3 params)) (prefix (nth 4 params)) - direction-re submodi) ; direction argument not supported until requested + ;; direction-re ; direction argument not supported until requested + submodi) ;; Lookup position, etc of co-module ;; Note this may raise an error (when (setq submodi (verilog-modi-lookup submod t)) @@ -11539,11 +11528,11 @@ See the example in `verilog-auto-inout-modport'." (setq sig-list-i (verilog-signals-edit-wire-reg (verilog-signals-matching-dir-re (verilog-signals-matching-regexp sig-list-i regexp) - "input" direction-re)) + "input" nil)) ;; direction-re sig-list-o (verilog-signals-edit-wire-reg (verilog-signals-matching-dir-re (verilog-signals-matching-regexp sig-list-o regexp) - "output" direction-re))) + "output" nil))) ;; direction-re (setq sig-list-i (sort (copy-alist sig-list-i) #'verilog-signals-sort-compare)) (setq sig-list-o (sort (copy-alist sig-list-o) #'verilog-signals-sort-compare)) (when (or sig-list-i sig-list-o) @@ -11571,6 +11560,7 @@ See the example in `verilog-auto-inout-modport'." (defvar vl-cell-type nil "See `verilog-auto-inst'.") ; Prevent compile warning (defvar vl-cell-name nil "See `verilog-auto-inst'.") ; Prevent compile warning +(defvar vl-memory nil "See `verilog-auto-inst'.") ; Prevent compile warning (defvar vl-modport nil "See `verilog-auto-inst'.") ; Prevent compile warning (defvar vl-name nil "See `verilog-auto-inst'.") ; Prevent compile warning (defvar vl-width nil "See `verilog-auto-inst'.") ; Prevent compile warning @@ -11684,7 +11674,7 @@ If PAR-VALUES replace final strings with these parameter values." (setq tpl-net (verilog-string-replace-matches "\\[\\]" vl-bits nil nil tpl-net))) ;; Insert it (when (or tpl-ass (not verilog-auto-inst-template-required)) - (verilog-auto-inst-first section) + (verilog--auto-inst-first indent-pt section) (indent-to indent-pt) (insert "." port) (unless (and verilog-auto-inst-dot-name @@ -11723,7 +11713,7 @@ If PAR-VALUES replace final strings with these parameter values." (defvar verilog-auto-inst-first-any nil "Local first-in-any-section for `verilog-auto-inst-first'.") -(defun verilog-auto-inst-first (section) +(defun verilog--auto-inst-first (indent-pt section) "Insert , and SECTION before port, as part of \\[verilog-auto-inst]." ;; Do we need a trailing comma? ;; There maybe an ifdef or something similar before us. What a mess. Thus @@ -12073,6 +12063,7 @@ Lisp Templates: vl-width Width of the input/output port (`3' for [2:0]). May be a (...) expression if bits isn't a constant. vl-dir Direction of the pin input/output/inout/interface. + vl-memory The unpacked array part of the I/O port (`[5:0]'). vl-modport The modport, if an interface with a modport. vl-cell-type Module name/type of the cell (`InstModule'). vl-cell-name Instance name of the cell (`instName'). @@ -12957,21 +12948,25 @@ that expression are included." (verilog-signals-not-matching-regexp (verilog-signals-matching-dir-re (verilog-signals-matching-regexp sig-list-i regexp) - "input" direction-re) not-re)) + "input" direction-re) + not-re)) sig-list-o (verilog-signals-edit-wire-reg (verilog-signals-not-matching-regexp (verilog-signals-matching-dir-re (verilog-signals-matching-regexp sig-list-o regexp) - "output" direction-re) not-re)) + "output" direction-re) + not-re)) sig-list-io (verilog-signals-edit-wire-reg (verilog-signals-not-matching-regexp (verilog-signals-matching-dir-re (verilog-signals-matching-regexp sig-list-io regexp) - "inout" direction-re) not-re)) + "inout" direction-re) + not-re)) sig-list-if (verilog-signals-not-matching-regexp (verilog-signals-matching-dir-re (verilog-signals-matching-regexp sig-list-if regexp) - "interface" direction-re) not-re)) + "interface" direction-re) + not-re)) (when v2k (verilog-repair-open-comma)) (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") @@ -13257,7 +13252,8 @@ driver/monitor using AUTOINST in the testbench." (modport-re (nth 1 params)) (regexp (nth 2 params)) (prefix (nth 3 params)) - direction-re submodi) ; direction argument not supported until requested + ;; direction-re ; direction argument not supported until requested + submodi) ;; Lookup position, etc of co-module ;; Note this may raise an error (when (setq submodi (verilog-modi-lookup submod t)) @@ -13288,7 +13284,7 @@ driver/monitor using AUTOINST in the testbench." (verilog-signals-add-prefix (verilog-signals-matching-dir-re (verilog-signals-matching-regexp sig-list-i regexp) - "input" direction-re) + "input" nil) ;; direction-re prefix) (verilog-decls-get-ports moddecls))) sig-list-o (verilog-signals-edit-wire-reg @@ -13296,7 +13292,7 @@ driver/monitor using AUTOINST in the testbench." (verilog-signals-add-prefix (verilog-signals-matching-dir-re (verilog-signals-matching-regexp sig-list-o regexp) - "output" direction-re) + "output" nil) ;; direction-re prefix) (verilog-decls-get-ports moddecls))) sig-list-io (verilog-signals-edit-wire-reg @@ -13304,7 +13300,7 @@ driver/monitor using AUTOINST in the testbench." (verilog-signals-add-prefix (verilog-signals-matching-dir-re (verilog-signals-matching-regexp sig-list-io regexp) - "inout" direction-re) + "inout" nil) ;; direction-re prefix) (verilog-decls-get-ports moddecls)))) (when v2k (verilog-repair-open-comma)) @@ -14275,37 +14271,37 @@ Wilson Snyder (wsnyder@wsnyder.org)." (defvar verilog-template-map (let ((map (make-sparse-keymap))) - (define-key map "a" 'verilog-sk-always) - (define-key map "b" 'verilog-sk-begin) - (define-key map "c" 'verilog-sk-case) - (define-key map "f" 'verilog-sk-for) - (define-key map "g" 'verilog-sk-generate) - (define-key map "h" 'verilog-sk-header) - (define-key map "i" 'verilog-sk-initial) - (define-key map "j" 'verilog-sk-fork) - (define-key map "m" 'verilog-sk-module) - (define-key map "o" 'verilog-sk-ovm-class) - (define-key map "p" 'verilog-sk-primitive) - (define-key map "r" 'verilog-sk-repeat) - (define-key map "s" 'verilog-sk-specify) - (define-key map "t" 'verilog-sk-task) - (define-key map "u" 'verilog-sk-uvm-object) - (define-key map "w" 'verilog-sk-while) - (define-key map "x" 'verilog-sk-casex) - (define-key map "z" 'verilog-sk-casez) - (define-key map "?" 'verilog-sk-if) - (define-key map ":" 'verilog-sk-else-if) - (define-key map "/" 'verilog-sk-comment) - (define-key map "A" 'verilog-sk-assign) - (define-key map "F" 'verilog-sk-function) - (define-key map "I" 'verilog-sk-input) - (define-key map "O" 'verilog-sk-output) - (define-key map "S" 'verilog-sk-state-machine) - (define-key map "=" 'verilog-sk-inout) - (define-key map "U" 'verilog-sk-uvm-component) - (define-key map "W" 'verilog-sk-wire) - (define-key map "R" 'verilog-sk-reg) - (define-key map "D" 'verilog-sk-define-signal) + (define-key map "a" #'verilog-sk-always) + (define-key map "b" #'verilog-sk-begin) + (define-key map "c" #'verilog-sk-case) + (define-key map "f" #'verilog-sk-for) + (define-key map "g" #'verilog-sk-generate) + (define-key map "h" #'verilog-sk-header) + (define-key map "i" #'verilog-sk-initial) + (define-key map "j" #'verilog-sk-fork) + (define-key map "m" #'verilog-sk-module) + (define-key map "o" #'verilog-sk-ovm-class) + (define-key map "p" #'verilog-sk-primitive) + (define-key map "r" #'verilog-sk-repeat) + (define-key map "s" #'verilog-sk-specify) + (define-key map "t" #'verilog-sk-task) + (define-key map "u" #'verilog-sk-uvm-object) + (define-key map "w" #'verilog-sk-while) + (define-key map "x" #'verilog-sk-casex) + (define-key map "z" #'verilog-sk-casez) + (define-key map "?" #'verilog-sk-if) + (define-key map ":" #'verilog-sk-else-if) + (define-key map "/" #'verilog-sk-comment) + (define-key map "A" #'verilog-sk-assign) + (define-key map "F" #'verilog-sk-function) + (define-key map "I" #'verilog-sk-input) + (define-key map "O" #'verilog-sk-output) + (define-key map "S" #'verilog-sk-state-machine) + (define-key map "=" #'verilog-sk-inout) + (define-key map "U" #'verilog-sk-uvm-component) + (define-key map "W" #'verilog-sk-wire) + (define-key map "R" #'verilog-sk-reg) + (define-key map "D" #'verilog-sk-define-signal) map) "Keymap used in Verilog mode for smart template operations.") @@ -14696,13 +14692,13 @@ and the case items." (let ((map (make-sparse-keymap))) ; as described in info pages, make a map (set-keymap-parent map verilog-mode-map) ;; mouse button bindings - (define-key map "\r" 'verilog-load-file-at-point) - (if (featurep 'xemacs) - (define-key map 'button2 'verilog-load-file-at-mouse);ffap-at-mouse ? - (define-key map [mouse-2] 'verilog-load-file-at-mouse)) + (define-key map "\r" #'verilog-load-file-at-point) + (define-key map + (if (featurep 'xemacs) 'button2 [mouse-2]) + #'verilog-load-file-at-mouse) (if (featurep 'xemacs) - (define-key map 'Sh-button2 'mouse-yank) ; you wanna paste don't you ? - (define-key map [S-mouse-2] 'mouse-yank-at-click)) + (define-key map 'Sh-button2 #'mouse-yank) ; you wanna paste don't you ? + (define-key map [S-mouse-2] #'mouse-yank-at-click)) map) "Map containing mouse bindings for `verilog-mode'.") @@ -14775,7 +14771,7 @@ Clicking on the middle-mouse button loads them in a buffer (as in dired)." (verilog-highlight-region (point-min) (point-max) nil)) ;; Deprecated, but was interactive, so we'll keep it around -(defalias 'verilog-colorize-include-files-buffer 'verilog-highlight-buffer) +(defalias 'verilog-colorize-include-files-buffer #'verilog-highlight-buffer) ;; ffap-at-mouse isn't useful for Verilog mode. It uses library paths. ;; so define this function to do more or less the same as ffap-at-mouse diff --git a/lisp/progmodes/vhdl-mode.el b/lisp/progmodes/vhdl-mode.el index c4de800e332..5eeac8af3b8 100644 --- a/lisp/progmodes/vhdl-mode.el +++ b/lisp/progmodes/vhdl-mode.el @@ -1,4 +1,4 @@ -;;; vhdl-mode.el --- major mode for editing VHDL code +;;; vhdl-mode.el --- major mode for editing VHDL code -*- lexical-binding: t; -*- ;; Copyright (C) 1992-2021 Free Software Foundation, Inc. @@ -6,12 +6,15 @@ ;; Rodney J. Whitby <software.vhdl-mode@rwhitby.net> ;; Maintainer: Reto Zimmermann <reto@gnu.org> ;; Keywords: languages vhdl -;; WWW: http://www.iis.ee.ethz.ch/~zimmi/emacs/vhdl-mode.html +;; WWW: https://guest.iis.ee.ethz.ch/~zimmi/emacs/vhdl-mode.html ;; Yoni Rabkin <yoni@rabkins.net> contacted the maintainer of this ;; file on 18/3/2008, and the maintainer agreed that when a bug is ;; filed in the Emacs bug reporting system against this file, a copy ;; of the bug report be sent to the maintainer's email address. +;; +;; Reto also said in Apr 2021 that he preferred to keep the XEmacs +;; compatibility code. (defconst vhdl-version "3.38.1" "VHDL Mode version number.") @@ -77,7 +80,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Installation -;; Prerequisites: GNU Emacs 20/21/22/23/24, XEmacs 20/21. +;; Prerequisites: GNU Emacs >= 21, 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 @@ -92,7 +95,7 @@ ;; Add the following lines to the `site-start.el' file in the `site-lisp' ;; directory of your Emacs installation or to your Emacs start-up file `.emacs' -;; (not required in Emacs 20 and higher): +;; (not required in Emacs): ;; (autoload 'vhdl-mode "vhdl-mode" "VHDL Mode" t) ;; (push '("\\.vhdl?\\'" . vhdl-mode) auto-mode-alist) @@ -136,12 +139,9 @@ (when (< emacs-major-version 25) (condition-case nil (require 'cl-lib) (file-missing (require 'cl)))) -;; Emacs 21+ handling -(defconst vhdl-emacs-21 (and (<= 21 emacs-major-version) (not (featurep 'xemacs))) - "Non-nil if GNU Emacs 21, 22, ... is used.") ;; Emacs 22+ handling (defconst vhdl-emacs-22 (and (<= 22 emacs-major-version) (not (featurep 'xemacs))) - "Non-nil if GNU Emacs 22, ... is used.") + "Non-nil if GNU Emacs >= 22, ... is used.") (defvar compilation-file-regexp-alist) (defvar conf-alist) @@ -490,7 +490,7 @@ NOTE: Activate new error and file message regexps and reflect the new setting (const :tag "Upcase" upcase) (const :tag "Downcase" downcase)))))) :set (lambda (variable value) - (vhdl-custom-set variable value 'vhdl-update-mode-menu)) + (vhdl-custom-set variable value #'vhdl-update-mode-menu)) :version "24.4" :group 'vhdl-compile) @@ -668,8 +668,8 @@ NOTE: Reflect the new setting in the choice list of option `vhdl-project' :format "%t\n%v\n"))) :set (lambda (variable value) (vhdl-custom-set variable value - 'vhdl-update-mode-menu - 'vhdl-speedbar-refresh)) + #'vhdl-update-mode-menu + #'vhdl-speedbar-refresh)) :group 'vhdl-project) (defcustom vhdl-project nil @@ -713,7 +713,7 @@ All project setup files that match the file names specified in option \(alphabetically) last loaded setup of the first `vhdl-project-file-name' entry is activated. A project setup file can be obtained by exporting a project (see menu). - At startup: project setup file is loaded at Emacs startup" + At startup: project setup file is loaded at Emacs startup." :type '(set (const :tag "At startup" startup)) :group 'vhdl-project) @@ -751,12 +751,12 @@ NOTE: Activate the new setting in a VHDL buffer by using the menu entry (const :tag "Math packages" math))) :set (lambda (variable value) (vhdl-custom-set variable value - 'vhdl-template-map-init - 'vhdl-mode-abbrev-table-init - 'vhdl-template-construct-alist-init - 'vhdl-template-package-alist-init - 'vhdl-update-mode-menu - 'vhdl-words-init 'vhdl-font-lock-init)) + #'vhdl-template-map-init + #'vhdl-mode-abbrev-table-init + #'vhdl-template-construct-alist-init + #'vhdl-template-package-alist-init + #'vhdl-update-mode-menu + #'vhdl-words-init 'vhdl-font-lock-init)) :group 'vhdl-style) (defcustom vhdl-basic-offset 2 @@ -770,7 +770,7 @@ This value is used by + and - symbols in `vhdl-offsets-alist'." This is done when typed or expanded or by the fix case functions." :type 'boolean :set (lambda (variable value) - (vhdl-custom-set variable value 'vhdl-abbrev-list-init)) + (vhdl-custom-set variable value #'vhdl-abbrev-list-init)) :group 'vhdl-style) (defcustom vhdl-upper-case-types nil @@ -778,7 +778,7 @@ This is done when typed or expanded or by the fix case functions." This is done when expanded or by the fix case functions." :type 'boolean :set (lambda (variable value) - (vhdl-custom-set variable value 'vhdl-abbrev-list-init)) + (vhdl-custom-set variable value #'vhdl-abbrev-list-init)) :group 'vhdl-style) (defcustom vhdl-upper-case-attributes nil @@ -786,7 +786,7 @@ This is done when expanded or by the fix case functions." This is done when expanded or by the fix case functions." :type 'boolean :set (lambda (variable value) - (vhdl-custom-set variable value 'vhdl-abbrev-list-init)) + (vhdl-custom-set variable value #'vhdl-abbrev-list-init)) :group 'vhdl-style) (defcustom vhdl-upper-case-enum-values nil @@ -794,7 +794,7 @@ This is done when expanded or by the fix case functions." This is done when expanded or by the fix case functions." :type 'boolean :set (lambda (variable value) - (vhdl-custom-set variable value 'vhdl-abbrev-list-init)) + (vhdl-custom-set variable value #'vhdl-abbrev-list-init)) :group 'vhdl-style) (defcustom vhdl-upper-case-constants t @@ -802,7 +802,7 @@ This is done when expanded or by the fix case functions." This is done when expanded." :type 'boolean :set (lambda (variable value) - (vhdl-custom-set variable value 'vhdl-abbrev-list-init)) + (vhdl-custom-set variable value #'vhdl-abbrev-list-init)) :group 'vhdl-style) (defcustom vhdl-use-direct-instantiation 'standard @@ -909,7 +909,7 @@ follows: :type '(set (const :tag "VHDL keywords" vhdl) (const :tag "User model keywords" user)) :set (lambda (variable value) - (vhdl-custom-set variable value 'vhdl-mode-abbrev-table-init)) + (vhdl-custom-set variable value #'vhdl-mode-abbrev-table-init)) :group 'vhdl-template) (defcustom vhdl-optional-labels 'process @@ -1192,10 +1192,10 @@ NOTE: Activate the new setting in a VHDL buffer by using the menu entry (string :tag "Keyword " :format "%t: %v\n"))) :set (lambda (variable value) (vhdl-custom-set variable value - 'vhdl-model-map-init - 'vhdl-model-defun - 'vhdl-mode-abbrev-table-init - 'vhdl-update-mode-menu)) + #'vhdl-model-map-init + #'vhdl-model-defun + #'vhdl-mode-abbrev-table-init + #'vhdl-update-mode-menu)) :group 'vhdl-model) @@ -1598,7 +1598,7 @@ NOTE: Activate the new setting in a VHDL buffer by re-fontifying it (menu entry \"Fontify Buffer\")." :type 'boolean :set (lambda (variable value) - (vhdl-custom-set variable value 'vhdl-font-lock-init)) + (vhdl-custom-set variable value #'vhdl-font-lock-init)) :group 'vhdl-highlight) (defcustom vhdl-highlight-names t @@ -1615,7 +1615,7 @@ NOTE: Activate the new setting in a VHDL buffer by re-fontifying it (menu entry \"Fontify Buffer\")." :type 'boolean :set (lambda (variable value) - (vhdl-custom-set variable value 'vhdl-font-lock-init)) + (vhdl-custom-set variable value #'vhdl-font-lock-init)) :group 'vhdl-highlight) (defcustom vhdl-highlight-special-words nil @@ -1628,7 +1628,7 @@ NOTE: Activate the new setting in a VHDL buffer by re-fontifying it (menu entry \"Fontify Buffer\")." :type 'boolean :set (lambda (variable value) - (vhdl-custom-set variable value 'vhdl-font-lock-init)) + (vhdl-custom-set variable value #'vhdl-font-lock-init)) :group 'vhdl-highlight) (defcustom vhdl-highlight-forbidden-words nil @@ -1643,7 +1643,7 @@ NOTE: Activate the new setting in a VHDL buffer by re-fontifying it (menu :type 'boolean :set (lambda (variable value) (vhdl-custom-set variable value - 'vhdl-words-init 'vhdl-font-lock-init)) + #'vhdl-words-init #'vhdl-font-lock-init)) :group 'vhdl-highlight) (defcustom vhdl-highlight-verilog-keywords nil @@ -1656,7 +1656,7 @@ NOTE: Activate the new setting in a VHDL buffer by re-fontifying it (menu :type 'boolean :set (lambda (variable value) (vhdl-custom-set variable value - 'vhdl-words-init 'vhdl-font-lock-init)) + #'vhdl-words-init #'vhdl-font-lock-init)) :group 'vhdl-highlight) (defcustom vhdl-highlight-translate-off nil @@ -1670,7 +1670,7 @@ NOTE: Activate the new setting in a VHDL buffer by re-fontifying it (menu entry \"Fontify Buffer\")." :type 'boolean :set (lambda (variable value) - (vhdl-custom-set variable value 'vhdl-font-lock-init)) + (vhdl-custom-set variable value #'vhdl-font-lock-init)) :group 'vhdl-highlight) (defcustom vhdl-highlight-case-sensitive nil @@ -1724,7 +1724,7 @@ NOTE: Activate a changed regexp in a VHDL buffer by re-fontifying it (menu (string :tag "Color (dark) ") (boolean :tag "In comments "))) :set (lambda (variable value) - (vhdl-custom-set variable value 'vhdl-font-lock-init)) + (vhdl-custom-set variable value #'vhdl-font-lock-init)) :group 'vhdl-highlight) (defcustom vhdl-forbidden-words '() @@ -1737,7 +1737,7 @@ NOTE: Activate the new setting in a VHDL buffer by re-fontifying it (menu :type '(repeat (string :format "%v")) :set (lambda (variable value) (vhdl-custom-set variable value - 'vhdl-words-init 'vhdl-font-lock-init)) + #'vhdl-words-init #'vhdl-font-lock-init)) :group 'vhdl-highlight) (defcustom vhdl-forbidden-syntax "" @@ -1752,7 +1752,7 @@ NOTE: Activate the new setting in a VHDL buffer by re-fontifying it (menu :type 'regexp :set (lambda (variable value) (vhdl-custom-set variable value - 'vhdl-words-init 'vhdl-font-lock-init)) + #'vhdl-words-init #'vhdl-font-lock-init)) :group 'vhdl-highlight) (defcustom vhdl-directive-keywords '("psl" "pragma" "synopsys") @@ -1763,7 +1763,7 @@ NOTE: Activate the new setting in a VHDL buffer by re-fontifying it (menu :type '(repeat (string :format "%v")) :set (lambda (variable value) (vhdl-custom-set variable value - 'vhdl-words-init 'vhdl-font-lock-init)) + #'vhdl-words-init #'vhdl-font-lock-init)) :group 'vhdl-highlight) @@ -2159,7 +2159,8 @@ your style, only those that are different from the default.") ;; mandatory (require 'compile) ; XEmacs -(require 'easymenu) +(when (< emacs-major-version 28) ; preloaded in Emacs 28 + (require 'easymenu)) (require 'hippie-exp) ;; optional (minimize warning messages during compile) @@ -2237,11 +2238,11 @@ Ignore byte-compiler warnings you might see." ; (vhdl-warning-when-idle "Please install `xemacs-devel' package.") (defun regexp-opt (strings &optional paren) (let ((open (if paren "\\(" "")) (close (if paren "\\)" ""))) - (concat open (mapconcat 'regexp-quote strings "\\|") close)))) + (concat open (mapconcat #'regexp-quote strings "\\|") close)))) ;; `match-string-no-properties' undefined (XEmacs, what else?) (unless (fboundp 'match-string-no-properties) - (defalias 'match-string-no-properties 'match-string)) + (defalias 'match-string-no-properties #'match-string)) ;; `subst-char-in-string' undefined (XEmacs) (unless (fboundp 'subst-char-in-string) @@ -2268,7 +2269,7 @@ Ignore byte-compiler warnings you might see." (let* ((nondir (file-name-nondirectory pattern)) (dirpart (file-name-directory pattern)) (dirs (if (and dirpart (string-match "[[*?]" dirpart)) - (mapcar 'file-name-as-directory + (mapcar #'file-name-as-directory (file-expand-wildcards (directory-file-name dirpart))) (list dirpart))) contents) @@ -2295,7 +2296,7 @@ Ignore byte-compiler warnings you might see." ;; `member-ignore-case' undefined (XEmacs) (unless (fboundp 'member-ignore-case) - (defalias 'member-ignore-case 'member)) + (defalias 'member-ignore-case #'member)) ;; `last-input-char' obsolete in Emacs 24, `last-input-event' different ;; behavior in XEmacs @@ -2494,6 +2495,7 @@ current buffer if no project is defined." "Enable case insensitive search and switch to syntax table that includes `_', then execute BODY, and finally restore the old environment. Used for consistent searching." + (declare (debug t)) `(let ((case-fold-search t)) ; case insensitive search ;; use extended syntax table (with-syntax-table vhdl-mode-ext-syntax-table @@ -2503,55 +2505,59 @@ consistent searching." "Enable case insensitive search, switch to syntax table that includes `_', arrange to ignore `intangible' overlays, then execute BODY, and finally restore the old environment. Used for consistent searching." + (declare (debug t)) `(let ((case-fold-search t) ; case insensitive search - (current-syntax-table (syntax-table)) (inhibit-point-motion-hooks t)) ;; use extended syntax table - (set-syntax-table vhdl-mode-ext-syntax-table) - ;; execute BODY safely - (unwind-protect - (progn ,@body) - ;; restore syntax table - (set-syntax-table current-syntax-table)))) + (with-syntax-table vhdl-mode-ext-syntax-table + ;; execute BODY safely + (progn ,@body)))) (defmacro vhdl-visit-file (file-name issue-error &rest body) "Visit file FILE-NAME and execute BODY." - `(if (null ,file-name) - (progn ,@body) - (unless (file-directory-p ,file-name) - (let ((source-buffer (current-buffer)) - (visiting-buffer (find-buffer-visiting ,file-name)) - file-opened) - (when (or (and visiting-buffer (set-buffer visiting-buffer)) - (condition-case () - (progn (set-buffer (create-file-buffer ,file-name)) - (setq file-opened t) - (vhdl-insert-file-contents ,file-name) - ;; FIXME: This modifies a global syntax-table! - (modify-syntax-entry ?\- ". 12" (syntax-table)) - (modify-syntax-entry ?\n ">" (syntax-table)) - (modify-syntax-entry ?\^M ">" (syntax-table)) - (modify-syntax-entry ?_ "w" (syntax-table)) - t) - (error - (if ,issue-error - (progn - (when file-opened (kill-buffer (current-buffer))) - (set-buffer source-buffer) - (error "ERROR: File cannot be opened: \"%s\"" ,file-name)) - (vhdl-warning (format "File cannot be opened: \"%s\"" ,file-name) t) - nil)))) - (condition-case info - (progn ,@body) - (error - (if ,issue-error - (progn - (when file-opened (kill-buffer (current-buffer))) - (set-buffer source-buffer) - (error (cadr info))) - (vhdl-warning (cadr info)))))) - (when file-opened (kill-buffer (current-buffer))) - (set-buffer source-buffer))))) + (declare (debug t) (indent 2)) + `(vhdl--visit-file ,file-name ,issue-error (lambda () . ,body))) + +(defun vhdl--visit-file (file-name issue-error body-fun) + (if (null file-name) + (funcall body-fun) + (unless (file-directory-p file-name) + (let ((source-buffer (current-buffer)) + (visiting-buffer (find-buffer-visiting file-name)) + file-opened) + (when (or (and visiting-buffer (set-buffer visiting-buffer)) + (condition-case () + (progn (set-buffer (create-file-buffer file-name)) + (setq file-opened t) + (vhdl-insert-file-contents file-name) + (let ((st (copy-syntax-table (syntax-table)))) + (modify-syntax-entry ?\- ". 12" st) + (modify-syntax-entry ?\n ">" st) + (modify-syntax-entry ?\^M ">" st) + (modify-syntax-entry ?_ "w" st) + ;; FIXME: We should arguably reset the + ;; syntax-table after running `body-fun'. + (set-syntax-table st)) + t) + (error + (if issue-error + (progn + (when file-opened (kill-buffer (current-buffer))) + (set-buffer source-buffer) + (error "ERROR: File cannot be opened: \"%s\"" file-name)) + (vhdl-warning (format "File cannot be opened: \"%s\"" file-name) t) + nil)))) + (condition-case info + (funcall body-fun) + (error + (if issue-error + (progn + (when file-opened (kill-buffer (current-buffer))) + (set-buffer source-buffer) + (error (cadr info))) + (vhdl-warning (cadr info)))))) + (when file-opened (kill-buffer (current-buffer))) + (set-buffer source-buffer))))) (defun vhdl-insert-file-contents (filename) "Nicked from `insert-file-contents-literally', but allow coding system @@ -2599,7 +2605,7 @@ conversion." "Refresh directory or project with name KEY." (when (and (boundp 'speedbar-frame) (frame-live-p speedbar-frame)) - (let ((pos (point)) + (let (;; (pos (point)) (last-frame (selected-frame))) (if (null key) (speedbar-refresh) @@ -2676,96 +2682,96 @@ elements > `vhdl-menu-max-size'." "Initialize `vhdl-template-map'." (setq vhdl-template-map (make-sparse-keymap)) ;; key bindings for VHDL templates - (define-key vhdl-template-map "al" 'vhdl-template-alias) - (define-key vhdl-template-map "ar" 'vhdl-template-architecture) - (define-key vhdl-template-map "at" 'vhdl-template-assert) - (define-key vhdl-template-map "ad" 'vhdl-template-attribute-decl) - (define-key vhdl-template-map "as" 'vhdl-template-attribute-spec) - (define-key vhdl-template-map "bl" 'vhdl-template-block) - (define-key vhdl-template-map "ca" 'vhdl-template-case-is) - (define-key vhdl-template-map "cd" 'vhdl-template-component-decl) - (define-key vhdl-template-map "ci" 'vhdl-template-component-inst) - (define-key vhdl-template-map "cs" 'vhdl-template-conditional-signal-asst) - (define-key vhdl-template-map "Cb" 'vhdl-template-block-configuration) - (define-key vhdl-template-map "Cc" 'vhdl-template-component-conf) - (define-key vhdl-template-map "Cd" 'vhdl-template-configuration-decl) - (define-key vhdl-template-map "Cs" 'vhdl-template-configuration-spec) - (define-key vhdl-template-map "co" 'vhdl-template-constant) - (define-key vhdl-template-map "ct" 'vhdl-template-context) - (define-key vhdl-template-map "di" 'vhdl-template-disconnect) - (define-key vhdl-template-map "el" 'vhdl-template-else) - (define-key vhdl-template-map "ei" 'vhdl-template-elsif) - (define-key vhdl-template-map "en" 'vhdl-template-entity) - (define-key vhdl-template-map "ex" 'vhdl-template-exit) - (define-key vhdl-template-map "fi" 'vhdl-template-file) - (define-key vhdl-template-map "fg" 'vhdl-template-for-generate) - (define-key vhdl-template-map "fl" 'vhdl-template-for-loop) - (define-key vhdl-template-map "\C-f" 'vhdl-template-footer) - (define-key vhdl-template-map "fb" 'vhdl-template-function-body) - (define-key vhdl-template-map "fd" 'vhdl-template-function-decl) - (define-key vhdl-template-map "ge" 'vhdl-template-generic) - (define-key vhdl-template-map "gd" 'vhdl-template-group-decl) - (define-key vhdl-template-map "gt" 'vhdl-template-group-template) - (define-key vhdl-template-map "\C-h" 'vhdl-template-header) - (define-key vhdl-template-map "ig" 'vhdl-template-if-generate) - (define-key vhdl-template-map "it" 'vhdl-template-if-then) - (define-key vhdl-template-map "li" 'vhdl-template-library) - (define-key vhdl-template-map "lo" 'vhdl-template-bare-loop) - (define-key vhdl-template-map "\C-m" 'vhdl-template-modify) - (define-key vhdl-template-map "\C-t" 'vhdl-template-insert-date) - (define-key vhdl-template-map "ma" 'vhdl-template-map) - (define-key vhdl-template-map "ne" 'vhdl-template-next) - (define-key vhdl-template-map "ot" 'vhdl-template-others) - (define-key vhdl-template-map "Pd" 'vhdl-template-package-decl) - (define-key vhdl-template-map "Pb" 'vhdl-template-package-body) - (define-key vhdl-template-map "(" 'vhdl-template-paired-parens) - (define-key vhdl-template-map "po" 'vhdl-template-port) - (define-key vhdl-template-map "pb" 'vhdl-template-procedure-body) - (define-key vhdl-template-map "pd" 'vhdl-template-procedure-decl) - (define-key vhdl-template-map "pc" 'vhdl-template-process-comb) - (define-key vhdl-template-map "ps" 'vhdl-template-process-seq) - (define-key vhdl-template-map "rp" 'vhdl-template-report) - (define-key vhdl-template-map "rt" 'vhdl-template-return) - (define-key vhdl-template-map "ss" 'vhdl-template-selected-signal-asst) - (define-key vhdl-template-map "si" 'vhdl-template-signal) - (define-key vhdl-template-map "su" 'vhdl-template-subtype) - (define-key vhdl-template-map "ty" 'vhdl-template-type) - (define-key vhdl-template-map "us" 'vhdl-template-use) - (define-key vhdl-template-map "va" 'vhdl-template-variable) - (define-key vhdl-template-map "wa" 'vhdl-template-wait) - (define-key vhdl-template-map "wl" 'vhdl-template-while-loop) - (define-key vhdl-template-map "wi" 'vhdl-template-with) - (define-key vhdl-template-map "wc" 'vhdl-template-clocked-wait) - (define-key vhdl-template-map "\C-pb" 'vhdl-template-package-numeric-bit) - (define-key vhdl-template-map "\C-pn" 'vhdl-template-package-numeric-std) - (define-key vhdl-template-map "\C-ps" 'vhdl-template-package-std-logic-1164) - (define-key vhdl-template-map "\C-pA" 'vhdl-template-package-std-logic-arith) - (define-key vhdl-template-map "\C-pM" 'vhdl-template-package-std-logic-misc) - (define-key vhdl-template-map "\C-pS" 'vhdl-template-package-std-logic-signed) - (define-key vhdl-template-map "\C-pT" 'vhdl-template-package-std-logic-textio) - (define-key vhdl-template-map "\C-pU" 'vhdl-template-package-std-logic-unsigned) - (define-key vhdl-template-map "\C-pt" 'vhdl-template-package-textio) - (define-key vhdl-template-map "\C-dn" 'vhdl-template-directive-translate-on) - (define-key vhdl-template-map "\C-df" 'vhdl-template-directive-translate-off) - (define-key vhdl-template-map "\C-dN" 'vhdl-template-directive-synthesis-on) - (define-key vhdl-template-map "\C-dF" 'vhdl-template-directive-synthesis-off) - (define-key vhdl-template-map "\C-q" 'vhdl-template-search-prompt) + (define-key vhdl-template-map "al" #'vhdl-template-alias) + (define-key vhdl-template-map "ar" #'vhdl-template-architecture) + (define-key vhdl-template-map "at" #'vhdl-template-assert) + (define-key vhdl-template-map "ad" #'vhdl-template-attribute-decl) + (define-key vhdl-template-map "as" #'vhdl-template-attribute-spec) + (define-key vhdl-template-map "bl" #'vhdl-template-block) + (define-key vhdl-template-map "ca" #'vhdl-template-case-is) + (define-key vhdl-template-map "cd" #'vhdl-template-component-decl) + (define-key vhdl-template-map "ci" #'vhdl-template-component-inst) + (define-key vhdl-template-map "cs" #'vhdl-template-conditional-signal-asst) + (define-key vhdl-template-map "Cb" #'vhdl-template-block-configuration) + (define-key vhdl-template-map "Cc" #'vhdl-template-component-conf) + (define-key vhdl-template-map "Cd" #'vhdl-template-configuration-decl) + (define-key vhdl-template-map "Cs" #'vhdl-template-configuration-spec) + (define-key vhdl-template-map "co" #'vhdl-template-constant) + (define-key vhdl-template-map "ct" #'vhdl-template-context) + (define-key vhdl-template-map "di" #'vhdl-template-disconnect) + (define-key vhdl-template-map "el" #'vhdl-template-else) + (define-key vhdl-template-map "ei" #'vhdl-template-elsif) + (define-key vhdl-template-map "en" #'vhdl-template-entity) + (define-key vhdl-template-map "ex" #'vhdl-template-exit) + (define-key vhdl-template-map "fi" #'vhdl-template-file) + (define-key vhdl-template-map "fg" #'vhdl-template-for-generate) + (define-key vhdl-template-map "fl" #'vhdl-template-for-loop) + (define-key vhdl-template-map "\C-f" #'vhdl-template-footer) + (define-key vhdl-template-map "fb" #'vhdl-template-function-body) + (define-key vhdl-template-map "fd" #'vhdl-template-function-decl) + (define-key vhdl-template-map "ge" #'vhdl-template-generic) + (define-key vhdl-template-map "gd" #'vhdl-template-group-decl) + (define-key vhdl-template-map "gt" #'vhdl-template-group-template) + (define-key vhdl-template-map "\C-h" #'vhdl-template-header) + (define-key vhdl-template-map "ig" #'vhdl-template-if-generate) + (define-key vhdl-template-map "it" #'vhdl-template-if-then) + (define-key vhdl-template-map "li" #'vhdl-template-library) + (define-key vhdl-template-map "lo" #'vhdl-template-bare-loop) + (define-key vhdl-template-map "\C-m" #'vhdl-template-modify) + (define-key vhdl-template-map "\C-t" #'vhdl-template-insert-date) + (define-key vhdl-template-map "ma" #'vhdl-template-map) + (define-key vhdl-template-map "ne" #'vhdl-template-next) + (define-key vhdl-template-map "ot" #'vhdl-template-others) + (define-key vhdl-template-map "Pd" #'vhdl-template-package-decl) + (define-key vhdl-template-map "Pb" #'vhdl-template-package-body) + (define-key vhdl-template-map "(" #'vhdl-template-paired-parens) + (define-key vhdl-template-map "po" #'vhdl-template-port) + (define-key vhdl-template-map "pb" #'vhdl-template-procedure-body) + (define-key vhdl-template-map "pd" #'vhdl-template-procedure-decl) + (define-key vhdl-template-map "pc" #'vhdl-template-process-comb) + (define-key vhdl-template-map "ps" #'vhdl-template-process-seq) + (define-key vhdl-template-map "rp" #'vhdl-template-report) + (define-key vhdl-template-map "rt" #'vhdl-template-return) + (define-key vhdl-template-map "ss" #'vhdl-template-selected-signal-asst) + (define-key vhdl-template-map "si" #'vhdl-template-signal) + (define-key vhdl-template-map "su" #'vhdl-template-subtype) + (define-key vhdl-template-map "ty" #'vhdl-template-type) + (define-key vhdl-template-map "us" #'vhdl-template-use) + (define-key vhdl-template-map "va" #'vhdl-template-variable) + (define-key vhdl-template-map "wa" #'vhdl-template-wait) + (define-key vhdl-template-map "wl" #'vhdl-template-while-loop) + (define-key vhdl-template-map "wi" #'vhdl-template-with) + (define-key vhdl-template-map "wc" #'vhdl-template-clocked-wait) + (define-key vhdl-template-map "\C-pb" #'vhdl-template-package-numeric-bit) + (define-key vhdl-template-map "\C-pn" #'vhdl-template-package-numeric-std) + (define-key vhdl-template-map "\C-ps" #'vhdl-template-package-std-logic-1164) + (define-key vhdl-template-map "\C-pA" #'vhdl-template-package-std-logic-arith) + (define-key vhdl-template-map "\C-pM" #'vhdl-template-package-std-logic-misc) + (define-key vhdl-template-map "\C-pS" #'vhdl-template-package-std-logic-signed) + (define-key vhdl-template-map "\C-pT" #'vhdl-template-package-std-logic-textio) + (define-key vhdl-template-map "\C-pU" #'vhdl-template-package-std-logic-unsigned) + (define-key vhdl-template-map "\C-pt" #'vhdl-template-package-textio) + (define-key vhdl-template-map "\C-dn" #'vhdl-template-directive-translate-on) + (define-key vhdl-template-map "\C-df" #'vhdl-template-directive-translate-off) + (define-key vhdl-template-map "\C-dN" #'vhdl-template-directive-synthesis-on) + (define-key vhdl-template-map "\C-dF" #'vhdl-template-directive-synthesis-off) + (define-key vhdl-template-map "\C-q" #'vhdl-template-search-prompt) (when (vhdl-standard-p 'ams) - (define-key vhdl-template-map "br" 'vhdl-template-break) - (define-key vhdl-template-map "cu" 'vhdl-template-case-use) - (define-key vhdl-template-map "iu" 'vhdl-template-if-use) - (define-key vhdl-template-map "lm" 'vhdl-template-limit) - (define-key vhdl-template-map "na" 'vhdl-template-nature) - (define-key vhdl-template-map "pa" 'vhdl-template-procedural) - (define-key vhdl-template-map "qf" 'vhdl-template-quantity-free) - (define-key vhdl-template-map "qb" 'vhdl-template-quantity-branch) - (define-key vhdl-template-map "qs" 'vhdl-template-quantity-source) - (define-key vhdl-template-map "sn" 'vhdl-template-subnature) - (define-key vhdl-template-map "te" 'vhdl-template-terminal) + (define-key vhdl-template-map "br" #'vhdl-template-break) + (define-key vhdl-template-map "cu" #'vhdl-template-case-use) + (define-key vhdl-template-map "iu" #'vhdl-template-if-use) + (define-key vhdl-template-map "lm" #'vhdl-template-limit) + (define-key vhdl-template-map "na" #'vhdl-template-nature) + (define-key vhdl-template-map "pa" #'vhdl-template-procedural) + (define-key vhdl-template-map "qf" #'vhdl-template-quantity-free) + (define-key vhdl-template-map "qb" #'vhdl-template-quantity-branch) + (define-key vhdl-template-map "qs" #'vhdl-template-quantity-source) + (define-key vhdl-template-map "sn" #'vhdl-template-subnature) + (define-key vhdl-template-map "te" #'vhdl-template-terminal) ) (when (vhdl-standard-p 'math) - (define-key vhdl-template-map "\C-pc" 'vhdl-template-package-math-complex) - (define-key vhdl-template-map "\C-pr" 'vhdl-template-package-math-real) + (define-key vhdl-template-map "\C-pc" #'vhdl-template-package-math-complex) + (define-key vhdl-template-map "\C-pr" #'vhdl-template-package-math-real) )) ;; initialize template map for VHDL Mode @@ -2811,119 +2817,120 @@ STRING are replaced by `-' and substrings are converted to lower case." ;; model key bindings (define-key vhdl-mode-map "\C-c\C-m" vhdl-model-map) ;; standard key bindings - (define-key vhdl-mode-map "\M-a" 'vhdl-beginning-of-statement) - (define-key vhdl-mode-map "\M-e" 'vhdl-end-of-statement) - (define-key vhdl-mode-map "\M-\C-f" 'vhdl-forward-sexp) - (define-key vhdl-mode-map "\M-\C-b" 'vhdl-backward-sexp) - (define-key vhdl-mode-map "\M-\C-u" 'vhdl-backward-up-list) - (define-key vhdl-mode-map "\M-\C-a" 'vhdl-backward-same-indent) - (define-key vhdl-mode-map "\M-\C-e" 'vhdl-forward-same-indent) + (define-key vhdl-mode-map "\M-a" #'vhdl-beginning-of-statement) + (define-key vhdl-mode-map "\M-e" #'vhdl-end-of-statement) + (define-key vhdl-mode-map "\M-\C-f" #'vhdl-forward-sexp) + (define-key vhdl-mode-map "\M-\C-b" #'vhdl-backward-sexp) + (define-key vhdl-mode-map "\M-\C-u" #'vhdl-backward-up-list) + (define-key vhdl-mode-map "\M-\C-a" #'vhdl-backward-same-indent) + (define-key vhdl-mode-map "\M-\C-e" #'vhdl-forward-same-indent) (unless (featurep 'xemacs) ; would override `M-backspace' in XEmacs - (define-key vhdl-mode-map "\M-\C-h" 'vhdl-mark-defun)) - (define-key vhdl-mode-map "\M-\C-q" 'vhdl-indent-sexp) - (define-key vhdl-mode-map "\M-^" 'vhdl-delete-indentation) + (define-key vhdl-mode-map "\M-\C-h" #'vhdl-mark-defun)) + (define-key vhdl-mode-map "\M-\C-q" #'vhdl-indent-sexp) + (define-key vhdl-mode-map "\M-^" #'vhdl-delete-indentation) ;; mode specific key bindings - (define-key vhdl-mode-map "\C-c\C-m\C-e" 'vhdl-electric-mode) - (define-key vhdl-mode-map "\C-c\C-m\C-s" 'vhdl-stutter-mode) - (define-key vhdl-mode-map "\C-c\C-s\C-p" 'vhdl-set-project) - (define-key vhdl-mode-map "\C-c\C-p\C-d" 'vhdl-duplicate-project) - (define-key vhdl-mode-map "\C-c\C-p\C-m" 'vhdl-import-project) - (define-key vhdl-mode-map "\C-c\C-p\C-x" 'vhdl-export-project) - (define-key vhdl-mode-map "\C-c\C-s\C-k" 'vhdl-set-compiler) - (define-key vhdl-mode-map "\C-c\C-k" 'vhdl-compile) - (define-key vhdl-mode-map "\C-c\M-\C-k" 'vhdl-make) - (define-key vhdl-mode-map "\C-c\M-k" 'vhdl-generate-makefile) - (define-key vhdl-mode-map "\C-c\C-p\C-w" 'vhdl-port-copy) - (define-key vhdl-mode-map "\C-c\C-p\M-w" 'vhdl-port-copy) - (define-key vhdl-mode-map "\C-c\C-p\C-e" 'vhdl-port-paste-entity) - (define-key vhdl-mode-map "\C-c\C-p\C-c" 'vhdl-port-paste-component) - (define-key vhdl-mode-map "\C-c\C-p\C-i" 'vhdl-port-paste-instance) - (define-key vhdl-mode-map "\C-c\C-p\C-s" 'vhdl-port-paste-signals) - (define-key vhdl-mode-map "\C-c\C-p\M-c" 'vhdl-port-paste-constants) - (if (featurep 'xemacs) ; `... C-g' not allowed in XEmacs - (define-key vhdl-mode-map "\C-c\C-p\M-g" 'vhdl-port-paste-generic-map) - (define-key vhdl-mode-map "\C-c\C-p\C-g" 'vhdl-port-paste-generic-map)) - (define-key vhdl-mode-map "\C-c\C-p\C-z" 'vhdl-port-paste-initializations) - (define-key vhdl-mode-map "\C-c\C-p\C-t" 'vhdl-port-paste-testbench) - (define-key vhdl-mode-map "\C-c\C-p\C-f" 'vhdl-port-flatten) - (define-key vhdl-mode-map "\C-c\C-p\C-r" 'vhdl-port-reverse-direction) - (define-key vhdl-mode-map "\C-c\C-s\C-w" 'vhdl-subprog-copy) - (define-key vhdl-mode-map "\C-c\C-s\M-w" 'vhdl-subprog-copy) - (define-key vhdl-mode-map "\C-c\C-s\C-d" 'vhdl-subprog-paste-declaration) - (define-key vhdl-mode-map "\C-c\C-s\C-b" 'vhdl-subprog-paste-body) - (define-key vhdl-mode-map "\C-c\C-s\C-c" 'vhdl-subprog-paste-call) - (define-key vhdl-mode-map "\C-c\C-s\C-f" 'vhdl-subprog-flatten) - (define-key vhdl-mode-map "\C-c\C-m\C-n" 'vhdl-compose-new-component) - (define-key vhdl-mode-map "\C-c\C-m\C-p" 'vhdl-compose-place-component) - (define-key vhdl-mode-map "\C-c\C-m\C-w" 'vhdl-compose-wire-components) - (define-key vhdl-mode-map "\C-c\C-m\C-f" 'vhdl-compose-configuration) - (define-key vhdl-mode-map "\C-c\C-m\C-k" 'vhdl-compose-components-package) - (define-key vhdl-mode-map "\C-c\C-c" 'vhdl-comment-uncomment-region) - (define-key vhdl-mode-map "\C-c-" 'vhdl-comment-append-inline) - (define-key vhdl-mode-map "\C-c\M--" 'vhdl-comment-display-line) - (define-key vhdl-mode-map "\C-c\C-i\C-l" 'indent-according-to-mode) - (define-key vhdl-mode-map "\C-c\C-i\C-g" 'vhdl-indent-group) - (define-key vhdl-mode-map "\M-\C-\\" 'vhdl-indent-region) - (define-key vhdl-mode-map "\C-c\C-i\C-b" 'vhdl-indent-buffer) - (define-key vhdl-mode-map "\C-c\C-a\C-g" 'vhdl-align-group) - (define-key vhdl-mode-map "\C-c\C-a\C-a" 'vhdl-align-group) - (define-key vhdl-mode-map "\C-c\C-a\C-i" 'vhdl-align-same-indent) - (define-key vhdl-mode-map "\C-c\C-a\C-l" 'vhdl-align-list) - (define-key vhdl-mode-map "\C-c\C-a\C-d" 'vhdl-align-declarations) - (define-key vhdl-mode-map "\C-c\C-a\M-a" 'vhdl-align-region) - (define-key vhdl-mode-map "\C-c\C-a\C-b" 'vhdl-align-buffer) - (define-key vhdl-mode-map "\C-c\C-a\C-c" 'vhdl-align-inline-comment-group) - (define-key vhdl-mode-map "\C-c\C-a\M-c" 'vhdl-align-inline-comment-region) - (define-key vhdl-mode-map "\C-c\C-f\C-l" 'vhdl-fill-list) - (define-key vhdl-mode-map "\C-c\C-f\C-f" 'vhdl-fill-list) - (define-key vhdl-mode-map "\C-c\C-f\C-g" 'vhdl-fill-group) - (define-key vhdl-mode-map "\C-c\C-f\C-i" 'vhdl-fill-same-indent) - (define-key vhdl-mode-map "\C-c\C-f\M-f" 'vhdl-fill-region) - (define-key vhdl-mode-map "\C-c\C-l\C-w" 'vhdl-line-kill) - (define-key vhdl-mode-map "\C-c\C-l\M-w" 'vhdl-line-copy) - (define-key vhdl-mode-map "\C-c\C-l\C-y" 'vhdl-line-yank) - (define-key vhdl-mode-map "\C-c\C-l\t" 'vhdl-line-expand) - (define-key vhdl-mode-map "\C-c\C-l\C-n" 'vhdl-line-transpose-next) - (define-key vhdl-mode-map "\C-c\C-l\C-p" 'vhdl-line-transpose-previous) - (define-key vhdl-mode-map "\C-c\C-l\C-o" 'vhdl-line-open) - (define-key vhdl-mode-map "\C-c\C-l\C-g" 'goto-line) - (define-key vhdl-mode-map "\C-c\C-l\C-c" 'vhdl-comment-uncomment-line) - (define-key vhdl-mode-map "\C-c\C-x\C-s" 'vhdl-fix-statement-region) - (define-key vhdl-mode-map "\C-c\C-x\M-s" 'vhdl-fix-statement-buffer) - (define-key vhdl-mode-map "\C-c\C-x\C-p" 'vhdl-fix-clause) - (define-key vhdl-mode-map "\C-c\C-x\M-c" 'vhdl-fix-case-region) - (define-key vhdl-mode-map "\C-c\C-x\C-c" 'vhdl-fix-case-buffer) - (define-key vhdl-mode-map "\C-c\C-x\M-w" 'vhdl-fixup-whitespace-region) - (define-key vhdl-mode-map "\C-c\C-x\C-w" 'vhdl-fixup-whitespace-buffer) - (define-key vhdl-mode-map "\C-c\M-b" 'vhdl-beautify-region) - (define-key vhdl-mode-map "\C-c\C-b" 'vhdl-beautify-buffer) - (define-key vhdl-mode-map "\C-c\C-u\C-s" 'vhdl-update-sensitivity-list-process) - (define-key vhdl-mode-map "\C-c\C-u\M-s" 'vhdl-update-sensitivity-list-buffer) - (define-key vhdl-mode-map "\C-c\C-i\C-f" 'vhdl-fontify-buffer) - (define-key vhdl-mode-map "\C-c\C-i\C-s" 'vhdl-statistics-buffer) - (define-key vhdl-mode-map "\C-c\M-m" 'vhdl-show-messages) - (define-key vhdl-mode-map "\C-c\C-h" 'vhdl-doc-mode) - (define-key vhdl-mode-map "\C-c\C-v" 'vhdl-version) - (define-key vhdl-mode-map "\M-\t" 'insert-tab) + (define-key vhdl-mode-map "\C-c\C-m\C-e" #'vhdl-electric-mode) + (define-key vhdl-mode-map "\C-c\C-m\C-s" #'vhdl-stutter-mode) + (define-key vhdl-mode-map "\C-c\C-s\C-p" #'vhdl-set-project) + (define-key vhdl-mode-map "\C-c\C-p\C-d" #'vhdl-duplicate-project) + (define-key vhdl-mode-map "\C-c\C-p\C-m" #'vhdl-import-project) + (define-key vhdl-mode-map "\C-c\C-p\C-x" #'vhdl-export-project) + (define-key vhdl-mode-map "\C-c\C-s\C-k" #'vhdl-set-compiler) + (define-key vhdl-mode-map "\C-c\C-k" #'vhdl-compile) + (define-key vhdl-mode-map "\C-c\M-\C-k" #'vhdl-make) + (define-key vhdl-mode-map "\C-c\M-k" #'vhdl-generate-makefile) + (define-key vhdl-mode-map "\C-c\C-p\C-w" #'vhdl-port-copy) + (define-key vhdl-mode-map "\C-c\C-p\M-w" #'vhdl-port-copy) + (define-key vhdl-mode-map "\C-c\C-p\C-e" #'vhdl-port-paste-entity) + (define-key vhdl-mode-map "\C-c\C-p\C-c" #'vhdl-port-paste-component) + (define-key vhdl-mode-map "\C-c\C-p\C-i" #'vhdl-port-paste-instance) + (define-key vhdl-mode-map "\C-c\C-p\C-s" #'vhdl-port-paste-signals) + (define-key vhdl-mode-map "\C-c\C-p\M-c" #'vhdl-port-paste-constants) + (define-key vhdl-mode-map + ;; `... C-g' not allowed in XEmacs. + (if (featurep 'xemacs) "\C-c\C-p\M-g" "\C-c\C-p\C-g") + #'vhdl-port-paste-generic-map) + (define-key vhdl-mode-map "\C-c\C-p\C-z" #'vhdl-port-paste-initializations) + (define-key vhdl-mode-map "\C-c\C-p\C-t" #'vhdl-port-paste-testbench) + (define-key vhdl-mode-map "\C-c\C-p\C-f" #'vhdl-port-flatten) + (define-key vhdl-mode-map "\C-c\C-p\C-r" #'vhdl-port-reverse-direction) + (define-key vhdl-mode-map "\C-c\C-s\C-w" #'vhdl-subprog-copy) + (define-key vhdl-mode-map "\C-c\C-s\M-w" #'vhdl-subprog-copy) + (define-key vhdl-mode-map "\C-c\C-s\C-d" #'vhdl-subprog-paste-declaration) + (define-key vhdl-mode-map "\C-c\C-s\C-b" #'vhdl-subprog-paste-body) + (define-key vhdl-mode-map "\C-c\C-s\C-c" #'vhdl-subprog-paste-call) + (define-key vhdl-mode-map "\C-c\C-s\C-f" #'vhdl-subprog-flatten) + (define-key vhdl-mode-map "\C-c\C-m\C-n" #'vhdl-compose-new-component) + (define-key vhdl-mode-map "\C-c\C-m\C-p" #'vhdl-compose-place-component) + (define-key vhdl-mode-map "\C-c\C-m\C-w" #'vhdl-compose-wire-components) + (define-key vhdl-mode-map "\C-c\C-m\C-f" #'vhdl-compose-configuration) + (define-key vhdl-mode-map "\C-c\C-m\C-k" #'vhdl-compose-components-package) + (define-key vhdl-mode-map "\C-c\C-c" #'vhdl-comment-uncomment-region) + (define-key vhdl-mode-map "\C-c-" #'vhdl-comment-append-inline) + (define-key vhdl-mode-map "\C-c\M--" #'vhdl-comment-display-line) + (define-key vhdl-mode-map "\C-c\C-i\C-l" #'indent-according-to-mode) + (define-key vhdl-mode-map "\C-c\C-i\C-g" #'vhdl-indent-group) + (define-key vhdl-mode-map "\M-\C-\\" #'indent-region) + (define-key vhdl-mode-map "\C-c\C-i\C-b" #'vhdl-indent-buffer) + (define-key vhdl-mode-map "\C-c\C-a\C-g" #'vhdl-align-group) + (define-key vhdl-mode-map "\C-c\C-a\C-a" #'vhdl-align-group) + (define-key vhdl-mode-map "\C-c\C-a\C-i" #'vhdl-align-same-indent) + (define-key vhdl-mode-map "\C-c\C-a\C-l" #'vhdl-align-list) + (define-key vhdl-mode-map "\C-c\C-a\C-d" #'vhdl-align-declarations) + (define-key vhdl-mode-map "\C-c\C-a\M-a" #'vhdl-align-region) + (define-key vhdl-mode-map "\C-c\C-a\C-b" #'vhdl-align-buffer) + (define-key vhdl-mode-map "\C-c\C-a\C-c" #'vhdl-align-inline-comment-group) + (define-key vhdl-mode-map "\C-c\C-a\M-c" #'vhdl-align-inline-comment-region) + (define-key vhdl-mode-map "\C-c\C-f\C-l" #'vhdl-fill-list) + (define-key vhdl-mode-map "\C-c\C-f\C-f" #'vhdl-fill-list) + (define-key vhdl-mode-map "\C-c\C-f\C-g" #'vhdl-fill-group) + (define-key vhdl-mode-map "\C-c\C-f\C-i" #'vhdl-fill-same-indent) + (define-key vhdl-mode-map "\C-c\C-f\M-f" #'vhdl-fill-region) + (define-key vhdl-mode-map "\C-c\C-l\C-w" #'vhdl-line-kill) + (define-key vhdl-mode-map "\C-c\C-l\M-w" #'vhdl-line-copy) + (define-key vhdl-mode-map "\C-c\C-l\C-y" #'vhdl-line-yank) + (define-key vhdl-mode-map "\C-c\C-l\t" #'vhdl-line-expand) + (define-key vhdl-mode-map "\C-c\C-l\C-n" #'vhdl-line-transpose-next) + (define-key vhdl-mode-map "\C-c\C-l\C-p" #'vhdl-line-transpose-previous) + (define-key vhdl-mode-map "\C-c\C-l\C-o" #'vhdl-line-open) + (define-key vhdl-mode-map "\C-c\C-l\C-g" #'goto-line) + (define-key vhdl-mode-map "\C-c\C-l\C-c" #'vhdl-comment-uncomment-line) + (define-key vhdl-mode-map "\C-c\C-x\C-s" #'vhdl-fix-statement-region) + (define-key vhdl-mode-map "\C-c\C-x\M-s" #'vhdl-fix-statement-buffer) + (define-key vhdl-mode-map "\C-c\C-x\C-p" #'vhdl-fix-clause) + (define-key vhdl-mode-map "\C-c\C-x\M-c" #'vhdl-fix-case-region) + (define-key vhdl-mode-map "\C-c\C-x\C-c" #'vhdl-fix-case-buffer) + (define-key vhdl-mode-map "\C-c\C-x\M-w" #'vhdl-fixup-whitespace-region) + (define-key vhdl-mode-map "\C-c\C-x\C-w" #'vhdl-fixup-whitespace-buffer) + (define-key vhdl-mode-map "\C-c\M-b" #'vhdl-beautify-region) + (define-key vhdl-mode-map "\C-c\C-b" #'vhdl-beautify-buffer) + (define-key vhdl-mode-map "\C-c\C-u\C-s" #'vhdl-update-sensitivity-list-process) + (define-key vhdl-mode-map "\C-c\C-u\M-s" #'vhdl-update-sensitivity-list-buffer) + (define-key vhdl-mode-map "\C-c\C-i\C-f" #'vhdl-fontify-buffer) + (define-key vhdl-mode-map "\C-c\C-i\C-s" #'vhdl-statistics-buffer) + (define-key vhdl-mode-map "\C-c\M-m" #'vhdl-show-messages) + (define-key vhdl-mode-map "\C-c\C-h" #'vhdl-doc-mode) + (define-key vhdl-mode-map "\C-c\C-v" #'vhdl-version) + (define-key vhdl-mode-map "\M-\t" #'insert-tab) ;; insert commands bindings - (define-key vhdl-mode-map "\C-c\C-i\C-t" 'vhdl-template-insert-construct) - (define-key vhdl-mode-map "\C-c\C-i\C-p" 'vhdl-template-insert-package) - (define-key vhdl-mode-map "\C-c\C-i\C-d" 'vhdl-template-insert-directive) - (define-key vhdl-mode-map "\C-c\C-i\C-m" 'vhdl-model-insert) + (define-key vhdl-mode-map "\C-c\C-i\C-t" #'vhdl-template-insert-construct) + (define-key vhdl-mode-map "\C-c\C-i\C-p" #'vhdl-template-insert-package) + (define-key vhdl-mode-map "\C-c\C-i\C-d" #'vhdl-template-insert-directive) + (define-key vhdl-mode-map "\C-c\C-i\C-m" #'vhdl-model-insert) ;; electric key bindings - (define-key vhdl-mode-map " " 'vhdl-electric-space) + (define-key vhdl-mode-map " " #'vhdl-electric-space) (when vhdl-intelligent-tab - (define-key vhdl-mode-map "\t" 'vhdl-electric-tab)) - (define-key vhdl-mode-map "\r" 'vhdl-electric-return) - (define-key vhdl-mode-map "-" 'vhdl-electric-dash) - (define-key vhdl-mode-map "[" 'vhdl-electric-open-bracket) - (define-key vhdl-mode-map "]" 'vhdl-electric-close-bracket) - (define-key vhdl-mode-map "'" 'vhdl-electric-quote) - (define-key vhdl-mode-map ";" 'vhdl-electric-semicolon) - (define-key vhdl-mode-map "," 'vhdl-electric-comma) - (define-key vhdl-mode-map "." 'vhdl-electric-period) + (define-key vhdl-mode-map "\t" #'vhdl-electric-tab)) + (define-key vhdl-mode-map "\r" #'vhdl-electric-return) + (define-key vhdl-mode-map "-" #'vhdl-electric-dash) + (define-key vhdl-mode-map "[" #'vhdl-electric-open-bracket) + (define-key vhdl-mode-map "]" #'vhdl-electric-close-bracket) + (define-key vhdl-mode-map "'" #'vhdl-electric-quote) + (define-key vhdl-mode-map ";" #'vhdl-electric-semicolon) + (define-key vhdl-mode-map "," #'vhdl-electric-comma) + (define-key vhdl-mode-map "." #'vhdl-electric-period) (when (vhdl-standard-p 'ams) - (define-key vhdl-mode-map "=" 'vhdl-electric-equal))) + (define-key vhdl-mode-map "=" #'vhdl-electric-equal))) ;; initialize mode map for VHDL Mode (vhdl-mode-map-init) @@ -2934,7 +2941,7 @@ STRING are replaced by `-' and substrings are converted to lower case." (let ((map (make-sparse-keymap))) (set-keymap-parent map minibuffer-local-map) (when vhdl-word-completion-in-minibuffer - (define-key map "\t" 'vhdl-minibuffer-tab)) + (define-key map "\t" #'vhdl-minibuffer-tab)) map) "Keymap for minibuffer used in VHDL Mode.") @@ -3167,7 +3174,8 @@ STRING are replaced by `-' and substrings are converted to lower case." (unless (equal keyword "") (push (list keyword "" (vhdl-function-name - "vhdl-model" (nth 0 elem) "hook") 0 'system) + "vhdl-model" (nth 0 elem) "hook") + 0 'system) abbrev-list))) abbrev-list))))) @@ -3574,7 +3582,7 @@ STRING are replaced by `-' and substrings are converted to lower case." ("Indent" ["Line" indent-according-to-mode :keys "C-c C-i C-l"] ["Group" vhdl-indent-group :keys "C-c C-i C-g"] - ["Region" vhdl-indent-region (mark)] + ["Region" indent-region (mark)] ["Buffer" vhdl-indent-buffer :keys "C-c C-i C-b"]) ("Align" ["Group" vhdl-align-group t] @@ -4884,7 +4892,7 @@ Key bindings: (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) - (set (make-local-variable 'indent-line-function) 'vhdl-indent-line) + (set (make-local-variable 'indent-line-function) #'vhdl-indent-line) (set (make-local-variable 'comment-start) "--") (set (make-local-variable 'comment-end) "") (set (make-local-variable 'comment-column) vhdl-inline-comment-column) @@ -4897,13 +4905,13 @@ Key bindings: ;; setup the comment indent variable in an Emacs version portable way ;; ignore any byte compiler warnings you might get here (when (boundp 'comment-indent-function) - (set (make-local-variable 'comment-indent-function) 'vhdl-comment-indent)) + (set (make-local-variable 'comment-indent-function) #'vhdl-comment-indent)) ;; initialize font locking (set (make-local-variable 'font-lock-defaults) (list '(nil vhdl-font-lock-keywords) nil - (not vhdl-highlight-case-sensitive) '((?\_ . "w")) 'beginning-of-line)) + (not vhdl-highlight-case-sensitive) '((?\_ . "w")) #'beginning-of-line)) (if (eval-when-compile (fboundp 'syntax-propertize-rules)) (set (make-local-variable 'syntax-propertize-function) (syntax-propertize-rules @@ -4912,7 +4920,7 @@ Key bindings: ("\\('\\).\\('\\)" (1 "\"'") (2 "\"'")))) (set (make-local-variable 'font-lock-syntactic-keywords) vhdl-font-lock-syntactic-keywords)) - (unless vhdl-emacs-21 + (when (featurep 'xemacs) (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) @@ -4958,10 +4966,10 @@ Key bindings: (defun vhdl-write-file-hooks-init () "Add/remove hooks when buffer is saved." (if vhdl-modify-date-on-saving - (add-hook 'write-file-functions 'vhdl-template-modify-noerror nil t) - (remove-hook 'write-file-functions 'vhdl-template-modify-noerror t)) + (add-hook 'write-file-functions #'vhdl-template-modify-noerror nil t) + (remove-hook 'write-file-functions #'vhdl-template-modify-noerror t)) (if (featurep 'xemacs) (make-local-hook 'after-save-hook)) - (add-hook 'after-save-hook 'vhdl-add-modified-file nil t)) + (add-hook 'after-save-hook #'vhdl-add-modified-file nil t)) (defun vhdl-process-command-line-option (option) "Process command line options for VHDL Mode." @@ -5744,7 +5752,7 @@ negative, skip forward otherwise." ;; XEmacs hack: work around buggy `forward-comment' in XEmacs 21.4+ (unless (and (featurep 'xemacs) (string< "21.2" emacs-version)) - (defalias 'vhdl-forward-comment 'forward-comment)) + (defalias 'vhdl-forward-comment #'forward-comment)) (defun vhdl-back-to-indentation () "Move point to the first non-whitespace character on this line." @@ -5808,7 +5816,7 @@ negative, skip forward otherwise." state))) (and (string-match "Win-Emacs" emacs-version) - (fset 'vhdl-in-literal 'vhdl-win-il)) + (fset 'vhdl-in-literal #'vhdl-win-il)) ;; Skipping of "syntactic whitespace". Syntactic whitespace is ;; defined as lexical whitespace or comments. Search no farther back @@ -5846,9 +5854,9 @@ negative, skip forward otherwise." (t (setq stop t)))))) (and (string-match "Win-Emacs" emacs-version) - (fset 'vhdl-forward-syntactic-ws 'vhdl-win-fsws)) + (fset 'vhdl-forward-syntactic-ws #'vhdl-win-fsws)) -(defun vhdl-beginning-of-macro (&optional lim) +(defun vhdl-beginning-of-macro (&optional _lim) "Go to the beginning of a cpp macro definition (nicked from `cc-engine')." (let ((here (point))) (beginning-of-line) @@ -5861,7 +5869,7 @@ negative, skip forward otherwise." (goto-char here) nil))) -(defun vhdl-beginning-of-directive (&optional lim) +(defun vhdl-beginning-of-directive (&optional _lim) "Go to the beginning of a directive (nicked from `cc-engine')." (let ((here (point))) (beginning-of-line) @@ -5905,7 +5913,7 @@ negative, skip forward otherwise." (t (setq stop t)))))) (and (string-match "Win-Emacs" emacs-version) - (fset 'vhdl-backward-syntactic-ws 'vhdl-win-bsws)) + (fset 'vhdl-backward-syntactic-ws #'vhdl-win-bsws)) ;; Functions to help finding the correct indentation column: @@ -6053,7 +6061,7 @@ keyword." t) )) -(defun vhdl-corresponding-mid (&optional lim) +(defun vhdl-corresponding-mid (&optional _lim) (cond ((looking-at "is\\|block\\|generate\\|process\\|procedural") "begin") @@ -6269,7 +6277,7 @@ of an identifier that just happens to contain an \"end\" keyword." "A regular expression for searching backward that matches all known \"statement\" keywords.") -(defun vhdl-statement-p (&optional lim) +(defun vhdl-statement-p (&optional _lim) "Return t if we are looking at a real \"statement\" keyword. Assumes that the caller will make sure that we are looking at vhdl-statement-fwd-re, and are not inside a literal, and that we are not @@ -6461,7 +6469,7 @@ searches." ;; internal-p controls where the statement keyword can ;; be found. (internal-p (aref begin-vec 3)) - (last-backward (point)) last-forward + (last-backward (point)) ;; last-forward foundp literal keyword) ;; Look for the statement keyword. (while (and (not foundp) @@ -6496,7 +6504,7 @@ searches." (setq begin-re (concat "\\b\\(" begin-re "\\)\\b[^_]")) (save-excursion - (setq last-forward (point)) + ;; (setq last-forward (point)) ;; Look for the supplementary keyword ;; (bounded by the backward search start ;; point). @@ -6548,7 +6556,7 @@ With argument, do this that many times." (setq target (point))) (goto-char target))) -(defun vhdl-end-of-defun (&optional count) +(defun vhdl-end-of-defun (&optional _count) "Move forward to the end of a VHDL defun." (interactive) (let ((case-fold-search t)) @@ -7320,7 +7328,7 @@ after the containing paren which starts the arglist." (current-column)))) (- ce-curcol cs-curcol -1)))) -(defun vhdl-lineup-comment (langelem) +(defun vhdl-lineup-comment (_langelem) "Support old behavior for comment indentation. We look at vhdl-comment-only-line-offset to decide how to indent comment only-lines." @@ -7382,27 +7390,13 @@ only-lines." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Progress reporting -(defvar vhdl-progress-info nil - "Array variable for progress information: 0 begin, 1 end, 2 time.") - -(defun vhdl-update-progress-info (string pos) - "Update progress information." - (when (and vhdl-progress-info (not noninteractive) - (time-less-p vhdl-progress-interval - (time-since (aref vhdl-progress-info 2)))) - (let ((delta (- (aref vhdl-progress-info 1) - (aref vhdl-progress-info 0)))) - (message "%s... (%2d%%)" string - (if (= 0 delta) - 100 - (floor (* 100.0 (- pos (aref vhdl-progress-info 0))) - delta)))) - (aset vhdl-progress-info 2 (time-convert nil 'integer)))) +(defvar vhdl--progress-reporter nil + "Holds the progress reporter data during long running operations.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Indentation commands -(defun vhdl-electric-tab (&optional prefix-arg) +(defun vhdl-electric-tab (&optional arg) "If preceding character is part of a word or a paren then hippie-expand, else if right of non whitespace on line then insert tab, else if last command was a tab or return then dedent one step or if a comment @@ -7413,7 +7407,7 @@ else indent `correctly'." (cond ;; indent region if region is active ((and (not (featurep 'xemacs)) (use-region-p)) - (vhdl-indent-region (region-beginning) (region-end) nil)) + (indent-region (region-beginning) (region-end) nil)) ;; expand word ((= (char-syntax (preceding-char)) ?w) (let ((case-fold-search (not vhdl-word-completion-case-sensitive)) @@ -7422,12 +7416,12 @@ else indent `correctly'." (or (and (boundp 'hippie-expand-only-buffers) hippie-expand-only-buffers) '(vhdl-mode)))) - (vhdl-expand-abbrev prefix-arg))) + (vhdl-expand-abbrev arg))) ;; expand parenthesis ((or (= (preceding-char) ?\() (= (preceding-char) ?\))) (let ((case-fold-search (not vhdl-word-completion-case-sensitive)) (case-replace nil)) - (vhdl-expand-paren prefix-arg))) + (vhdl-expand-paren arg))) ;; insert tab ((> (current-column) (current-indentation)) (insert-tab)) @@ -7486,7 +7480,7 @@ indentation change." (setq syntax (vhdl-get-syntactic-context))))) (when is-comment (push (cons 'comment nil) syntax)) - (apply '+ (mapcar 'vhdl-get-offset syntax))) + (apply #'+ (mapcar #'vhdl-get-offset syntax))) ;; indent like previous nonblank line (save-excursion (beginning-of-line) (re-search-backward "^[^\n]" nil t) @@ -7508,25 +7502,17 @@ indentation change." (when (> (- (point-max) pos) (point)) (goto-char (- (point-max) pos)))) (run-hooks 'vhdl-special-indent-hook) - (vhdl-update-progress-info "Indenting" (vhdl-current-line)) + (when vhdl--progress-reporter + (progress-reporter-update vhdl--progress-reporter (point))) shift-amt)) -(defun vhdl-indent-region (beg end &optional column) - "Indent region as VHDL code. -Adds progress reporting to `indent-region'." - (interactive "r\nP") - (when vhdl-progress-interval - (setq vhdl-progress-info (vector (count-lines (point-min) beg) - (count-lines (point-min) end) 0))) - (indent-region beg end column) - (when vhdl-progress-interval (message "Indenting...done")) - (setq vhdl-progress-info nil)) +(define-obsolete-function-alias 'vhdl-indent-region #'indent-region "28.1") (defun vhdl-indent-buffer () "Indent whole buffer as VHDL code. Calls `indent-region' for whole buffer and adds progress reporting." (interactive) - (vhdl-indent-region (point-min) (point-max))) + (indent-region (point-min) (point-max))) (defun vhdl-indent-group () "Indent group of lines between empty lines." @@ -7539,7 +7525,7 @@ Calls `indent-region' for whole buffer and adds progress reporting." (if (re-search-forward vhdl-align-group-separate nil t) (point-marker) (point-max-marker))))) - (vhdl-indent-region beg end))) + (indent-region beg end))) (defun vhdl-indent-sexp (&optional endpos) "Indent each line of the list starting just after point. @@ -7698,7 +7684,7 @@ parentheses." ;; run FUNCTION (funcall function beg end spacing))) -(defun vhdl-align-region-1 (begin end &optional spacing alignment-list indent) +(defun vhdl-align-region-1 (begin end &optional spacing alignment-list _indent) "Attempt to align a range of lines based on the content of the lines. The definition of `alignment-list' determines the matching order and the manner in which the lines are aligned. If ALIGNMENT-LIST @@ -7708,12 +7694,15 @@ indentation is done before aligning." (setq alignment-list (or alignment-list vhdl-align-alist)) (setq spacing (or spacing 1)) (save-excursion - (let (bol indent) + (let (bol) ;; indent (goto-char end) (setq end (point-marker)) (goto-char begin) (setq bol (setq begin (progn (beginning-of-line) (point)))) - (when indent + ;; FIXME: The `indent' arg is not used, and I think it's because + ;; the let binding commented out above `indent' was hiding it, so + ;; the test below should maybe still test `indent'? + (when nil ;; indent (indent-region bol end nil)))) (let ((copy (copy-alist alignment-list))) (vhdl-prepare-search-2 @@ -7798,18 +7787,21 @@ the token in MATCH." "Align region, treat groups of lines separately." (interactive "r\nP") (save-excursion - (let (orig pos) - (goto-char beg) - (beginning-of-line) - (setq orig (point-marker)) - (setq beg (point)) - (goto-char end) - (setq end (point-marker)) - (untabify beg end) - (unless no-message - (when vhdl-progress-interval - (setq vhdl-progress-info (vector (count-lines (point-min) beg) - (count-lines (point-min) end) 0)))) + (goto-char beg) + (beginning-of-line) + (setq beg (point)) + (goto-char end) + (setq end (point-marker)) + (untabify beg end) + (let ((orig (copy-marker beg)) + pos + (vhdl--progress-reporter + (if no-message + ;; Preserve a potential progress reporter from + ;; when called from `vhdl-align-region' call. + vhdl--progress-reporter + (when vhdl-progress-interval + (make-progress-reporter "Aligning..." beg (copy-marker end)))))) (when (nth 0 vhdl-beautify-options) (vhdl-fixup-whitespace-region beg end t)) (goto-char beg) @@ -7824,19 +7816,21 @@ the token in MATCH." (setq pos (point-marker)) (vhdl-align-region-1 beg pos spacing) (unless no-comments (vhdl-align-inline-comment-region-1 beg pos)) - (vhdl-update-progress-info "Aligning" (vhdl-current-line)) + (when vhdl--progress-reporter + (progress-reporter-update vhdl--progress-reporter (point))) (setq beg (1+ pos)) (goto-char beg)) ;; align last group (when (< beg end) (vhdl-align-region-1 beg end spacing) (unless no-comments (vhdl-align-inline-comment-region-1 beg end)) - (vhdl-update-progress-info "Aligning" (vhdl-current-line)))) + (when vhdl--progress-reporter + (progress-reporter-update vhdl--progress-reporter (point))))) (when vhdl-indent-tabs-mode (tabify orig end)) (unless no-message - (when vhdl-progress-interval (message "Aligning...done")) - (setq vhdl-progress-info nil))))) + (when vhdl--progress-reporter + (progress-reporter-done vhdl--progress-reporter)))))) (defun vhdl-align-region (beg end &optional spacing) "Align region, treat blocks with same indent and argument lists separately." @@ -7847,10 +7841,10 @@ the token in MATCH." ;; align blocks with same indent and argument lists (save-excursion (let ((cur-beg beg) - indent cur-end) - (when vhdl-progress-interval - (setq vhdl-progress-info (vector (count-lines (point-min) beg) - (count-lines (point-min) end) 0))) + indent cur-end + (vhdl--progress-reporter + (when vhdl-progress-interval + (make-progress-reporter "Aligning..." beg (copy-marker end))))) (goto-char end) (setq end (point-marker)) (goto-char cur-beg) @@ -7873,15 +7867,16 @@ the token in MATCH." (= (current-indentation) indent)) (<= (save-excursion (nth 0 (parse-partial-sexp - (point) (vhdl-point 'eol)))) 0)) + (point) (vhdl-point 'eol)))) + 0)) (unless (looking-at "^\\s-*$") (setq cur-end (vhdl-point 'bonl))) (beginning-of-line 2))) ;; align region (vhdl-align-region-groups cur-beg cur-end spacing t t)) (vhdl-align-inline-comment-region beg end spacing noninteractive) - (when vhdl-progress-interval (message "Aligning...done")) - (setq vhdl-progress-info nil))))) + (when vhdl--progress-reporter + (progress-reporter-done vhdl--progress-reporter)))))) (defun vhdl-align-group (&optional spacing) "Align group of lines between empty lines." @@ -8030,7 +8025,7 @@ empty lines are aligned individually, if `vhdl-align-groups' is non-nil." (tabify orig end)) (unless no-message (message "Aligning inline comments...done"))))) -(defun vhdl-align-inline-comment-group (&optional spacing) +(defun vhdl-align-inline-comment-group (&optional _spacing) "Align inline comments within a group of lines between empty lines." (interactive) (save-excursion @@ -8125,7 +8120,8 @@ end of line, do nothing in comments." "Convert all words matching WORD-REGEXP in region to lower or upper case, depending on parameter UPPER-CASE." (let ((case-replace nil) - (last-update 0)) + (pr (when (and count vhdl-progress-interval (not noninteractive)) + (make-progress-reporter "Fixing case..." beg (copy-marker end))))) (vhdl-prepare-search-2 (save-excursion (goto-char end) @@ -8136,19 +8132,13 @@ depending on parameter UPPER-CASE." (if upper-case (upcase-word -1) (downcase-word -1))) - (when (and count vhdl-progress-interval (not noninteractive) - (time-less-p vhdl-progress-interval - (time-since last-update))) - (message "Fixing case... (%2d%s)" - (+ (* count 20) (/ (* 20 (- (point) beg)) (- end beg))) - "%") - (setq last-update (time-convert nil 'integer)))) - (goto-char end))))) - -(defun vhdl-fix-case-region (beg end &optional arg) + (when pr (progress-reporter-update pr (point)))) + (when pr (progress-reporter-done pr)))))) + +(defun vhdl-fix-case-region (beg end &optional _arg) "Convert all VHDL words in region to lower or upper case, depending on options vhdl-upper-case-{keywords,types,attributes,enum-values}." - (interactive "r\nP") + (interactive "r") (vhdl-fix-case-region-1 beg end vhdl-upper-case-keywords vhdl-keywords-regexp 0) (vhdl-fix-case-region-1 @@ -8194,11 +8184,11 @@ options vhdl-upper-case-{keywords,types,attributes,enum-values}." ;; - force each statement to be on a separate line except when on same line ;; with 'end' keyword -(defun vhdl-fix-statement-region (beg end &optional arg) +(defun vhdl-fix-statement-region (beg end &optional _arg) "Force statements in region on separate line except when on same line with `end' keyword (necessary for correct indentation). Currently supported keywords: `begin', `if'." - (interactive "r\nP") + (interactive "r") (vhdl-prepare-search-2 (let (point) (save-excursion @@ -8250,9 +8240,9 @@ with `end' keyword (necessary for correct indentation)." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Trailing spaces -(defun vhdl-remove-trailing-spaces-region (beg end &optional arg) +(defun vhdl-remove-trailing-spaces-region (beg end &optional _arg) "Remove trailing spaces in region." - (interactive "r\nP") + (interactive "r") (save-excursion (goto-char end) (setq end (point-marker)) @@ -8282,7 +8272,7 @@ case fixing to a region. Calls functions `vhdl-indent-buffer', (replace-match "" nil t))) (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)) + (when (nth 2 vhdl-beautify-options) (indent-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)) @@ -8515,7 +8505,7 @@ buffer." (delete-region sens-beg sens-end) (when read-list (insert " ()") (backward-char))) - (setq read-list (sort read-list 'string<)) + (setq read-list (sort read-list #'string<)) (when read-list (setq margin (current-column)) (insert (car read-list)) @@ -8547,7 +8537,7 @@ buffer." (concat (vhdl-replace-string vhdl-entity-file-name entity-name t) "." (file-name-extension (buffer-file-name))))) (vhdl-visit-file - file-name t + file-name t (vhdl-prepare-search-2 (goto-char (point-min)) (if (not (re-search-forward (concat "^entity\\s-+" entity-name "\\>") nil t)) @@ -8555,7 +8545,8 @@ buffer." (when (setq beg (vhdl-re-search-forward "\\<port[ \t\n\r\f]*(" (save-excursion - (re-search-forward "^end\\>" nil t)) t)) + (re-search-forward "^end\\>" nil t)) + t)) (setq end (save-excursion (backward-char) (forward-sexp) (point))) (vhdl-forward-syntactic-ws) @@ -8687,9 +8678,9 @@ buffer." Used for undoing after template abortion.") ;; correct different behavior of function `unread-command-events' in XEmacs -(defun vhdl-character-to-event (arg)) +(defun vhdl-character-to-event (_arg) nil) (defalias 'vhdl-character-to-event - (if (fboundp 'character-to-event) 'character-to-event 'identity)) + (if (fboundp 'character-to-event) #'character-to-event #'identity)) (defun vhdl-work-library () "Return the working library name of the current project or \"work\" if no @@ -9146,7 +9137,8 @@ a configuration declaration if not within a design unit." (re-search-backward "^\\(configuration\\|end\\)\\>" nil t)) (equal "CONFIGURATION" (upcase (match-string 1)))) (if (eq (vhdl-decision-query - "configuration" "(b)lock or (c)omponent configuration?" t) ?c) + "configuration" "(b)lock or (c)omponent configuration?" t) + ?c) (vhdl-template-component-conf) (vhdl-template-block-configuration))) (t (vhdl-template-configuration-decl))))) ; otherwise @@ -9255,7 +9247,7 @@ a configuration declaration if not within a design unit." (interactive) (let ((margin (current-indentation)) (start (point)) - entity-exists string name position) + name position) ;; entity-exists string (vhdl-insert-keyword "CONTEXT ") (when (setq name (vhdl-template-field "name" nil t start (point))) (vhdl-insert-keyword " IS\n") @@ -9411,7 +9403,8 @@ otherwise." (re-search-backward "^\\(configuration\\|end\\)\\>" nil t)) (equal "CONFIGURATION" (upcase (match-string 1)))) (if (eq (vhdl-decision-query - "for" "(b)lock or (c)omponent configuration?" t) ?c) + "for" "(b)lock or (c)omponent configuration?" t) + ?c) (vhdl-template-component-conf) (vhdl-template-block-configuration))) ((and (save-excursion @@ -9526,11 +9519,12 @@ otherwise." (defun vhdl-template-group () "Insert group or group template declaration." (interactive) - (let ((start (point))) - (if (eq (vhdl-decision-query - "group" "(d)eclaration or (t)emplate declaration?" t) ?t) - (vhdl-template-group-template) - (vhdl-template-group-decl)))) + ;; (let ((start (point))) + (if (eq (vhdl-decision-query + "group" "(d)eclaration or (t)emplate declaration?" t) + ?t) + (vhdl-template-group-template) + (vhdl-template-group-decl))) ;; ) (defun vhdl-template-group-decl () "Insert group declaration." @@ -10471,7 +10465,8 @@ specification, if not already there." (and (not (bobp)) (re-search-backward (concat "^\\s-*\\(\\(library\\)\\s-+\\(\\w+\\s-*,\\s-*\\)*" - library "\\|end\\)\\>") nil t) + library "\\|end\\)\\>") + nil t) (match-string 2)))) (equal (downcase library) "work")) (vhdl-insert-keyword "LIBRARY ") @@ -10831,9 +10826,9 @@ If starting after end-comment-column, start a new line." (vhdl-line-kill-entire))))) (goto-char final-pos)))) -(defun vhdl-comment-uncomment-region (beg end &optional arg) +(defun vhdl-comment-uncomment-region (beg end &optional _arg) "Comment out region if not commented out, uncomment otherwise." - (interactive "r\nP") + (interactive "r") (save-excursion (goto-char (1- end)) (end-of-line) @@ -10910,7 +10905,7 @@ Point is left between them." "Read from user a procedure or function argument list." (insert " (") (let ((margin (current-column)) - (start (point)) + ;; (start (point)) (end-pos (point)) not-empty interface semicolon-pos) (unless vhdl-argument-list-indent @@ -10919,7 +10914,8 @@ Point is left between them." (indent-to margin)) (setq interface (vhdl-template-field (concat "[CONSTANT | SIGNAL" - (unless is-function " | VARIABLE") "]") " " t)) + (unless is-function " | VARIABLE") "]") + " " t)) (while (vhdl-template-field "[names]" nil t) (setq not-empty t) (insert " : ") @@ -10936,7 +10932,8 @@ Point is left between them." (indent-to margin) (setq interface (vhdl-template-field (concat "[CONSTANT | SIGNAL" - (unless is-function " | VARIABLE") "]") " " t))) + (unless is-function " | VARIABLE") "]") + " " t))) (delete-region end-pos (point)) (when semicolon-pos (goto-char semicolon-pos)) (if not-empty @@ -11156,7 +11153,7 @@ with double-quotes is to be inserted. DEFAULT specifies a default string." "Adjust case of following NUM words." (if vhdl-upper-case-keywords (upcase-word num) (downcase-word num))) -(defun vhdl-minibuffer-tab (&optional prefix-arg) +(defun vhdl-minibuffer-tab (&optional arg) "If preceding character is part of a word or a paren then hippie-expand, else insert tab (used for word completion in VHDL minibuffer)." (interactive "P") @@ -11169,12 +11166,12 @@ else insert tab (used for word completion in VHDL minibuffer)." (or (and (boundp 'hippie-expand-only-buffers) hippie-expand-only-buffers) '(vhdl-mode)))) - (vhdl-expand-abbrev prefix-arg))) + (vhdl-expand-abbrev arg))) ;; expand parenthesis ((or (= (preceding-char) ?\() (= (preceding-char) ?\))) (let ((case-fold-search (not vhdl-word-completion-case-sensitive)) (case-replace nil)) - (vhdl-expand-paren prefix-arg))) + (vhdl-expand-paren arg))) ;; insert tab (t (insert-tab)))) @@ -11561,7 +11558,8 @@ but not if inside a comment or quote." (unless (equal model-keyword "") (eval `(defun ,(vhdl-function-name - "vhdl-model" model-name "hook") () + "vhdl-model" model-name "hook") + () (vhdl-hooked-abbrev ',(vhdl-function-name "vhdl-model" model-name))))) (setq model-alist (cdr model-alist))))) @@ -11857,7 +11855,7 @@ reflected in a subsequent paste operation." (defun vhdl-port-paste-context-clause (&optional exclude-pack-name) "Paste a context clause." - (let ((margin (current-indentation)) + (let (;; (margin (current-indentation)) (clause-list (nth 3 vhdl-port-list)) clause) (while clause-list @@ -11867,7 +11865,8 @@ reflected in a subsequent paste operation." (save-excursion (re-search-backward (concat "^\\s-*use\\s-+" (car clause) - "." (cdr clause) "\\>") nil t))) + "." (cdr clause) "\\>") + nil t))) (vhdl-template-standard-package (car clause) (cdr clause)) (insert "\n")) (setq clause-list (cdr clause-list))))) @@ -12259,7 +12258,8 @@ reflected in a subsequent paste operation." (cond ((and vhdl-include-direction-comments (nth 2 port)) (format "%-6s" (concat "[" (nth 2 port) "] "))) (vhdl-include-direction-comments " ")) - (when vhdl-include-port-comments (nth 4 port))) t)) + (when vhdl-include-port-comments (nth 4 port))) + t)) (setq port-list (cdr port-list)) (when port-list (insert "\n") (indent-to margin))) ;; align signal list @@ -12313,7 +12313,7 @@ reflected in a subsequent paste operation." (let ((case-fold-search t) (ent-name (vhdl-replace-string vhdl-testbench-entity-name (nth 0 vhdl-port-list))) - (source-buffer (current-buffer)) + ;; (source-buffer (current-buffer)) arch-name config-name ent-file-name arch-file-name ent-buffer arch-buffer position) ;; open entity file @@ -12410,7 +12410,7 @@ reflected in a subsequent paste operation." (insert "\n") (setq position (point)) (vhdl-insert-string-or-file vhdl-testbench-declarations) - (vhdl-indent-region position (point))) + (indent-region position (point))) (setq position (point)) (insert "\n\n") (vhdl-comment-display-line) (insert "\n") @@ -12441,7 +12441,7 @@ reflected in a subsequent paste operation." (insert "\n") (setq position (point)) (vhdl-insert-string-or-file vhdl-testbench-statements) - (vhdl-indent-region position (point))) + (indent-region position (point))) (insert "\n") (indent-to vhdl-basic-offset) (unless (eq vhdl-testbench-create-files 'none) @@ -12814,7 +12814,7 @@ expressions (e.g. for index ranges of types and signals)." ;; override `he-list-beg' from `hippie-exp' (unless (and (boundp 'viper-mode) viper-mode) - (defalias 'he-list-beg 'vhdl-he-list-beg)) + (defalias 'he-list-beg #'vhdl-he-list-beg)) ;; function for expanding abbrevs and dabbrevs (defalias 'vhdl-expand-abbrev (make-hippie-expand-function @@ -12861,14 +12861,14 @@ expressions (e.g. for index ranges of types and signals)." (beginning-of-line) (yank)) -(defun vhdl-line-expand (&optional prefix-arg) +(defun vhdl-line-expand (&optional arg) "Hippie-expand current line." (interactive "P") (require 'hippie-exp) (let ((case-fold-search t) (case-replace nil) (hippie-expand-try-functions-list '(try-expand-line try-expand-line-all-buffers))) - (hippie-expand prefix-arg))) + (hippie-expand arg))) (defun vhdl-line-transpose-next (&optional arg) "Interchange this line with next line." @@ -12990,7 +12990,7 @@ File statistics: \"%s\"\n\ # total lines : %5d\n" (buffer-file-name) no-stats no-code-lines no-empty-lines no-comm-lines no-comments no-lines) - (unless vhdl-emacs-21 (vhdl-show-messages)))) + (when (featurep 'xemacs) (vhdl-show-messages)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Help functions @@ -13039,7 +13039,7 @@ File statistics: \"%s\"\n\ (customize-set-variable 'vhdl-project vhdl-project) (customize-save-customized)) -(defun vhdl-toggle-project (name token indent) +(defun vhdl-toggle-project (name _token _indent) "Set current project to NAME or unset if NAME is current project." (vhdl-set-project (if (equal name vhdl-project) "" name))) @@ -13243,6 +13243,7 @@ File statistics: \"%s\"\n\ "Toggle hideshow minor mode and update menu bar." (interactive "P") (require 'hideshow) + (declare-function hs-hide-all "hideshow" ()) ;; check for hideshow version 5.x (if (not (boundp 'hs-block-start-mdata-select)) (vhdl-warning-when-idle "Install included `hideshow.el' patch first (see INSTALL file)") @@ -13254,8 +13255,8 @@ File statistics: \"%s\"\n\ hs-special-modes-alist))) (if (featurep 'xemacs) (make-local-hook 'hs-minor-mode-hook)) (if vhdl-hide-all-init - (add-hook 'hs-minor-mode-hook 'hs-hide-all nil t) - (remove-hook 'hs-minor-mode-hook 'hs-hide-all t)) + (add-hook 'hs-minor-mode-hook #'hs-hide-all nil t) + (remove-hook 'hs-minor-mode-hook #'hs-hide-all t)) (hs-minor-mode arg) (force-mode-line-update))) ; hack to update menu bar @@ -13522,6 +13523,8 @@ This does background highlighting of translate-off regions.") (while syntax-alist (setq name (vhdl-function-name "vhdl-font-lock" (nth 0 (car syntax-alist)) "face")) + ;; FIXME: This `defvar' shouldn't be needed: just quote the face + ;; name when you use it. (eval `(defvar ,name ',name ,(concat "Face name to use for " (nth 0 (car syntax-alist)) "."))) @@ -13734,7 +13737,7 @@ This does background highlighting of translate-off regions.") (when (boundp 'ps-print-color-p) (vhdl-ps-print-settings)) (if (featurep 'xemacs) (make-local-hook 'ps-print-hook)) - (add-hook 'ps-print-hook 'vhdl-ps-print-settings nil t))) + (add-hook 'ps-print-hook #'vhdl-ps-print-settings nil t))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -13906,7 +13909,7 @@ hierarchy otherwise.") pack-list pack-body-list inst-list inst-ent-list) ;; scan file (vhdl-visit-file - file-name nil + file-name nil (vhdl-prepare-search-2 (save-excursion ;; scan for design units @@ -14081,7 +14084,8 @@ hierarchy otherwise.") "component[ \t\n\r\f]+\\(\\w+\\)\\|" "\\(\\(entity\\)\\|configuration\\)[ \t\n\r\f]+\\(\\(\\w+\\)\\.\\)?\\(\\w+\\)\\([ \t\n\r\f]*(\\(\\w+\\))\\)?\\|" "\\(\\(for\\|if\\)\\>[^;:]+\\<generate\\>\\|block\\>\\)\\)\\|" - "\\(^[ \t]*end[ \t\n\r\f]+\\(generate\\|block\\)\\>\\)") end-of-unit t) + "\\(^[ \t]*end[ \t\n\r\f]+\\(generate\\|block\\)\\>\\)") + end-of-unit t) (or (not limit-hier-inst-no) (<= (if (or (match-string 14) (match-string 16)) @@ -14443,12 +14447,15 @@ of PROJECT." ;; (inst-key inst-file-marker comp-ent-key comp-ent-file-marker ;; comp-arch-key comp-arch-file-marker comp-conf-key comp-conf-file-marker ;; comp-lib-name level) -(defun vhdl-get-hierarchy (ent-alist conf-alist ent-key arch-key conf-key - conf-inst-alist level indent - &optional include-top ent-hier) +(defun vhdl-get-hierarchy ( ent-alist-arg conf-alist-arg ent-key arch-key + conf-key-arg conf-inst-alist level indent + &optional include-top ent-hier) "Get instantiation hierarchy beginning in architecture ARCH-KEY of entity ENT-KEY." - (let* ((ent-entry (vhdl-aget ent-alist ent-key)) + (let* ((ent-alist ent-alist-arg) + (conf-alist conf-alist-arg) + (conf-key conf-key-arg) + (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)) @@ -14580,6 +14587,8 @@ entity ENT-KEY." (error (progn (vhdl-warning "ERROR: An error occurred while saving the hierarchy caches") (sit-for 2))))) +(defvar vhdl-cache-version) + (defun vhdl-save-cache (key) "Save current hierarchy cache to file." (let* ((orig-buffer (current-buffer)) @@ -14666,7 +14675,7 @@ entity ENT-KEY." (file-dir-name (expand-file-name file-name directory)) vhdl-cache-version) (unless (memq 'vhdl-save-caches kill-emacs-hook) - (add-hook 'kill-emacs-hook 'vhdl-save-caches)) + (add-hook 'kill-emacs-hook #'vhdl-save-caches)) (when (file-exists-p file-dir-name) (condition-case () (progn (load-file file-dir-name) @@ -14706,6 +14715,8 @@ if required." (declare-function speedbar-change-initial-expansion-list "speedbar" (new-default)) (declare-function speedbar-add-expansion-list "speedbar" (new-list)) +(declare-function speedbar-expand-line "speedbar" (&optional arg)) +(declare-function speedbar-edit-line "speedbar" ()) (defun vhdl-speedbar-initialize () "Initialize speedbar." @@ -14730,19 +14741,19 @@ if required." ;; keymap (unless vhdl-speedbar-mode-map (setq vhdl-speedbar-mode-map (speedbar-make-specialized-keymap)) - (define-key vhdl-speedbar-mode-map "e" 'speedbar-edit-line) - (define-key vhdl-speedbar-mode-map "\C-m" 'speedbar-edit-line) - (define-key vhdl-speedbar-mode-map "+" 'speedbar-expand-line) - (define-key vhdl-speedbar-mode-map "=" 'speedbar-expand-line) - (define-key vhdl-speedbar-mode-map "-" 'vhdl-speedbar-contract-level) - (define-key vhdl-speedbar-mode-map "_" 'vhdl-speedbar-contract-all) - (define-key vhdl-speedbar-mode-map "C" 'vhdl-speedbar-port-copy) - (define-key vhdl-speedbar-mode-map "P" 'vhdl-speedbar-place-component) - (define-key vhdl-speedbar-mode-map "F" 'vhdl-speedbar-configuration) - (define-key vhdl-speedbar-mode-map "A" 'vhdl-speedbar-select-mra) - (define-key vhdl-speedbar-mode-map "K" 'vhdl-speedbar-make-design) - (define-key vhdl-speedbar-mode-map "R" 'vhdl-speedbar-rescan-hierarchy) - (define-key vhdl-speedbar-mode-map "S" 'vhdl-save-caches) + (define-key vhdl-speedbar-mode-map "e" #'speedbar-edit-line) + (define-key vhdl-speedbar-mode-map "\C-m" #'speedbar-edit-line) + (define-key vhdl-speedbar-mode-map "+" #'speedbar-expand-line) + (define-key vhdl-speedbar-mode-map "=" #'speedbar-expand-line) + (define-key vhdl-speedbar-mode-map "-" #'vhdl-speedbar-contract-level) + (define-key vhdl-speedbar-mode-map "_" #'vhdl-speedbar-contract-all) + (define-key vhdl-speedbar-mode-map "C" #'vhdl-speedbar-port-copy) + (define-key vhdl-speedbar-mode-map "P" #'vhdl-speedbar-place-component) + (define-key vhdl-speedbar-mode-map "F" #'vhdl-speedbar-configuration) + (define-key vhdl-speedbar-mode-map "A" #'vhdl-speedbar-select-mra) + (define-key vhdl-speedbar-mode-map "K" #'vhdl-speedbar-make-design) + (define-key vhdl-speedbar-mode-map "R" #'vhdl-speedbar-rescan-hierarchy) + (define-key vhdl-speedbar-mode-map "S" #'vhdl-save-caches) (let ((key 0)) (while (<= key 9) (define-key vhdl-speedbar-mode-map (int-to-string key) @@ -14813,7 +14824,7 @@ if required." (setq speedbar-initial-expansion-list-name "vhdl directory")) (when (eq vhdl-speedbar-display-mode 'project) (setq speedbar-initial-expansion-list-name "vhdl project")) - (add-hook 'speedbar-timer-hook 'vhdl-update-hierarchy))) + (add-hook 'speedbar-timer-hook #'vhdl-update-hierarchy))) (defun vhdl-speedbar (&optional arg) "Open/close speedbar." @@ -14831,17 +14842,17 @@ if required." "Name of last selected project.") ;; macros must be defined in the file they are used (copied from `speedbar.el') -;;; (defmacro speedbar-with-writable (&rest forms) -;;; "Allow the buffer to be writable and evaluate FORMS." -;;; (list 'let '((inhibit-read-only t)) -;;; (cons 'progn forms))) -;;; (put 'speedbar-with-writable 'lisp-indent-function 0) +;; (defmacro speedbar-with-writable (&rest forms) +;; "Allow the buffer to be writable and evaluate FORMS." +;; (declare (indent 0) (debug t)) +;; (list 'let '((inhibit-read-only t)) +;; (cons 'progn forms))) (declare-function speedbar-extension-list-to-regex "speedbar" (extlist)) (declare-function speedbar-directory-buttons "speedbar" (directory _index)) (declare-function speedbar-file-lists "speedbar" (directory)) -(defun vhdl-speedbar-display-directory (directory depth &optional rescan) +(defun vhdl-speedbar-display-directory (directory depth &optional _rescan) "Display directory and hierarchy information in speedbar." (setq vhdl-speedbar-show-projects nil) (setq speedbar-ignored-directory-regexp @@ -14862,7 +14873,7 @@ if required." (when (= depth 0) (vhdl-speedbar-expand-dirs directory))) (error (vhdl-warning-when-idle "ERROR: Invalid hierarchy information, unable to display correctly"))))) -(defun vhdl-speedbar-display-projects (project depth &optional rescan) +(defun vhdl-speedbar-display-projects (_project _depth &optional _rescan) "Display projects and hierarchy information in speedbar." (setq vhdl-speedbar-show-projects t) (setq speedbar-ignored-directory-regexp ".") @@ -14878,6 +14889,8 @@ if required." (declare-function speedbar-make-tag-line "speedbar" (type char func data tag tfunc tdata tface depth)) +(defvar vhdl-speedbar-update-current-unit) + (defun vhdl-speedbar-insert-projects () "Insert all projects in speedbar." (vhdl-speedbar-make-title-line "Projects:") @@ -14888,9 +14901,9 @@ if required." ;; insert projects (while project-alist (speedbar-make-tag-line - 'angle ?+ 'vhdl-speedbar-expand-project + 'angle ?+ #'vhdl-speedbar-expand-project (caar project-alist) (caar project-alist) - 'vhdl-toggle-project (caar project-alist) 'speedbar-directory-face 0) + #'vhdl-toggle-project (caar project-alist) 'speedbar-directory-face 0) (setq project-alist (cdr project-alist))) (setq project-alist vhdl-project-alist) ;; expand projects @@ -14937,12 +14950,14 @@ otherwise use cached data." (vhdl-speedbar-expand-units 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) +(defun vhdl-speedbar-insert-hierarchy ( ent-alist-arg conf-alist-arg pack-alist + ent-inst-list depth) "Insert hierarchy of ENT-ALIST, CONF-ALIST, and PACK-ALIST." (if (not (or ent-alist conf-alist pack-alist)) (vhdl-speedbar-make-title-line "No VHDL design units!" depth) - (let (ent-entry conf-entry pack-entry) + (let ((ent-alist ent-alist-arg) + (conf-alist conf-alist-arg) + ent-entry conf-entry pack-entry) ;; insert entities (when ent-alist (vhdl-speedbar-make-title-line "Entities:" depth)) (while ent-alist @@ -15003,7 +15018,7 @@ otherwise use cached data." (declare-function speedbar-goto-this-file "speedbar" (file)) -(defun vhdl-speedbar-expand-dirs (directory) +(defun vhdl-speedbar-expand-dirs (_directory) "Expand subdirectories in DIRECTORY according to `speedbar-shown-directories'." ;; (nicked from `speedbar-default-directory-list') @@ -15042,7 +15057,8 @@ otherwise use cached data." (goto-char position) (when (re-search-forward (concat "^[0-9]+:\\s-*\\(\\[\\|{.}\\s-+" - (car arch-alist) "\\>\\)") nil t) + (car arch-alist) "\\>\\)") + nil t) (beginning-of-line) (when (looking-at "^[0-9]+:\\s-*{") (goto-char (match-end 0)) @@ -15411,6 +15427,7 @@ otherwise use cached data." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Display help functions +;; FIXME: This `defvar' should be moved before its first use. (defvar vhdl-speedbar-update-current-unit t "Non-nil means to run `vhdl-speedbar-update-current-unit'.") @@ -15846,7 +15863,7 @@ NO-POSITION non-nil means do not re-position cursor." (abbreviate-file-name (file-name-as-directory (speedbar-line-directory indent))))) -(defun vhdl-speedbar-line-project (&optional indent) +(defun vhdl-speedbar-line-project (&optional _indent) "Get currently displayed project name." (and vhdl-speedbar-show-projects (save-excursion @@ -15916,7 +15933,7 @@ NO-POSITION non-nil means do not re-position cursor." ;; speedbar loads dframe at runtime. (declare-function dframe-maybee-jump-to-attached-frame "dframe" ()) -(defun vhdl-speedbar-find-file (text token indent) +(defun vhdl-speedbar-find-file (_text token _indent) "When user clicks on TEXT, load file with name and position in TOKEN. Jump to the design unit if `vhdl-speedbar-jump-to-unit' is t or if the file is already shown in a buffer." @@ -15944,12 +15961,12 @@ is already shown in a buffer." (let ((token (get-text-property (match-beginning 3) 'speedbar-token))) (vhdl-visit-file (car token) t - (progn (goto-char (point-min)) - (forward-line (1- (cdr token))) - (end-of-line) - (if is-entity - (vhdl-port-copy) - (vhdl-subprog-copy))))) + (goto-char (point-min)) + (forward-line (1- (cdr token))) + (end-of-line) + (if is-entity + (vhdl-port-copy) + (vhdl-subprog-copy)))) (error (error "ERROR: %s not scanned successfully\n (%s)" (if is-entity "Port" "Interface") (cadr info)))) (error "ERROR: No entity/component or subprogram on current line"))))) @@ -16139,7 +16156,7 @@ expansion function)." ;; initialize speedbar (if (not (boundp 'speedbar-frame)) - (with-no-warnings (add-hook 'speedbar-load-hook 'vhdl-speedbar-initialize)) + (with-no-warnings (add-hook 'speedbar-load-hook #'vhdl-speedbar-initialize)) (vhdl-speedbar-initialize) (when speedbar-frame (vhdl-speedbar-refresh))) @@ -16167,7 +16184,7 @@ expansion function)." (read-from-minibuffer "architecture name: " nil vhdl-minibuffer-local-map) (vhdl-replace-string vhdl-compose-architecture-name ent-name))) - ent-file-name arch-file-name ent-buffer arch-buffer project end-pos) + ent-file-name arch-file-name ent-buffer arch-buffer end-pos) ;; project (message "Creating component \"%s(%s)\"..." ent-name arch-name) ;; open entity file (unless (eq vhdl-compose-create-files 'none) @@ -16367,7 +16384,7 @@ component instantiation." (if comp-name ;; ... from component declaration (vhdl-visit-file - (when vhdl-use-components-package pack-file-name) t + (when vhdl-use-components-package pack-file-name) t (save-excursion (goto-char (point-min)) (unless (re-search-forward (concat "^\\s-*component[ \t\n\r\f]+" comp-name "\\>") nil t) @@ -16378,7 +16395,7 @@ component instantiation." (concat (vhdl-replace-string vhdl-entity-file-name comp-ent-name t) "." (file-name-extension (buffer-file-name)))) (vhdl-visit-file - comp-ent-file-name t + comp-ent-file-name t (save-excursion (goto-char (point-min)) (unless (re-search-forward (concat "^\\s-*entity[ \t\n\r\f]+" comp-ent-name "\\>") nil t) @@ -16651,6 +16668,8 @@ component instantiation." (vhdl-comment-insert-inline (nth 4 entry) t)) (insert "\n")) +(defvar lazy-lock-minimum-size) + (defun vhdl-compose-components-package () "Generate a package containing component declarations for all entities in the current project/directory." @@ -16703,10 +16722,10 @@ current project/directory." ;; insert component declarations (while ent-alist (vhdl-visit-file (nth 2 (car ent-alist)) nil - (progn (goto-char (point-min)) - (forward-line (1- (nth 3 (car ent-alist)))) - (end-of-line) - (vhdl-port-copy))) + (goto-char (point-min)) + (forward-line (1- (nth 3 (car ent-alist)))) + (end-of-line) + (vhdl-port-copy)) (goto-char component-pos) (vhdl-port-paste-component t) (when (cdr ent-alist) (insert "\n\n") (indent-to vhdl-basic-offset)) @@ -16720,13 +16739,16 @@ current project/directory." (message "Generating components package \"%s\"...done\n File created: \"%s\"" pack-name pack-file-name))) -(defun vhdl-compose-configuration-architecture (ent-name arch-name ent-alist - conf-alist inst-alist - &optional insert-conf) +(defun vhdl-compose-configuration-architecture ( _ent-name arch-name + ent-alist-arg conf-alist-arg + inst-alist + &optional insert-conf) "Generate block configuration for architecture." - (let ((margin (current-indentation)) + (let ((ent-alist ent-alist-arg) + (conf-alist conf-alist-arg) + (margin (current-indentation)) (beg (point-at-bol)) - ent-entry inst-entry inst-path inst-prev-path cons-key tmp-alist) + ent-entry inst-entry inst-path inst-prev-path tmp-alist) ;; cons-key ;; insert block configuration (for architecture) (vhdl-insert-keyword "FOR ") (insert arch-name "\n") (setq margin (+ margin vhdl-basic-offset)) @@ -17077,7 +17099,7 @@ do not print any file names." (file-relative-name (buffer-file-name)))) (when (and (= 0 (nth 1 (nth 10 compiler))) (= 0 (nth 1 (nth 11 compiler)))) - (setq compilation-process-setup-function 'vhdl-compile-print-file-name)) + (setq compilation-process-setup-function #'vhdl-compile-print-file-name)) ;; run compilation (if options (when command @@ -17151,7 +17173,7 @@ specified by a target." vhdl-error-regexp-emacs-alist))) (when vhdl-emacs-22 - (add-hook 'compilation-mode-hook 'vhdl-error-regexp-add-emacs)) + (add-hook 'compilation-mode-hook #'vhdl-error-regexp-add-emacs)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Makefile generation @@ -17430,7 +17452,7 @@ specified by a target." (setq tmp-list rule-alist) (while tmp-list ; pre-sort rule targets (setq cell (cdar tmp-list)) - (setcar cell (sort (car cell) 'string<)) + (setcar cell (sort (car cell) #'string<)) (setq tmp-list (cdr tmp-list))) (setq rule-alist ; sort by first rule target (sort rule-alist @@ -17520,9 +17542,9 @@ specified by a target." ;; insert rule for each library unit (insert "\n\n# Rules for compiling single library units and their subhierarchy\n") (while prim-list - (setq second-list (sort (nth 1 (car prim-list)) 'string<)) + (setq second-list (sort (nth 1 (car prim-list)) #'string<)) (setq subcomp-list - (sort (vhdl-uniquify (nth 2 (car prim-list))) 'string<)) + (sort (vhdl-uniquify (nth 2 (car prim-list))) #'string<)) (setq unit-key (caar prim-list) unit-name (or (nth 0 (vhdl-aget ent-alist unit-key)) (nth 0 (vhdl-aget conf-alist unit-key)) @@ -17552,7 +17574,7 @@ specified by a target." (vhdl-get-compile-options project compiler (nth 0 rule) t)) ;; insert rule if file is supposed to be compiled (setq target-list (nth 1 rule) - depend-list (sort (vhdl-uniquify (nth 2 rule)) 'string<)) + depend-list (sort (vhdl-uniquify (nth 2 rule)) #'string<)) ;; insert targets (setq tmp-list target-list) (while target-list @@ -17575,7 +17597,8 @@ specified by a target." (if (eq options 'default) "$(OPTIONS)" options) " " (nth 0 rule) (if (equal vhdl-compile-post-command "") "" - " $(POST-COMPILE)") "\n") + " $(POST-COMPILE)") + "\n") (insert "\n")) (unless (and options mapping-exist) (setq tmp-list target-list) @@ -17615,6 +17638,7 @@ specified by a target." "Submit via mail a bug report on VHDL Mode." (interactive) ;; load in reporter + (defvar reporter-prompt-for-summary-p) (and (y-or-n-p "Do you want to submit a report on VHDL Mode? ") (let ((reporter-prompt-for-summary-p t)) diff --git a/lisp/progmodes/which-func.el b/lisp/progmodes/which-func.el index 3303257c98c..eb170baa5d8 100644 --- a/lisp/progmodes/which-func.el +++ b/lisp/progmodes/which-func.el @@ -1,7 +1,6 @@ ;;; which-func.el --- print current function in mode line -*- lexical-binding:t -*- -;; Copyright (C) 1994, 1997-1998, 2001-2021 Free Software Foundation, -;; Inc. +;; Copyright (C) 1994-2021 Free Software Foundation, Inc. ;; Author: Alex Rezinsky <alexr@msil.sps.mot.com> ;; (doesn't seem to be responsive any more) @@ -25,17 +24,17 @@ ;;; Commentary: ;; This package prints name of function where your current point is -;; located in mode line. It assumes that you work with imenu package -;; and imenu--index-alist is up to date. +;; located in mode line. It assumes that you work with the imenu +;; package and `imenu--index-alist' is up to date. ;; KNOWN BUGS ;; ---------- ;; Really this package shows not "function where the current point is ;; located now", but "nearest function which defined above the current -;; point". So if your current point is located after end of function -;; FOO but before begin of function BAR, FOO will be displayed in mode -;; line. -;; - if two windows display the same buffer, both windows +;; point". So if your current point is located after the end of +;; function FOO but before the beginning of function BAR, FOO will be +;; displayed in the mode line. +;; - If two windows display the same buffer, both windows ;; show the same `which-func' information. ;; TODO LIST @@ -44,7 +43,7 @@ ;; function determination mechanism should be used to determine the end ;; of a function as well as the beginning of a function. ;; 2. This package should be realized with the help of overlay -;; properties instead of imenu--index-alist variable. +;; properties instead of the `imenu--index-alist' variable. ;;; History: @@ -176,7 +175,7 @@ and you want to simplify them for the mode line (defvar which-func-table (make-hash-table :test 'eq :weakness 'key)) (defconst which-func-current - '(:eval (replace-regexp-in-string + '(:eval (string-replace "%" "%%" (or (gethash (selected-window) which-func-table) which-func-unknown)))) @@ -214,7 +213,7 @@ It creates the Imenu index for the buffer, if necessary." (setq which-func-mode nil)))) (defun which-func-update () - ;; "Update the Which-Function mode display for all windows." + "Update the Which-Function mode display for all windows." ;; (walk-windows 'which-func-update-1 nil 'visible)) (let ((non-essential t)) (which-func-update-1 (selected-window)))) diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index 18fdd963fb1..d3780d571fc 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -1,7 +1,7 @@ ;;; xref.el --- Cross-referencing commands -*-lexical-binding:t-*- ;; Copyright (C) 2014-2021 Free Software Foundation, Inc. -;; Version: 1.0.4 +;; Version: 1.1.0 ;; Package-Requires: ((emacs "26.1")) ;; This is a GNU ELPA :core package. Avoid functionality that is not @@ -24,11 +24,6 @@ ;;; Commentary: -;; NOTE: The xref API is still experimental and can change in major, -;; backward-incompatible ways. Everyone is encouraged to try it, and -;; report to us any problems or use cases we hadn't anticipated, by -;; sending an email to emacs-devel, or `M-x report-emacs-bug'. -;; ;; This file provides a somewhat generic infrastructure for cross ;; referencing commands, in particular "find-definition". ;; @@ -97,17 +92,13 @@ This is typically the filename.") "Return the line number corresponding to the location." nil) -(cl-defgeneric xref-location-column (_location) - "Return the exact column corresponding to the location." - nil) - (cl-defgeneric xref-match-length (_item) "Return the length of the match." nil) ;;;; Commonly needed location classes are defined here: -(defcustom xref-file-name-display 'abs +(defcustom xref-file-name-display 'project-relative "Style of file name display in *xref* buffers. If the value is the symbol `abs', the default, show the file names @@ -130,7 +121,7 @@ in its full absolute form." (defclass xref-file-location (xref-location) ((file :type string :initarg :file) (line :type fixnum :initarg :line :reader xref-location-line) - (column :type fixnum :initarg :column :reader xref-location-column)) + (column :type fixnum :initarg :column :reader xref-file-location-column)) :documentation "A file location is a file/line/column triple. Line numbers start from 1 and columns from 0.") @@ -415,6 +406,12 @@ elements is negated: these commands will NOT prompt." "Functions called after returning to a pre-jump location." :type 'hook) +(defcustom xref-after-update-hook nil + "Functions called after the xref buffer is updated." + :type 'hook + :version "28.1" + :package-version '(xref . "1.0.4")) + (defvar xref--marker-ring (make-ring xref-marker-ring-length) "Ring of markers to implement the marker stack.") @@ -519,7 +516,7 @@ If SELECT is non-nil, select the target window." "Face for displaying line numbers in the xref buffer." :version "27.1") -(defface xref-match '((t :inherit highlight)) +(defface xref-match '((t :inherit match)) "Face used to highlight matches in the xref buffer." :version "27.1") @@ -607,16 +604,26 @@ SELECT is `quit', also quit the *xref* window." (when xref (xref--show-location (xref-item-location xref))))) +(defun xref-next-line-no-show () + "Move to the next xref but don't display its source." + (interactive) + (xref--search-property 'xref-item)) + (defun xref-next-line () "Move to the next xref and display its source in the appropriate window." (interactive) - (xref--search-property 'xref-item) + (xref-next-line-no-show) (xref-show-location-at-point)) +(defun xref-prev-line-no-show () + "Move to the previous xref but don't display its source." + (interactive) + (xref--search-property 'xref-item t)) + (defun xref-prev-line () "Move to the previous xref and display its source in the appropriate window." (interactive) - (xref--search-property 'xref-item t) + (xref-prev-line-no-show) (xref-show-location-at-point)) (defun xref-next-group () @@ -645,12 +652,12 @@ SELECT is `quit', also quit the *xref* window." (defun xref-goto-xref (&optional quit) "Jump to the xref on the current line and select its window. -Non-interactively, non-nil QUIT, or interactively, with prefix argument -means to first quit the *xref* buffer." +If QUIT is non-nil (interactively, with prefix argument), also +quit the *xref* buffer." (interactive "P") (let* ((buffer (current-buffer)) (xref (or (xref--item-at-point) - (user-error "No reference at point"))) + (user-error "Choose a reference to visit"))) (xref--current-item xref)) (xref--show-location (xref-item-location xref) (if quit 'quit t)) (if (fboundp 'next-error-found) @@ -713,10 +720,7 @@ references displayed in the current *xref* buffer." (push pair all-pairs) ;; Perform sanity check first. (xref--goto-location loc) - (if (xref--outdated-p item - (buffer-substring-no-properties - (line-beginning-position) - (line-end-position))) + (if (xref--outdated-p item) (message "Search result out of date, skipping") (cond ((null file-buf) @@ -733,18 +737,38 @@ references displayed in the current *xref* buffer." (move-marker (car pair) nil) (move-marker (cdr pair) nil))))))) -(defun xref--outdated-p (item line-text) - ;; FIXME: The check should probably be a generic function instead of - ;; the assumption that all matches contain the full line as summary. - (let ((summary (xref-item-summary item)) - (strip (lambda (s) (if (string-match "\r\\'" s) - (substring-no-properties s 0 -1) - s)))) +(defun xref--outdated-p (item) + "Check that the match location at current position is up-to-date. +ITEMS is an xref item which " + ;; FIXME: The check should most likely be a generic function instead + ;; of the assumption that all matches' summaries relate to the + ;; buffer text in a particular way. + (let* ((summary (xref-item-summary item)) + ;; Sometimes buffer contents include ^M, and sometimes Grep + ;; output includes it, and they don't always match. + (strip (lambda (s) (if (string-match "\r\\'" s) + (substring-no-properties s 0 -1) + s))) + (stripped-summary (funcall strip summary)) + (lendpos (line-end-position)) + (check (lambda () + (let ((comparison-end + (+ (point) (length stripped-summary)))) + (and (>= lendpos comparison-end) + (equal stripped-summary + (buffer-substring-no-properties + (point) comparison-end))))))) (not - ;; Sometimes buffer contents include ^M, and sometimes Grep - ;; output includes it, and they don't always match. - (equal (funcall strip line-text) - (funcall strip summary))))) + (or + ;; Either summary contains match text and after + ;; (2nd+ match on the line)... + (funcall check) + ;; ...or it starts at bol, includes the match and after. + (and (< (point) (+ (line-beginning-position) + (length stripped-summary))) + (save-excursion + (forward-line 0) + (funcall check))))))) ;; FIXME: Write a nicer UI. (defun xref--query-replace-1 (from to iter) @@ -872,6 +896,44 @@ beginning of the line." (xref--search-property 'xref-item)) (xref-show-location-at-point)) +(defcustom xref-truncation-width 400 + "The column to visually \"truncate\" each Xref buffer line to." + :type '(choice + (integer :tag "Number of columns") + (const :tag "Disable truncation" nil))) + +(defun xref--apply-truncation () + (let ((bol (line-beginning-position)) + (eol (line-end-position)) + (inhibit-read-only t) + pos adjusted-bol) + (when (and xref-truncation-width + (> (- eol bol) xref-truncation-width) + ;; Either truncation not applied yet, or it hides the current + ;; position: need to refresh. + (or (and (null (get-text-property (1- eol) 'invisible)) + (null (get-text-property bol 'invisible))) + (get-text-property (point) 'invisible))) + (setq adjusted-bol + (cond + ((eq (get-text-property bol 'face) 'xref-line-number) + (next-single-char-property-change bol 'face)) + (t bol))) + (cond + ((< (- (point) bol) xref-truncation-width) + (setq pos (+ bol xref-truncation-width)) + (remove-text-properties bol pos '(invisible)) + (put-text-property pos eol 'invisible 'ellipsis)) + ((< (- eol (point)) xref-truncation-width) + (setq pos (- eol xref-truncation-width)) + (remove-text-properties pos eol '(invisible)) + (put-text-property adjusted-bol pos 'invisible 'ellipsis)) + (t + (setq pos (- (point) (/ xref-truncation-width 2))) + (put-text-property adjusted-bol pos 'invisible 'ellipsis) + (remove-text-properties pos (+ pos xref-truncation-width) '(invisible)) + (put-text-property (+ pos xref-truncation-width) eol 'invisible 'ellipsis)))))) + (defun xref--insert-xrefs (xref-alist) "Insert XREF-ALIST in the current-buffer. XREF-ALIST is of the form ((GROUP . (XREF ...)) ...), where @@ -886,30 +948,27 @@ GROUP is a string for decoration purposes and XREF is an (length (and line (format "%d" line))))) for line-format = (and max-line-width (format "%%%dd: " max-line-width)) - with prev-line-key = nil + with prev-group = nil + with prev-line = nil do (xref--insert-propertized '(face xref-file-header xref-group t) group "\n") (cl-loop for (xref . more2) on xrefs do (with-slots (summary location) xref (let* ((line (xref-location-line location)) - (new-summary summary) - (line-key (list (xref-location-group location) line)) (prefix - (if line - (propertize (format line-format line) - 'face 'xref-line-number) - " "))) + (cond + ((not line) " ") + ((and (equal line prev-line) + (equal prev-group group)) + "") + (t (propertize (format line-format line) + 'face 'xref-line-number))))) ;; Render multiple matches on the same line, together. - (when (and line (equal prev-line-key line-key)) - (when-let ((column (xref-location-column location))) - (delete-region - (save-excursion - (forward-line -1) - (move-to-column (+ (length prefix) column)) - (point)) - (point)) - (setq new-summary (substring summary column) prefix ""))) + (when (and (equal prev-group group) + (or (null line) + (not (equal prev-line line)))) + (insert "\n")) (xref--insert-propertized (list 'xref-item xref 'mouse-face 'highlight @@ -917,9 +976,16 @@ GROUP is a string for decoration purposes and XREF is an 'help-echo (concat "mouse-2: display in another window, " "RET or mouse-1: follow reference")) - prefix new-summary) - (setq prev-line-key line-key))) - (insert "\n")))) + prefix summary) + (setq prev-line line + prev-group group)))) + (insert "\n")) + (add-to-invisibility-spec '(ellipsis . t)) + (save-excursion + (goto-char (point-min)) + (while (= 0 (forward-line 1)) + (xref--apply-truncation))) + (run-hooks 'xref-after-update-hook)) (defun xref--analyze (xrefs) "Find common filenames in XREFS. @@ -956,6 +1022,7 @@ Return an alist of the form ((FILENAME . (XREF ...)) ...)." (buffer-undo-list t)) (erase-buffer) (xref--insert-xrefs xref-alist) + (add-hook 'post-command-hook 'xref--apply-truncation nil t) (goto-char (point-min)) (setq xref--original-window (assoc-default 'window alist) xref--original-window-intent (assoc-default 'display-action alist)) @@ -1024,6 +1091,12 @@ local keymap that binds `RET' to `xref-quit-and-goto-xref'." (define-obsolete-function-alias 'xref--show-defs-buffer-at-bottom #'xref-show-definitions-buffer-at-bottom "28.1") +(defun xref--completing-read-group (cand transform) + "Return group title of candidate CAND or TRANSFORM the candidate." + (if transform + (substring cand (1+ (next-single-property-change 0 'xref--group cand))) + (get-text-property 0 'xref--group cand))) + (defun xref-show-definitions-completing-read (fetcher alist) "Let the user choose the target definition with completion. @@ -1052,10 +1125,12 @@ between them by typing in the minibuffer with completion." (format #("%d:" 0 2 (face xref-line-number)) line) "")) + (group-prefix + (substring group group-prefix-length)) (group-fmt - (propertize - (substring group group-prefix-length) - 'face 'xref-file-header)) + (propertize group-prefix + 'face 'xref-file-header + 'xref--group group-prefix)) (candidate (format "%s:%s%s" group-fmt line-fmt summary))) (push (cons candidate xref) xref-alist-with-line-info))))) @@ -1067,7 +1142,9 @@ between them by typing in the minibuffer with completion." (lambda (string pred action) (cond ((eq action 'metadata) - '(metadata . ((category . xref-location)))) + `(metadata + . ((category . xref-location) + (group-function . ,#'xref--completing-read-group)))) (t (complete-with-action action collection string pred))))) (def (caar collection))) @@ -1279,7 +1356,9 @@ This command is intended to be bound to a mouse event." The argument has the same meaning as in `apropos'." (interactive (list (read-string "Search for pattern (word list or regexp): " - nil 'xref--read-pattern-history))) + nil 'xref--read-pattern-history + (xref-backend-identifier-at-point + (xref-find-backend))))) (require 'apropos) (let* ((newpat (if (and (version< emacs-version "28.0.50") @@ -1390,8 +1469,9 @@ IGNORES is a list of glob patterns for files to ignore." ;; do that reliably enough, without creating false negatives? (command (xref--rgrep-command (xref--regexp-to-extended regexp) files - (file-name-as-directory - (file-local-name (expand-file-name dir))) + (directory-file-name + (file-name-unquote + (file-local-name (expand-file-name dir)))) ignores)) (def default-directory) (buf (get-buffer-create " *xref-grep*")) @@ -1508,6 +1588,8 @@ FILES must be a list of absolute file names." #'tramp-file-local-name #'file-local-name) files))) + (when (file-name-quoted-p (car files)) + (setq files (mapcar #'file-name-unquote files))) (with-current-buffer output (erase-buffer) (with-temp-buffer @@ -1647,12 +1729,14 @@ Such as the current syntax table and the applied syntax properties." (if buf (with-current-buffer buf (save-excursion - (goto-char (point-min)) - (forward-line (1- line)) - (xref--collect-matches-1 regexp file line - (line-beginning-position) - (line-end-position) - syntax-needed))) + (save-restriction + (widen) + (goto-char (point-min)) + (forward-line (1- line)) + (xref--collect-matches-1 regexp file line + (line-beginning-position) + (line-end-position) + syntax-needed)))) ;; Using the temporary buffer is both a performance and a buffer ;; management optimization. (with-current-buffer tmp-buffer @@ -1678,20 +1762,30 @@ Such as the current syntax table and the applied syntax properties." syntax-needed))))) (defun xref--collect-matches-1 (regexp file line line-beg line-end syntax-needed) - (let (matches) + (let (match-pairs matches) (when syntax-needed (syntax-propertize line-end)) - ;; FIXME: This results in several lines with the same - ;; summary. Solve with composite pattern? (while (and ;; REGEXP might match an empty string. Or line. - (or (null matches) + (or (null match-pairs) (> (point) line-beg)) (re-search-forward regexp line-end t)) - (let* ((beg-column (- (match-beginning 0) line-beg)) - (end-column (- (match-end 0) line-beg)) + (push (cons (match-beginning 0) + (match-end 0)) + match-pairs)) + (setq match-pairs (nreverse match-pairs)) + (while match-pairs + (let* ((beg-end (pop match-pairs)) + (beg-column (- (car beg-end) line-beg)) + (end-column (- (cdr beg-end) line-beg)) (loc (xref-make-file-location file line beg-column)) - (summary (buffer-substring line-beg line-end))) + (summary (buffer-substring (if matches (car beg-end) line-beg) + (if match-pairs + (caar match-pairs) + line-end)))) + (when matches + (cl-decf beg-column (- (car beg-end) line-beg)) + (cl-decf end-column (- (car beg-end) line-beg))) (add-face-text-property beg-column end-column 'xref-match t summary) (push (xref-make-match summary loc (- end-column beg-column)) diff --git a/lisp/progmodes/xscheme.el b/lisp/progmodes/xscheme.el index e85e3cfdbbd..70763319840 100644 --- a/lisp/progmodes/xscheme.el +++ b/lisp/progmodes/xscheme.el @@ -104,20 +104,17 @@ reading-string reading prompt string") (defcustom scheme-band-name nil "Band loaded by the `run-scheme' command." - :type '(choice (const nil) string) - :group 'xscheme) + :type '(choice (const nil) string)) (defcustom scheme-program-arguments nil "Arguments passed to the Scheme program by the `run-scheme' command." - :type '(choice (const nil) string) - :group 'xscheme) + :type '(choice (const nil) string)) (defcustom xscheme-allow-pipelined-evaluation t "If non-nil, an expression may be transmitted while another is evaluating. Otherwise, attempting to evaluate an expression before the previous expression has finished evaluating will signal an error." - :type 'boolean - :group 'xscheme) + :type 'boolean) (defcustom xscheme-startup-message "This is the Scheme process buffer. @@ -128,19 +125,16 @@ Type \\[describe-mode] for more information. " "String to insert into Scheme process buffer first time it is started. Is processed with `substitute-command-keys' first." - :type 'string - :group 'xscheme) + :type 'string) (defcustom xscheme-signal-death-message nil "If non-nil, causes a message to be generated when the Scheme process dies." - :type 'boolean - :group 'xscheme) + :type 'boolean) (defcustom xscheme-start-hook nil "If non-nil, a procedure to call when the Scheme process is started. When called, the current buffer will be the Scheme process-buffer." :type 'hook - :group 'xscheme :version "20.3") (defun xscheme-evaluation-commands (keymap) @@ -942,7 +936,7 @@ the remaining input.") (setq call-noexcursion nil) (with-current-buffer (process-buffer proc) (cond ((eq xscheme-process-filter-state 'idle) - (let ((start (string-match "\e" xscheme-filter-input))) + (let ((start (string-search "\e" xscheme-filter-input))) (if start (progn (xscheme-process-filter-output @@ -966,7 +960,7 @@ the remaining input.") (xscheme-process-filter-output ?\e char) (setq xscheme-process-filter-state 'idle))))))) ((eq xscheme-process-filter-state 'reading-string) - (let ((start (string-match "\e" xscheme-filter-input))) + (let ((start (string-search "\e" xscheme-filter-input))) (if start (let ((string (concat xscheme-string-accumulator |