diff options
| author | Sean Whitton <spwhitton@spwhitton.name> | 2024-04-01 17:58:04 +0800 |
|---|---|---|
| committer | Sean Whitton <spwhitton@spwhitton.name> | 2024-04-01 17:58:04 +0800 |
| commit | 3af419ed0f0bf23320f8a7ac3479e2c50c353cde (patch) | |
| tree | fa45f6aee9812f8684ca888823c89cdcc89e6ddb /lisp | |
| parent | 101801ca13632ae17b486f690701b9cb36868676 (diff) | |
| parent | 87be53846bfbf5a6387cb5a40105bd0fc5b48b38 (diff) | |
| download | emacs-3af419ed0f0bf23320f8a7ac3479e2c50c353cde.tar.gz | |
Merge upstream Git snapshot into athena/unstable
Diffstat (limited to 'lisp')
344 files changed, 12523 insertions, 7959 deletions
diff --git a/lisp/abbrev.el b/lisp/abbrev.el index 4e26136e8f8..188eeb720c0 100644 --- a/lisp/abbrev.el +++ b/lisp/abbrev.el @@ -602,8 +602,7 @@ It is nil if the abbrev has already been unexpanded.") "Undefine all abbrevs in abbrev table TABLE, leaving TABLE empty." (setq abbrevs-changed t) (let* ((sym (obarray-get table ""))) - (dotimes (i (length table)) - (aset table i 0)) + (obarray-clear table) ;; Preserve the table's properties. (cl-assert sym) (let ((newsym (obarray-put table ""))) @@ -721,7 +720,7 @@ either a single abbrev table or a list of abbrev tables." ;; to treat the distinction between a single table and a list of tables. (cond ((consp tables) tables) - ((vectorp tables) (list tables)) + ((obarrayp tables) (list tables)) (t (let ((tables (if (listp local-abbrev-table) (append local-abbrev-table @@ -1275,7 +1274,7 @@ which see." (setq font-lock-multiline nil)) (defun abbrev--possibly-save (query &optional arg) - "Hook function for use by `save-some-buffer-functions'. + "Hook function for use by `save-some-buffers-functions'. Maybe save abbrevs, and record whether we either saved them or asked to." ;; Query mode. diff --git a/lisp/align.el b/lisp/align.el index fa95f24fa02..81ccc4b5e2d 100644 --- a/lisp/align.el +++ b/lisp/align.el @@ -181,13 +181,12 @@ If nil, then no messages will ever be printed to the minibuffer." :type '(choice (const :tag "Align a large region silently" nil) integer) :group 'align) -(defcustom align-c++-modes '( c++-mode c-mode java-mode - c-ts-mode c++-ts-mode) +(defcustom align-c++-modes '( c++-mode c-mode java-mode) "A list of modes whose syntax resembles C/C++." :type '(repeat symbol) :group 'align) -(defcustom align-perl-modes '(perl-mode cperl-mode) +(defcustom align-perl-modes '(perl-mode) "A list of modes where Perl syntax is to be seen." :type '(repeat symbol) :group 'align) @@ -576,13 +575,13 @@ The possible settings for `align-region-separate' are: "=" (group (zero-or-more (syntax whitespace))))) (group . (1 2)) - (modes . '(conf-toml-mode toml-ts-mode lua-mode lua-ts-mode))) + (modes . '(conf-toml-mode lua-mode))) (double-dash-comment (regexp . ,(rx (group (zero-or-more (syntax whitespace))) "--" (zero-or-more nonl))) - (modes . '(lua-mode lua-ts-mode)) + (modes . '(lua-mode)) (column . comment-column) (valid . ,(lambda () (save-excursion diff --git a/lisp/allout.el b/lisp/allout.el index 95b73c54934..e3fe8d08841 100644 --- a/lisp/allout.el +++ b/lisp/allout.el @@ -161,9 +161,9 @@ respective `allout-mode' keybinding variables, `allout-command-prefix', (defcustom allout-command-prefix "\C-c " "Key sequence to be used as prefix for outline mode command key bindings. -Default is `\C-c<space>'; just `\C-c' is more short-and-sweet, if you're -willing to let allout use a bunch of \C-c keybindings." - :type 'string +Default is \\`C-c SPC'; just \\`C-c' is more short-and-sweet, if you're +willing to let allout use a bunch of \\`C-c' keybindings." + :type 'key-sequence :group 'allout-keybindings :set #'allout-compose-and-institute-keymap) ;;;_ = allout-keybindings-binding @@ -6195,7 +6195,7 @@ for details on preparing Emacs for automatic allout activation." (allout-open-topic 2) (insert (substitute-command-keys (concat "Dummy outline topic header -- see" - " `allout-mode' docstring: `\\[describe-mode]'."))) + " `allout-mode' docstring: \\[describe-mode]"))) (allout-adjust-file-variable "allout-layout" (or allout-layout '(-1 : 0)))))) ;;;_ > allout-file-vars-section-data () diff --git a/lisp/ansi-osc.el b/lisp/ansi-osc.el index 7e686193f69..8dbaeb45132 100644 --- a/lisp/ansi-osc.el +++ b/lisp/ansi-osc.el @@ -121,7 +121,8 @@ and `shell-dirtrack-mode'." (let ((url (url-generic-parse-url text))) (when (and (string= (url-type url) "file") (or (null (url-host url)) - (string= (url-host url) (system-name)))) + ;; Use `downcase' to match `url-generic-parse-url' behavior + (string= (url-host url) (downcase (system-name))))) (ignore-errors (cd-absolute (url-unhex-string (url-filename url))))))) diff --git a/lisp/auth-source.el b/lisp/auth-source.el index 369cf4dca2e..5f5629d9cfc 100644 --- a/lisp/auth-source.el +++ b/lisp/auth-source.el @@ -233,8 +233,8 @@ EPA/EPG set up, the file will be encrypted and decrypted automatically. See Info node `(epa)Encrypting/decrypting gpg files' for details. -It's best to customize this with `\\[customize-variable]' because the choices -can get pretty complex." +It's best to customize this with \\[customize-variable] because +the choices can get pretty complex." :version "26.1" ; neither new nor changed default :type `(repeat :tag "Authentication Sources" (choice @@ -330,7 +330,6 @@ If the value is not a list, symmetric encryption will be used." (defun auth-source-read-char-choice (prompt choices) "Read one of CHOICES by `read-char-choice', or `read-char'. -`dropdown-list' support is disabled because it doesn't work reliably. Only one of CHOICES will be returned. The PROMPT is augmented with \"[a/b/c] \" if CHOICES is \(?a ?b ?c)." (when choices @@ -1946,18 +1945,20 @@ entries for git.gnus.org: (returned-keys (delete-dups (append '(:host :login :port :secret) search-keys))) - ;; Extract host and port from spec + ;; Extract host, port and user from spec (hosts (plist-get spec :host)) - (hosts (if (and hosts (listp hosts)) hosts `(,hosts))) + (hosts (if (consp hosts) hosts `(,hosts))) (ports (plist-get spec :port)) - (ports (if (and ports (listp ports)) ports `(,ports))) + (ports (if (consp ports) ports `(,ports))) (users (plist-get spec :user)) - (users (if (and users (listp users)) users `(,users))) + (users (if (consp users) users `(,users))) ;; Loop through all combinations of host/port and pass each of these to - ;; auth-source-macos-keychain-search-items + ;; auth-source-macos-keychain-search-items. Convert numeric port to + ;; string (bug#68376). (items (catch 'match (dolist (host hosts) (dolist (port ports) + (when (numberp port) (setq port (number-to-string port))) (dolist (user users) (let ((items (apply #'auth-source-macos-keychain-search-items @@ -1984,7 +1985,7 @@ entries for git.gnus.org: (defun auth-source--decode-octal-string (string) - "Convert octal STRING to utf-8 string. E.g: \"a\134b\" to \"a\b\"." + "Convert octal STRING to utf-8 string. E.g.: \"a\\134b\" to \"a\\b\"." (let ((list (string-to-list string)) (size (length string))) (decode-coding-string @@ -2019,7 +2020,7 @@ entries for git.gnus.org: (when port (if keychain-generic (setq args (append args (list "-s" port))) - (setq args (append args (if (string-match "[0-9]+" port) + (setq args (append args (if (string-match-p "\\`[[:digit:]]+\\'" port) (list "-P" port) (list "-r" (substring (format "%-4s" port) diff --git a/lisp/bind-key.el b/lisp/bind-key.el index 94a39f795cd..780314fecbd 100644 --- a/lisp/bind-key.el +++ b/lisp/bind-key.el @@ -155,6 +155,7 @@ add keys to that keymap." (add-to-list 'emulation-mode-map-alists `((override-global-mode . ,override-global-map))) +;;;###autoload (defvar personal-keybindings nil "List of bindings performed by `bind-key'. @@ -452,31 +453,28 @@ other modes. See `override-global-mode'." (macroexp-progn (bind-keys-form args 'override-global-map))) (defun bind-key--get-binding-description (elem) - (cond - ((listp elem) + (let (doc) (cond - ((memq (car elem) '(lambda function)) - (if (and bind-key-describe-special-forms - (stringp (nth 2 elem))) - (nth 2 elem) - "#<lambda>")) - ((eq 'closure (car elem)) - (if (and bind-key-describe-special-forms - (stringp (nth 3 elem))) - (nth 3 elem) - "#<closure>")) - ((eq 'keymap (car elem)) - "#<keymap>") + ((symbolp elem) + (cond + ((and bind-key-describe-special-forms (keymapp elem) + ;; FIXME: Is this really ever better than the symbol-name? + ;; FIXME: `variable-documentation' describe what's in + ;; elem's `symbol-value', whereas `elem' here stands for + ;; its `symbol-function'. + (stringp (setq doc (get elem 'variable-documentation)))) + doc) + (t elem))) + ((and bind-key-describe-special-forms (functionp elem) + (stringp (setq doc (documentation elem)))) + doc) ;;FIXME: Keep only the first line? + ;; FIXME: Use `help-fns-function-name'? + ((consp elem) + (if (symbolp (car elem)) + (format "#<%s>" (car elem)) + elem)) (t - elem))) - ;; must be a symbol, non-symbol keymap case covered above - ((and bind-key-describe-special-forms (keymapp elem)) - (let ((doc (get elem 'variable-documentation))) - (if (stringp doc) doc elem))) - ((symbolp elem) - elem) - (t - "#<byte-compiled lambda>"))) + (format "#<%s>" (type-of elem)))))) (defun bind-key--compare-keybindings (l r) (let* ((regex bind-key-segregation-regexp) diff --git a/lisp/bookmark.el b/lisp/bookmark.el index 893fdffb7ce..bf2357207d8 100644 --- a/lisp/bookmark.el +++ b/lisp/bookmark.el @@ -142,7 +142,7 @@ Nil means don't prompt for confirmation." "Non-nil means show annotations when jumping to a bookmark." :type 'boolean) -(defconst bookmark-bmenu-buffer "*Bookmark List*" +(defvar bookmark-bmenu-buffer "*Bookmark List*" "Name of buffer used for Bookmark List.") (defvar bookmark-bmenu-use-header-line t @@ -515,10 +515,11 @@ See user option `bookmark-fringe-mark'." (non-essential t) overlays found temp) (when (and pos filename) - (setq filename (expand-file-name filename)) + (setq filename (abbreviate-file-name (expand-file-name filename))) (dolist (buf (buffer-list)) (with-current-buffer buf - (when (equal filename buffer-file-name) + (when (equal filename + (ignore-errors (bookmark-buffer-file-name))) (setq overlays (save-excursion (goto-char pos) @@ -1192,6 +1193,8 @@ it to the name of the bookmark currently being set, advancing (if (stringp dired-directory) dired-directory (car dired-directory))) + ((and (boundp 'Info-current-file) (stringp Info-current-file)) + Info-current-file) (t (error "Buffer not visiting a file or directory"))))) (defvar bookmark--watch-already-asked-mtime nil diff --git a/lisp/buff-menu.el b/lisp/buff-menu.el index 82afea3d053..ec5337e3fda 100644 --- a/lisp/buff-menu.el +++ b/lisp/buff-menu.el @@ -95,11 +95,35 @@ as it is by default." :group 'Buffer-menu :version "22.1") +(defcustom Buffer-menu-group-by nil + "If non-nil, a function to call to divide buffer-menu buffers into groups. +This function is called with one argument: a list of entries in the same +format as in `tabulated-list-entries', and should return a list in the +format suitable for `tabulated-list-groups'. Also, when this variable +is non-nil, `outline-minor-mode' is enabled in the Buffer Menu and you +can use Outline minor mode commands to show/hide groups of buffers, +according to the value of `outline-regexp'. +The default options can group by a mode, and by a root directory of +a project or just `default-directory'. +If this is nil, buffers are not divided into groups." + :type '(choice (const :tag "No grouping" nil) + (function-item :tag "Group by mode" + Buffer-menu-group-by-mode) + (function-item :tag "Group by project root or directory" + Buffer-menu-group-by-root) + (function :tag "Custom function")) + :group 'Buffer-menu + :version "30.1") + (defvar-local Buffer-menu-files-only nil "Non-nil if the current Buffer Menu lists only file buffers. This is set by the prefix argument to `buffer-menu' and related commands.") +(defvar-local Buffer-menu-show-internal nil + "Non-nil if the current Buffer Menu lists internal buffers. +Internal buffers are those whose names start with a space.") + (defvar-local Buffer-menu-filter-predicate nil "Function to filter out buffers in the buffer list. Buffers that don't satisfy the predicate will be skipped. @@ -140,6 +164,7 @@ then the buffer will be displayed in the buffer list.") "V" #'Buffer-menu-view "O" #'Buffer-menu-view-other-window "T" #'Buffer-menu-toggle-files-only + "I" #'Buffer-menu-toggle-internal "M-s a C-s" #'Buffer-menu-isearch-buffers "M-s a C-M-s" #'Buffer-menu-isearch-buffers-regexp "M-s a C-o" #'Buffer-menu-multi-occur @@ -197,6 +222,10 @@ then the buffer will be displayed in the buffer list.") :help "Toggle whether the current buffer-menu displays only file buffers" :style toggle :selected Buffer-menu-files-only] + ["Show Internal Buffers" Buffer-menu-toggle-internal + :help "Toggle whether the current buffer-menu displays internal buffers" + :style toggle + :selected Buffer-menu-show-internal] "---" ["Refresh" revert-buffer :help "Refresh the *Buffer List* buffer contents"] @@ -317,6 +346,11 @@ ARG, show only buffers that are visiting files." (interactive "P") (display-buffer (list-buffers-noselect arg))) +(defun Buffer-menu--selection-message () + (message (cond (Buffer-menu-files-only "Showing only file-visiting buffers.") + (Buffer-menu-show-internal "Showing all buffers.") + (t "Showing all buffers except internal ones.")))) + (defun Buffer-menu-toggle-files-only (arg) "Toggle whether the current `buffer-menu' displays only file buffers. With a positive ARG, display only file buffers. With zero or @@ -325,9 +359,18 @@ negative ARG, display other buffers as well." (setq Buffer-menu-files-only (cond ((not arg) (not Buffer-menu-files-only)) ((> (prefix-numeric-value arg) 0) t))) - (message (if Buffer-menu-files-only - "Showing only file-visiting buffers." - "Showing all non-internal buffers.")) + (Buffer-menu--selection-message) + (revert-buffer)) + +(defun Buffer-menu-toggle-internal (arg) + "Toggle whether the current `buffer-menu' displays internal buffers. +With a positive ARG, don't show internal buffers. With zero or +negative ARG, display internal buffers as well." + (interactive "P" Buffer-menu-mode) + (setq Buffer-menu-show-internal + (cond ((not arg) (not Buffer-menu-show-internal)) + ((> (prefix-numeric-value arg) 0) t))) + (Buffer-menu--selection-message) (revert-buffer)) (define-obsolete-function-alias 'Buffer-menu-sort 'tabulated-list-sort @@ -385,14 +428,12 @@ When called interactively prompt for MARK; RET remove all marks." (interactive "cRemove marks (RET means all):" Buffer-menu-mode) (save-excursion (goto-char (point-min)) - (when (tabulated-list-header-overlay-p) - (forward-line)) (while (not (eobp)) - (let ((xmarks (list (aref (tabulated-list-get-entry) 0) - (aref (tabulated-list-get-entry) 2)))) - (when (or (char-equal mark ?\r) - (member (char-to-string mark) xmarks)) - (Buffer-menu--unmark))) + (when-let ((entry (tabulated-list-get-entry))) + (let ((xmarks (list (aref entry 0) (aref entry 2)))) + (when (or (char-equal mark ?\r) + (member (char-to-string mark) xmarks)) + (Buffer-menu--unmark)))) (forward-line)))) (defun Buffer-menu-unmark-all () @@ -416,7 +457,7 @@ When called interactively prompt for MARK; RET remove all marks." (defun Buffer-menu-delete (&optional arg) "Mark the buffer on this Buffer Menu buffer line for deletion. -A subsequent \\<Buffer-menu-mode-map>`\\[Buffer-menu-execute]' command +A subsequent \\<Buffer-menu-mode-map>\\[Buffer-menu-execute] command \ will delete it. If prefix argument ARG is non-nil, it specifies the number of @@ -437,16 +478,16 @@ buffers to delete; a negative ARG means to delete backwards." (defun Buffer-menu-delete-backwards (&optional arg) "Mark the buffer on this Buffer Menu line for deletion, and move up. -A subsequent \\<Buffer-menu-mode-map>`\\[Buffer-menu-execute]' -command will delete the marked buffer. Prefix ARG means move -that many lines." +A subsequent \\<Buffer-menu-mode-map>\\[Buffer-menu-execute] command \ +will delete the marked buffer. Prefix ARG + means move that many lines." (interactive "p" Buffer-menu-mode) (Buffer-menu-delete (- (or arg 1)))) (defun Buffer-menu-save () "Mark the buffer on this Buffer Menu line for saving. -A subsequent \\<Buffer-menu-mode-map>`\\[Buffer-menu-execute]' command -will save it." +A subsequent \\<Buffer-menu-mode-map>\\[Buffer-menu-execute] \ +command will save it." (interactive nil Buffer-menu-mode) (when (Buffer-menu-buffer) (tabulated-list-set-col 2 "S" t) @@ -463,8 +504,8 @@ it as modified." (defun Buffer-menu-execute () "Save and/or delete marked buffers in the Buffer Menu. -Buffers marked with \\<Buffer-menu-mode-map>`\\[Buffer-menu-save]' are saved. -Buffers marked with \\<Buffer-menu-mode-map>`\\[Buffer-menu-delete]' are deleted." +Buffers marked with \\<Buffer-menu-mode-map>\\[Buffer-menu-save] are saved. +Buffers marked with \\<Buffer-menu-mode-map>\\[Buffer-menu-delete] are deleted." (interactive nil Buffer-menu-mode) (save-excursion (Buffer-menu-beginning) @@ -492,7 +533,7 @@ Buffers marked with \\<Buffer-menu-mode-map>`\\[Buffer-menu-delete]' are deleted (defun Buffer-menu-select () "Select this line's buffer; also, display buffers marked with `>'. -You can mark buffers with the \\<Buffer-menu-mode-map>`\\[Buffer-menu-mark]' command. +You can mark buffers with the \\<Buffer-menu-mode-map>\\[Buffer-menu-mark] command. This command deletes and replaces all the previously existing windows in the selected frame, and will remove any marks." @@ -515,15 +556,16 @@ in the selected frame, and will remove any marks." (defun Buffer-menu-marked-buffers (&optional unmark) "Return the list of buffers marked with `Buffer-menu-mark'. If UNMARK is non-nil, unmark them." - (let (buffers) - (Buffer-menu-beginning) - (while (re-search-forward "^>" nil t) - (let ((buffer (Buffer-menu-buffer))) - (if (and buffer unmark) - (tabulated-list-set-col 0 " " t)) - (if (buffer-live-p buffer) - (push buffer buffers)))) - (nreverse buffers))) + (save-excursion + (let (buffers) + (Buffer-menu-beginning) + (while (re-search-forward "^>" nil t) + (let ((buffer (Buffer-menu-buffer))) + (if (and buffer unmark) + (tabulated-list-set-col 0 " " t)) + (if (buffer-live-p buffer) + (push buffer buffers)))) + (nreverse buffers)))) (defun Buffer-menu-isearch-buffers () "Search for a string through all marked buffers using Isearch." @@ -569,13 +611,17 @@ If UNMARK is non-nil, unmark them." (defun Buffer-menu-other-window () "Select this line's buffer in other window, leaving buffer menu visible." (interactive nil Buffer-menu-mode) - (switch-to-buffer-other-window (Buffer-menu-buffer t))) + (let ((display-buffer-overriding-action + '(nil (inhibit-same-window . t)))) + (switch-to-buffer-other-window (Buffer-menu-buffer t)))) (defun Buffer-menu-switch-other-window () "Make the other window select this line's buffer. The current window remains selected." (interactive nil Buffer-menu-mode) - (display-buffer (Buffer-menu-buffer t) t)) + (let ((display-buffer-overriding-action + '(nil (inhibit-same-window . t)))) + (display-buffer (Buffer-menu-buffer t) t))) (defun Buffer-menu-2-window () "Select this line's buffer, with previous buffer in second window." @@ -647,7 +693,12 @@ See more at `Buffer-menu-filter-predicate'." (setq Buffer-menu-buffer-list buffer-list) (setq Buffer-menu-filter-predicate filter-predicate) (list-buffers--refresh buffer-list old-buffer) - (tabulated-list-print)) + (tabulated-list-print) + (when tabulated-list-groups + (setq-local outline-minor-mode-cycle t + outline-minor-mode-highlight t + outline-minor-mode-use-buttons 'in-margins) + (outline-minor-mode 1))) buffer)) (defun Buffer-menu-mouse-select (event) @@ -667,6 +718,7 @@ See more at `Buffer-menu-filter-predicate'." (marked-buffers (Buffer-menu-marked-buffers)) (buffer-menu-buffer (current-buffer)) (show-non-file (not Buffer-menu-files-only)) + (show-internal Buffer-menu-show-internal) (filter-predicate (and (functionp Buffer-menu-filter-predicate) Buffer-menu-filter-predicate)) entries name-width) @@ -686,7 +738,8 @@ See more at `Buffer-menu-filter-predicate'." (file buffer-file-name)) (when (and (buffer-live-p buffer) (or buffer-list - (and (or (not (string= (substring name 0 1) " ")) + (and (or show-internal + (not (string= (substring name 0 1) " ")) file) (not (eq buffer buffer-menu-buffer)) (or file show-non-file) @@ -721,7 +774,11 @@ See more at `Buffer-menu-filter-predicate'." `("Mode" ,Buffer-menu-mode-width t) '("File" 1 t))) (setq tabulated-list-use-header-line Buffer-menu-use-header-line) - (setq tabulated-list-entries (nreverse entries))) + (setq tabulated-list-entries (nreverse entries)) + (when Buffer-menu-group-by + (setq tabulated-list-groups + (seq-group-by Buffer-menu-group-by + tabulated-list-entries)))) (tabulated-list-init-header)) (defun tabulated-list-entry-size-> (entry1 entry2) @@ -740,4 +797,14 @@ See more at `Buffer-menu-filter-predicate'." (abbreviate-file-name list-buffers-directory)) (t ""))) +(defun Buffer-menu-group-by-mode (entry) + (concat "* " (aref (cadr entry) 5))) + +(declare-function project-root "project" (project)) +(defun Buffer-menu-group-by-root (entry) + (concat "* " (with-current-buffer (car entry) + (if-let ((project (project-current))) + (project-root project) + default-directory)))) + ;;; buff-menu.el ends here diff --git a/lisp/calc/calc-aent.el b/lisp/calc/calc-aent.el index 08e8d9fcd6f..a21efc0238d 100644 --- a/lisp/calc/calc-aent.el +++ b/lisp/calc/calc-aent.el @@ -505,6 +505,7 @@ The value t means abort and give an error message.") ("⅝" "(5:8)") ; 5/8 ("⅞" "(7:8)") ; 7/8 ("⅟" "1:") ; 1/... + ("⁄" ":") ; arbitrary fractions of the form 123⁄456 ;; superscripts ("⁰" "0") ; 0 ("¹" "1") ; 1 diff --git a/lisp/calc/calc-prog.el b/lisp/calc/calc-prog.el index 03210995eb3..8dff7f1f264 100644 --- a/lisp/calc/calc-prog.el +++ b/lisp/calc/calc-prog.el @@ -1225,13 +1225,17 @@ Redefine the corresponding command." (interactive) (calc-kbd-if)) +(defun calc--at-end-of-kmacro-p () + (and (arrayp executing-kbd-macro) + (>= executing-kbd-macro-index (length executing-kbd-macro)))) + (defun calc-kbd-skip-to-else-if (else-okay) (let ((count 0) ch) (while (>= count 0) - (setq ch (read-char)) - (if (= ch -1) + (if (calc--at-end-of-kmacro-p) (error "Unterminated Z[ in keyboard macro")) + (setq ch (read-char)) (if (= ch ?Z) (progn (setq ch (read-char)) @@ -1299,9 +1303,9 @@ Redefine the corresponding command." (or executing-kbd-macro (message "Reading loop body...")) (while (>= count 0) - (setq ch (read-event)) - (if (eq ch -1) + (if (calc--at-end-of-kmacro-p) (error "Unterminated Z%c in keyboard macro" open)) + (setq ch (read-event)) (if (eq ch ?Z) (progn (setq ch (read-event) @@ -1427,9 +1431,9 @@ Redefine the corresponding command." (if defining-kbd-macro (message "Reading body...")) (while (>= count 0) - (setq ch (read-char)) - (if (= ch -1) + (if (calc--at-end-of-kmacro-p) (error "Unterminated Z` in keyboard macro")) + (setq ch (read-char)) (if (= ch ?Z) (progn (setq ch (read-char) diff --git a/lisp/calendar/calendar.el b/lisp/calendar/calendar.el index a25684f7b5d..10c86571804 100644 --- a/lisp/calendar/calendar.el +++ b/lisp/calendar/calendar.el @@ -1985,7 +1985,7 @@ Gregorian date Sunday, December 31, 1 BC. This function does not handle dates in years BC." ;; For an explanation, see the footnote on page 384 of "Calendrical ;; Calculations, Part II: Three Historical Calendars" by - ;; E. M. Reingold, N. Dershowitz, and S. M. Clamen, + ;; E. M. Reingold, N. Dershowitz, and S. M. Clamen, ;; Software--Practice and Experience, Volume 23, Number 4 (April, ;; 1993), pages 383-404 <https://doi.org/10.1002/spe.4380230404> ;; <http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.42.6421&rep=rep1&type=pdf>. @@ -2337,10 +2337,12 @@ returned is (month year)." (defmon (aref month-array (1- (calendar-extract-month default-date)))) (completion-ignore-case t) (month (cdr (assoc-string - (completing-read - (format-prompt "Month name" defmon) - (append month-array nil) - nil t nil nil defmon) + (let ((completion-extra-properties + '(:category calendar-month))) + (completing-read + (format-prompt "Month name" defmon) + (append month-array nil) + nil t nil nil defmon)) (calendar-make-alist month-array 1) t))) (defday (calendar-extract-day default-date)) (last (calendar-last-day-of-month month year))) diff --git a/lisp/calendar/todo-mode.el b/lisp/calendar/todo-mode.el index 7989fff9466..12287299a7f 100644 --- a/lisp/calendar/todo-mode.el +++ b/lisp/calendar/todo-mode.el @@ -677,7 +677,7 @@ current (i.e., last displayed) category. In Todo mode just the category's unfinished todo items are shown by default. The done items are hidden, but typing -`\\[todo-toggle-view-done-items]' displays them below the todo +\\[todo-toggle-view-done-items] displays them below the todo items. With non-nil user option `todo-show-with-done' both todo and done items are always shown on visiting a category." (interactive "P\np") @@ -1553,7 +1553,7 @@ the archive of the file moved to, creating it if it does not exist." (prin1 todo-categories (current-buffer))) ;; If archive was just created, save it to avoid "File ;; <xyz> no longer exists!" message on invoking - ;; `todo-view-archived-items'. + ;; `todo-find-archive'. (unless (file-exists-p (buffer-file-name)) (save-buffer)) (todo-category-number (or new cat)) @@ -1612,7 +1612,7 @@ archive file and the source category is deleted." (garchive (concat (file-name-sans-extension gfile) ".toda")) (archived-count (todo-get-count 'archived)) here) - (with-current-buffer (get-buffer (find-file-noselect tfile)) + (with-current-buffer (find-file-noselect tfile) (widen) (let* ((inhibit-read-only t) (cbeg (progn @@ -1638,7 +1638,7 @@ archive file and the source category is deleted." (todo-count (todo-get-count 'todo cat)) (done-count (todo-get-count 'done cat))) ;; Merge into goal todo category. - (with-current-buffer (get-buffer (find-file-noselect gfile)) + (with-current-buffer (find-file-noselect gfile) (unless (derived-mode-p 'todo-mode) (todo-mode)) (widen) (goto-char (point-min)) @@ -1677,7 +1677,7 @@ archive file and the source category is deleted." (mapc (lambda (m) (set-marker m nil)) (list cbeg tbeg dbeg tend cend)))) (when (> archived-count 0) - (with-current-buffer (get-buffer (find-file-noselect tarchive)) + (with-current-buffer (find-file-noselect tarchive) (widen) (goto-char (point-min)) (let* ((inhibit-read-only t) @@ -1697,7 +1697,7 @@ archive file and the source category is deleted." (forward-line) (buffer-substring-no-properties (point) cend)))) ;; Merge into goal archive category, if it exists, else create it. - (with-current-buffer (get-buffer (find-file-noselect garchive)) + (with-current-buffer (find-file-noselect garchive) (let ((gbeg (when (re-search-forward (concat "^" (regexp-quote (concat todo-category-beg goal)) @@ -3570,12 +3570,12 @@ categories display according to priority." In the initial display the lines of the table are numbered, indicating the current order of the categories when sequentially -navigating through the todo file with `\\[todo-forward-category]' -and `\\[todo-backward-category]'. You can reorder the lines, and -hence the category sequence, by typing `\\[todo-raise-category]' -or `\\[todo-lower-category]' to raise or lower the category at -point, or by typing `\\[todo-set-category-number]' and entering a -number at the prompt or by typing `\\[todo-set-category-number]' +navigating through the todo file with \\[todo-forward-category] +and \\[todo-backward-category]. You can reorder the lines, and +hence the category sequence, by typing \\[todo-raise-category] +or \\[todo-lower-category] to raise or lower the category at +point, or by typing \\[todo-set-category-number] and entering a +number at the prompt or by typing \\[todo-set-category-number] with a numeric prefix. If you save the todo file after reordering the categories, the new order persists in subsequent Emacs sessions. @@ -3584,8 +3584,8 @@ The labels above the category names and item counts are buttons, and clicking these changes the display: sorted by category name or by the respective item counts (alternately descending or ascending). In these displays the categories are not numbered -and `\\[todo-set-category-number]', `\\[todo-raise-category]' and -`\\[todo-lower-category]' are disabled. (Programmatically, the +and \\[todo-set-category-number], \\[todo-raise-category] and +\\[todo-lower-category] are disabled. (Programmatically, the sorting is triggered by passing a non-nil SORTKEY argument.) In addition, the lines with the category names and item counts @@ -4065,8 +4065,8 @@ face." (defcustom todo-top-priorities-overrides nil "List of rules specifying number of top priority items to show. These rules override `todo-top-priorities' on invocations of -`\\[todo-filter-top-priorities]' and -`\\[todo-filter-top-priorities-multifile]'. Each rule is a list +\\[todo-filter-top-priorities] and +\\[todo-filter-top-priorities-multifile]. Each rule is a list of the form (FILE NUM ALIST), where FILE is a member of `todo-files', NUM is a number specifying the default number of top priority items for each category in that file, and ALIST, @@ -4075,8 +4075,8 @@ number specifying the default number of top priority items in that category, which overrides NUM. This variable should be set interactively by -`\\[todo-set-top-priorities-in-file]' or -`\\[todo-set-top-priorities-in-category]'." +\\[todo-set-top-priorities-in-file] or +\\[todo-set-top-priorities-in-category]." :type 'sexp :group 'todo-filtered) diff --git a/lisp/cedet/mode-local.el b/lisp/cedet/mode-local.el index 28f14232704..9f11b9707bd 100644 --- a/lisp/cedet/mode-local.el +++ b/lisp/cedet/mode-local.el @@ -1,6 +1,6 @@ ;;; mode-local.el --- Support for mode local facilities -*- lexical-binding:t -*- ;; -;; Copyright (C) 2004-2005, 2007-2024 Free Software Foundation, Inc. +;; Copyright (C) 2004-2024 Free Software Foundation, Inc. ;; ;; Author: David Ponce <david@dponce.com> ;; Created: 27 Apr 2004 @@ -84,7 +84,7 @@ MODES can be a symbol or a list of symbols. FUNCTION does not have arguments." (setq modes (ensure-list modes)) (mode-local-map-file-buffers - function (lambda () (apply #'derived-mode-p modes)))) + function (lambda () (derived-mode-p modes)))) ;;; Hook machinery ;; diff --git a/lisp/cedet/semantic/lex-spp.el b/lisp/cedet/semantic/lex-spp.el index a4be5bf67e2..f63d316c1ac 100644 --- a/lisp/cedet/semantic/lex-spp.el +++ b/lisp/cedet/semantic/lex-spp.el @@ -153,13 +153,13 @@ The search priority is: "Return the dynamic macro map for the current buffer." (or semantic-lex-spp-dynamic-macro-symbol-obarray (setq semantic-lex-spp-dynamic-macro-symbol-obarray - (make-vector 13 0)))) + (obarray-make 13)))) (defsubst semantic-lex-spp-dynamic-map-stack () "Return the dynamic macro map for the current buffer." (or semantic-lex-spp-dynamic-macro-symbol-obarray-stack (setq semantic-lex-spp-dynamic-macro-symbol-obarray-stack - (make-vector 13 0)))) + (obarray-make 13)))) (defun semantic-lex-spp-value-valid-p (value) "Return non-nil if VALUE is valid." @@ -260,7 +260,7 @@ NAME is the name of the spp macro symbol to define. REPLACEMENT a string that would be substituted in for NAME." ;; Create the symbol hash table - (let ((semantic-lex-spp-macro-symbol-obarray (make-vector 13 0)) + (let ((semantic-lex-spp-macro-symbol-obarray (obarray-make 13)) spec) ;; fill it with stuff (while specs diff --git a/lisp/cedet/semantic/lex.el b/lisp/cedet/semantic/lex.el index b32cb96bed9..f3d671ac312 100644 --- a/lisp/cedet/semantic/lex.el +++ b/lisp/cedet/semantic/lex.el @@ -259,7 +259,7 @@ If optional argument PROPSPECS is non-nil, then interpret it, and apply those properties. PROPSPECS must be a list of (NAME PROPERTY VALUE) elements." ;; Create the symbol hash table - (let ((semantic-flex-keywords-obarray (make-vector 13 0)) + (let ((semantic-flex-keywords-obarray (obarray-make 13)) spec) ;; fill it with stuff (while specs @@ -416,7 +416,7 @@ If optional argument PROPSPECS is non-nil, then interpret it, and apply those properties. PROPSPECS must be a list of (TYPE PROPERTY VALUE)." ;; Create the symbol hash table - (let* ((semantic-lex-types-obarray (make-vector 13 0)) + (let* ((semantic-lex-types-obarray (obarray-make 13)) spec type tokens token alist default) ;; fill it with stuff (while specs diff --git a/lisp/cedet/semantic/symref/grep.el b/lisp/cedet/semantic/symref/grep.el index 83e3bc36073..cc4d1546c85 100644 --- a/lisp/cedet/semantic/symref/grep.el +++ b/lisp/cedet/semantic/symref/grep.el @@ -44,9 +44,7 @@ those hits returned.") (defvar semantic-symref-filepattern-alist '((c-mode "*.[ch]") - (c-ts-mode "*.[ch]") (c++-mode "*.[chCH]" "*.[ch]pp" "*.cc" "*.hh") - (c++-ts-mode "*.[chCH]" "*.[ch]pp" "*.cc" "*.hh") (html-mode "*.html" "*.shtml" "*.php") (mhtml-mode "*.html" "*.shtml" "*.php") ; FIXME: remove ; duplication of @@ -55,12 +53,8 @@ those hits returned.") ; major mode definition? (ruby-mode "*.r[bu]" "*.rake" "*.gemspec" "*.erb" "*.haml" "Rakefile" "Thorfile" "Capfile" "Guardfile" "Vagrantfile") - (ruby-ts-mode "*.r[bu]" "*.rake" "*.gemspec" "*.erb" "*.haml" - "Rakefile" "Thorfile" "Capfile" "Guardfile" "Vagrantfile") (python-mode "*.py" "*.pyi" "*.pyw") - (python-ts-mode "*.py" "*.pyi" "*.pyw") (perl-mode "*.pl" "*.PL") - (cperl-mode "*.pl" "*.PL") (lisp-interaction-mode "*.el" "*.ede" ".emacs" "_emacs") ) "List of major modes and file extension pattern. diff --git a/lisp/cedet/semantic/tag.el b/lisp/cedet/semantic/tag.el index 18a0b4caee2..a0843dd5df9 100644 --- a/lisp/cedet/semantic/tag.el +++ b/lisp/cedet/semantic/tag.el @@ -349,6 +349,9 @@ If TAG is unlinked, but has a :filename property, then that is used." ;; If an error occurs, then it most certainly is not a tag. (error nil))) +;; Used in `semantic-utest-ia.el'. +(cl-deftype semantic-tag () `(satisfies semantic-tag-p)) + (defsubst semantic-tag-of-class-p (tag class) "Return non-nil if class of TAG is CLASS." (eq (semantic-tag-class tag) class)) diff --git a/lisp/char-fold.el b/lisp/char-fold.el index a620d4d8dc3..4d9644216d8 100644 --- a/lisp/char-fold.el +++ b/lisp/char-fold.el @@ -214,7 +214,7 @@ equiv)) equiv))) -(defconst char-fold-table +(defvar char-fold-table (eval-when-compile (char-fold--make-table)) "Used for folding characters of the same group during search. diff --git a/lisp/comint.el b/lisp/comint.el index 0a9cdb44bef..a8fe095e99c 100644 --- a/lisp/comint.el +++ b/lisp/comint.el @@ -254,7 +254,7 @@ This variable is buffer-local." See also `comint-read-input-ring' and `comint-write-input-ring'. `comint-mode' makes this a buffer-local variable. You probably want to set this in a mode hook, rather than customize the default value." - :type '(choice (const :tag "nil" nil) + :type '(choice (const :tag "Disable input history" nil) file) :group 'comint) @@ -3510,7 +3510,7 @@ the completions." ;; Read the next key, to process SPC. (let (key first) - (if (with-current-buffer (get-buffer "*Completions*") + (if (with-current-buffer "*Completions*" (setq-local comint-displayed-dynamic-completions completions) (setq key (read-key-sequence nil) diff --git a/lisp/completion-preview.el b/lisp/completion-preview.el index baadb4714b1..e827da43a08 100644 --- a/lisp/completion-preview.el +++ b/lisp/completion-preview.el @@ -52,6 +52,8 @@ ;;; Code: +(require 'mwheel) + (defgroup completion-preview nil "In-buffer completion preview." :group 'completion) @@ -128,19 +130,19 @@ If this option is nil, these commands do not display any message." ;; "M-p" #'completion-preview-prev-candidate ) -(defvar mouse-wheel-up-event) -(defvar mouse-wheel-up-alternate-event) -(defvar mouse-wheel-down-event) -(defvar mouse-wheel-down-alternate-event) (defvar-keymap completion-preview--mouse-map :doc "Keymap for mouse clicks on the completion preview." "<down-mouse-1>" #'completion-preview-insert "C-<down-mouse-1>" #'completion-at-point "<down-mouse-2>" #'completion-at-point - (format "<%s>" mouse-wheel-up-event) #'completion-preview-prev-candidate - (format "<%s>" mouse-wheel-up-alternate-event) #'completion-preview-prev-candidate - (format "<%s>" mouse-wheel-down-event) #'completion-preview-next-candidate - (format "<%s>" mouse-wheel-down-alternate-event) #'completion-preview-next-candidate) + ;; BEWARE: `mouse-wheel-UP-event' corresponds to `wheel-DOWN' events + ;; and vice versa!! + "<wheel-up>" #'completion-preview-prev-candidate + "<wheel-down>" #'completion-preview-next-candidate + (key-description (vector mouse-wheel-up-event)) + #'completion-preview-next-candidate + (key-description (vector mouse-wheel-down-event)) + #'completion-preview-prev-candidate) (defvar-local completion-preview--overlay nil) @@ -300,21 +302,21 @@ point, otherwise hide it." ;; never display a stale preview and that the preview doesn't ;; flicker, even with slow completion backends. (let* ((beg (completion-preview--get 'completion-preview-beg)) + (end (max (point) (overlay-start completion-preview--overlay))) (cands (completion-preview--get 'completion-preview-cands)) (index (completion-preview--get 'completion-preview-index)) (cand (nth index cands)) - (len (length cand)) - (end (+ beg len)) - (cur (point)) - (face (get-text-property 0 'face (completion-preview--get 'after-string)))) - (if (and (< beg cur end) (string-prefix-p (buffer-substring beg cur) cand)) + (after (completion-preview--get 'after-string)) + (face (get-text-property 0 'face after))) + (if (and (<= beg (point) end (1- (+ beg (length cand)))) + (string-prefix-p (buffer-substring beg end) cand)) ;; The previous preview is still applicable, update it. (overlay-put (completion-preview--make-overlay - cur (propertize (substring cand (- cur beg)) + end (propertize (substring cand (- end beg)) 'face face 'mouse-face 'completion-preview-highlight 'keymap completion-preview--mouse-map)) - 'completion-preview-end cur) + 'completion-preview-end end) ;; The previous preview is no longer applicable, hide it. (completion-preview-active-mode -1)))) ;; Run `completion-at-point-functions' to get a new candidate. @@ -364,16 +366,16 @@ prefix argument and defaults to 1." (interactive "p") (when completion-preview-active-mode (let* ((beg (completion-preview--get 'completion-preview-beg)) + (end (completion-preview--get 'completion-preview-end)) (all (completion-preview--get 'completion-preview-cands)) (cur (completion-preview--get 'completion-preview-index)) (len (length all)) (new (mod (+ cur direction) len)) - (str (nth new all)) - (pos (point))) - (while (or (<= (+ beg (length str)) pos) - (not (string-prefix-p (buffer-substring beg pos) str))) + (str (nth new all))) + (while (or (<= (+ beg (length str)) end) + (not (string-prefix-p (buffer-substring beg end) str))) (setq new (mod (+ new direction) len) str (nth new all))) - (let ((aft (propertize (substring str (- pos beg)) + (let ((aft (propertize (substring str (- end beg)) 'face (if (< 1 len) 'completion-preview 'completion-preview-exact) diff --git a/lisp/completion.el b/lisp/completion.el index ab7f2a7bc52..6c758e56eab 100644 --- a/lisp/completion.el +++ b/lisp/completion.el @@ -875,11 +875,11 @@ This is sensitive to `case-fold-search'." ;; GNU implements obarrays (defconst cmpl-obarray-length 511) -(defvar cmpl-prefix-obarray (make-vector cmpl-obarray-length 0) +(defvar cmpl-prefix-obarray (obarray-make cmpl-obarray-length) "An obarray used to store the downcased completion prefixes. Each symbol is bound to a list of completion entries.") -(defvar cmpl-obarray (make-vector cmpl-obarray-length 0) +(defvar cmpl-obarray (obarray-make cmpl-obarray-length) "An obarray used to store the downcased completions. Each symbol is bound to a single completion entry.") @@ -962,8 +962,8 @@ Each symbol is bound to a single completion entry.") (defun clear-all-completions () "Initialize the completion storage. All existing completions are lost." (interactive) - (setq cmpl-prefix-obarray (make-vector cmpl-obarray-length 0)) - (setq cmpl-obarray (make-vector cmpl-obarray-length 0))) + (setq cmpl-prefix-obarray (obarray-make cmpl-obarray-length)) + (setq cmpl-obarray (obarray-make cmpl-obarray-length))) (defun list-all-completions () "Return a list of all the known completion entries." diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index 0eeca7c2f31..f004002333b 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -1159,14 +1159,15 @@ argument or if the current major mode has no known group, prompt for the MODE to customize." (interactive (list - (let ((completion-regexp-list '("-mode\\'")) - (group (custom-group-of-mode major-mode))) + (let ((group (custom-group-of-mode major-mode))) (if (and group (not current-prefix-arg)) major-mode (intern (completing-read (format-prompt "Mode" (and group major-mode)) obarray - 'custom-group-of-mode + (lambda (s) + (and (string-match "-mode\\'" (symbol-name s)) + (custom-group-of-mode s))) t nil nil (if group (symbol-name major-mode)))))))) (customize-group (custom-group-of-mode mode))) @@ -1228,6 +1229,41 @@ If OTHER-WINDOW is non-nil, display in another window." (message "`%s' is an alias for `%s'" symbol basevar)))) ;;;###autoload +(defun customize-toggle-option (symbol) + "Toggle the value of boolean option SYMBOL for this session." + (interactive (let ((prompt "Toggle boolean option: ") opts) + (mapatoms + (lambda (sym) + (when (eq (get sym 'custom-type) 'boolean) + (push sym opts)))) + (list (intern (completing-read prompt opts nil nil nil nil + (symbol-at-point)))))) + (let* ((setter (or (get symbol 'custom-set) #'set-default)) + (getter (or (get symbol 'custom-get) #'symbol-value)) + (value (condition-case nil + (funcall getter symbol) + (void-variable (error "`%s' is not bound" symbol)))) + (type (get symbol 'custom-type))) + (cond + ((eq type 'boolean)) + ((and (null type) + (yes-or-no-p + (format "`%s' doesn't have a type, and has the value %S. \ +Proceed to toggle?" symbol value)))) + ((yes-or-no-p + (format "`%s' is of type %s, and has the value %S. \ +Proceed to toggle?" + symbol type value))) + ((error "Abort toggling of option `%s'" symbol))) + (message "%s user options `%s'." + (if (funcall setter symbol (not value)) + "Enabled" "Disabled") + symbol))) + +;;;###autoload +(defalias 'toggle-option #'customize-toggle-option) + +;;;###autoload (defalias 'customize-variable-other-window 'customize-option-other-window) ;;;###autoload @@ -5389,9 +5425,49 @@ The following properties have special meanings for this widget: :hidden-states '(standard) :action #'custom-icon-action :custom-set #'custom-icon-set - :custom-reset-current #'custom-redraw) - ;; Not implemented yet. - ;; :custom-reset-saved 'custom-icon-reset-saved) + :custom-mark-to-save #'custom-icon-mark-to-save + :custom-reset-current #'custom-redraw + :custom-reset-saved #'custom-icon-reset-saved + :custom-state-set-and-redraw #'custom-icon-state-set-and-redraw + :custom-reset-standard #'custom-icon-reset-standard + :custom-mark-to-reset-standard #'custom-icon-mark-to-reset-standard) + +(defun custom-icon-mark-to-save (widget) + "Mark user customization for icon edited by WIDGET to be saved later." + (let* ((icon (widget-value widget)) + (value (custom--icons-widget-value + (car (widget-get widget :children))))) + (custom-push-theme 'theme-icon icon 'user 'set value))) + +(defun custom-icon-reset-saved (widget) + "Restore icon customized by WIDGET to the icon's default attributes. + +If there's a theme value for the icon, resets to that. Otherwise, resets to +its standard value." + (let* ((icon (widget-value widget))) + (custom-push-theme 'theme-icon icon 'user 'reset) + (custom-icon-state-set widget) + (custom-redraw widget))) + +(defun custom-icon-state-set-and-redraw (widget) + "Set state of icon widget WIDGET and redraw it with up-to-date settings." + (custom-icon-state-set widget) + (custom-redraw-magic widget)) + +(defun custom-icon-reset-standard (widget) + "Reset icon edited by WIDGET to its standard value." + (let* ((icon (widget-value widget)) + (themes (get icon 'theme-icon))) + (dolist (theme themes) + (custom-push-theme 'theme-icon icon (car theme) 'reset)) + (custom-save-all)) + (widget-put widget :custom-state 'unknown) + (custom-redraw widget)) + +(defun custom-icon-mark-to-reset-standard (widget) + "Reset icon edited by WIDGET to its standard value." + ;; Don't mark for now, there aren't that many icons. + (custom-icon-reset-standard widget)) (defvar custom-icon-extended-menu (let ((map (make-sparse-keymap))) @@ -5410,6 +5486,18 @@ The following properties have special meanings for this widget: :enable (memq (widget-get custom-actioned-widget :custom-state) '(modified changed)))) + (define-key-after map [custom-icon-reset-saved] + '(menu-item "Revert This Session's Customization" + custom-icon-reset-saved + :enable (memq + (widget-get custom-actioned-widget :custom-state) + '(modified set changed rogue)))) + (when (or custom-file init-file-user) + (define-key-after map [custom-icon-reset-standard] + '(menu-item "Erase Customization" custom-icon-reset-standard + :enable (memq + (widget-get custom-actioned-widget :custom-state) + '(modified set changed saved rogue))))) map) "A menu for `custom-icon' widgets. Used in `custom-icon-action' to show a menu to the user.") diff --git a/lisp/cus-face.el b/lisp/cus-face.el index 0c8b6b0b97c..47afa841f5e 100644 --- a/lisp/cus-face.el +++ b/lisp/cus-face.el @@ -32,7 +32,7 @@ (defun custom-declare-face (face spec doc &rest args) "Like `defface', but with FACE evaluated as a normal argument." (when (and doc - (not (stringp doc))) + (not (documentation-stringp doc))) (error "Invalid (or missing) doc string %S" doc)) (unless (get face 'face-defface-spec) (face-spec-set face (purecopy spec) 'face-defface-spec) diff --git a/lisp/cus-start.el b/lisp/cus-start.el index 36879029282..165296d2242 100644 --- a/lisp/cus-start.el +++ b/lisp/cus-start.el @@ -371,6 +371,7 @@ Leaving \"Default\" unchecked is equivalent with specifying a default of (auto-save-timeout auto-save (choice (const :tag "off" nil) (integer :format "%v"))) (echo-keystrokes minibuffer number) + (echo-keystrokes-help minibuffer boolean "30.1") (polling-period keyboard float) (double-click-time mouse (restricted-sexp :match-alternatives (integerp 'nil 't))) @@ -606,6 +607,8 @@ This should only be chosen under exceptional circumstances, since it could result in memory overflow and make Emacs crash." nil)) "27.1") + ;; w32fns.c + (w32-follow-system-dark-mode display boolean "30.1") ;; window.c (temp-buffer-show-function windows (choice (const nil) function)) (next-screen-context-lines windows integer) @@ -843,6 +846,8 @@ since it could result in memory overflow and make Emacs crash." (x-select-enable-clipboard-manager killing boolean "24.1") ;; xsettings.c (font-use-system-font font-selection boolean "23.2") + ;; xwidget.c + (xwidget-webkit-disable-javascript xwidget boolean "30.1") ;; haikuterm.c (haiku-debug-on-fatal-error debug boolean "29.1") ;; haikufns.c @@ -903,6 +908,8 @@ since it could result in memory overflow and make Emacs crash." (symbol-name symbol)) ;; Any function from fontset.c will do. (fboundp 'new-fontset)) + ((string-match "xwidget-" (symbol-name symbol)) + (boundp 'xwidget-internal)) (t t)))) (if (not (boundp symbol)) ;; If variables are removed from C code, give an error here! diff --git a/lisp/descr-text.el b/lisp/descr-text.el index eeab995c37d..524a6474cd4 100644 --- a/lisp/descr-text.el +++ b/lisp/descr-text.el @@ -42,26 +42,6 @@ (insert-text-button "(widget)Top" 'type 'help-info 'help-args '("(widget)Top"))) -(defun describe-text-sexp (sexp) - "Insert a short description of SEXP in the current buffer." - (let ((pp (condition-case signal - (pp-to-string sexp) - (error (prin1-to-string signal))))) - (when (string-match-p "\n\\'" pp) - (setq pp (substring pp 0 (1- (length pp))))) - - (if (and (not (string-search "\n" pp)) - (<= (length pp) (- (window-width) (current-column)))) - (insert pp) - (insert-text-button - "[Show]" - 'follow-link t - 'action (lambda (&rest _ignore) - (with-output-to-temp-buffer - "*Pp Eval Output*" - (princ pp))) - 'help-echo "mouse-2, RET: pretty print value in another buffer")))) - (defun describe-property-list (properties) "Insert a description of PROPERTIES in the current buffer. PROPERTIES should be a list of overlay or text properties. @@ -92,7 +72,9 @@ into help buttons that call `describe-text-category' or (format "%S" value) 'type 'help-face 'help-args (list value))) (t - (describe-text-sexp value)))) + (require 'pp) + (declare-function pp-insert-short-sexp "pp" (sexp &optional width)) + (pp-insert-short-sexp value)))) (insert "\n"))) ;;; Describe-Text Commands. @@ -522,24 +504,24 @@ The character information includes: (setcar composition (concat " with the surrounding characters \"" - (mapconcat 'describe-char-padded-string - (buffer-substring from pos) "") + (mapconcat #'describe-char-padded-string + (buffer-substring from pos)) "\" and \"" - (mapconcat 'describe-char-padded-string - (buffer-substring (1+ pos) to) "") + (mapconcat #'describe-char-padded-string + (buffer-substring (1+ pos) to)) "\"")) (setcar composition (concat " with the preceding character(s) \"" - (mapconcat 'describe-char-padded-string - (buffer-substring from pos) "") + (mapconcat #'describe-char-padded-string + (buffer-substring from pos)) "\""))) (if (< (1+ pos) to) (setcar composition (concat " with the following character(s) \"" - (mapconcat 'describe-char-padded-string - (buffer-substring (1+ pos) to) "") + (mapconcat #'describe-char-padded-string + (buffer-substring (1+ pos) to)) "\"")) (setcar composition nil))) (setcar (cdr composition) @@ -568,7 +550,7 @@ The character information includes: ("character" ,(format "%s (displayed as %s) (codepoint %d, #o%o, #x%x)" char-description - (apply 'propertize char-description + (apply #'propertize char-description (text-properties-at pos)) char char char)) ("charset" @@ -620,7 +602,7 @@ The character information includes: (if (consp key-list) (list "type" (concat "\"" - (mapconcat 'identity + (mapconcat #'identity key-list "\" or \"") "\"") "with" @@ -721,7 +703,7 @@ The character information includes: (let ((unicodedata (describe-char-unicode-data char))) (if unicodedata (cons (list "Unicode data" "") unicodedata)))))) - (setq max-width (apply 'max (mapcar (lambda (x) + (setq max-width (apply #'max (mapcar (lambda (x) (if (cadr x) (length (car x)) 0)) item-list))) (set-buffer src-buf) @@ -736,7 +718,7 @@ The character information includes: (dolist (clm (cdr elt)) (cond ((eq (car-safe clm) 'insert-text-button) (insert " ") - (eval clm)) + (eval clm t)) ((not (zerop (length clm))) (insert " " clm)))) (insert "\n")))) @@ -855,7 +837,7 @@ The character information includes: (insert "\n") (dolist (elt (cond ((eq describe-char-unidata-list t) - (nreverse (mapcar 'car char-code-property-alist))) + (nreverse (mapcar #'car char-code-property-alist))) ((< char 32) ;; Temporary fix (2016-05-22): The ;; decomposition item for \n corrupts the @@ -898,7 +880,7 @@ characters." (setq width (- width (length (car last)) 1))) (let ((ellipsis (and (cdr last) "..."))) (setcdr last nil) - (concat (mapconcat 'identity words " ") ellipsis))) + (concat (mapconcat #'identity words " ") ellipsis))) ""))) (defun describe-char-eldoc--format (ch &optional width) diff --git a/lisp/desktop.el b/lisp/desktop.el index ff113c85e12..3fa09ce6a41 100644 --- a/lisp/desktop.el +++ b/lisp/desktop.el @@ -163,13 +163,22 @@ Used at desktop read to provide backward compatibility.") (define-minor-mode desktop-save-mode "Toggle desktop saving (Desktop Save mode). -When Desktop Save mode is enabled, the state of Emacs is saved from -one session to another. In particular, Emacs will save the desktop when -it exits (this may prompt you; see the option `desktop-save'). The next -time Emacs starts, if this mode is active it will restore the desktop. +When Desktop Save mode is enabled, the state of Emacs is saved from one +session to another. The saved Emacs \"desktop configuration\" includes the +buffers, their file names, major modes, buffer positions, window and frame +configuration, and some important global variables. -To manually save the desktop at any time, use the command `\\[desktop-save]'. -To load it, use `\\[desktop-read]'. +To enable this feature for future sessions, customize `desktop-save-mode' +to t, or add this line in your init file: + + (desktop-save-mode 1) + +When this mode is enabled, Emacs will save the desktop when it exits +(this may prompt you, see the option `desktop-save'). The next time +Emacs starts, if this mode is active it will restore the desktop. + +To manually save the desktop at any time, use the command \\[desktop-save]. +To load it, use \\[desktop-read]. Once a desktop file exists, Emacs will auto-save it according to the option `desktop-auto-save-timeout'. diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index f091101ea27..a2ce3083cfe 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -1467,7 +1467,7 @@ With a prefix argument, kill that many lines starting with the current line. (defun dired-do-kill-lines (&optional arg fmt init-count) "Remove all marked lines, or the next ARG lines. The files or directories on those lines are _not_ deleted. Only the -Dired listing is affected. To restore the removals, use `\\[revert-buffer]'. +Dired listing is affected. To restore the removals, use \\[revert-buffer]. With a numeric prefix arg, remove that many lines going forward, starting with the current line. (A negative prefix arg removes lines @@ -2871,7 +2871,7 @@ similar to the \"-d\" option for the \"cp\" shell command. But if `dired-copy-dereference' is non-nil, the symbolic links are dereferenced and then copied, similar to the \"-L\" option for the \"cp\" shell command. If ARG is a cons with -element 4 (`\\[universal-argument]'), the inverted value of +element 4 (\\[universal-argument]), the inverted value of `dired-copy-dereference' will be used. Also see `dired-do-revert-buffer'." diff --git a/lisp/dired-x.el b/lisp/dired-x.el index 62fdd916e69..753d3054d2f 100644 --- a/lisp/dired-x.el +++ b/lisp/dired-x.el @@ -77,12 +77,17 @@ files not writable by you are visited read-only." (other :tag "non-writable only" if-file-read-only)) :group 'dired-x) -(defcustom dired-omit-size-limit 100000 - "Maximum size for the \"omitting\" feature. +(defcustom dired-omit-size-limit 300000 + "Maximum buffer size for `dired-omit-mode'. + +Omitting will be disabled if the directory listing exceeds this size in +bytes. This variable is ignored when `dired-omit-mode' is called +interactively. + If nil, there is no maximum size." :type '(choice (const :tag "no maximum" nil) integer) :group 'dired-x - :version "29.1") + :version "30.1") (defcustom dired-omit-case-fold 'filesystem "Determine whether \"omitting\" patterns are case-sensitive. @@ -506,14 +511,23 @@ status message." (re-search-forward dired-re-mark nil t)))) count))) +(defvar dired-omit--extension-regexp-cache + nil + "A cache of `regexp-opt' applied to `dired-omit-extensions'. + +This is a cons whose car is a list of strings and whose cdr is a +regexp produced by `regexp-opt'.") + (defun dired-omit-regexp () + (unless (equal dired-omit-extensions (car dired-omit--extension-regexp-cache)) + (setq dired-omit--extension-regexp-cache + (cons dired-omit-extensions (regexp-opt dired-omit-extensions)))) (concat (if dired-omit-files (concat "\\(" dired-omit-files "\\)") "") (if (and dired-omit-files dired-omit-extensions) "\\|" "") (if dired-omit-extensions (concat ".";; a non-extension part should exist - "\\(" - (mapconcat 'regexp-quote dired-omit-extensions "\\|") - "\\)$") + (cdr dired-omit--extension-regexp-cache) + "$") ""))) ;; Returns t if any work was done, nil otherwise. diff --git a/lisp/dired.el b/lisp/dired.el index 69fa15dde73..9e3b888df14 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -2817,7 +2817,9 @@ is controlled by `dired-movement-style'." (dired--trivial-next-line arg))) (defun dired--move-to-next-line (arg jumpfun) - (let ((old-position (progn + (let ((wrapped nil) + (old-arg arg) + (old-position (progn ;; It's always true that we should move ;; to the filename when possible. (dired-move-to-filename) @@ -2832,16 +2834,27 @@ is controlled by `dired-movement-style'." (when (= old-position (point)) ;; Now point is at beginning/end of movable area, ;; but it still wants to move farther. - (if (eq dired-movement-style 'cycle) - ;; `cycle': go to the other end. + (cond + ;; `cycle': go to the other end. + ((eq dired-movement-style 'cycle) + ;; Argument not changing on the second wrap + ;; means infinite loop with no files found. + (if (and wrapped (eq old-arg arg)) + (setq arg 0) (goto-char (if (cl-plusp moving-down) (point-min) - (point-max))) - ;; `bounded': go back to the last non-empty line. - (while (dired-between-files) - (funcall jumpfun (- moving-down))) + (point-max)))) + (setq wrapped t)) + ;; `bounded': go back to the last non-empty line. + ((eq dired-movement-style 'bounded) + (while (and (dired-between-files) (not (zerop arg))) + (funcall jumpfun (- moving-down)) + ;; Point not moving means infinite loop. + (if (= old-position (point)) + (setq arg 0) + (setq old-position (point)))) ;; Encountered a boundary, so let's stop movement. - (setq arg moving-down))) + (setq arg (if (dired-between-files) 0 moving-down))))) (unless (dired-between-files) ;; Has moved to a non-empty line. This movement does ;; make sense. @@ -4308,6 +4321,11 @@ this subdir." (prefix-numeric-value arg) (lambda () (when (or (not (looking-at-p dired-re-dot)) + ;; Don't skip symlinks to ".", "..", etc. + (save-excursion + (re-search-forward + dired-permission-flags-regexp nil t) + (eq (char-after (match-beginning 1)) ?l)) (not (equal dired-marker-char dired-del-marker))) (delete-char 1) (insert dired-marker-char)))))))) diff --git a/lisp/dnd.el b/lisp/dnd.el index 22cb18359a3..1fc1ab45b84 100644 --- a/lisp/dnd.el +++ b/lisp/dnd.el @@ -453,7 +453,10 @@ on FRAME itself. This function might return immediately if no mouse buttons are currently being held down. It should only be called upon a -`down-mouse-1' (or similar) event." +`down-mouse-1' (or similar) event. + +This function is only supported on X Windows, macOS/GNUstep, and Haiku; +on all other platforms it will signal an error." (unless (fboundp 'x-begin-drag) (error "Dragging text from Emacs is not supported by this window system")) (gui-set-selection 'XdndSelection text) @@ -513,7 +516,10 @@ nil, any drops on FRAME itself will be ignored. This function might return immediately if no mouse buttons are currently being held down. It should only be called upon a -`down-mouse-1' (or similar) event." +`down-mouse-1' (or similar) event. + +This function is only supported on X Windows, macOS/GNUstep, and Haiku; +on all other platforms it will signal an error." (unless (fboundp 'x-begin-drag) (error "Dragging files from Emacs is not supported by this window system")) (dnd-remove-last-dragged-remote-file) @@ -580,7 +586,10 @@ FRAME, ACTION and ALLOW-SAME-FRAME mean the same as in FILES is a list of files that will be dragged. If the drop target doesn't support dropping multiple files, the first file in -FILES will be dragged." +FILES will be dragged. + +This function is only supported on X Windows, macOS/GNUstep, and Haiku; +on all other platforms it will signal an error." (unless (fboundp 'x-begin-drag) (error "Dragging files from Emacs is not supported by this window system")) (dnd-remove-last-dragged-remote-file) diff --git a/lisp/dom.el b/lisp/dom.el index f7043ba8252..b329379fdc3 100644 --- a/lisp/dom.el +++ b/lisp/dom.el @@ -288,7 +288,7 @@ If XML, generate XML instead of HTML." (insert ">") (dolist (child children) (if (stringp child) - (insert child) + (insert (url-insert-entities-in-string child)) (setq non-text t) (when pretty (insert "\n" (make-string (+ column 2) ?\s))) diff --git a/lisp/edmacro.el b/lisp/edmacro.el index 362ec0ecbb4..abfc380d154 100644 --- a/lisp/edmacro.el +++ b/lisp/edmacro.el @@ -124,9 +124,9 @@ from `kmacro-edit-lossage'." (defun edit-kbd-macro (keys &optional prefix finish-hook store-hook) "Edit a keyboard macro. At the prompt, type any key sequence which is bound to a keyboard macro. -Or, type `\\[kmacro-end-and-call-macro]' or \\`RET' to edit the last -keyboard macro, `\\[view-lossage]' to edit the last 300 -keystrokes as a keyboard macro, or `\\[execute-extended-command]' +Or, type \\[kmacro-end-and-call-macro] or \\`RET' to edit the last +keyboard macro, \\[view-lossage] to edit the last 300 +keystrokes as a keyboard macro, or \\[execute-extended-command] to edit a macro by its command name. With a prefix argument, format the macro in a more concise way." (interactive @@ -720,17 +720,15 @@ This function assumes that the events can be stored in a string." (setf (aref seq i) (logand (aref seq i) 127))) seq) -;; These are needed in a --without-x build. -(defvar mouse-wheel-down-event) -(defvar mouse-wheel-up-event) -(defvar mouse-wheel-right-event) -(defvar mouse-wheel-left-event) - (defun edmacro-fix-menu-commands (macro &optional noerror) (if (vectorp macro) (let (result) ;; Not preloaded in a --without-x build. (require 'mwheel) + (defvar mouse-wheel-down-event) + (defvar mouse-wheel-up-event) + (defvar mouse-wheel-right-event) + (defvar mouse-wheel-left-event) ;; Make a list of the elements. (setq macro (append macro nil)) (dolist (ev macro) @@ -746,9 +744,9 @@ This function assumes that the events can be stored in a string." ;; info is recorded in macros to make this possible. ((or (mouse-event-p ev) (mouse-movement-p ev) (memq (event-basic-type ev) - (list mouse-wheel-down-event mouse-wheel-up-event - mouse-wheel-right-event - mouse-wheel-left-event))) + `( ,mouse-wheel-down-event ,mouse-wheel-up-event + ,mouse-wheel-right-event ,mouse-wheel-left-event + wheel-down wheel-up wheel-left wheel-right))) nil) (noerror nil) (t diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 9489a9fd1b3..752660156b9 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -2042,8 +2042,6 @@ in that CLASS." function class name))) (error "ad-remove-advice: `%s' is not advised" function))) -(declare-function comp-subr-trampoline-install "comp-run") - ;;;###autoload (defun ad-add-advice (function advice class position) "Add a piece of ADVICE to FUNCTION's list of advices in CLASS. diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el index 73745e8c7ac..42ba89ba2c1 100644 --- a/lisp/emacs-lisp/bindat.el +++ b/lisp/emacs-lisp/bindat.el @@ -204,6 +204,9 @@ ('str (bindat--unpack-str len)) ('strz (bindat--unpack-strz len)) ('vec + (when (> len (length bindat-raw)) + (error "Vector length %d is greater than raw data length %d" + len (length bindat-raw))) (let ((v (make-vector len 0)) (vlen 1)) (if (consp vectype) (setq vlen (nth 1 vectype) @@ -941,9 +944,13 @@ a bindat type expression." (bindat-defmacro sint (bitlen le) "Signed integer of size BITLEN. Big-endian if LE is nil and little-endian if not." + (unless lexical-binding + (error "The `sint' type requires 'lexical-binding'")) (let ((bl (make-symbol "bitlen")) (max (make-symbol "max")) (wrap (make-symbol "wrap"))) + ;; FIXME: This `let*' around the `struct' results in code which the + ;; byte-compiler does not handle efficiently. 🙁 `(let* ((,bl ,bitlen) (,max (ash 1 (1- ,bl))) (,wrap (+ ,max ,max))) diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index add13a5c312..ea163723a3e 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -482,9 +482,6 @@ There can be multiple entries for the same NAME if it has several aliases.") (push name byte-optimize--dynamic-vars) `(,fn ,name . ,optimized-rest))) - (`(,(pred byte-code-function-p) . ,exps) - (cons fn (mapcar #'byte-optimize-form exps))) - ((guard (when for-effect (if-let ((tmp (byte-opt--fget fn 'side-effect-free))) (or byte-compile-delete-errors @@ -1448,7 +1445,8 @@ See Info node `(elisp) Integer Basics'." (defun byte-optimize-apply (form) (let ((len (length form))) - (if (>= len 2) + ;; Single-arg `apply' is an abomination that we don't bother optimizing. + (if (> len 2) (let ((fn (nth 1 form)) (last (nth (1- len) form))) (cond @@ -1774,7 +1772,7 @@ See Info node `(elisp) Integer Basics'." string-version-lessp substring substring-no-properties sxhash-eq sxhash-eql sxhash-equal sxhash-equal-including-properties - take vconcat + take value< vconcat ;; frame.c frame-ancestor-p frame-bottom-divider-width frame-char-height frame-char-width frame-child-frame-border-width frame-focus @@ -1975,7 +1973,7 @@ See Info node `(elisp) Integer Basics'." hash-table-p identity length length< length= length> member memq memql nth nthcdr proper-list-p rassoc rassq safe-length string-bytes string-distance string-equal string-lessp - string-search string-version-lessp take + string-search string-version-lessp take value< ;; search.c regexp-quote ;; syntax.c @@ -3115,7 +3113,6 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; (eval-when-compile (or (compiled-function-p (symbol-function 'byte-optimize-form)) - (assq 'byte-code (symbol-function 'byte-optimize-form)) (let ((byte-optimize nil) (byte-compile-warnings nil)) (mapc (lambda (x) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 1ef3f0fba6d..2b5eb34e571 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -231,17 +231,8 @@ This includes variable references and calls to functions such as `car'." :type 'boolean) (defvar byte-compile-dynamic nil - "If non-nil, compile function bodies so they load lazily. -They are hidden in comments in the compiled file, -and each one is brought into core when the -function is called. - -To enable this option, make it a file-local variable -in the source file you want it to apply to. -For example, add -*-byte-compile-dynamic: t;-*- on the first line. - -When this option is true, if you load the compiled file and then move it, -the functions you loaded will not be able to run.") + "Formerly used to compile function bodies so they load lazily. +This variable no longer has any effect.") (make-obsolete-variable 'byte-compile-dynamic "not worthwhile any more." "27.1") ;;;###autoload(put 'byte-compile-dynamic 'safe-local-variable 'booleanp) @@ -262,7 +253,7 @@ This option is enabled by default because it reduces Emacs memory usage." :type 'boolean) ;;;###autoload(put 'byte-compile-dynamic-docstrings 'safe-local-variable 'booleanp) -(defconst byte-compile-log-buffer "*Compile-Log*" +(defvar byte-compile-log-buffer "*Compile-Log*" "Name of the byte-compiler's log buffer.") (defvar byte-compile--known-dynamic-vars nil @@ -294,6 +285,7 @@ The information is logged to `byte-compile-log-buffer'." (defconst byte-compile-warning-types '( callargs constants docstrings docstrings-non-ascii-quotes docstrings-wide + docstrings-control-chars empty-body free-vars ignored-return-value interactive-only lexical lexical-dynamic make-local mapcar ; obsolete @@ -316,6 +308,8 @@ Elements of the list may be: docstrings that are too wide, containing lines longer than both `byte-compile-docstring-max-column' and `fill-column' characters. Only enabled when `docstrings' also is. + docstrings-control-chars + docstrings that contain control characters other than NL and TAB empty-body body argument to a special form or macro is empty. free-vars references to variables not in the current lexical scope. ignored-return-value @@ -354,7 +348,7 @@ A value of `all' really means all." '(docstrings-non-ascii-quotes) "List of warning types that are only enabled during Emacs builds. This is typically either warning types that are being phased in -(but shouldn't be enabled for packages yet), or that are only relevant +\(but shouldn't be enabled for packages yet), or that are only relevant for the Emacs build itself.") (defvar byte-compile--suppressed-warnings nil @@ -1749,68 +1743,100 @@ Also ignore URLs." The byte-compiler will emit a warning for documentation strings containing lines wider than this. If `fill-column' has a larger value, it will override this variable." - :group 'bytecomp :type 'natnum :safe #'natnump :version "28.1") -(define-obsolete-function-alias 'byte-compile-docstring-length-warn - 'byte-compile-docstring-style-warn "29.1") - -(defun byte-compile-docstring-style-warn (form) - "Warn if there are stylistic problems with the docstring in FORM. -Warn if documentation string of FORM is too wide. +(defun byte-compile--list-with-n (list n elem) + "Return LIST with its Nth element replaced by ELEM." + (if (eq elem (nth n list)) + list + (nconc (take n list) + (list elem) + (nthcdr (1+ n) list)))) + +(defun byte-compile--docstring-style-warn (docs kind name) + "Warn if there are stylistic problems in the docstring DOCS. +Warn if documentation string is too wide. It is too wide if it has any lines longer than the largest of `fill-column' and `byte-compile-docstring-max-column'." (when (byte-compile-warning-enabled-p 'docstrings) - (let* ((kind nil) (name nil) (docs nil) + (let* ((name (if (eq (car-safe name) 'quote) (cadr name) name)) (prefix (lambda () (format "%s%s" kind - (if name (format-message " `%s' " name) ""))))) - (pcase (car form) - ((or 'autoload 'custom-declare-variable 'defalias - 'defconst 'define-abbrev-table - 'defvar 'defvaralias - 'custom-declare-face) - (setq kind (nth 0 form)) - (setq name (nth 1 form)) - (when (and (consp name) (eq (car name) 'quote)) - (setq name (cadr name))) - (setq docs (nth 3 form))) - ('lambda - (setq kind "") ; can't be "function", unfortunately - (setq docs (nth 2 form)))) - (when (and kind docs (stringp docs)) - (let ((col (max byte-compile-docstring-max-column fill-column))) - (when (and (byte-compile-warning-enabled-p 'docstrings-wide) - (byte-compile--wide-docstring-p docs col)) - (byte-compile-warn-x - name - "%sdocstring wider than %s characters" (funcall prefix) col))) - ;; There's a "naked" ' character before a symbol/list, so it - ;; should probably be quoted with \=. - (when (string-match-p (rx (| (in " \t") bol) - (? (in "\"#")) - "'" - (in "A-Za-z" "(")) + (if name (format-message " `%S' " name) ""))))) + (let ((col (max byte-compile-docstring-max-column fill-column))) + (when (and (byte-compile-warning-enabled-p 'docstrings-wide) + (byte-compile--wide-docstring-p docs col)) + (byte-compile-warn-x + name + "%sdocstring wider than %s characters" (funcall prefix) col))) + + (when (byte-compile-warning-enabled-p 'docstrings-control-chars) + (let ((start 0) + (len (length docs))) + (while (and (< start len) + (string-match (rx (intersection (in (0 . 31) 127) + (not (in "\n\t")))) + docs start)) + (let* ((ofs (match-beginning 0)) + (c (aref docs ofs))) + ;; FIXME: it should be possible to use the exact source position + ;; of the control char in most cases, and it would be helpful + (byte-compile-warn-x + name + "%sdocstring contains control char #x%02x (position %d)" + (funcall prefix) c ofs) + (setq start (1+ ofs)))))) + + ;; There's a "naked" ' character before a symbol/list, so it + ;; should probably be quoted with \=. + (when (string-match-p (rx (| (in " \t") bol) + (? (in "\"#")) + "'" + (in "A-Za-z" "(")) + docs) + (byte-compile-warn-x + name + (concat "%sdocstring has wrong usage of unescaped single quotes" + " (use \\=%c or different quoting such as %c...%c)") + (funcall prefix) ?' ?` ?')) + ;; There's a "Unicode quote" in the string -- it should probably + ;; be an ASCII one instead. + (when (byte-compile-warning-enabled-p 'docstrings-non-ascii-quotes) + (when (string-match-p (rx (| " \"" (in " \t") bol) + (in "‘’")) docs) (byte-compile-warn-x name - (concat "%sdocstring has wrong usage of unescaped single quotes" - " (use \\=%c or different quoting such as %c...%c)") - (funcall prefix) ?' ?` ?')) - ;; There's a "Unicode quote" in the string -- it should probably - ;; be an ASCII one instead. - (when (byte-compile-warning-enabled-p 'docstrings-non-ascii-quotes) - (when (string-match-p (rx (| " \"" (in " \t") bol) - (in "‘’")) - docs) - (byte-compile-warn-x - name - "%sdocstring uses curved single quotes; use %s instead of ‘...’" - (funcall prefix) "`...'")))))) - form) + "%sdocstring uses curved single quotes; use %s instead of ‘...’" + (funcall prefix) "`...'")))))) + +(defvar byte-compile--\#$) ; Special value that will print as `#$'. +(defvar byte-compile--docstrings nil "Table of already compiled docstrings.") + +(defun byte-compile--docstring (doc kind name &optional is-a-value) + (byte-compile--docstring-style-warn doc kind name) + ;; Make docstrings dynamic, when applicable. + (cond + ((and byte-compile-dynamic-docstrings + ;; The native compiler doesn't use those dynamic docstrings. + (not byte-native-compiling) + ;; Docstrings can only be dynamic when compiling a file. + byte-compile--\#$) + (let* ((byte-pos (with-memoization + ;; Reuse a previously written identical docstring. + ;; This is not done out of thriftiness but to try and + ;; make sure that "equal" functions remain `equal'. + ;; (Often those identical docstrings come from + ;; `help-add-fundoc-usage'). + ;; Needed e.g. for `advice-tests-nadvice'. + (gethash doc byte-compile--docstrings) + (byte-compile-output-as-comment doc nil))) + (newdoc (cons byte-compile--\#$ byte-pos))) + (if is-a-value newdoc (macroexp-quote newdoc)))) + (t doc))) ;; If we have compiled any calls to functions which are not known to be ;; defined, issue a warning enumerating them. @@ -1845,6 +1871,8 @@ It is too wide if it has any lines longer than the largest of ;; macroenvironment. (copy-alist byte-compile-initial-macro-environment)) (byte-compile--outbuffer nil) + (byte-compile--\#$ nil) + (byte-compile--docstrings (make-hash-table :test 'equal)) (overriding-plist-environment nil) (byte-compile-function-environment nil) (byte-compile-bound-variables nil) @@ -1858,7 +1886,6 @@ It is too wide if it has any lines longer than the largest of ;; (byte-compile-verbose byte-compile-verbose) (byte-optimize byte-optimize) - (byte-compile-dynamic byte-compile-dynamic) (byte-compile-dynamic-docstrings byte-compile-dynamic-docstrings) (byte-compile-warnings byte-compile-warnings) @@ -1874,39 +1901,44 @@ It is too wide if it has any lines longer than the largest of (setq byte-to-native-plist-environment overriding-plist-environment))))) -(defmacro displaying-byte-compile-warnings (&rest body) +(defmacro displaying-byte-compile-warnings (&rest body) ;FIXME: namespace! (declare (debug (def-body))) `(bytecomp--displaying-warnings (lambda () ,@body))) (defun bytecomp--displaying-warnings (body-fn) - (let* ((warning-series-started + (let* ((wrapped-body + (lambda () + (if byte-compile-debug + (funcall body-fn) + ;; Use a `handler-bind' to remember the `byte-compile-form-stack' + ;; active at the time the error is signaled, so as to + ;; get more precise error locations. + (let ((form-stack nil)) + (condition-case error-info + (handler-bind + ((error (lambda (_err) + (setq form-stack byte-compile-form-stack)))) + (funcall body-fn)) + (error (let ((byte-compile-form-stack form-stack)) + (byte-compile-report-error error-info)))))))) + (warning-series-started (and (markerp warning-series) (eq (marker-buffer warning-series) (get-buffer byte-compile-log-buffer)))) (byte-compile-form-stack byte-compile-form-stack)) - (if (or (eq warning-series 'byte-compile-warning-series) + (if (or (eq warning-series #'byte-compile-warning-series) warning-series-started) ;; warning-series does come from compilation, ;; so don't bind it, but maybe do set it. - (let (tem) - ;; Log the file name. Record position of that text. - (setq tem (byte-compile-log-file)) + (let ((tem (byte-compile-log-file))) ;; Log the file name. (unless warning-series-started - (setq warning-series (or tem 'byte-compile-warning-series))) - (if byte-compile-debug - (funcall body-fn) - (condition-case error-info - (funcall body-fn) - (error (byte-compile-report-error error-info))))) + (setq warning-series (or tem #'byte-compile-warning-series))) + (funcall wrapped-body)) ;; warning-series does not come from compilation, so bind it. (let ((warning-series ;; Log the file name. Record position of that text. - (or (byte-compile-log-file) 'byte-compile-warning-series))) - (if byte-compile-debug - (funcall body-fn) - (condition-case error-info - (funcall body-fn) - (error (byte-compile-report-error error-info)))))))) + (or (byte-compile-log-file) #'byte-compile-warning-series))) + (funcall wrapped-body))))) ;;;###autoload (defun byte-force-recompile (directory) @@ -2368,7 +2400,12 @@ With argument ARG, insert value in current buffer after the form." (setq case-fold-search nil)) (displaying-byte-compile-warnings (with-current-buffer inbuffer - (when byte-compile-current-file + (when byte-compile-dest-file + (setq byte-compile--\#$ + (copy-sequence ;It needs to be a fresh new object. + ;; Also it stands for the `load-file-name' when the `.elc' will + ;; be loaded, so make it look like it. + byte-compile-dest-file)) (byte-compile-insert-header byte-compile-current-file byte-compile--outbuffer) ;; Instruct native-comp to ignore this file. @@ -2423,8 +2460,7 @@ With argument ARG, insert value in current buffer after the form." (defun byte-compile-insert-header (_filename outbuffer) "Insert a header at the start of OUTBUFFER. Call from the source buffer." - (let ((dynamic byte-compile-dynamic) - (optimize byte-optimize)) + (let ((optimize byte-optimize)) (with-current-buffer outbuffer (goto-char (point-min)) ;; The magic number of .elc files is ";ELC", or 0x3B454C43. After @@ -2458,18 +2494,11 @@ Call from the source buffer." ((eq optimize 'byte) " byte-level optimization only") (optimize " all optimizations") (t "out optimization")) - ".\n" - (if dynamic ";;; Function definitions are lazy-loaded.\n" - "") - "\n\n")))) + ".\n\n\n")))) (defun byte-compile-output-file-form (form) ;; Write the given form to the output buffer, being careful of docstrings - ;; (for `byte-compile-dynamic-docstrings') in defvar, defvaralias, - ;; defconst, autoload, and custom-declare-variable. - ;; defalias calls are output directly by byte-compile-file-form-defmumble; - ;; it does not pay to first build the defalias in defmumble and then parse - ;; it here. + ;; (for `byte-compile-dynamic-docstrings'). (when byte-native-compiling ;; Spill output for the native compiler here (push (make-byte-to-native-top-level :form form :lexical lexical-binding) @@ -2479,152 +2508,17 @@ Call from the source buffer." (print-level nil) (print-quoted t) (print-gensym t) - (print-circle t)) ; Handle circular data structures. - (if (memq (car-safe form) '(defvar defvaralias defconst - autoload custom-declare-variable)) - (byte-compile-output-docform nil nil nil '("\n(" ")") form nil 3 nil - (memq (car form) - '(defvaralias autoload - custom-declare-variable))) - (princ "\n" byte-compile--outbuffer) - (prin1 form byte-compile--outbuffer) - nil))) + (print-circle t) + (print-continuous-numbering t) + (print-number-table (make-hash-table :test #'eq))) + (when byte-compile--\#$ + (puthash byte-compile--\#$ "#$" print-number-table)) + (princ "\n" byte-compile--outbuffer) + (prin1 form byte-compile--outbuffer) + nil)) (defvar byte-compile--for-effect) -(defun byte-compile--output-docform-recurse - (info position form cvecindex docindex specindex quoted) - "Print a form with a doc string. INFO is (prefix postfix). -POSITION is where the next doc string is to be inserted. -CVECINDEX is the index in the FORM of the constant vector, or nil. -DOCINDEX is the index of the doc string (or nil) in the FORM. -If SPECINDEX is non-nil, it is the index in FORM -of the function bytecode string. In that case, -we output that argument and the following argument -\(the constants vector) together, for lazy loading. -QUOTED says that we have to put a quote before the -list that represents a doc string reference. -`defvaralias', `autoload' and `custom-declare-variable' need that. - -Return the position after any inserted docstrings as comments." - (let ((index 0) - doc-string-position) - ;; Insert the doc string, and make it a comment with #@LENGTH. - (when (and byte-compile-dynamic-docstrings - (stringp (nth docindex form))) - (goto-char position) - (setq doc-string-position - (byte-compile-output-as-comment - (nth docindex form) nil) - position (point)) - (goto-char (point-max))) - - (insert (car info)) - (prin1 (car form) byte-compile--outbuffer) - (while (setq form (cdr form)) - (setq index (1+ index)) - (insert " ") - (cond ((and (numberp specindex) (= index specindex) - ;; Don't handle the definition dynamically - ;; if it refers (or might refer) - ;; to objects already output - ;; (for instance, gensyms in the arg list). - (let (non-nil) - (when (hash-table-p print-number-table) - (maphash (lambda (_k v) (if v (setq non-nil t))) - print-number-table)) - (not non-nil))) - ;; Output the byte code and constants specially - ;; for lazy dynamic loading. - (goto-char position) - (let ((lazy-position (byte-compile-output-as-comment - (cons (car form) (nth 1 form)) - t))) - (setq position (point)) - (goto-char (point-max)) - (princ (format "(#$ . %d) nil" lazy-position) - byte-compile--outbuffer) - (setq form (cdr form)) - (setq index (1+ index)))) - ((eq index cvecindex) - (let* ((cvec (car form)) - (len (length cvec)) - (index2 0) - elt) - (insert "[") - (while (< index2 len) - (setq elt (aref cvec index2)) - (if (byte-code-function-p elt) - (setq position - (byte-compile--output-docform-recurse - '("#[" "]") position - (append elt nil) ; Convert the vector to a list. - 2 4 specindex nil)) - (prin1 elt byte-compile--outbuffer)) - (setq index2 (1+ index2)) - (unless (eq index2 len) - (insert " "))) - (insert "]"))) - ((= index docindex) - (cond - (doc-string-position - (princ (format (if quoted "'(#$ . %d)" "(#$ . %d)") - doc-string-position) - byte-compile--outbuffer)) - ((stringp (car form)) - (let ((print-escape-newlines nil)) - (goto-char (prog1 (1+ (point)) - (prin1 (car form) - byte-compile--outbuffer))) - (insert "\\\n") - (goto-char (point-max)))) - (t (prin1 (car form) byte-compile--outbuffer)))) - (t (prin1 (car form) byte-compile--outbuffer)))) - (insert (cadr info)) - position)) - -(defun byte-compile-output-docform (preface tailpiece name info form - cvecindex docindex - specindex quoted) - "Print a form with a doc string. INFO is (prefix postfix). -If PREFACE, NAME, and TAILPIECE are non-nil, print them too, -before/after INFO and the FORM but after the doc string itself. -CVECINDEX is the index in the FORM of the constant vector, or nil. -DOCINDEX is the index of the doc string (or nil) in the FORM. -If SPECINDEX is non-nil, it is the index in FORM -of the function bytecode string. In that case, -we output that argument and the following argument -\(the constants vector) together, for lazy loading. -QUOTED says that we have to put a quote before the -list that represents a doc string reference. -`defvaralias', `autoload' and `custom-declare-variable' need that." - ;; We need to examine byte-compile-dynamic-docstrings - ;; in the input buffer (now current), not in the output buffer. - (let ((byte-compile-dynamic-docstrings byte-compile-dynamic-docstrings)) - (with-current-buffer byte-compile--outbuffer - (let ((position (point)) - (print-continuous-numbering t) - print-number-table - ;; FIXME: The bindings below are only needed for when we're - ;; called from ...-defmumble. - (print-escape-newlines t) - (print-length nil) - (print-level nil) - (print-quoted t) - (print-gensym t) - (print-circle t)) ; Handle circular data structures. - (when preface - ;; FIXME: We don't handle uninterned names correctly. - ;; E.g. if cl-define-compiler-macro uses uninterned name we get: - ;; (defalias '#1=#:foo--cmacro #[514 ...]) - ;; (put 'foo 'compiler-macro '#:foo--cmacro) - (insert preface) - (prin1 name byte-compile--outbuffer)) - (byte-compile--output-docform-recurse - info position form cvecindex docindex specindex quoted) - (when tailpiece - (insert tailpiece)))))) - (defun byte-compile-keep-pending (form &optional handler) (if (memq byte-optimize '(t source)) (setq form (byte-optimize-one-form form t))) @@ -2644,7 +2538,7 @@ list that represents a doc string reference. (if byte-compile-output (let ((form (byte-compile-out-toplevel t 'file))) (cond ((eq (car-safe form) 'progn) - (mapc 'byte-compile-output-file-form (cdr form))) + (mapc #'byte-compile-output-file-form (cdr form))) (form (byte-compile-output-file-form form))) (setq byte-compile-constants nil @@ -2719,12 +2613,12 @@ list that represents a doc string reference. (setq byte-compile-unresolved-functions (delq (assq funsym byte-compile-unresolved-functions) byte-compile-unresolved-functions))))) - (if (stringp (nth 3 form)) - (prog1 - form - (byte-compile-docstring-style-warn form)) - ;; No doc string, so we can compile this as a normal form. - (byte-compile-keep-pending form 'byte-compile-normal-call))) + (let* ((doc (nth 3 form)) + (newdoc (if (not (stringp doc)) doc + (byte-compile--docstring + doc 'autoload (nth 1 form))))) + (byte-compile-keep-pending (byte-compile--list-with-n form 3 newdoc) + #'byte-compile-normal-call))) (put 'defvar 'byte-hunk-handler 'byte-compile-file-form-defvar) (put 'defconst 'byte-hunk-handler 'byte-compile-file-form-defvar) @@ -2736,9 +2630,10 @@ list that represents a doc string reference. (byte-compile-warn-x sym "global/dynamic var `%s' lacks a prefix" sym))) -(defun byte-compile--declare-var (sym) +(defun byte-compile--declare-var (sym &optional not-toplevel) (byte-compile--check-prefixed-var sym) - (when (memq sym byte-compile-lexical-variables) + (when (and (not not-toplevel) + (memq sym byte-compile-lexical-variables)) (setq byte-compile-lexical-variables (delq sym byte-compile-lexical-variables)) (when (byte-compile-warning-enabled-p 'lexical sym) @@ -2747,19 +2642,7 @@ list that represents a doc string reference. (push sym byte-compile--seen-defvars)) (defun byte-compile-file-form-defvar (form) - (let ((sym (nth 1 form))) - (byte-compile--declare-var sym) - (if (eq (car form) 'defconst) - (push sym byte-compile-const-variables))) - (if (and (null (cddr form)) ;No `value' provided. - (eq (car form) 'defvar)) ;Just a declaration. - nil - (byte-compile-docstring-style-warn form) - (setq form (copy-sequence form)) - (when (consp (nth 2 form)) - (setcar (cdr (cdr form)) - (byte-compile-top-level (nth 2 form) nil 'file))) - form)) + (byte-compile-defvar form 'toplevel)) (put 'define-abbrev-table 'byte-hunk-handler 'byte-compile-file-form-defvar-function) @@ -2767,26 +2650,37 @@ list that represents a doc string reference. (defun byte-compile-file-form-defvar-function (form) (pcase-let (((or `',name (let name nil)) (nth 1 form))) - (if name (byte-compile--declare-var name))) - ;; Variable aliases are better declared before the corresponding variable, - ;; since it makes it more likely that only one of the two vars has a value - ;; before the `defvaralias' gets executed, which avoids the need to - ;; merge values. - (pcase form - (`(defvaralias ,_ ',newname . ,_) - (when (memq newname byte-compile-bound-variables) - (if (byte-compile-warning-enabled-p 'suspicious) - (byte-compile-warn-x - newname - "Alias for `%S' should be declared before its referent" newname))))) - (byte-compile-docstring-style-warn form) - (byte-compile-keep-pending form)) + (if name (byte-compile--declare-var name)) + ;; Variable aliases are better declared before the corresponding variable, + ;; since it makes it more likely that only one of the two vars has a value + ;; before the `defvaralias' gets executed, which avoids the need to + ;; merge values. + (pcase form + (`(defvaralias ,_ ',newname . ,_) + (when (memq newname byte-compile-bound-variables) + (if (byte-compile-warning-enabled-p 'suspicious) + (byte-compile-warn-x + newname + "Alias for `%S' should be declared before its referent" + newname))))) + (let ((doc (nth 3 form))) + (when (stringp doc) + (setcar (nthcdr 3 form) + (byte-compile--docstring doc (nth 0 form) name)))) + (byte-compile-keep-pending form))) (put 'custom-declare-variable 'byte-hunk-handler 'byte-compile-file-form-defvar-function) (put 'custom-declare-face 'byte-hunk-handler - 'byte-compile-docstring-style-warn) + #'byte-compile--custom-declare-face) +(defun byte-compile--custom-declare-face (form) + (let ((kind (nth 0 form)) (name (nth 1 form)) (docs (nth 3 form))) + (when (stringp docs) + (let ((newdocs (byte-compile--docstring docs kind name))) + (unless (eq docs newdocs) + (setq form (byte-compile--list-with-n form 3 newdocs))))) + form)) (put 'require 'byte-hunk-handler 'byte-compile-file-form-require) (defun byte-compile-file-form-require (form) @@ -2940,34 +2834,24 @@ not to take responsibility for the actual compilation of the code." (cons (cons bare-name code) (symbol-value this-kind)))) - (if rest - ;; There are additional args to `defalias' (like maybe a docstring) - ;; that the code below can't handle: punt! - nil - ;; Otherwise, we have a bona-fide defun/defmacro definition, and use - ;; special code to allow dynamic docstrings and byte-code. - (byte-compile-flush-pending) + (byte-compile-flush-pending) + (let ((newform `(defalias ',bare-name + ,(if macro `'(macro . ,code) code) ,@rest))) (when byte-native-compiling - ;; Spill output for the native compiler here. + ;; Don't let `byte-compile-output-file-form' push the form to + ;; `byte-to-native-top-level-forms' because we want to use + ;; `make-byte-to-native-func-def' when possible. (push - (if macro + (if (or macro rest) (make-byte-to-native-top-level - :form `(defalias ',name '(macro . ,code) nil) + :form newform :lexical lexical-binding) (make-byte-to-native-func-def :name name :byte-func code)) byte-to-native-top-level-forms)) - ;; Output the form by hand, that's much simpler than having - ;; b-c-output-file-form analyze the defalias. - (byte-compile-output-docform - "\n(defalias '" ")" - bare-name - (if macro '(" '(macro . #[" "])") '(" #[" "]")) - (append code nil) ; Turn byte-code-function-p into list. - 2 4 - (and (atom code) byte-compile-dynamic 1) - nil) - t))))) + (let ((byte-native-compiling nil)) + (byte-compile-output-file-form newform))) + t)))) (defun byte-compile-output-as-comment (exp quoted) "Print Lisp object EXP in the output file at point, inside a comment. @@ -3012,18 +2896,10 @@ otherwise, print without quoting." (defun byte-compile--reify-function (fun) "Return an expression which will evaluate to a function value FUN. -FUN should be either a `lambda' value or a `closure' value." - (pcase-let* (((or (and `(lambda ,args . ,body) (let env nil)) - `(closure ,env ,args . ,body)) - fun) - (preamble nil) +FUN should be an interpreted closure." + (pcase-let* ((`(closure ,env ,args . ,body) fun) + (`(,preamble . ,body) (macroexp-parse-body body)) (renv ())) - ;; Split docstring and `interactive' form from body. - (when (stringp (car body)) - (push (pop body) preamble)) - (when (eq (car-safe (car body)) 'interactive) - (push (pop body) preamble)) - (setq preamble (nreverse preamble)) ;; Turn the function's closed vars (if any) into local let bindings. (dolist (binding env) (cond @@ -3045,41 +2921,39 @@ If FORM is a lambda or a macro, byte-compile it as a function." (fun (if (symbolp form) (symbol-function form) form)) - (macro (eq (car-safe fun) 'macro))) - (if macro - (setq fun (cdr fun))) - (prog1 - (cond - ;; Up until Emacs-24.1, byte-compile silently did nothing - ;; when asked to compile something invalid. So let's tone - ;; down the complaint from an error to a simple message for - ;; the known case where signaling an error causes problems. - ((compiled-function-p fun) - (message "Function %s is already compiled" - (if (symbolp form) form "provided")) - fun) - (t - (let (final-eval) - (when (or (symbolp form) (eq (car-safe fun) 'closure)) - ;; `fun' is a function *value*, so try to recover its corresponding - ;; source code. - (setq lexical-binding (eq (car fun) 'closure)) - (setq fun (byte-compile--reify-function fun)) - (setq final-eval t)) - ;; Expand macros. - (setq fun (byte-compile-preprocess fun)) - (setq fun (byte-compile-top-level fun nil 'eval)) - (if (symbolp form) - ;; byte-compile-top-level returns an *expression* equivalent to the - ;; `fun' expression, so we need to evaluate it, tho normally - ;; this is not needed because the expression is just a constant - ;; byte-code object, which is self-evaluating. - (setq fun (eval fun t))) - (if final-eval - (setq fun (eval fun t))) - (if macro (push 'macro fun)) - (if (symbolp form) (fset form fun)) - fun)))))))) + (macro (eq (car-safe fun) 'macro)) + (need-a-value nil)) + (when macro + (setq need-a-value t) + (setq fun (cdr fun))) + (cond + ;; Up until Emacs-24.1, byte-compile silently did nothing + ;; when asked to compile something invalid. So let's tone + ;; down the complaint from an error to a simple message for + ;; the known case where signaling an error causes problems. + ((compiled-function-p fun) + (message "Function %s is already compiled" + (if (symbolp form) form "provided")) + fun) + (t + (when (or (symbolp form) (eq (car-safe fun) 'closure)) + ;; `fun' is a function *value*, so try to recover its + ;; corresponding source code. + (when (setq lexical-binding (eq (car-safe fun) 'closure)) + (setq fun (byte-compile--reify-function fun))) + (setq need-a-value t)) + ;; Expand macros. + (setq fun (byte-compile-preprocess fun)) + (setq fun (byte-compile-top-level fun nil 'eval)) + (when need-a-value + ;; `byte-compile-top-level' returns an *expression* equivalent to + ;; the `fun' expression, so we need to evaluate it, tho normally + ;; this is not needed because the expression is just a constant + ;; byte-code object, which is self-evaluating. + (setq fun (eval fun lexical-binding))) + (if macro (push 'macro fun)) + (if (symbolp form) (fset form fun)) + fun)))))) (defun byte-compile-sexp (sexp) "Compile and return SEXP." @@ -3178,27 +3052,32 @@ lambda-expression." (setq fun (cons 'lambda fun)) (unless (eq 'lambda (car-safe fun)) (error "Not a lambda list: %S" fun))) - (byte-compile-docstring-style-warn fun) (byte-compile-check-lambda-list (nth 1 fun)) (let* ((arglist (nth 1 fun)) + (bare-arglist (byte-run-strip-symbol-positions arglist)) ; for compile-defun. (arglistvars (byte-run-strip-symbol-positions (byte-compile-arglist-vars arglist))) (byte-compile-bound-variables (append (if (not lexical-binding) arglistvars) byte-compile-bound-variables)) (body (cdr (cdr fun))) - (doc (if (stringp (car body)) + ;; Treat a final string literal as a value, not a doc string. + (doc (if (and (cdr body) (stringp (car body))) (prog1 (car body) - ;; Discard the doc string - ;; unless it is the last element of the body. - (if (cdr body) - (setq body (cdr body)))))) + ;; Discard the doc string from the body. + (setq body (cdr body))))) (int (assq 'interactive body)) command-modes) (when lexical-binding + (when arglist + ;; byte-compile-make-args-desc lost the args's names, + ;; so preserve them in the docstring. + (setq doc (help-add-fundoc-usage doc bare-arglist))) (dolist (var arglistvars) (when (assq var byte-compile--known-dynamic-vars) (byte-compile--warn-lexical-dynamic var 'lambda)))) + (when (stringp doc) + (setq doc (byte-compile--docstring doc "" nil 'is-a-value))) ;; Process the interactive spec. (when int ;; Skip (interactive) if it is in front (the most usual location). @@ -3242,8 +3121,7 @@ lambda-expression." (and lexical-binding (byte-compile-make-lambda-lexenv arglistvars)) - reserved-csts)) - (bare-arglist (byte-run-strip-symbol-positions arglist))) ; for compile-defun. + reserved-csts))) ;; Build the actual byte-coded function. (cl-assert (eq 'byte-code (car-safe compiled))) (let ((out @@ -3255,12 +3133,7 @@ lambda-expression." ;; byte-string, constants-vector, stack depth (cdr compiled) ;; optionally, the doc string. - (cond ((and lexical-binding arglist) - ;; byte-compile-make-args-desc lost the args's names, - ;; so preserve them in the docstring. - (list (help-add-fundoc-usage doc bare-arglist))) - ((or doc int) - (list doc))) + (when (or doc int) (list doc)) ;; optionally, the interactive spec (and the modes the ;; command applies to). (cond @@ -3572,6 +3445,7 @@ lambda-expression." ((and (or sef (function-get (car form) 'important-return-value)) ;; Don't warn for arguments to `ignore'. (not (eq byte-compile--for-effect 'for-effect-no-warn)) + (bytecomp--actually-important-return-value-p form) (byte-compile-warning-enabled-p 'ignored-return-value (car form))) (byte-compile-warn-x @@ -3598,6 +3472,15 @@ lambda-expression." (if byte-compile--for-effect (byte-compile-discard))))) +(defun bytecomp--actually-important-return-value-p (form) + "Whether FORM is really a call with a return value that should not go unused. +This assumes the function has the `important-return-value' property." + (cond ((eq (car form) 'sort) + ;; For `sort', we only care about non-destructive uses. + (and (zerop (% (length form) 2)) ; new-style call + (not (plist-get (cddr form) :in-place)))) + (t t))) + (let ((important-return-value-fns '( ;; These functions are side-effect-free except for the @@ -3605,9 +3488,11 @@ lambda-expression." mapcar mapcan mapconcat assoc plist-get plist-member - ;; It's safe to ignore the value of `sort' and `nreverse' + ;; It's safe to ignore the value of `nreverse' ;; when used on arrays, but most calls pass lists. - nreverse sort + nreverse + + sort ; special handling (non-destructive calls only) match-data @@ -3814,7 +3699,6 @@ lambda-expression." (alen (length (cdr form))) (dynbinds ()) lap) - (fetch-bytecode fun) (setq lap (byte-decompile-bytecode-1 (aref fun 1) (aref fun 2) t)) ;; optimized switch bytecode makes it impossible to guess the correct ;; `byte-compile-depth', which can result in incorrect inlined code. @@ -5141,49 +5025,49 @@ binding slots have been popped." (push (nth 1 (nth 1 form)) byte-compile-global-not-obsolete-vars)) (byte-compile-normal-call form)) -(defun byte-compile-defvar (form) - ;; This is not used for file-level defvar/consts. - (when (and (symbolp (nth 1 form)) - (not (string-match "[-*/:$]" (symbol-name (nth 1 form)))) - (byte-compile-warning-enabled-p 'lexical (nth 1 form))) - (byte-compile-warn-x - (nth 1 form) - "global/dynamic var `%s' lacks a prefix" - (nth 1 form))) - (byte-compile-docstring-style-warn form) - (let ((fun (nth 0 form)) - (var (nth 1 form)) - (value (nth 2 form)) - (string (nth 3 form))) - (when (or (> (length form) 4) - (and (eq fun 'defconst) (null (cddr form)))) - (let ((ncall (length (cdr form)))) - (byte-compile-warn-x - fun - "`%s' called with %d argument%s, but %s %s" - fun ncall - (if (= 1 ncall) "" "s") - (if (< ncall 2) "requires" "accepts only") - "2-3"))) - (push var byte-compile-bound-variables) +(defun byte-compile-defvar (form &optional toplevel) + (let* ((fun (nth 0 form)) + (var (nth 1 form)) + (value (nth 2 form)) + (string (nth 3 form))) + (byte-compile--declare-var var (not toplevel)) (if (eq fun 'defconst) (push var byte-compile-const-variables)) - (when (and string (not (stringp string))) + (cond + ((stringp string) + (setq string (byte-compile--docstring string fun var 'is-a-value))) + (string (byte-compile-warn-x string "third arg to `%s %s' is not a string: %s" - fun var string)) - ;; Delegate the actual work to the function version of the - ;; special form, named with a "-1" suffix. - (byte-compile-form-do-effect - (cond - ((eq fun 'defconst) `(defconst-1 ',var ,@(nthcdr 2 form))) - ((not (cddr form)) `',var) ; A simple (defvar foo) just returns foo. - (t `(defvar-1 ',var - ;; Don't eval `value' if `defvar' wouldn't eval it either. - ,(if (macroexp-const-p value) value - `(if (boundp ',var) nil ,value)) - ,@(nthcdr 3 form))))))) + fun var string))) + (if toplevel + ;; At top-level we emit calls to defvar/defconst. + (if (and (null (cddr form)) ;No `value' provided. + (eq (car form) 'defvar)) ;Just a declaration. + nil + (let ((tail (nthcdr 4 form))) + (when (or tail string) (push string tail)) + (when (cddr form) + (push (if (not (consp value)) value + (byte-compile-top-level value nil 'file)) + tail)) + `(,fun ,var ,@tail))) + ;; At non-top-level, since there is no byte code for + ;; defvar/defconst, we delegate the actual work to the function + ;; version of the special form, named with a "-1" suffix. + (byte-compile-form-do-effect + (cond + ((eq fun 'defconst) + `(defconst-1 ',var ,@(byte-compile--list-with-n + (nthcdr 2 form) 1 (macroexp-quote string)))) + ((not (cddr form)) `',var) ; A simple (defvar foo) just returns foo. + (t `(defvar-1 ',var + ;; Don't eval `value' if `defvar' wouldn't eval it either. + ,(if (macroexp-const-p value) value + `(if (boundp ',var) nil ,value)) + ,@(byte-compile--list-with-n + (nthcdr 3 form) 0 (macroexp-quote string))))))))) (defun byte-compile-autoload (form) (and (macroexp-const-p (nth 1 form)) @@ -5209,14 +5093,6 @@ binding slots have been popped." ;; For the compilation itself, we could largely get rid of this hunk-handler, ;; if it weren't for the fact that we need to figure out when a defalias ;; defines a macro, so as to add it to byte-compile-macro-environment. - ;; - ;; FIXME: we also use this hunk-handler to implement the function's - ;; dynamic docstring feature (via byte-compile-file-form-defmumble). - ;; We should probably actually implement it (more elegantly) in - ;; byte-compile-lambda so it applies to all lambdas. We did it here - ;; so the resulting .elc format was recognizable by make-docfile, - ;; but since then we stopped using DOC for the docstrings of - ;; preloaded elc files so that obstacle is gone. (let ((byte-compile-free-references nil) (byte-compile-free-assignments nil)) (pcase form @@ -5225,7 +5101,11 @@ binding slots have been popped." ;; - `arg' is the expression to which it is defined. ;; - `rest' is the rest of the arguments. (`(,_ ',name ,arg . ,rest) - (byte-compile-docstring-style-warn form) + (let ((doc (car rest))) + (when (stringp doc) + (setq rest (byte-compile--list-with-n + rest 0 + (byte-compile--docstring doc (nth 0 form) name))))) (pcase-let* ;; `macro' is non-nil if it defines a macro. ;; `fun' is the function part of `arg' (defaults to `arg'). @@ -5668,23 +5548,14 @@ invoked interactively." (if (null f) " <top level>";; shouldn't insert nil then, actually -sk " <not defined>")) - ((subrp (setq f (symbol-function f))) - " <subr>") - ((symbolp f) + ((symbolp (setq f (symbol-function f))) ;; An alias. (format " ==> %s" f)) - ((byte-code-function-p f) - "<compiled function>") ((not (consp f)) - "<malformed function>") + (format " <%s>" (type-of f))) ((eq 'macro (car f)) - (if (or (compiled-function-p (cdr f)) - ;; FIXME: Can this still happen? - (assq 'byte-code (cdr (cdr (cdr f))))) + (if (compiled-function-p (cdr f)) " <compiled macro>" " <macro>")) - ((assq 'byte-code (cdr (cdr f))) - ;; FIXME: Can this still happen? - "<compiled lambda>") ((eq 'lambda (car f)) "<function>") (t "???")) @@ -5894,6 +5765,16 @@ and corresponding effects." (eval form) form))) +;; Report comma operator used outside of backquote. +;; Inside backquote, backquote will transform it before it gets here. + +(put '\, 'compiler-macro #'bytecomp--report-comma) +(defun bytecomp--report-comma (form &rest _ignore) + (macroexp-warn-and-return + (format-message "`%s' called -- perhaps used not within backquote" + (car form)) + form (list 'suspicious (car form)) t)) + ;; Check for (in)comparable constant values in calls to `eq', `memq' etc. (defun bytecomp--dodgy-eq-arg-p (x number-ok) diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index e210cfdf5ce..4ff47971351 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -621,12 +621,16 @@ places where they originally did not directly appear." (cconv-convert exp env extend)) (`(,func . ,forms) - (if (symbolp func) + (if (or (symbolp func) (functionp func)) ;; First element is function or whatever function-like forms are: ;; or, and, if, catch, progn, prog1, while, until - `(,func . ,(mapcar (lambda (form) - (cconv-convert form env extend)) - forms)) + (let ((args (mapcar (lambda (form) (cconv-convert form env extend)) + forms))) + (unless (symbolp func) + (byte-compile-warn-x + form + "Use `funcall' instead of `%s' in the function position" func)) + `(,func . ,args)) (byte-compile-warn-x form "Malformed function `%S'" func) nil)) diff --git a/lisp/emacs-lisp/check-declare.el b/lisp/emacs-lisp/check-declare.el index 0362c7d2c24..faa7824c8bd 100644 --- a/lisp/emacs-lisp/check-declare.el +++ b/lisp/emacs-lisp/check-declare.el @@ -40,7 +40,7 @@ ;;; Code: -(defconst check-declare-warning-buffer "*Check Declarations Warnings*" +(defvar check-declare-warning-buffer "*Check Declarations Warnings*" "Name of buffer used to display any `check-declare' warnings.") (defun check-declare-locate (file basefile) @@ -85,6 +85,9 @@ don't know how to recognize (e.g. some macros)." (let (alist) (with-temp-buffer (insert-file-contents file) + ;; Ensure shorthands available, as we will be `read'ing Elisp + ;; (bug#67523) + (let (enable-local-variables) (hack-local-variables)) ;; FIXME we could theoretically be inside a string. (while (re-search-forward "^[ \t]*\\((declare-function\\)[ \t\n]" nil t) (let ((pos (match-beginning 1))) @@ -145,64 +148,70 @@ is a string giving details of the error." (if (file-regular-p fnfile) (with-temp-buffer (insert-file-contents fnfile) + (unless cflag + ;; If in Elisp, ensure syntax and shorthands available + ;; (bug#67523) + (set-syntax-table emacs-lisp-mode-syntax-table) + (let (enable-local-variables) (hack-local-variables))) ;; defsubst's don't _have_ to be known at compile time. - (setq re (format (if cflag - "^[ \t]*\\(DEFUN\\)[ \t]*([ \t]*\"%s\"" - "^[ \t]*(\\(fset[ \t]+'\\|\ + (setq re (if cflag + (format "^[ \t]*\\(DEFUN\\)[ \t]*([ \t]*\"%s\"" + (regexp-opt (mapcar 'cadr fnlist) t)) + "^[ \t]*(\\(fset[ \t]+'\\|\ cl-def\\(?:generic\\|method\\|un\\)\\|\ def\\(?:un\\|subst\\|foo\\|method\\|class\\|\ ine-\\(?:derived\\|generic\\|\\(?:global\\(?:ized\\)?-\\)?minor\\)-mode\\|\ \\(?:ine-obsolete-function-\\)?alias[ \t]+'\\|\ ine-overloadable-function\\)\\)\ -[ \t]*%s\\([ \t;]+\\|$\\)") - (regexp-opt (mapcar 'cadr fnlist) t))) +[ \t]*\\(\\(?:\\sw\\|\\s_\\)+\\)\\([ \t;]+\\|$\\)")) (while (re-search-forward re nil t) (skip-chars-forward " \t\n") - (setq fn (match-string 2) - type (match-string 1) - ;; (min . max) for a fixed number of arguments, or - ;; arglists with optional elements. - ;; (min) for arglists with &rest. - ;; sig = 'err means we could not find an arglist. - sig (cond (cflag - (or - (when (search-forward "," nil t 3) - (skip-chars-forward " \t\n") - ;; Assuming minargs and maxargs on same line. - (when (looking-at "\\([0-9]+\\)[ \t]*,[ \t]*\ + (setq fn (symbol-name (car (read-from-string (match-string 2))))) + (when (member fn (mapcar 'cadr fnlist)) + (setq type (match-string 1) + ;; (min . max) for a fixed number of arguments, or + ;; arglists with optional elements. + ;; (min) for arglists with &rest. + ;; sig = 'err means we could not find an arglist. + sig (cond (cflag + (or + (when (search-forward "," nil t 3) + (skip-chars-forward " \t\n") + ;; Assuming minargs and maxargs on same line. + (when (looking-at "\\([0-9]+\\)[ \t]*,[ \t]*\ \\([0-9]+\\|MANY\\|UNEVALLED\\)") - (setq minargs (string-to-number - (match-string 1)) - maxargs (match-string 2)) - (cons minargs (unless (string-match "[^0-9]" - maxargs) - (string-to-number - maxargs))))) - 'err)) - ((string-match - "\\`define-\\(derived\\|generic\\)-mode\\'" - type) - '(0 . 0)) - ((string-match - "\\`define\\(-global\\(ized\\)?\\)?-minor-mode\\'" - type) - '(0 . 1)) - ;; Prompt to update. - ((string-match - "\\`define-obsolete-function-alias\\>" - type) - 'obsolete) - ;; Can't easily check arguments in these cases. - ((string-match "\\`\\(def\\(alias\\|class\\)\\|\ + (setq minargs (string-to-number + (match-string 1)) + maxargs (match-string 2)) + (cons minargs (unless (string-match "[^0-9]" + maxargs) + (string-to-number + maxargs))))) + 'err)) + ((string-match + "\\`define-\\(derived\\|generic\\)-mode\\'" + type) + '(0 . 0)) + ((string-match + "\\`define\\(-global\\(ized\\)?\\)?-minor-mode\\'" + type) + '(0 . 1)) + ;; Prompt to update. + ((string-match + "\\`define-obsolete-function-alias\\>" + type) + 'obsolete) + ;; Can't easily check arguments in these cases. + ((string-match "\\`\\(def\\(alias\\|class\\)\\|\ fset\\|\\(?:cl-\\)?defmethod\\)\\>" type) - t) - ((looking-at "\\((\\|nil\\)") - (byte-compile-arglist-signature - (read (current-buffer)))) - (t - 'err)) - ;; alist of functions and arglist signatures. - siglist (cons (cons fn sig) siglist))))) + t) + ((looking-at "\\((\\|nil\\)") + (byte-compile-arglist-signature + (read (current-buffer)))) + (t + 'err)) + ;; alist of functions and arglist signatures. + siglist (cons (cons fn sig) siglist)))))) (dolist (e fnlist) (setq arglist (nth 2 e) type @@ -319,9 +328,14 @@ Returns non-nil if any false statements are found." (setq root (directory-file-name (file-relative-name root))) (or (file-directory-p root) (error "Directory `%s' not found" root)) - (let ((files (directory-files-recursively root "\\.el\\'"))) - (when files - (apply #'check-declare-files files)))) + (when-let* ((files (directory-files-recursively root "\\.el\\'")) + (files (mapcan (lambda (file) + ;; Filter out lock files. + (and (not (string-prefix-p + ".#" (file-name-nondirectory file))) + (list file))) + files))) + (apply #'check-declare-files files))) (provide 'check-declare) diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index 80eaf93c3b7..c22dfb2eb26 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -556,7 +556,8 @@ the users will view as each check is completed." "Display and update the status buffer for the current checkdoc mode. CHECK is a list of four strings stating the current status of each test; the nth string describes the status of the nth test." - (let (temp-buffer-setup-hook) + (let (temp-buffer-setup-hook + (temp-buffer-show-hook #'special-mode)) (with-output-to-temp-buffer "*Checkdoc Status*" (mapc #'princ (list "Buffer comments and tags: " (nth 0 check) @@ -1993,7 +1994,7 @@ from the comment." (defun-depth (ppss-depth (syntax-ppss))) (lst nil) (ret nil) - (oo (make-vector 3 0))) ;substitute obarray for `read' + (oo (obarray-make 3))) ;substitute obarray for `read' (forward-char 1) (forward-sexp 1) (skip-chars-forward " \n\t") @@ -2793,7 +2794,7 @@ function called to create the messages." ": " msg))) (if (string= checkdoc-diagnostic-buffer "*warn*") (warn (apply #'concat text)) - (with-current-buffer (get-buffer checkdoc-diagnostic-buffer) + (with-current-buffer checkdoc-diagnostic-buffer (let ((inhibit-read-only t) (pt (point-max))) (goto-char pt) diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 9281cd9821e..437dea2d6a9 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -711,11 +711,6 @@ PROPLIST is a list of the sort returned by `symbol-plist'. (eval-when-compile (require 'cl-macs)) ;Explicitly, for cl--find-class. (require 'help-mode) -;; FIXME: We could go crazy and add another entry so describe-symbol can be -;; used with the slot names of CL structs (and/or EIEIO objects). -(add-to-list 'describe-symbol-backends - `(nil ,#'cl-find-class ,(lambda (s _b _f) (cl-describe-type s)))) - (defconst cl--typedef-regexp (concat "(" (regexp-opt '("defclass" "defstruct" "cl-defstruct" "cl-deftype" "deftype")) @@ -725,11 +720,6 @@ PROPLIST is a list of the sort returned by `symbol-plist'. (add-to-list 'find-function-regexp-alist '(define-type . cl--typedef-regexp))) -(define-button-type 'cl-help-type - :supertype 'help-function-def - 'help-function #'cl-describe-type - 'help-echo (purecopy "mouse-2, RET: describe this type")) - (define-button-type 'cl-type-definition :supertype 'help-function-def 'help-echo (purecopy "mouse-2, RET: find type definition")) @@ -744,7 +734,7 @@ Call `cl--find-class' to get TYPE's propname `cl--class'" (cl--find-class type)) ;;;###autoload -(defun cl-describe-type (type) +(defun cl-describe-type (type &optional _buf _frame) "Display the documentation for type TYPE (a symbol)." (interactive (let ((str (completing-read "Describe type: " obarray #'cl-find-class t))) @@ -766,6 +756,15 @@ Call `cl--find-class' to get TYPE's propname `cl--class'" ;; Return the text we displayed. (buffer-string))))) +(defun cl--class-children (class) + (let ((children '())) + (mapatoms + (lambda (sym) + (let ((sym-class (cl--find-class sym))) + (and sym-class (memq class (cl--class-parents sym-class)) + (push sym children))))) + children)) + (defun cl--describe-class (type &optional class) (unless class (setq class (cl--find-class type))) (let ((location (find-lisp-object-file-name type 'define-type)) @@ -773,7 +772,7 @@ Call `cl--find-class' to get TYPE's propname `cl--class'" (insert (symbol-name type) (substitute-command-keys " is a type (of kind `")) (help-insert-xref-button (symbol-name metatype) - 'cl-help-type metatype) + 'help-type metatype) (insert (substitute-command-keys "')")) (when location (insert (substitute-command-keys " in `")) @@ -792,21 +791,19 @@ Call `cl--find-class' to get TYPE's propname `cl--class'" (setq cur (cl--class-name cur)) (insert (substitute-quotes "`")) (help-insert-xref-button (symbol-name cur) - 'cl-help-type cur) + 'help-type cur) (insert (substitute-command-keys (if pl "', " "'")))) (insert ".\n"))) - ;; Children, if available. ¡For EIEIO! - (let ((ch (condition-case nil - (cl-struct-slot-value metatype 'children class) - (cl-struct-unknown-slot nil))) + ;; Children. + (let ((ch (cl--class-children class)) cur) (when ch (insert " Children ") (while (setq cur (pop ch)) (insert (substitute-quotes "`")) (help-insert-xref-button (symbol-name cur) - 'cl-help-type cur) + 'help-type cur) (insert (substitute-command-keys (if ch "', " "'")))) (insert ".\n"))) @@ -903,22 +900,25 @@ Outputs to the current buffer." (cslots (condition-case nil (cl-struct-slot-value metatype 'class-slots class) (cl-struct-unknown-slot nil)))) - (insert (propertize "Instance Allocated Slots:\n\n" - 'face 'bold)) - (let* ((has-doc nil) - (slots-strings - (mapcar - (lambda (slot) - (list (cl-prin1-to-string (cl--slot-descriptor-name slot)) - (cl-prin1-to-string (cl--slot-descriptor-type slot)) - (cl-prin1-to-string (cl--slot-descriptor-initform slot)) - (let ((doc (alist-get :documentation - (cl--slot-descriptor-props slot)))) - (if (not doc) "" - (setq has-doc t) - (substitute-command-keys doc))))) - slots))) - (cl--print-table `("Name" "Type" "Default") slots-strings has-doc)) + (if (and (null slots) (eq metatype 'built-in-class)) + (insert "This is a built-in type.\n") + + (insert (propertize "Instance Allocated Slots:\n\n" + 'face 'bold)) + (let* ((has-doc nil) + (slots-strings + (mapcar + (lambda (slot) + (list (cl-prin1-to-string (cl--slot-descriptor-name slot)) + (cl-prin1-to-string (cl--slot-descriptor-type slot)) + (cl-prin1-to-string (cl--slot-descriptor-initform slot)) + (let ((doc (alist-get :documentation + (cl--slot-descriptor-props slot)))) + (if (not doc) "" + (setq has-doc t) + (substitute-command-keys doc))))) + slots))) + (cl--print-table `("Name" "Type" "Default") slots-strings has-doc))) (insert "\n") (when (> (length cslots) 0) (insert (propertize "\nClass Allocated Slots:\n\n" 'face 'bold)) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 48f5c06e390..8bda857afdd 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -672,7 +672,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined ;; compiled. Otherwise the byte-compiler and all the code on ;; which it depends needs to be usable before cl-generic is loaded, ;; which imposes a significant burden on the bootstrap. - (if (consp (lambda (x) (+ x 1))) + (if (not (compiled-function-p (lambda (x) (+ x 1)))) (lambda (exp) (eval exp t)) ;; But do byte-compile the dispatchers once bootstrap is passed: ;; the performance difference is substantial (like a 5x speedup on @@ -1140,12 +1140,8 @@ MET-NAME is as returned by `cl--generic-load-hist-format'." (add-hook 'help-fns-describe-function-functions #'cl--generic-describe) (defun cl--generic-describe (function) - ;; Supposedly this is called from help-fns, so help-fns should be loaded at - ;; this point. - (declare-function help-fns-short-filename "help-fns" (filename)) (let ((generic (if (symbolp function) (cl--generic function)))) (when generic - (require 'help-mode) ;Needed for `help-function-def' button! (save-excursion ;; Ensure that we have two blank lines (but not more). (unless (looking-back "\n\n" (- (point) 2)) @@ -1153,33 +1149,49 @@ MET-NAME is as returned by `cl--generic-load-hist-format'." (insert "This is a generic function.\n\n") (insert (propertize "Implementations:\n\n" 'face 'bold)) ;; Loop over fanciful generics - (dolist (method (cl--generic-method-table generic)) - (pcase-let* - ((`(,qualifiers ,args ,doc) (cl--generic-method-info method))) - ;; FIXME: Add hyperlinks for the types as well. - (let ((print-quoted nil) - (quals (if (length> qualifiers 0) - (concat (substring qualifiers - 0 (string-match " *\\'" - qualifiers)) - "\n") - ""))) - (insert (format "%s%S" - quals - (cons function - (cl--generic-upcase-formal-args args))))) - (let* ((met-name (cl--generic-load-hist-format - function - (cl--generic-method-qualifiers method) - (cl--generic-method-specializers method))) - (file (find-lisp-object-file-name met-name 'cl-defmethod))) - (when file - (insert (substitute-command-keys " in `")) - (help-insert-xref-button (help-fns-short-filename file) - 'help-function-def met-name file - 'cl-defmethod) - (insert (substitute-command-keys "'.\n")))) - (insert "\n" (or doc "Undocumented") "\n\n"))))))) + (cl--map-methods-documentation + function + (lambda (quals signature file doc) + (insert (format "%s%S%s\n\n%s\n\n" + quals signature + (if file (format-message " in `%s'." file) "") + (or doc "Undocumented"))))))))) + +(defun cl--map-methods-documentation (funname metname-printer) + "Iterate on FUNNAME's methods documentation at point." + ;; Supposedly this is called from help-fns, so help-fns should be loaded at + ;; this point. + (require 'help-fns) + (declare-function help-fns-short-filename "help-fns" (filename)) + (let ((generic (if (symbolp funname) (cl--generic funname)))) + (when generic + (require 'help-mode) ;Needed for `help-function-def' button! + ;; Loop over fanciful generics + (dolist (method (cl--generic-method-table generic)) + (pcase-let* + ((`(,qualifiers ,args ,doc) (cl--generic-method-info method)) + ;; FIXME: Add hyperlinks for the types as well. + (quals (if (length> qualifiers 0) + (concat (substring qualifiers + 0 (string-match " *\\'" + qualifiers)) + "\n") + "")) + (met-name (cl--generic-load-hist-format + funname + (cl--generic-method-qualifiers method) + (cl--generic-method-specializers method))) + (file (find-lisp-object-file-name met-name 'cl-defmethod))) + (funcall metname-printer + quals + (cons funname + (cl--generic-upcase-formal-args args)) + (when file + (make-text-button (help-fns-short-filename file) nil + 'type 'help-function-def + 'help-args + (list met-name file 'cl-defmethod))) + doc)))))) (defun cl--generic-specializers-apply-to-type-p (specializers type) "Return non-nil if a method with SPECIALIZERS applies to TYPE." @@ -1318,62 +1330,30 @@ These match if the argument is `eql' to VAL." (cl--generic-prefill-dispatchers (terminal-parameter nil 'xterm--set-selection) (eql nil)) -;;; Support for cl-defstructs specializers. - -(defun cl--generic-struct-tag (name &rest _) - ;; Use exactly the same code as for `typeof'. - `(if ,name (type-of ,name) 'null)) +;;; Dispatch on "normal types". -(defun cl--generic-struct-specializers (tag &rest _) +(defun cl--generic-type-specializers (tag &rest _) (and (symbolp tag) - (let ((class (get tag 'cl--class))) - (when (cl-typep class 'cl-structure-class) + (let ((class (cl--find-class tag))) + (when class (cl--class-allparents class))))) -(cl-generic-define-generalizer cl--generic-struct-generalizer - 50 #'cl--generic-struct-tag - #'cl--generic-struct-specializers) - -(cl-defmethod cl-generic-generalizers :extra "cl-struct" (type) - "Support for dispatch on types defined by `cl-defstruct'." - (or - (when (symbolp type) - ;; Use the "cl--struct-class*" (inlinable) functions/macros rather than - ;; the "cl-struct-*" variants which aren't inlined, so that dispatch can - ;; take place without requiring cl-lib. - (let ((class (cl--find-class type))) - (and (cl-typep class 'cl-structure-class) - (or (null (cl--struct-class-type class)) - (error "Can't dispatch on cl-struct %S: type is %S" - type (cl--struct-class-type class))) - (progn (cl-assert (null (cl--struct-class-named class))) t) - (list cl--generic-struct-generalizer)))) - (cl-call-next-method))) - -(cl--generic-prefill-dispatchers 0 cl--generic-generalizer) - -;;; Dispatch on "system types". - (cl-generic-define-generalizer cl--generic-typeof-generalizer - ;; FIXME: We could also change `type-of' to return `null' for nil. - 10 (lambda (name &rest _) `(if ,name (type-of ,name) 'null)) - (lambda (tag &rest _) - (and (symbolp tag) (assq tag cl--typeof-types)))) + 10 (lambda (name &rest _) `(cl-type-of ,name)) + #'cl--generic-type-specializers) (cl-defmethod cl-generic-generalizers :extra "typeof" (type) - "Support for dispatch on builtin types. -See the full list and their hierarchy in `cl--typeof-types'." - ;; FIXME: Add support for other types accepted by `cl-typep' such - ;; as `character', `face', `function', ... + "Support for dispatch on types. +This currently works for built-in types and types built on top of records." + ;; FIXME: Add support for other "types" accepted by `cl-typep' such + ;; as `character', `face', `keyword', ...? (or - (and (memq type cl--all-builtin-types) - (progn - ;; FIXME: While this wrinkle in the semantics can be occasionally - ;; problematic, this warning is more often annoying than helpful. - ;;(if (memq type '(vector array sequence)) - ;; (message "`%S' also matches CL structs and EIEIO classes" - ;; type)) - (list cl--generic-typeof-generalizer))) + (and (symbolp type) + (not (eq type t)) ;; Handled by the `t-generalizer'. + (let ((class (cl--find-class type))) + (memq (type-of class) + '(built-in-class cl-structure-class eieio--class))) + (list cl--generic-typeof-generalizer)) (cl-call-next-method))) (cl--generic-prefill-dispatchers 0 integer) @@ -1381,6 +1361,8 @@ See the full list and their hierarchy in `cl--typeof-types'." (cl--generic-prefill-dispatchers 0 cl--generic-generalizer integer) (cl--generic-prefill-dispatchers 0 (eql 'x) integer) +(cl--generic-prefill-dispatchers 0 cl--generic-generalizer) + ;;; Dispatch on major mode. ;; Two parts: @@ -1418,19 +1400,13 @@ Used internally for the (major-mode MODE) context specializers." (defun cl--generic-oclosure-tag (name &rest _) `(oclosure-type ,name)) -(defun cl-generic--oclosure-specializers (tag &rest _) - (and (symbolp tag) - (let ((class (cl--find-class tag))) - (when (cl-typep class 'oclosure--class) - (oclosure--class-allparents class))))) - (cl-generic-define-generalizer cl--generic-oclosure-generalizer ;; Give slightly higher priority than the struct specializer, so that ;; for a generic function with methods dispatching structs and on OClosures, ;; we first try `oclosure-type' before `type-of' since `type-of' will return ;; non-nil for an OClosure as well. 51 #'cl--generic-oclosure-tag - #'cl-generic--oclosure-specializers) + #'cl--generic-type-specializers) (cl-defmethod cl-generic-generalizers :extra "oclosure-struct" (type) "Support for dispatch on types defined by `oclosure-define'." diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 88447203a64..a84ef4a34b2 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2250,7 +2250,7 @@ Like `cl-flet' but the definitions can refer to previous ones. ;;;###autoload (defmacro cl-labels (bindings &rest body) "Make local (recursive) function definitions. -+BINDINGS is a list of definitions of the form (FUNC ARGLIST BODY...) where +BINDINGS is a list of definitions of the form (FUNC ARGLIST BODY...) where FUNC is the function name, ARGLIST its arguments, and BODY the forms of the function body. FUNC is defined in any BODY, as well as FORM, so you can write recursive and mutually recursive @@ -3344,14 +3344,14 @@ Elements of FIELDS can be of the form (NAME PAT) in which case the contents of field NAME is matched against PAT, or they can be of the form NAME which is a shorthand for (NAME NAME)." (declare (debug (sexp &rest [&or (sexp pcase-PAT) sexp]))) - `(and (pred (pcase--flip cl-typep ',type)) + `(and (pred (cl-typep _ ',type)) ,@(mapcar (lambda (field) (let* ((name (if (consp field) (car field) field)) (pat (if (consp field) (cadr field) field))) `(app ,(if (eq (cl-struct-sequence-type type) 'list) `(nth ,(cl-struct-slot-offset type name)) - `(pcase--flip aref ,(cl-struct-slot-offset type name))) + `(aref _ ,(cl-struct-slot-offset type name))) ,pat))) fields))) @@ -3368,13 +3368,13 @@ the form NAME which is a shorthand for (NAME NAME)." "Extra special cases for `cl-typep' predicates." (let* ((x1 pred1) (x2 pred2) (t1 - (and (eq 'pcase--flip (car-safe x1)) (setq x1 (cdr x1)) - (eq 'cl-typep (car-safe x1)) (setq x1 (cdr x1)) + (and (eq 'cl-typep (car-safe x1)) (setq x1 (cdr x1)) + (eq '_ (car-safe x1)) (setq x1 (cdr x1)) (null (cdr-safe x1)) (setq x1 (car x1)) (eq 'quote (car-safe x1)) (cadr x1))) (t2 - (and (eq 'pcase--flip (car-safe x2)) (setq x2 (cdr x2)) - (eq 'cl-typep (car-safe x2)) (setq x2 (cdr x2)) + (and (eq 'cl-typep (car-safe x2)) (setq x2 (cdr x2)) + (eq '_ (car-safe x2)) (setq x2 (cdr x2)) (null (cdr-safe x2)) (setq x2 (car x2)) (eq 'quote (car-safe x2)) (cadr x2)))) (or @@ -3460,45 +3460,20 @@ Of course, we really can't know that for sure, so it's just a heuristic." (or (cdr (assq sym byte-compile-function-environment)) (cdr (assq sym macroexpand-all-environment)))))) +;; Please keep it in sync with `comp-known-predicates'. (pcase-dolist (`(,type . ,pred) ;; Mostly kept in alphabetical order. - '((array . arrayp) - (atom . atom) - (base-char . characterp) - (bignum . bignump) - (boolean . booleanp) - (bool-vector . bool-vector-p) - (buffer . bufferp) - (byte-code-function . byte-code-function-p) - (character . natnump) - (char-table . char-table-p) - (command . commandp) - (compiled-function . compiled-function-p) - (hash-table . hash-table-p) - (cons . consp) - (fixnum . fixnump) - (float . floatp) - (frame . framep) - (function . functionp) - (integer . integerp) - (keyword . keywordp) + ;; These aren't defined via `cl--define-built-in-type'. + '((base-char . characterp) ;Could be subtype of `fixnum'. + (character . natnump) ;Could be subtype of `fixnum'. + (command . commandp) ;Subtype of closure & subr. + (keyword . keywordp) ;Would need `keyword-with-pos`. + (natnum . natnump) ;Subtype of fixnum & bignum. + (real . numberp) ;Not clear where it would fit. + ;; This one is redundant, but we keep it to silence a + ;; warning during the early bootstrap when `cl-seq.el' gets + ;; loaded before `cl-preloaded.el' is defined. (list . listp) - (marker . markerp) - (natnum . natnump) - (number . numberp) - (null . null) - (overlay . overlayp) - (process . processp) - (real . numberp) - (sequence . sequencep) - (subr . subrp) - (string . stringp) - (symbol . symbolp) - (vector . vectorp) - (window . windowp) - ;; FIXME: Do we really want to consider these types? - (number-or-marker . number-or-marker-p) - (integer-or-marker . integer-or-marker-p) )) (put type 'cl-deftype-satisfies pred)) @@ -3818,7 +3793,8 @@ STRUCT-TYPE and SLOT-NAME are symbols. INST is a structure instance." (pcase-defmacro cl-type (type) "Pcase pattern that matches objects of TYPE. TYPE is a type descriptor as accepted by `cl-typep', which see." - `(pred (pcase--flip cl-typep ',type))) + `(pred (cl-typep _ ',type))) + ;; Local variables: ;; generated-autoload-file: "cl-loaddefs.el" diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index 20e68555578..d23ad3972a9 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -50,51 +50,16 @@ (apply #'error string (append sargs args)) (signal 'cl-assertion-failed `(,form ,@sargs))))) -(defconst cl--typeof-types - ;; Hand made from the source code of `type-of'. - '((integer number integer-or-marker number-or-marker atom) - (symbol-with-pos symbol atom) (symbol atom) (string array sequence atom) - (cons list sequence) - ;; Markers aren't `numberp', yet they are accepted wherever integers are - ;; accepted, pretty much. - (marker integer-or-marker number-or-marker atom) - (overlay atom) (float number number-or-marker atom) - (window-configuration atom) (process atom) (window atom) - ;; FIXME: We'd want to put `function' here, but that's only true - ;; for those `subr's which aren't special forms! - (subr atom) - ;; FIXME: We should probably reverse the order between - ;; `compiled-function' and `byte-code-function' since arguably - ;; `subr' is also "compiled functions" but not "byte code functions", - ;; but it would require changing the value returned by `type-of' for - ;; byte code objects, which risks breaking existing code, which doesn't - ;; seem worth the trouble. - (compiled-function byte-code-function function atom) - (module-function function atom) - (buffer atom) (char-table array sequence atom) - (bool-vector array sequence atom) - (frame atom) (hash-table atom) (terminal atom) - (thread atom) (mutex atom) (condvar atom) - (font-spec atom) (font-entity atom) (font-object atom) - (vector array sequence atom) - (user-ptr atom) - (tree-sitter-parser atom) - (tree-sitter-node atom) - (tree-sitter-compiled-query atom) - ;; Plus, really hand made: - (null symbol list sequence atom)) - "Alist of supertypes. -Each element has the form (TYPE . SUPERTYPES) where TYPE is one of -the symbols returned by `type-of', and SUPERTYPES is the list of its -supertypes from the most specific to least specific.") - -(defconst cl--all-builtin-types - (delete-dups (copy-sequence (apply #'append cl--typeof-types)))) +(defun cl--builtin-type-p (name) + (if (not (fboundp 'built-in-class-p)) ;; Early bootstrap + nil + (let ((class (and (symbolp name) (get name 'cl--class)))) + (and class (built-in-class-p class))))) (defun cl--struct-name-p (name) "Return t if NAME is a valid structure name for `cl-defstruct'." (and name (symbolp name) (not (keywordp name)) - (not (memq name cl--all-builtin-types)))) + (not (cl--builtin-type-p name)))) ;; When we load this (compiled) file during pre-loading, the cl--struct-class ;; code below will need to access the `cl-struct' info, since it's considered @@ -147,7 +112,7 @@ supertypes from the most specific to least specific.") (defun cl--struct-register-child (parent tag) ;; Can't use (cl-typep parent 'cl-structure-class) at this stage ;; because `cl-structure-class' is defined later. - (while (recordp parent) + (while (cl--struct-class-p parent) (add-to-list (cl--struct-class-children-sym parent) tag) ;; Only register ourselves as a child of the leftmost parent since structs ;; can only have one parent. @@ -162,9 +127,14 @@ supertypes from the most specific to least specific.") (with-suppressed-warnings ((obsolete cl-old-struct-compat-mode)) (message "cl-old-struct-compat-mode is obsolete!") (cl-old-struct-compat-mode 1))) - (if (eq type 'record) - ;; Defstruct using record objects. - (setq type nil)) + (when (eq type 'record) + ;; Defstruct using record objects. + (setq type nil) + ;; `cl-structure-class' and `cl-structure-object' are allowed to be + ;; defined without specifying the parent, because their parent + ;; doesn't exist yet when they're defined. + (cl-assert (or parent (memq name '(cl-structure-class + cl-structure-object))))) (cl-assert (or type (not named))) (if (boundp children-sym) (add-to-list children-sym tag) @@ -172,7 +142,9 @@ supertypes from the most specific to least specific.") (and (null type) (eq (caar slots) 'cl-tag-slot) ;; Hide the tag slot from "standard" (i.e. non-`type'd) structs. (setq slots (cdr slots))) - (let* ((parent-class (when parent (cl--struct-get-class parent))) + (let* ((parent-class (if parent (cl--struct-get-class parent) + (cl--find-class (if (eq type 'list) 'cons + (or type 'record))))) (n (length slots)) (index-table (make-hash-table :test 'eq :size n)) (vslots (let ((v (make-vector n nil)) @@ -195,7 +167,9 @@ supertypes from the most specific to least specific.") name docstring (unless (symbolp parent-class) (list parent-class)) type named vslots index-table children-sym tag print))) - (unless (symbolp parent-class) + (cl-assert (or (not (symbolp parent-class)) + (memq name '(cl-structure-class cl-structure-object)))) + (when (cl--struct-class-p parent-class) (let ((pslots (cl--struct-class-slots parent-class))) (or (>= n (length pslots)) (let ((ok t)) @@ -286,7 +260,7 @@ supertypes from the most specific to least specific.") (cl-defstruct (cl--class (:constructor nil) (:copier nil)) - "Type of descriptors for any kind of structure-like data." + "Abstract supertype of all type descriptors." ;; Intended to be shared between defstruct and defclass. (name nil :type symbol) ;The type name. (docstring nil :type string) @@ -327,8 +301,170 @@ supertypes from the most specific to least specific.") (merge-ordered-lists (mapcar #'cl--class-allparents (cl--class-parents class))))) -(eval-and-compile - (cl-assert (null (cl--class-parents (cl--find-class 'cl-structure-object))))) +(cl-defstruct (built-in-class + (:include cl--class) + (:noinline t) + (:constructor nil) + (:constructor built-in-class--make (name docstring parents)) + (:copier nil)) + "Type descriptors for built-in types. +The `slots' (and hence `index-table') are currently unused." + ) + +(defmacro cl--define-built-in-type (name parents &optional docstring &rest slots) + ;; `slots' is currently unused, but we could make it take + ;; a list of "slot like properties" together with the corresponding + ;; accessor, and then we could maybe even make `slot-value' work + ;; on some built-in types :-) + (declare (indent 2) (doc-string 3)) + (unless (listp parents) (setq parents (list parents))) + (unless (or parents (eq name t)) + (error "Missing parents for %S: %S" name parents)) + (let ((predicate (intern-soft (format + (if (string-match "-" (symbol-name name)) + "%s-p" "%sp") + name)))) + (unless (fboundp predicate) (setq predicate nil)) + (while (keywordp (car slots)) + (let ((kw (pop slots)) (val (pop slots))) + (pcase kw + (:predicate (setq predicate val)) + (_ (error "Unknown keyword arg: %S" kw))))) + `(progn + ,(if predicate `(put ',name 'cl-deftype-satisfies #',predicate) + ;; (message "Missing predicate for: %S" name) + nil) + (put ',name 'cl--class + (built-in-class--make ',name ,docstring + (mapcar (lambda (type) + (let ((class (get type 'cl--class))) + (unless class + (error "Unknown type: %S" type)) + class)) + ',parents)))))) + +;; FIXME: Our type DAG has various quirks: +;; - Some `keyword's are also `symbol-with-pos' but that's not reflected +;; in the DAG. +;; - An OClosure can be an interpreted function or a `byte-code-function', +;; so the DAG of OClosure types is "orthogonal" to the distinction +;; between interpreted and compiled functions. + +(defun cl-functionp (object) + "Return non-nil if OBJECT is a member of type `function'. +This is like `functionp' except that it returns nil for all lists and symbols, +regardless if `funcall' would accept to call them." + (memq (cl-type-of object) + '(primitive-function subr-native-elisp module-function + interpreted-function byte-code-function))) + +(cl--define-built-in-type t nil "Abstract supertype of everything.") +(cl--define-built-in-type atom t "Abstract supertype of anything but cons cells." + :predicate atom) + +(cl--define-built-in-type tree-sitter-compiled-query atom) +(cl--define-built-in-type tree-sitter-node atom) +(cl--define-built-in-type tree-sitter-parser atom) +(when (fboundp 'user-ptrp) + (cl--define-built-in-type user-ptr atom nil + ;; FIXME: Shouldn't it be called `user-ptr-p'? + :predicate user-ptrp)) +(cl--define-built-in-type font-object atom) +(cl--define-built-in-type font-entity atom) +(cl--define-built-in-type font-spec atom) +(cl--define-built-in-type condvar atom) +(cl--define-built-in-type mutex atom) +(cl--define-built-in-type thread atom) +(cl--define-built-in-type terminal atom) +(cl--define-built-in-type hash-table atom) +(cl--define-built-in-type frame atom) +(cl--define-built-in-type buffer atom) +(cl--define-built-in-type window atom) +(cl--define-built-in-type process atom) +(cl--define-built-in-type finalizer atom) +(cl--define-built-in-type window-configuration atom) +(cl--define-built-in-type overlay atom) +(cl--define-built-in-type number-or-marker atom + "Abstract supertype of both `number's and `marker's.") +(cl--define-built-in-type symbol atom + "Type of symbols." + ;; Example of slots we could document. It would be desirable to + ;; have some way to extract this from the C code, or somehow keep it + ;; in sync (probably not for `cons' and `symbol' but for things like + ;; `font-entity'). + (name symbol-name) + (value symbol-value) + (function symbol-function) + (plist symbol-plist)) + +(cl--define-built-in-type obarray atom) +(cl--define-built-in-type native-comp-unit atom) + +(cl--define-built-in-type sequence t "Abstract supertype of sequences.") +(cl--define-built-in-type list sequence) +(cl--define-built-in-type array (sequence atom) "Abstract supertype of arrays.") +(cl--define-built-in-type number (number-or-marker) + "Abstract supertype of numbers.") +(cl--define-built-in-type float (number)) +(cl--define-built-in-type integer-or-marker (number-or-marker) + "Abstract supertype of both `integer's and `marker's.") +(cl--define-built-in-type integer (number integer-or-marker)) +(cl--define-built-in-type marker (integer-or-marker)) +(cl--define-built-in-type bignum (integer) + "Type of those integers too large to fit in a `fixnum'.") +(cl--define-built-in-type fixnum (integer) + (format "Type of small (fixed-size) integers. +The size depends on the Emacs version and compilation options. +For this build of Emacs it's %dbit." + (1+ (logb (1+ most-positive-fixnum))))) +(cl--define-built-in-type boolean (symbol) + "Type of the canonical boolean values, i.e. either nil or t.") +(cl--define-built-in-type symbol-with-pos (symbol) + "Type of symbols augmented with source-position information.") +(cl--define-built-in-type vector (array)) +(cl--define-built-in-type record (atom) + "Abstract type of objects with slots.") +(cl--define-built-in-type bool-vector (array) "Type of bitvectors.") +(cl--define-built-in-type char-table (array) + "Type of special arrays that are indexed by characters.") +(cl--define-built-in-type string (array)) +(cl--define-built-in-type null (boolean list) ;FIXME: `atom' comes before `list'? + "Type of the nil value." + :predicate null) +(cl--define-built-in-type cons (list) + "Type of cons cells." + ;; Example of slots we could document. + (car car) (cdr cdr)) +(cl--define-built-in-type function (atom) + "Abstract supertype of function values." + ;; FIXME: Historically, (cl-typep FOO 'function) called `functionp', + ;; so while `cl-functionp' would be the more correct predicate, it + ;; would breaks existing code :-( + ;; :predicate cl-functionp + ) +(cl--define-built-in-type compiled-function (function) + "Abstract type of functions that have been compiled.") +(cl--define-built-in-type byte-code-function (compiled-function) + "Type of functions that have been byte-compiled.") +(cl--define-built-in-type subr (atom) + "Abstract type of functions compiled to machine code.") +(cl--define-built-in-type module-function (function) + "Type of functions provided via the module API.") +(cl--define-built-in-type interpreted-function (function) + "Type of functions that have not been compiled.") +(cl--define-built-in-type special-form (subr) + "Type of the core syntactic elements of the Emacs Lisp language.") +(cl--define-built-in-type subr-native-elisp (subr compiled-function) + "Type of functions that have been compiled by the native compiler.") +(cl--define-built-in-type primitive-function (subr compiled-function) + "Type of functions hand written in C.") + +(unless (cl--class-parents (cl--find-class 'cl-structure-object)) + ;; When `cl-structure-object' is created, built-in classes didn't exist + ;; yet, so we couldn't put `record' as the parent. + ;; Fix it now to close the recursion. + (setf (cl--class-parents (cl--find-class 'cl-structure-object)) + (list (cl--find-class 'record)))) ;; Make sure functions defined with cl-defsubst can be inlined even in ;; packages which do not require CL. We don't put an autoload cookie diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el index c35353ec3d0..5e5eee1da9e 100644 --- a/lisp/emacs-lisp/cl-print.el +++ b/lisp/emacs-lisp/cl-print.el @@ -444,7 +444,7 @@ primitives such as `prin1'.") (defun cl-print--preprocess (object) (let ((print-number-table (make-hash-table :test 'eq :rehash-size 2.0))) - (if (fboundp 'print--preprocess) + (if (fboundp 'print--preprocess) ;Emacs≥26 ;; Use the predefined C version if available. (print--preprocess object) ;Fill print-number-table! (let ((cl-print--number-index 0)) diff --git a/lisp/emacs-lisp/comp-common.el b/lisp/emacs-lisp/comp-common.el index 6ba9664ea5c..4edfe811586 100644 --- a/lisp/emacs-lisp/comp-common.el +++ b/lisp/emacs-lisp/comp-common.el @@ -119,7 +119,7 @@ Used to modify the compiler environment." (function ((or integer marker) (or integer marker)) string)) (bufferp (function (t) boolean)) (byte-code-function-p (function (t) boolean)) - (capitalize (function (or integer string) (or integer string))) + (capitalize (function ((or integer string)) (or integer string))) (car (function (list) t)) (car-less-than-car (function (list list) boolean)) (car-safe (function (t) t)) @@ -240,7 +240,8 @@ Used to modify the compiler environment." (integer-or-marker-p (function (t) boolean)) (integerp (function (t) boolean)) (interactive-p (function () boolean)) - (intern-soft (function ((or string symbol) &optional vector) symbol)) + (intern-soft (function ((or string symbol) &optional (or obarray vector)) + symbol)) (invocation-directory (function () string)) (invocation-name (function () string)) (isnan (function (float) boolean)) @@ -309,7 +310,7 @@ Used to modify the compiler environment." (numberp (function (t) boolean)) (one-window-p (function (&optional t t) boolean)) (overlayp (function (t) boolean)) - (parse-colon-path (function (string) cons)) + (parse-colon-path (function (string) list)) (plist-get (function (list t &optional t) t)) (plist-member (function (list t &optional t) list)) (point (function () integer)) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index c65af16b725..cbfb9540f03 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -38,13 +38,7 @@ (require 'cl-lib) (require 'cl-extra) ;HACK: For `cl-find-class' when `cl-loaddefs' is missing. -(defconst comp--typeof-builtin-types (mapcar (lambda (x) - (append x '(t))) - cl--typeof-types) - ;; TODO can we just add t in `cl--typeof-types'? - "Like `cl--typeof-types' but with t as common supertype.") - -(cl-defstruct (comp-cstr (:constructor comp-type-to-cstr +(cl-defstruct (comp-cstr (:constructor comp--type-to-cstr (type &aux (null (eq type 'null)) (integer (eq type 'integer)) @@ -55,7 +49,7 @@ '(nil))) (range (when integer '((- . +)))))) - (:constructor comp-value-to-cstr + (:constructor comp--value-to-cstr (value &aux (integer (integerp value)) (valset (unless integer @@ -63,7 +57,7 @@ (range (when integer `((,value . ,value)))) (typeset ()))) - (:constructor comp-irange-to-cstr + (:constructor comp--irange-to-cstr (irange &aux (range (list irange)) (typeset ()))) @@ -89,12 +83,7 @@ Integer values are handled in the `range' slot.") (defun comp--cl-class-hierarchy (x) "Given a class name `x' return its hierarchy." - `(,@(cl--class-allparents (cl--struct-get-class x)) - ;; FIXME: AFAICT, `comp--all-classes' will also find those struct types - ;; which use :type and can thus be either `vector' or `cons' (the latter - ;; isn't `atom'). - atom - t)) + (cl--class-allparents (cl--find-class x))) (defun comp--all-classes () "Return all non built-in type names currently defined." @@ -106,15 +95,14 @@ Integer values are handled in the `range' slot.") res)) (defun comp--compute-typeof-types () - (append comp--typeof-builtin-types - (mapcar #'comp--cl-class-hierarchy (comp--all-classes)))) + (mapcar #'comp--cl-class-hierarchy (comp--all-classes))) (defun comp--compute--pred-type-h () (cl-loop with h = (make-hash-table :test #'eq) for class-name in (comp--all-classes) for pred = (get class-name 'cl-deftype-satisfies) when pred - do (puthash pred class-name h) + do (puthash pred (comp--type-to-cstr class-name) h) finally return h)) (cl-defstruct comp-cstr-ctxt @@ -130,7 +118,7 @@ Integer values are handled in the `range' slot.") ;; TODO we should be able to just cons hash this. (common-supertype-mem (make-hash-table :test #'equal) :type hash-table :documentation "Serve memoization for -`comp-common-supertype'.") +`comp-ctxt-common-supertype-mem'.") (subtype-p-mem (make-hash-table :test #'equal) :type hash-table :documentation "Serve memoization for `comp-cstr-ctxt-subtype-p-mem'.") @@ -229,10 +217,10 @@ Return them as multiple value." ;; builds. (defvar comp-ctxt nil) -(defvar comp-cstr-one (comp-value-to-cstr 1) +(defvar comp-cstr-one (comp--value-to-cstr 1) "Represent the integer immediate one.") -(defvar comp-cstr-t (comp-type-to-cstr t) +(defvar comp-cstr-t (comp--type-to-cstr t) "Represent the superclass t.") @@ -249,6 +237,8 @@ Return them as multiple value." t) ((and (not (symbolp x)) (symbolp y)) nil) + ((or (consp x) (consp y) + nil)) (t (< (sxhash-equal x) (sxhash-equal y))))))) @@ -270,18 +260,10 @@ Return them as multiple value." (symbol-name y))) (defun comp--direct-supertypes (type) - "Return the direct supertypes of TYPE." - (let ((supers (comp-supertypes type))) - (cl-assert (eq type (car supers))) - (cl-loop - with notdirect = nil - with direct = nil - for parent in (cdr supers) - unless (memq parent notdirect) - do (progn - (push parent direct) - (setq notdirect (append notdirect (comp-supertypes parent)))) - finally return direct))) + (when (symbolp type) ;; FIXME: Can this test ever fail? + (let* ((class (cl--find-class type)) + (parents (if class (cl--class-parents class)))) + (mapcar #'cl--class-name parents)))) (defsubst comp-subtype-p (type1 type2) "Return t if TYPE1 is a subtype of TYPE2 or nil otherwise." @@ -306,13 +288,10 @@ Return them as multiple value." (apply #'append (mapcar #'comp--direct-supertypes typeset))) for subs = (comp--direct-subtypes sup) - when (and (length> subs 1) ;;FIXME: Why? - ;; Every subtype of `sup` is a subtype of - ;; some element of `typeset`? - ;; It's tempting to just check (member x typeset), - ;; but think of the typeset (marker number), - ;; where `sup' is `integer-or-marker' and `sub' - ;; is `integer'. + when (and (length> subs 1) ;; If there's only one sub do + ;; nothing as we want to + ;; return the most specific + ;; type. (cl-every (lambda (sub) (cl-some (lambda (type) (comp-subtype-p sub type)) @@ -353,23 +332,8 @@ Return them as multiple value." (defun comp-supertypes (type) "Return the ordered list of supertypes of TYPE." - ;; FIXME: We should probably keep the results in - ;; `comp-cstr-ctxt-typeof-types' (or maybe even precompute them - ;; and maybe turn `comp-cstr-ctxt-typeof-types' into a hash-table). - ;; Or maybe we shouldn't keep structs and defclasses in it, - ;; and just use `cl--class-allparents' when needed (and refuse to - ;; compute their direct subtypes since we can't know them). - (cl-loop - named loop - with above - for lane in (comp-cstr-ctxt-typeof-types comp-ctxt) - do (let ((x (memq type lane))) - (cond - ((null x) nil) - ((eq x lane) (cl-return-from loop x)) ;A base type: easy case. - (t (setq above - (if above (comp--intersection x above) x))))) - finally return above)) + (or (assq type (comp-cstr-ctxt-typeof-types comp-ctxt)) + (error "Type %S missing from typeof-types!" type))) (defun comp-union-typesets (&rest typesets) "Union types present into TYPESETS." @@ -608,7 +572,7 @@ All SRCS constraints must be homogeneously negated or non-negated." ;; We propagate only values those types are not already ;; into typeset. when (cl-notany (lambda (x) - (comp-subtype-p (type-of v) x)) + (comp-subtype-p (cl-type-of v) x)) (comp-cstr-typeset dst)) collect v))) @@ -697,7 +661,7 @@ DST is returned." ;; Verify disjoint condition between positive types and ;; negative types coming from values, in case give-up. - (let ((neg-value-types (nconc (mapcar #'type-of (valset neg)) + (let ((neg-value-types (nconc (mapcar #'cl-type-of (valset neg)) (when (range neg) '(integer))))) (when (cl-some (lambda (x) @@ -718,7 +682,7 @@ DST is returned." ((cl-some (lambda (x) (cl-some (lambda (y) (comp-subtype-p y x)) - (mapcar #'type-of (valset pos)))) + (mapcar #'cl-type-of (valset pos)))) (typeset neg)) (give-up)) (t @@ -1141,7 +1105,7 @@ DST is returned." (cl-loop for v in (valset dst) unless (symbolp v) do (push v strip-values) - (push (type-of v) strip-types)) + (push (cl-type-of v) strip-types)) (when strip-values (setf (typeset dst) (comp-union-typesets (typeset dst) strip-types) (valset dst) (cl-set-difference (valset dst) strip-values))) @@ -1210,14 +1174,14 @@ FN non-nil indicates we are parsing a function lambda list." ('nil (make-comp-cstr :typeset ())) ('fixnum - (comp-irange-to-cstr `(,most-negative-fixnum . ,most-positive-fixnum))) + (comp--irange-to-cstr `(,most-negative-fixnum . ,most-positive-fixnum))) ('boolean (comp-type-spec-to-cstr '(member t nil))) ('integer - (comp-irange-to-cstr '(- . +))) - ('null (comp-value-to-cstr nil)) + (comp--irange-to-cstr '(- . +))) + ('null (comp--value-to-cstr nil)) ((pred atom) - (comp-type-to-cstr type-spec)) + (comp--type-to-cstr type-spec)) (`(or . ,rest) (apply #'comp-cstr-union-make (mapcar #'comp-type-spec-to-cstr rest))) @@ -1227,16 +1191,16 @@ FN non-nil indicates we are parsing a function lambda list." (`(not ,cstr) (comp-cstr-negation-make (comp-type-spec-to-cstr cstr))) (`(integer ,(and (pred integerp) l) ,(and (pred integerp) h)) - (comp-irange-to-cstr `(,l . ,h))) + (comp--irange-to-cstr `(,l . ,h))) (`(integer * ,(and (pred integerp) h)) - (comp-irange-to-cstr `(- . ,h))) + (comp--irange-to-cstr `(- . ,h))) (`(integer ,(and (pred integerp) l) *) - (comp-irange-to-cstr `(,l . +))) + (comp--irange-to-cstr `(,l . +))) (`(float ,(pred comp-star-or-num-p) ,(pred comp-star-or-num-p)) ;; No float range support :/ - (comp-type-to-cstr 'float)) + (comp--type-to-cstr 'float)) (`(member . ,rest) - (apply #'comp-cstr-union-make (mapcar #'comp-value-to-cstr rest))) + (apply #'comp-cstr-union-make (mapcar #'comp--value-to-cstr rest))) (`(function ,args ,ret) (make-comp-cstr-f :args (mapcar (lambda (x) diff --git a/lisp/emacs-lisp/comp-run.el b/lisp/emacs-lisp/comp-run.el index 5d1a193269d..5cc61579030 100644 --- a/lisp/emacs-lisp/comp-run.el +++ b/lisp/emacs-lisp/comp-run.el @@ -25,7 +25,7 @@ ;; While the main native compiler is implemented in comp.el, when ;; commonly used as a jit compiler it is only loaded by Emacs sub -;; processes performing async compilation. This files contains all +;; processes performing async compilation. This file contains all ;; the code needed to drive async compilations and any Lisp code ;; needed at runtime to run native code. @@ -72,11 +72,23 @@ Set this variable to nil to suppress warnings altogether, or to the symbol `silent' to log warnings but not pop up the *Warnings* buffer." :type '(choice - (const :tag "Do not report warnings" nil) - (const :tag "Report and display warnings" t) - (const :tag "Report but do not display warnings" silent)) + (const :tag "Do not report warnings/errors" nil) + (const :tag "Report and display warnings/errors" t) + (const :tag "Report but do not display warnings/errors" silent)) :version "28.1") +(defcustom native-comp-async-warnings-errors-kind 'important + "Which kind of warnings and errors to report from async native compilation. + +Setting this variable to `important' (the default) will report +only important warnings and all errors. +Setting this variable to `all' will report all warnings and +errors." + :type '(choice + (const :tag "Report all warnings/errors" all) + (const :tag "Report important warnings and all errors" important)) + :version "30.1") + (defcustom native-comp-always-compile nil "Non-nil means unconditionally (re-)compile all files." :type 'boolean @@ -184,13 +196,21 @@ processes from `comp-async-compilations'" (let ((warning-suppress-types (if (eq native-comp-async-report-warnings-errors 'silent) (cons '(comp) warning-suppress-types) - warning-suppress-types))) + warning-suppress-types)) + (regexp (if (eq native-comp-async-warnings-errors-kind 'all) + "^.*?\\(?:Error\\|Warning\\): .*$" + (rx bol + (*? nonl) + (or + (seq "Error: " (*? nonl)) + (seq "Warning: the function ‘" (1+ (not "’")) + "’ is not known to be defined.")) + eol)))) (with-current-buffer (process-buffer process) (save-excursion (accept-process-output process) (goto-char (or comp-last-scanned-async-output (point-min))) - (while (re-search-forward "^.*?\\(?:Error\\|Warning\\): .*$" - nil t) + (while (re-search-forward regexp nil t) (display-warning 'comp (match-string 0))) (setq comp-last-scanned-async-output (point-max))))) (accept-process-output process))) @@ -213,8 +233,8 @@ display a message." "`comp-files-queue' should be \".el\" files: %s" source-file) when (or native-comp-always-compile - load ; Always compile when the compilation is - ; commanded for late load. + load ; Always compile when the compilation is + ; commanded for late load. ;; Skip compilation if `comp-el-to-eln-filename' fails ;; to find a writable directory. (with-demoted-errors "Async compilation :%S" @@ -236,6 +256,7 @@ display a message." load-path backtrace-line-length byte-compile-warnings + comp-sanitizer-emit ;; package-load-list ;; package-user-dir ;; package-directory-list @@ -344,13 +365,15 @@ Return the trampoline if found or nil otherwise." (when (memq subr-name comp-warn-primitives) (warn "Redefining `%s' might break native compilation of trampolines." subr-name)) - (unless (or (null native-comp-enable-subr-trampolines) - (memq subr-name native-comp-never-optimize-functions) - (gethash subr-name comp-installed-trampolines-h)) - (cl-assert (subr-primitive-p (symbol-function subr-name))) - (when-let ((trampoline (or (comp-trampoline-search subr-name) - (comp-trampoline-compile subr-name)))) - (comp--install-trampoline subr-name trampoline)))) + (let ((subr (symbol-function subr-name))) + (unless (or (not (string= subr-name (subr-name subr))) ;; (bug#69573) + (null native-comp-enable-subr-trampolines) + (memq subr-name native-comp-never-optimize-functions) + (gethash subr-name comp-installed-trampolines-h)) + (cl-assert (subr-primitive-p subr)) + (when-let ((trampoline (or (comp-trampoline-search subr-name) + (comp-trampoline-compile subr-name)))) + (comp--install-trampoline subr-name trampoline))))) ;;;###autoload (defun native--compile-async (files &optional recursively load selector) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 260bd2f1acb..2ec55ed98ee 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -43,7 +43,7 @@ (defvar native-comp-eln-load-path) (defvar native-comp-enable-subr-trampolines) -(declare-function comp--compile-ctxt-to-file "comp.c") +(declare-function comp--compile-ctxt-to-file0 "comp.c") (declare-function comp--init-ctxt "comp.c") (declare-function comp--release-ctxt "comp.c") (declare-function comp-el-to-eln-filename "comp.c") @@ -68,7 +68,7 @@ :safe #'integerp :version "28.1") -(defcustom native-comp-debug 0 +(defcustom native-comp-debug 0 "Debug level for native compilation, a number between 0 and 3. This is intended for debugging the compiler itself. 0 no debug output. @@ -155,17 +155,19 @@ native compilation runs.") "Current allocation class. Can be one of: `d-default', `d-impure' or `d-ephemeral'. See `comp-ctxt'.") -(defconst comp-passes '(comp-spill-lap - comp-limplify - comp-fwprop - comp-call-optim - comp-ipa-pure - comp-add-cstrs - comp-fwprop - comp-tco - comp-fwprop - comp-remove-type-hints - comp-final) +(defconst comp-passes '(comp--spill-lap + comp--limplify + comp--fwprop + comp--call-optim + comp--ipa-pure + comp--add-cstrs + comp--fwprop + comp--tco + comp--fwprop + comp--remove-type-hints + comp--sanitizer + comp--compute-function-types + comp--final) "Passes to be executed in order.") (defvar comp-disabled-passes '() @@ -187,42 +189,56 @@ Useful to hook into pass checkers.") finally return h) "Hash table function -> `comp-constraint'.") +;; Keep it in sync with the `cl-deftype-satisfies' property set in +;; cl-macs.el. We can't use `cl-deftype-satisfies' directly as the +;; relation type <-> predicate is not bijective (bug#45576). (defconst comp-known-predicates - '((arrayp . array) - (atom . atom) - (characterp . fixnum) - (booleanp . boolean) - (bool-vector-p . bool-vector) - (bufferp . buffer) - (natnump . (integer 0 *)) - (char-table-p . char-table) - (hash-table-p . hash-table) - (consp . cons) - (integerp . integer) - (floatp . float) - (functionp . (or function symbol)) - (integerp . integer) - (keywordp . keyword) - (listp . list) - (numberp . number) - (null . null) - (numberp . number) - (sequencep . sequence) - (stringp . string) - (symbolp . symbol) - (vectorp . vector) - (integer-or-marker-p . integer-or-marker)) - "Alist predicate -> matched type specifier.") + ;; FIXME: Auto-generate (most of) it from `cl-deftype-satifies'? + '((arrayp array) + (atom atom) + (bool-vector-p bool-vector) + (booleanp boolean) + (bufferp buffer) + (char-table-p char-table) + (characterp fixnum t) + (consp cons) + (floatp float) + (framep frame) + (functionp (or function symbol cons) (not function)) + (hash-table-p hash-table) + (integer-or-marker-p integer-or-marker) + (integerp integer) + (keywordp symbol t) + (listp list) + (markerp marker) + (natnump (integer 0 *)) + (null null) + (number-or-marker-p number-or-marker) + (numberp number) + (obarrayp obarray) + (overlayp overlay) + (processp process) + (sequencep sequence) + (stringp string) + (subrp subr) + (symbol-with-pos-p symbol-with-pos) + (symbolp symbol) + (vectorp vector) + (windowp window)) + "(PREDICATE TYPE-IF-SATISFIED ?TYPE-IF-NOT-SATISFIED).") (defconst comp-known-predicates-h (cl-loop with comp-ctxt = (make-comp-cstr-ctxt) with h = (make-hash-table :test #'eq) - for (pred . type-spec) in comp-known-predicates - for cstr = (comp-type-spec-to-cstr type-spec) - do (puthash pred cstr h) + for (pred . type-specs) in comp-known-predicates + for pos-cstr = (comp-type-spec-to-cstr (car type-specs)) + for neg-cstr = (if (length> type-specs 1) + (comp-type-spec-to-cstr (cl-second type-specs)) + (comp-cstr-negation-make pos-cstr)) + do (puthash pred (cons pos-cstr neg-cstr) h) finally return h) - "Hash table function -> `comp-constraint'.") + "Hash table FUNCTION -> (POS-CSTR . NEG-CSTR).") (defun comp--known-predicate-p (predicate) "Return t if PREDICATE is known." @@ -230,9 +246,14 @@ Useful to hook into pass checkers.") (gethash predicate (comp-cstr-ctxt-pred-type-h comp-ctxt))) t)) -(defun comp--pred-to-cstr (predicate) - "Given PREDICATE, return the corresponding constraint." - (or (gethash predicate comp-known-predicates-h) +(defun comp--pred-to-pos-cstr (predicate) + "Given PREDICATE, return the corresponding positive constraint." + (or (car-safe (gethash predicate comp-known-predicates-h)) + (gethash predicate (comp-cstr-ctxt-pred-type-h comp-ctxt)))) + +(defun comp--pred-to-neg-cstr (predicate) + "Given PREDICATE, return the corresponding negative constraint." + (or (cdr-safe (gethash predicate comp-known-predicates-h)) (gethash predicate (comp-cstr-ctxt-pred-type-h comp-ctxt)))) (defconst comp-symbol-values-optimizable '(most-positive-fixnum @@ -388,7 +409,7 @@ This is typically for top-level forms other than defun.") (closed nil :type boolean :documentation "t if closed.") ;; All the following are for SSA and CGF analysis. - ;; Keep in sync with `comp-clean-ssa'!! + ;; Keep in sync with `comp--clean-ssa'!! (in-edges () :type list :documentation "List of incoming edges.") (out-edges () :type list @@ -416,7 +437,7 @@ into it.") :documentation "Start block LAP address.") (non-ret-insn nil :type list :documentation "Insn known to perform a non local exit. -`comp-fwprop' may identify and store here basic blocks performing +`comp--fwprop' may identify and store here basic blocks performing non local exits and mark it rewrite it later.") (no-ret nil :type boolean :documentation "t when the block is known to perform a @@ -507,7 +528,7 @@ CFG is mutated by a pass.") (lambda-list nil :type list :documentation "Original lambda-list.")) -(cl-defstruct (comp-mvar (:constructor make--comp-mvar) +(cl-defstruct (comp-mvar (:constructor make--comp-mvar0) (:include comp-cstr)) "A meta-variable being a slot in the meta-stack." (id nil :type (or null number) @@ -516,6 +537,7 @@ CFG is mutated by a pass.") :documentation "Slot number in the array if a number or `scratch' for scratch slot.")) +;; In use by comp.c. (defun comp-mvar-type-hint-match-p (mvar type-hint) "Match MVAR against TYPE-HINT. In use by the back-end." @@ -569,10 +591,9 @@ In use by the back-end." finally return t) t)) -(defsubst comp--symbol-func-to-fun (symbol-funcion) - "Given a function called SYMBOL-FUNCION return its `comp-func'." - (gethash (gethash symbol-funcion (comp-ctxt-sym-to-c-name-h - comp-ctxt)) +(defsubst comp--symbol-func-to-fun (symbol-func) + "Given a function called SYMBOL-FUNC return its `comp-func'." + (gethash (gethash symbol-func (comp-ctxt-sym-to-c-name-h comp-ctxt)) (comp-ctxt-funcs-h comp-ctxt))) (defun comp--function-pure-p (f) @@ -637,7 +658,7 @@ VERBOSITY is a number between 0 and 3." -(defmacro comp-loop-insn-in-block (basic-block &rest body) +(defmacro comp--loop-insn-in-block (basic-block &rest body) "Loop over all insns in BASIC-BLOCK executing BODY. Inside BODY, `insn' and `insn-cell'can be used to read or set the current instruction or its cell." @@ -651,19 +672,19 @@ current instruction or its cell." ;;; spill-lap pass specific code. -(defun comp-lex-byte-func-p (f) +(defun comp--lex-byte-func-p (f) "Return t if F is a lexically-scoped byte compiled function." (and (byte-code-function-p f) (fixnump (aref f 0)))) -(defun comp-spill-decl-spec (function-name spec) +(defun comp--spill-decl-spec (function-name spec) "Return the declared specifier SPEC for FUNCTION-NAME." (plist-get (cdr (assq function-name byte-to-native-plist-environment)) spec)) -(defun comp-spill-speed (function-name) +(defun comp--spill-speed (function-name) "Return the speed for FUNCTION-NAME." - (or (comp-spill-decl-spec function-name 'speed) + (or (comp--spill-decl-spec function-name 'speed) (comp-ctxt-speed comp-ctxt))) ;; Autoloaded as might be used by `disassemble-internal'. @@ -702,7 +723,7 @@ clashes." ;; pick the first one. (concat prefix crypted "_" human-readable "_0")))) -(defun comp-decrypt-arg-list (x function-name) +(defun comp--decrypt-arg-list (x function-name) "Decrypt argument list X for FUNCTION-NAME." (unless (fixnump x) (signal 'native-compiler-error-dyn-func (list function-name))) @@ -717,21 +738,21 @@ clashes." :nonrest nonrest :rest rest)))) -(defsubst comp-byte-frame-size (byte-compiled-func) +(defsubst comp--byte-frame-size (byte-compiled-func) "Return the frame size to be allocated for BYTE-COMPILED-FUNC." (aref byte-compiled-func 3)) -(defun comp-add-func-to-ctxt (func) +(defun comp--add-func-to-ctxt (func) "Add FUNC to the current compiler context." (let ((name (comp-func-name func)) (c-name (comp-func-c-name func))) (puthash name c-name (comp-ctxt-sym-to-c-name-h comp-ctxt)) (puthash c-name func (comp-ctxt-funcs-h comp-ctxt)))) -(cl-defgeneric comp-spill-lap-function (input) +(cl-defgeneric comp--spill-lap-function (input) "Byte-compile INPUT and spill lap for further stages.") -(cl-defmethod comp-spill-lap-function ((function-name symbol)) +(cl-defmethod comp--spill-lap-function ((function-name symbol)) "Byte-compile FUNCTION-NAME, spilling data from the byte compiler." (unless (comp-ctxt-output comp-ctxt) (setf (comp-ctxt-output comp-ctxt) @@ -747,9 +768,9 @@ clashes." (list (make-byte-to-native-func-def :name function-name :c-name c-name :byte-func byte-code))) - (maphash #'comp-intern-func-in-ctxt byte-to-native-lambdas-h))) + (maphash #'comp--intern-func-in-ctxt byte-to-native-lambdas-h))) -(cl-defmethod comp-spill-lap-function ((form list)) +(cl-defmethod comp--spill-lap-function ((form list)) "Byte-compile FORM, spilling data from the byte compiler." (unless (memq (car-safe form) '(lambda closure)) (signal 'native-compiler-error @@ -763,9 +784,9 @@ clashes." (list (make-byte-to-native-func-def :name '--anonymous-lambda :c-name c-name :byte-func byte-code))) - (maphash #'comp-intern-func-in-ctxt byte-to-native-lambdas-h))) + (maphash #'comp--intern-func-in-ctxt byte-to-native-lambdas-h))) -(defun comp-intern-func-in-ctxt (_ obj) +(defun comp--intern-func-in-ctxt (_ obj) "Given OBJ of type `byte-to-native-lambda', create a function in `comp-ctxt'." (when-let ((byte-func (byte-to-native-lambda-byte-func obj))) (let* ((lap (byte-to-native-lambda-lap obj)) @@ -778,9 +799,9 @@ clashes." (name (when top-l-form (byte-to-native-func-def-name top-l-form))) (c-name (comp-c-func-name (or name "anonymous-lambda") "F")) - (func (if (comp-lex-byte-func-p byte-func) + (func (if (comp--lex-byte-func-p byte-func) (make-comp-func-l - :args (comp-decrypt-arg-list (aref byte-func 0) + :args (comp--decrypt-arg-list (aref byte-func 0) name)) (make-comp-func-d :lambda-list (aref byte-func 0))))) (setf (comp-func-name func) name @@ -790,9 +811,9 @@ clashes." (comp-func-command-modes func) (command-modes byte-func) (comp-func-c-name func) c-name (comp-func-lap func) lap - (comp-func-frame-size func) (comp-byte-frame-size byte-func) - (comp-func-speed func) (comp-spill-speed name) - (comp-func-pure func) (comp-spill-decl-spec name 'pure)) + (comp-func-frame-size func) (comp--byte-frame-size byte-func) + (comp-func-speed func) (comp--spill-speed name) + (comp-func-pure func) (comp--spill-decl-spec name 'pure)) ;; Store the c-name to have it retrievable from ;; `comp-ctxt-top-level-forms'. @@ -800,11 +821,11 @@ clashes." (setf (byte-to-native-func-def-c-name top-l-form) c-name)) (unless name (puthash byte-func func (comp-ctxt-byte-func-to-func-h comp-ctxt))) - (comp-add-func-to-ctxt func) + (comp--add-func-to-ctxt func) (comp-log (format "Function %s:\n" name) 1) (comp-log lap 1 t)))) -(cl-defmethod comp-spill-lap-function ((filename string)) +(cl-defmethod comp--spill-lap-function ((filename string)) "Byte-compile FILENAME, spilling data from the byte compiler." (byte-compile-file filename) (when (or (null byte-native-qualities) @@ -829,7 +850,7 @@ clashes." collect (if (and (byte-to-native-func-def-p form) (eq -1 - (comp-spill-speed (byte-to-native-func-def-name form)))) + (comp--spill-speed (byte-to-native-func-def-name form)))) (let ((byte-code (byte-to-native-func-def-byte-func form))) (remhash byte-code byte-to-native-lambdas-h) (make-byte-to-native-top-level @@ -837,11 +858,11 @@ clashes." ',(byte-to-native-func-def-name form) ,byte-code nil) - :lexical (comp-lex-byte-func-p byte-code))) + :lexical (comp--lex-byte-func-p byte-code))) form))) - (maphash #'comp-intern-func-in-ctxt byte-to-native-lambdas-h)) + (maphash #'comp--intern-func-in-ctxt byte-to-native-lambdas-h)) -(defun comp-spill-lap (input) +(defun comp--spill-lap (input) "Byte-compile and spill the LAP representation for INPUT. If INPUT is a symbol, it is the function-name to be compiled. If INPUT is a string, it is the filename to be compiled." @@ -849,7 +870,7 @@ If INPUT is a string, it is the filename to be compiled." (byte-to-native-lambdas-h (make-hash-table :test #'eq)) (byte-to-native-top-level-forms ()) (byte-to-native-plist-environment ()) - (res (comp-spill-lap-function input))) + (res (comp--spill-lap-function input))) (comp-cstr-ctxt-update-type-slots comp-ctxt) res)) @@ -878,55 +899,55 @@ Points to the next slot to be filled.") byte-switch byte-pushconditioncase) "LAP end of basic blocks op codes.") -(defun comp-lap-eob-p (inst) +(defun comp--lap-eob-p (inst) "Return t if INST closes the current basic blocks, nil otherwise." (when (memq (car inst) comp-lap-eob-ops) t)) -(defun comp-lap-fall-through-p (inst) +(defun comp--lap-fall-through-p (inst) "Return t if INST falls through, nil otherwise." (when (not (memq (car inst) '(byte-goto byte-return))) t)) -(defsubst comp-sp () +(defsubst comp--sp () "Current stack pointer." (declare (gv-setter (lambda (val) `(setf (comp-limplify-sp comp-pass) ,val)))) (comp-limplify-sp comp-pass)) -(defmacro comp-with-sp (sp &rest body) +(defmacro comp--with-sp (sp &rest body) "Execute BODY setting the stack pointer to SP. Restore the original value afterwards." (declare (debug (form body)) (indent defun)) (let ((sym (gensym))) - `(let ((,sym (comp-sp))) - (setf (comp-sp) ,sp) + `(let ((,sym (comp--sp))) + (setf (comp--sp) ,sp) (progn ,@body) - (setf (comp-sp) ,sym)))) + (setf (comp--sp) ,sym)))) -(defsubst comp-slot-n (n) +(defsubst comp--slot-n (n) "Slot N into the meta-stack." (comp-vec-aref (comp-limplify-frame comp-pass) n)) -(defsubst comp-slot () +(defsubst comp--slot () "Current slot into the meta-stack pointed by sp." - (comp-slot-n (comp-sp))) + (comp--slot-n (comp--sp))) -(defsubst comp-slot+1 () +(defsubst comp--slot+1 () "Slot into the meta-stack pointed by sp + 1." - (comp-slot-n (1+ (comp-sp)))) + (comp--slot-n (1+ (comp--sp)))) -(defsubst comp-label-to-addr (label) +(defsubst comp--label-to-addr (label) "Find the address of LABEL." (or (gethash label (comp-limplify-label-to-addr comp-pass)) (signal 'native-ice (list "label not found" label)))) -(defsubst comp-mark-curr-bb-closed () +(defsubst comp--mark-curr-bb-closed () "Mark the current basic block as closed." (setf (comp-block-closed (comp-limplify-curr-block comp-pass)) t)) -(defun comp-bb-maybe-add (lap-addr &optional sp) +(defun comp--bb-maybe-add (lap-addr &optional sp) "If necessary create a pending basic block for LAP-ADDR with stack depth SP. The basic block is returned regardless it was already declared or not." (let ((bb (or (cl-loop ; See if the block was already limplified. @@ -944,24 +965,24 @@ The basic block is returned regardless it was already declared or not." (signal 'native-ice (list "incoherent stack pointers" sp (comp-block-lap-sp bb)))) bb) - (car (push (make--comp-block-lap lap-addr sp (comp-new-block-sym)) + (car (push (make--comp-block-lap lap-addr sp (comp--new-block-sym)) (comp-limplify-pending-blocks comp-pass)))))) -(defsubst comp-call (func &rest args) +(defsubst comp--call (func &rest args) "Emit a call for function FUNC with ARGS." `(call ,func ,@args)) -(defun comp-callref (func nargs stack-off) +(defun comp--callref (func nargs stack-off) "Emit a call using narg abi for FUNC. NARGS is the number of arguments. STACK-OFF is the index of the first slot frame involved." `(callref ,func ,@(cl-loop repeat nargs for sp from stack-off - collect (comp-slot-n sp)))) + collect (comp--slot-n sp)))) -(cl-defun make-comp-mvar (&key slot (constant nil const-vld) type neg) +(cl-defun make--comp-mvar (&key slot (constant nil const-vld) type neg) "`comp-mvar' initializer." - (let ((mvar (make--comp-mvar :slot slot))) + (let ((mvar (make--comp-mvar0 :slot slot))) (when const-vld (comp--add-const-to-relocs constant) (setf (comp-cstr-imm mvar) constant)) @@ -971,49 +992,49 @@ STACK-OFF is the index of the first slot frame involved." (setf (comp-mvar-neg mvar) t)) mvar)) -(defun comp-new-frame (size vsize &optional ssa) +(defun comp--new-frame (size vsize &optional ssa) "Return a clean frame of meta variables of size SIZE and VSIZE. If SSA is non-nil, populate it with m-var in ssa form." (cl-loop with v = (make-comp-vec :beg (- vsize) :end size) for i from (- vsize) below size for mvar = (if ssa - (make-comp-ssa-mvar :slot i) - (make-comp-mvar :slot i)) + (make--comp--ssa-mvar :slot i) + (make--comp-mvar :slot i)) do (setf (comp-vec-aref v i) mvar) finally return v)) -(defun comp-emit (insn) +(defun comp--emit (insn) "Emit INSN into basic block BB." (let ((bb (comp-limplify-curr-block comp-pass))) (cl-assert (not (comp-block-closed bb))) (push insn (comp-block-insns bb)))) -(defun comp-emit-set-call (call) +(defun comp--emit-set-call (call) "Emit CALL assigning the result to the current slot frame. If the callee function is known to have a return type, propagate it." (cl-assert call) - (comp-emit (list 'set (comp-slot) call))) + (comp--emit (list 'set (comp--slot) call))) -(defun comp-copy-slot (src-n &optional dst-n) +(defun comp--copy-slot (src-n &optional dst-n) "Set slot number DST-N to slot number SRC-N as source. If DST-N is specified, use it; otherwise assume it to be the current slot." - (comp-with-sp (or dst-n (comp-sp)) - (let ((src-slot (comp-slot-n src-n))) + (comp--with-sp (or dst-n (comp--sp)) + (let ((src-slot (comp--slot-n src-n))) (cl-assert src-slot) - (comp-emit `(set ,(comp-slot) ,src-slot))))) + (comp--emit `(set ,(comp--slot) ,src-slot))))) -(defsubst comp-emit-annotation (str) +(defsubst comp--emit-annotation (str) "Emit annotation STR." - (comp-emit `(comment ,str))) + (comp--emit `(comment ,str))) -(defsubst comp-emit-setimm (val) +(defsubst comp--emit-setimm (val) "Set constant VAL to current slot." (comp--add-const-to-relocs val) ;; Leave relocation index nil on purpose, will be fixed-up in final ;; by `comp-finalize-relocs'. - (comp-emit `(setimm ,(comp-slot) ,val))) + (comp--emit `(setimm ,(comp--slot) ,val))) -(defun comp-make-curr-block (block-name entry-sp &optional addr) +(defun comp--make-curr-block (block-name entry-sp &optional addr) "Create a basic block with BLOCK-NAME and set it as current block. ENTRY-SP is the sp value when entering. Add block to the current function and return it." @@ -1025,104 +1046,104 @@ Add block to the current function and return it." (puthash (comp-block-name bb) bb (comp-func-blocks comp-func)) bb)) -(defun comp-latch-make-fill (target) +(defun comp--latch-make-fill (target) "Create a latch pointing to TARGET and fill it. Return the created latch." - (let ((latch (make-comp-latch :name (comp-new-block-sym "latch"))) + (let ((latch (make-comp-latch :name (comp--new-block-sym "latch"))) (curr-bb (comp-limplify-curr-block comp-pass))) - ;; See `comp-make-curr-block'. + ;; See `comp--make-curr-block'. (setf (comp-limplify-curr-block comp-pass) latch) (when (< (comp-func-speed comp-func) 3) ;; At speed 3 the programmer is responsible to manually ;; place `comp-maybe-gc-or-quit'. - (comp-emit '(call comp-maybe-gc-or-quit))) - ;; See `comp-emit-uncond-jump'. - (comp-emit `(jump ,(comp-block-name target))) - (comp-mark-curr-bb-closed) + (comp--emit '(call comp-maybe-gc-or-quit))) + ;; See `comp--emit-uncond-jump'. + (comp--emit `(jump ,(comp-block-name target))) + (comp--mark-curr-bb-closed) (puthash (comp-block-name latch) latch (comp-func-blocks comp-func)) (setf (comp-limplify-curr-block comp-pass) curr-bb) latch)) -(defun comp-emit-uncond-jump (lap-label) +(defun comp--emit-uncond-jump (lap-label) "Emit an unconditional branch to LAP-LABEL." (cl-destructuring-bind (label-num . stack-depth) lap-label (when stack-depth - (cl-assert (= (1- stack-depth) (comp-sp)))) - (let* ((target-addr (comp-label-to-addr label-num)) - (target (comp-bb-maybe-add target-addr - (comp-sp))) + (cl-assert (= (1- stack-depth) (comp--sp)))) + (let* ((target-addr (comp--label-to-addr label-num)) + (target (comp--bb-maybe-add target-addr + (comp--sp))) (latch (when (< target-addr (comp-limplify-pc comp-pass)) - (comp-latch-make-fill target))) + (comp--latch-make-fill target))) (eff-target-name (comp-block-name (or latch target)))) - (comp-emit `(jump ,eff-target-name)) - (comp-mark-curr-bb-closed)))) + (comp--emit `(jump ,eff-target-name)) + (comp--mark-curr-bb-closed)))) -(defun comp-emit-cond-jump (a b target-offset lap-label negated) +(defun comp--emit-cond-jump (a b target-offset lap-label negated) "Emit a conditional jump to LAP-LABEL when A and B satisfy EQ. TARGET-OFFSET is the positive offset on the SP when branching to the target block. If NEGATED is non null, negate the tested condition. Return value is the fall-through block name." (cl-destructuring-bind (label-num . label-sp) lap-label - (let* ((bb (comp-block-name (comp-bb-maybe-add + (let* ((bb (comp-block-name (comp--bb-maybe-add (1+ (comp-limplify-pc comp-pass)) - (comp-sp)))) ; Fall through block. - (target-sp (+ target-offset (comp-sp))) - (target-addr (comp-label-to-addr label-num)) - (target (comp-bb-maybe-add target-addr target-sp)) + (comp--sp)))) ; Fall through block. + (target-sp (+ target-offset (comp--sp))) + (target-addr (comp--label-to-addr label-num)) + (target (comp--bb-maybe-add target-addr target-sp)) (latch (when (< target-addr (comp-limplify-pc comp-pass)) - (comp-latch-make-fill target))) + (comp--latch-make-fill target))) (eff-target-name (comp-block-name (or latch target)))) (when label-sp - (cl-assert (= (1- label-sp) (+ target-offset (comp-sp))))) - (comp-emit (if negated + (cl-assert (= (1- label-sp) (+ target-offset (comp--sp))))) + (comp--emit (if negated (list 'cond-jump a b bb eff-target-name) (list 'cond-jump a b eff-target-name bb))) - (comp-mark-curr-bb-closed) + (comp--mark-curr-bb-closed) bb))) -(defun comp-emit-handler (lap-label handler-type) +(defun comp--emit-handler (lap-label handler-type) "Emit a nonlocal-exit handler to LAP-LABEL of type HANDLER-TYPE." (cl-destructuring-bind (label-num . label-sp) lap-label - (cl-assert (= (- label-sp 2) (comp-sp))) + (cl-assert (= (- label-sp 2) (comp--sp))) (setf (comp-func-has-non-local comp-func) t) - (let* ((guarded-bb (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass)) - (comp-sp))) - (handler-bb (comp-bb-maybe-add (comp-label-to-addr label-num) - (1+ (comp-sp)))) - (pop-bb (make--comp-block-lap nil (comp-sp) (comp-new-block-sym)))) - (comp-emit (list 'push-handler + (let* ((guarded-bb (comp--bb-maybe-add (1+ (comp-limplify-pc comp-pass)) + (comp--sp))) + (handler-bb (comp--bb-maybe-add (comp--label-to-addr label-num) + (1+ (comp--sp)))) + (pop-bb (make--comp-block-lap nil (comp--sp) (comp--new-block-sym)))) + (comp--emit (list 'push-handler handler-type - (comp-slot+1) + (comp--slot+1) (comp-block-name pop-bb) (comp-block-name guarded-bb))) - (comp-mark-curr-bb-closed) + (comp--mark-curr-bb-closed) ;; Emit the basic block to pop the handler if we got the non local. (puthash (comp-block-name pop-bb) pop-bb (comp-func-blocks comp-func)) (setf (comp-limplify-curr-block comp-pass) pop-bb) - (comp-emit `(fetch-handler ,(comp-slot+1))) - (comp-emit `(jump ,(comp-block-name handler-bb))) - (comp-mark-curr-bb-closed)))) + (comp--emit `(fetch-handler ,(comp--slot+1))) + (comp--emit `(jump ,(comp-block-name handler-bb))) + (comp--mark-curr-bb-closed)))) -(defun comp-limplify-listn (n) +(defun comp--limplify-listn (n) "Limplify list N." - (comp-with-sp (+ (comp-sp) n -1) - (comp-emit-set-call (comp-call 'cons - (comp-slot) - (make-comp-mvar :constant nil)))) - (cl-loop for sp from (+ (comp-sp) n -2) downto (comp-sp) - do (comp-with-sp sp - (comp-emit-set-call (comp-call 'cons - (comp-slot) - (comp-slot+1)))))) - -(defun comp-new-block-sym (&optional postfix) + (comp--with-sp (+ (comp--sp) n -1) + (comp--emit-set-call (comp--call 'cons + (comp--slot) + (make--comp-mvar :constant nil)))) + (cl-loop for sp from (+ (comp--sp) n -2) downto (comp--sp) + do (comp--with-sp sp + (comp--emit-set-call (comp--call 'cons + (comp--slot) + (comp--slot+1)))))) + +(defun comp--new-block-sym (&optional postfix) "Return a unique symbol postfixing POSTFIX naming the next new basic block." (intern (format (if postfix "bb_%s_%s" "bb_%s") (funcall (comp-func-block-cnt-gen comp-func)) postfix))) -(defun comp-fill-label-h () +(defun comp--fill-label-h () "Fill label-to-addr hash table for the current function." (setf (comp-limplify-label-to-addr comp-pass) (make-hash-table :test 'eql)) (cl-loop for insn in (comp-func-lap comp-func) @@ -1131,10 +1152,10 @@ Return value is the fall-through block name." (`(TAG ,label . ,_) (puthash label addr (comp-limplify-label-to-addr comp-pass)))))) -(defun comp-jump-table-optimizable (jmp-table) +(defun comp--jump-table-optimizable (jmp-table) "Return t if JMP-TABLE can be optimized out." ;; Identify LAP sequences like: - ;; (byte-constant #s(hash-table size 3 test eq rehash-size 1.5 rehash-threshold 0.8125 purecopy t data (created 126 deleted 126 changed 126)) . 24) + ;; (byte-constant #s(hash-table test eq purecopy t data (created 126 deleted 126 changed 126)) . 24) ;; (byte-switch) ;; (TAG 126 . 10) (let ((targets (hash-table-values jmp-table))) @@ -1143,13 +1164,13 @@ Return value is the fall-through block name." (`(TAG ,target . ,_label-sp) (= target (car targets))))))) -(defun comp-emit-switch (var last-insn) +(defun comp--emit-switch (var last-insn) "Emit a Limple for a lap jump table given VAR and LAST-INSN." ;; FIXME this not efficient for big jump tables. We should have a second ;; strategy for this case. (pcase last-insn (`(setimm ,_ ,jmp-table) - (unless (comp-jump-table-optimizable jmp-table) + (unless (comp--jump-table-optimizable jmp-table) (cl-loop for test being each hash-keys of jmp-table using (hash-value target-label) @@ -1157,27 +1178,27 @@ Return value is the fall-through block name." with test-func = (hash-table-test jmp-table) for n from 1 for last = (= n len) - for m-test = (make-comp-mvar :constant test) - for target-name = (comp-block-name (comp-bb-maybe-add - (comp-label-to-addr target-label) - (comp-sp))) + for m-test = (make--comp-mvar :constant test) + for target-name = (comp-block-name (comp--bb-maybe-add + (comp--label-to-addr target-label) + (comp--sp))) for ff-bb = (if last - (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass)) - (comp-sp)) + (comp--bb-maybe-add (1+ (comp-limplify-pc comp-pass)) + (comp--sp)) (make--comp-block-lap nil - (comp-sp) - (comp-new-block-sym))) + (comp--sp) + (comp--new-block-sym))) for ff-bb-name = (comp-block-name ff-bb) if (eq test-func 'eq) - do (comp-emit (list 'cond-jump var m-test target-name ff-bb-name)) + do (comp--emit (list 'cond-jump var m-test target-name ff-bb-name)) else ;; Store the result of the comparison into the scratch slot before ;; emitting the conditional jump. - do (comp-emit (list 'set (make-comp-mvar :slot 'scratch) - (comp-call test-func var m-test))) - (comp-emit (list 'cond-jump - (make-comp-mvar :slot 'scratch) - (make-comp-mvar :constant nil) + do (comp--emit (list 'set (make--comp-mvar :slot 'scratch) + (comp--call test-func var m-test))) + (comp--emit (list 'cond-jump + (make--comp-mvar :slot 'scratch) + (make--comp-mvar :constant nil) ff-bb-name target-name)) unless last ;; All fall through are artificially created here except the last one. @@ -1192,7 +1213,7 @@ SUBR-NAME is the name of function." (or (gethash subr-name comp-subr-arities-h) (func-arity subr-name))) -(defun comp-emit-set-call-subr (subr-name sp-delta) +(defun comp--emit-set-call-subr (subr-name sp-delta) "Emit a call for SUBR-NAME. SP-DELTA is the stack adjustment." (let* ((nargs (1+ (- sp-delta))) @@ -1203,39 +1224,39 @@ SP-DELTA is the stack adjustment." (signal 'native-ice (list "subr contains unevalled args" subr-name))) (if (eq maxarg 'many) ;; callref case. - (comp-emit-set-call (comp-callref subr-name nargs (comp-sp))) + (comp--emit-set-call (comp--callref subr-name nargs (comp--sp))) ;; Normal call. (unless (and (>= maxarg nargs) (<= minarg nargs)) (signal 'native-ice (list "incoherent stack adjustment" nargs maxarg minarg))) (let* ((subr-name subr-name) (slots (cl-loop for i from 0 below maxarg - collect (comp-slot-n (+ i (comp-sp)))))) - (comp-emit-set-call (apply #'comp-call (cons subr-name slots))))))) + collect (comp--slot-n (+ i (comp--sp)))))) + (comp--emit-set-call (apply #'comp--call (cons subr-name slots))))))) (eval-when-compile - (defun comp-op-to-fun (x) + (defun comp--op-to-fun (x) "Given the LAP op strip \"byte-\" to have the subr name." (intern (string-replace "byte-" "" x))) - (defun comp-body-eff (body op-name sp-delta) + (defun comp--body-eff (body op-name sp-delta) "Given the original BODY, compute the effective one. When BODY is `auto', guess function name from the LAP byte-code name. Otherwise expect lname fnname." (pcase (car body) ('auto - `((comp-emit-set-call-subr ',(comp-op-to-fun op-name) ,sp-delta))) + `((comp--emit-set-call-subr ',(comp--op-to-fun op-name) ,sp-delta))) ((pred symbolp) - `((comp-emit-set-call-subr ',(car body) ,sp-delta))) + `((comp--emit-set-call-subr ',(car body) ,sp-delta))) (_ body)))) -(defmacro comp-op-case (&rest cases) +(defmacro comp--op-case (&rest cases) "Expand CASES into the corresponding `pcase' expansion. This is responsible for generating the proper stack adjustment, when known, and the annotation emission." (declare (debug (body)) (indent defun)) - (declare-function comp-body-eff nil (body op-name sp-delta)) + (declare-function comp--body-eff nil (body op-name sp-delta)) `(pcase op ,@(cl-loop for (op . body) in cases for sp-delta = (gethash op comp-op-stack-info) @@ -1244,55 +1265,55 @@ and the annotation emission." collect `(',op ;; Log all LAP ops except the TAG one. ;; ,(unless (eq op 'TAG) - ;; `(comp-emit-annotation + ;; `(comp--emit-annotation ;; ,(concat "LAP op " op-name))) ;; Emit the stack adjustment if present. ,(when (and sp-delta (not (eq 0 sp-delta))) - `(cl-incf (comp-sp) ,sp-delta)) - ,@(comp-body-eff body op-name sp-delta)) + `(cl-incf (comp--sp) ,sp-delta)) + ,@(comp--body-eff body op-name sp-delta)) else collect `(',op (signal 'native-ice (list "unsupported LAP op" ',op-name)))) (_ (signal 'native-ice (list "unexpected LAP op" (symbol-name op)))))) -(defun comp-limplify-lap-inst (insn) +(defun comp--limplify-lap-inst (insn) "Limplify LAP instruction INSN pushing it in the proper basic block." (let ((op (car insn)) (arg (if (consp (cdr insn)) (cadr insn) (cdr insn)))) - (comp-op-case + (comp--op-case (TAG (cl-destructuring-bind (_TAG label-num . label-sp) insn ;; Paranoid? (when label-sp (cl-assert (= (1- label-sp) (comp-limplify-sp comp-pass)))) - (comp-emit-annotation (format "LAP TAG %d" label-num)))) + (comp--emit-annotation (format "LAP TAG %d" label-num)))) (byte-stack-ref - (comp-copy-slot (- (comp-sp) arg 1))) + (comp--copy-slot (- (comp--sp) arg 1))) (byte-varref - (comp-emit-set-call (comp-call 'symbol-value (make-comp-mvar + (comp--emit-set-call (comp--call 'symbol-value (make--comp-mvar :constant arg)))) (byte-varset - (comp-emit (comp-call 'set_internal - (make-comp-mvar :constant arg) - (comp-slot+1)))) + (comp--emit (comp--call 'set_internal + (make--comp-mvar :constant arg) + (comp--slot+1)))) (byte-varbind ;; Verify - (comp-emit (comp-call 'specbind - (make-comp-mvar :constant arg) - (comp-slot+1)))) + (comp--emit (comp--call 'specbind + (make--comp-mvar :constant arg) + (comp--slot+1)))) (byte-call - (cl-incf (comp-sp) (- arg)) - (comp-emit-set-call (comp-callref 'funcall (1+ arg) (comp-sp)))) + (cl-incf (comp--sp) (- arg)) + (comp--emit-set-call (comp--callref 'funcall (1+ arg) (comp--sp)))) (byte-unbind - (comp-emit (comp-call 'helper_unbind_n - (make-comp-mvar :constant arg)))) + (comp--emit (comp--call 'helper_unbind_n + (make--comp-mvar :constant arg)))) (byte-pophandler - (comp-emit '(pop-handler))) + (comp--emit '(pop-handler))) (byte-pushconditioncase - (comp-emit-handler (cddr insn) 'condition-case)) + (comp--emit-handler (cddr insn) 'condition-case)) (byte-pushcatch - (comp-emit-handler (cddr insn) 'catcher)) + (comp--emit-handler (cddr insn) 'catcher)) (byte-nth auto) (byte-symbolp auto) (byte-consp auto) @@ -1301,19 +1322,19 @@ and the annotation emission." (byte-eq auto) (byte-memq auto) (byte-not - (comp-emit-set-call (comp-call 'eq (comp-slot-n (comp-sp)) - (make-comp-mvar :constant nil)))) + (comp--emit-set-call (comp--call 'eq (comp--slot-n (comp--sp)) + (make--comp-mvar :constant nil)))) (byte-car auto) (byte-cdr auto) (byte-cons auto) (byte-list1 - (comp-limplify-listn 1)) + (comp--limplify-listn 1)) (byte-list2 - (comp-limplify-listn 2)) + (comp--limplify-listn 2)) (byte-list3 - (comp-limplify-listn 3)) + (comp--limplify-listn 3)) (byte-list4 - (comp-limplify-listn 4)) + (comp--limplify-listn 4)) (byte-length auto) (byte-aref auto) (byte-aset auto) @@ -1324,11 +1345,11 @@ and the annotation emission." (byte-get auto) (byte-substring auto) (byte-concat2 - (comp-emit-set-call (comp-callref 'concat 2 (comp-sp)))) + (comp--emit-set-call (comp--callref 'concat 2 (comp--sp)))) (byte-concat3 - (comp-emit-set-call (comp-callref 'concat 3 (comp-sp)))) + (comp--emit-set-call (comp--callref 'concat 3 (comp--sp)))) (byte-concat4 - (comp-emit-set-call (comp-callref 'concat 4 (comp-sp)))) + (comp--emit-set-call (comp--callref 'concat 4 (comp--sp)))) (byte-sub1 1-) (byte-add1 1+) (byte-eqlsign =) @@ -1338,7 +1359,7 @@ and the annotation emission." (byte-geq >=) (byte-diff -) (byte-negate - (comp-emit-set-call (comp-call 'negate (comp-slot)))) + (comp--emit-set-call (comp--call 'negate (comp--slot)))) (byte-plus +) (byte-max auto) (byte-min auto) @@ -1353,9 +1374,9 @@ and the annotation emission." (byte-preceding-char preceding-char) (byte-current-column auto) (byte-indent-to - (comp-emit-set-call (comp-call 'indent-to - (comp-slot) - (make-comp-mvar :constant nil)))) + (comp--emit-set-call (comp--call 'indent-to + (comp--slot) + (make--comp-mvar :constant nil)))) (byte-scan-buffer-OBSOLETE) (byte-eolp auto) (byte-eobp auto) @@ -1364,7 +1385,7 @@ and the annotation emission." (byte-current-buffer auto) (byte-set-buffer auto) (byte-save-current-buffer - (comp-emit (comp-call 'record_unwind_current_buffer))) + (comp--emit (comp--call 'record_unwind_current_buffer))) (byte-set-mark-OBSOLETE) (byte-interactive-p-OBSOLETE) (byte-forward-char auto) @@ -1376,41 +1397,41 @@ and the annotation emission." (byte-buffer-substring auto) (byte-delete-region auto) (byte-narrow-to-region - (comp-emit-set-call (comp-call 'narrow-to-region - (comp-slot) - (comp-slot+1)))) + (comp--emit-set-call (comp--call 'narrow-to-region + (comp--slot) + (comp--slot+1)))) (byte-widen - (comp-emit-set-call (comp-call 'widen))) + (comp--emit-set-call (comp--call 'widen))) (byte-end-of-line auto) (byte-constant2) ; TODO ;; Branches. (byte-goto - (comp-emit-uncond-jump (cddr insn))) + (comp--emit-uncond-jump (cddr insn))) (byte-goto-if-nil - (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 0 + (comp--emit-cond-jump (comp--slot+1) (make--comp-mvar :constant nil) 0 (cddr insn) nil)) (byte-goto-if-not-nil - (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 0 + (comp--emit-cond-jump (comp--slot+1) (make--comp-mvar :constant nil) 0 (cddr insn) t)) (byte-goto-if-nil-else-pop - (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 1 + (comp--emit-cond-jump (comp--slot+1) (make--comp-mvar :constant nil) 1 (cddr insn) nil)) (byte-goto-if-not-nil-else-pop - (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 1 + (comp--emit-cond-jump (comp--slot+1) (make--comp-mvar :constant nil) 1 (cddr insn) t)) (byte-return - (comp-emit `(return ,(comp-slot+1)))) + (comp--emit `(return ,(comp--slot+1)))) (byte-discard 'pass) (byte-dup - (comp-copy-slot (1- (comp-sp)))) + (comp--copy-slot (1- (comp--sp)))) (byte-save-excursion - (comp-emit (comp-call 'record_unwind_protect_excursion))) + (comp--emit (comp--call 'record_unwind_protect_excursion))) (byte-save-window-excursion-OBSOLETE) (byte-save-restriction - (comp-emit (comp-call 'helper_save_restriction))) + (comp--emit (comp--call 'helper_save_restriction))) (byte-catch) ;; Obsolete (byte-unwind-protect - (comp-emit (comp-call 'helper_unwind_protect (comp-slot+1)))) + (comp--emit (comp--call 'helper_unwind_protect (comp--slot+1)))) (byte-condition-case) ;; Obsolete (byte-temp-output-buffer-setup-OBSOLETE) (byte-temp-output-buffer-show-OBSOLETE) @@ -1437,61 +1458,61 @@ and the annotation emission." (byte-numberp auto) (byte-integerp auto) (byte-listN - (cl-incf (comp-sp) (- 1 arg)) - (comp-emit-set-call (comp-callref 'list arg (comp-sp)))) + (cl-incf (comp--sp) (- 1 arg)) + (comp--emit-set-call (comp--callref 'list arg (comp--sp)))) (byte-concatN - (cl-incf (comp-sp) (- 1 arg)) - (comp-emit-set-call (comp-callref 'concat arg (comp-sp)))) + (cl-incf (comp--sp) (- 1 arg)) + (comp--emit-set-call (comp--callref 'concat arg (comp--sp)))) (byte-insertN - (cl-incf (comp-sp) (- 1 arg)) - (comp-emit-set-call (comp-callref 'insert arg (comp-sp)))) + (cl-incf (comp--sp) (- 1 arg)) + (comp--emit-set-call (comp--callref 'insert arg (comp--sp)))) (byte-stack-set - (comp-copy-slot (1+ (comp-sp)) (- (comp-sp) arg -1))) + (comp--copy-slot (1+ (comp--sp)) (- (comp--sp) arg -1))) (byte-stack-set2 (cl-assert nil)) ;; TODO (byte-discardN - (cl-incf (comp-sp) (- arg))) + (cl-incf (comp--sp) (- arg))) (byte-switch ;; Assume to follow the emission of a setimm. - ;; This is checked into comp-emit-switch. - (comp-emit-switch (comp-slot+1) + ;; This is checked into comp--emit-switch. + (comp--emit-switch (comp--slot+1) (cl-first (comp-block-insns (comp-limplify-curr-block comp-pass))))) (byte-constant - (comp-emit-setimm arg)) + (comp--emit-setimm arg)) (byte-discardN-preserve-tos - (cl-incf (comp-sp) (- arg)) - (comp-copy-slot (+ arg (comp-sp))))))) + (cl-incf (comp--sp) (- arg)) + (comp--copy-slot (+ arg (comp--sp))))))) -(defun comp-emit-narg-prologue (minarg nonrest rest) +(defun comp--emit-narg-prologue (minarg nonrest rest) "Emit the prologue for a narg function." (cl-loop for i below minarg - do (comp-emit `(set-args-to-local ,(comp-slot-n i))) - (comp-emit '(inc-args))) + do (comp--emit `(set-args-to-local ,(comp--slot-n i))) + (comp--emit '(inc-args))) (cl-loop for i from minarg below nonrest for bb = (intern (format "entry_%s" i)) for fallback = (intern (format "entry_fallback_%s" i)) - do (comp-emit `(cond-jump-narg-leq ,i ,fallback ,bb)) - (comp-make-curr-block bb (comp-sp)) - (comp-emit `(set-args-to-local ,(comp-slot-n i))) - (comp-emit '(inc-args)) - finally (comp-emit '(jump entry_rest_args))) + do (comp--emit `(cond-jump-narg-leq ,i ,fallback ,bb)) + (comp--make-curr-block bb (comp--sp)) + (comp--emit `(set-args-to-local ,(comp--slot-n i))) + (comp--emit '(inc-args)) + finally (comp--emit '(jump entry_rest_args))) (when (/= minarg nonrest) (cl-loop for i from minarg below nonrest for bb = (intern (format "entry_fallback_%s" i)) for next-bb = (if (= (1+ i) nonrest) 'entry_rest_args (intern (format "entry_fallback_%s" (1+ i)))) - do (comp-with-sp i - (comp-make-curr-block bb (comp-sp)) - (comp-emit-setimm nil) - (comp-emit `(jump ,next-bb))))) - (comp-make-curr-block 'entry_rest_args (comp-sp)) - (comp-emit `(set-rest-args-to-local ,(comp-slot-n nonrest))) - (setf (comp-sp) nonrest) + do (comp--with-sp i + (comp--make-curr-block bb (comp--sp)) + (comp--emit-setimm nil) + (comp--emit `(jump ,next-bb))))) + (comp--make-curr-block 'entry_rest_args (comp--sp)) + (comp--emit `(set-rest-args-to-local ,(comp--slot-n nonrest))) + (setf (comp--sp) nonrest) (when (and (> nonrest 8) (null rest)) - (cl-decf (comp-sp)))) + (cl-decf (comp--sp)))) -(defun comp-limplify-finalize-function (func) +(defun comp--limplify-finalize-function (func) "Reverse insns into all basic blocks of FUNC." (cl-loop for bb being the hash-value in (comp-func-blocks func) do (setf (comp-block-insns bb) @@ -1499,49 +1520,49 @@ and the annotation emission." (comp--log-func func 2) func) -(cl-defgeneric comp-prepare-args-for-top-level (function) +(cl-defgeneric comp--prepare-args-for-top-level (function) "Given FUNCTION, return the two arguments for comp--register-...") -(cl-defmethod comp-prepare-args-for-top-level ((function comp-func-l)) +(cl-defmethod comp--prepare-args-for-top-level ((function comp-func-l)) "Lexically-scoped FUNCTION." (let ((args (comp-func-l-args function))) - (cons (make-comp-mvar :constant (comp-args-base-min args)) - (make-comp-mvar :constant (cond + (cons (make--comp-mvar :constant (comp-args-base-min args)) + (make--comp-mvar :constant (cond ((comp-args-p args) (comp-args-max args)) ((comp-nargs-rest args) 'many) (t (comp-nargs-nonrest args))))))) -(cl-defmethod comp-prepare-args-for-top-level ((function comp-func-d)) +(cl-defmethod comp--prepare-args-for-top-level ((function comp-func-d)) "Dynamically scoped FUNCTION." - (cons (make-comp-mvar :constant (func-arity (comp-func-byte-func function))) + (cons (make--comp-mvar :constant (func-arity (comp-func-byte-func function))) (let ((comp-curr-allocation-class 'd-default)) ;; Lambda-lists must stay in the same relocation class of ;; the object referenced by code to respect uninterned ;; symbols. - (make-comp-mvar :constant (comp-func-d-lambda-list function))))) + (make--comp-mvar :constant (comp-func-d-lambda-list function))))) -(cl-defgeneric comp-emit-for-top-level (form for-late-load) +(cl-defgeneric comp--emit-for-top-level (form for-late-load) "Emit the Limple code for top level FORM.") -(cl-defmethod comp-emit-for-top-level ((form byte-to-native-func-def) +(cl-defmethod comp--emit-for-top-level ((form byte-to-native-func-def) for-late-load) (let* ((name (byte-to-native-func-def-name form)) (c-name (byte-to-native-func-def-c-name form)) (f (gethash c-name (comp-ctxt-funcs-h comp-ctxt))) - (args (comp-prepare-args-for-top-level f))) + (args (comp--prepare-args-for-top-level f))) (cl-assert (and name f)) - (comp-emit - `(set ,(make-comp-mvar :slot 1) - ,(comp-call (if for-late-load + (comp--emit + `(set ,(make--comp-mvar :slot 1) + ,(comp--call (if for-late-load 'comp--late-register-subr 'comp--register-subr) - (make-comp-mvar :constant name) - (make-comp-mvar :constant c-name) + (make--comp-mvar :constant name) + (make--comp-mvar :constant c-name) (car args) (cdr args) (setf (comp-func-type f) - (make-comp-mvar :constant nil)) - (make-comp-mvar + (make--comp-mvar :constant nil)) + (make--comp-mvar :constant (list (let* ((h (comp-ctxt-function-docs comp-ctxt)) @@ -1552,40 +1573,40 @@ and the annotation emission." (comp-func-command-modes f))) ;; This is the compilation unit it-self passed as ;; parameter. - (make-comp-mvar :slot 0)))))) + (make--comp-mvar :slot 0)))))) -(cl-defmethod comp-emit-for-top-level ((form byte-to-native-top-level) +(cl-defmethod comp--emit-for-top-level ((form byte-to-native-top-level) for-late-load) (unless for-late-load - (comp-emit - (comp-call 'eval + (comp--emit + (comp--call 'eval (let ((comp-curr-allocation-class 'd-impure)) - (make-comp-mvar :constant + (make--comp-mvar :constant (byte-to-native-top-level-form form))) - (make-comp-mvar :constant + (make--comp-mvar :constant (byte-to-native-top-level-lexical form)))))) -(defun comp-emit-lambda-for-top-level (func) +(defun comp--emit-lambda-for-top-level (func) "Emit the creation of subrs for lambda FUNC. These are stored in the reloc data array." - (let ((args (comp-prepare-args-for-top-level func))) + (let ((args (comp--prepare-args-for-top-level func))) (let ((comp-curr-allocation-class 'd-impure)) (comp--add-const-to-relocs (comp-func-byte-func func))) - (comp-emit - (comp-call 'comp--register-lambda + (comp--emit + (comp--call 'comp--register-lambda ;; mvar to be fixed-up when containers are ;; finalized. (or (gethash (comp-func-byte-func func) (comp-ctxt-lambda-fixups-h comp-ctxt)) (puthash (comp-func-byte-func func) - (make-comp-mvar :constant nil) + (make--comp-mvar :constant nil) (comp-ctxt-lambda-fixups-h comp-ctxt))) - (make-comp-mvar :constant (comp-func-c-name func)) + (make--comp-mvar :constant (comp-func-c-name func)) (car args) (cdr args) (setf (comp-func-type func) - (make-comp-mvar :constant nil)) - (make-comp-mvar + (make--comp-mvar :constant nil)) + (make--comp-mvar :constant (list (let* ((h (comp-ctxt-function-docs comp-ctxt)) @@ -1596,9 +1617,9 @@ These are stored in the reloc data array." (comp-func-command-modes func))) ;; This is the compilation unit it-self passed as ;; parameter. - (make-comp-mvar :slot 0))))) + (make--comp-mvar :slot 0))))) -(defun comp-limplify-top-level (for-late-load) +(defun comp--limplify-top-level (for-late-load) "Create a Limple function to modify the global environment at load. When FOR-LATE-LOAD is non-nil, the emitted function modifies only function definition. @@ -1628,22 +1649,22 @@ into the C code forwarding the compilation unit." (comp-func func) (comp-pass (make-comp-limplify :curr-block (make--comp-block-lap -1 0 'top-level) - :frame (comp-new-frame 1 0)))) - (comp-make-curr-block 'entry (comp-sp)) - (comp-emit-annotation (if for-late-load + :frame (comp--new-frame 1 0)))) + (comp--make-curr-block 'entry (comp--sp)) + (comp--emit-annotation (if for-late-load "Late top level" "Top level")) ;; Assign the compilation unit incoming as parameter to the slot frame 0. - (comp-emit `(set-par-to-local ,(comp-slot-n 0) 0)) + (comp--emit `(set-par-to-local ,(comp--slot-n 0) 0)) (maphash (lambda (_ func) - (comp-emit-lambda-for-top-level func)) + (comp--emit-lambda-for-top-level func)) (comp-ctxt-byte-func-to-func-h comp-ctxt)) - (mapc (lambda (x) (comp-emit-for-top-level x for-late-load)) + (mapc (lambda (x) (comp--emit-for-top-level x for-late-load)) (comp-ctxt-top-level-forms comp-ctxt)) - (comp-emit `(return ,(make-comp-mvar :slot 1))) - (comp-limplify-finalize-function func))) + (comp--emit `(return ,(make--comp-mvar :slot 1))) + (comp--limplify-finalize-function func))) -(defun comp-addr-to-bb-name (addr) +(defun comp--addr-to-bb-name (addr) "Search for a block starting at ADDR into pending or limplified blocks." ;; FIXME Actually we could have another hash for this. (cl-flet ((pred (bb) @@ -1655,7 +1676,7 @@ into the C code forwarding the compilation unit." when (pred bb) return (comp-block-name bb))))) -(defun comp-limplify-block (bb) +(defun comp--limplify-block (bb) "Limplify basic-block BB and add it to the current function." (setf (comp-limplify-curr-block comp-pass) bb (comp-limplify-sp comp-pass) (comp-block-lap-sp bb) @@ -1666,51 +1687,51 @@ into the C code forwarding the compilation unit." (comp-func-lap comp-func)) for inst = (car inst-cell) for next-inst = (car-safe (cdr inst-cell)) - do (comp-limplify-lap-inst inst) + do (comp--limplify-lap-inst inst) (cl-incf (comp-limplify-pc comp-pass)) - when (comp-lap-fall-through-p inst) + when (comp--lap-fall-through-p inst) do (pcase next-inst (`(TAG ,_label . ,label-sp) (when label-sp - (cl-assert (= (1- label-sp) (comp-sp)))) + (cl-assert (= (1- label-sp) (comp--sp)))) (let* ((stack-depth (if label-sp (1- label-sp) - (comp-sp))) - (next-bb (comp-block-name (comp-bb-maybe-add + (comp--sp))) + (next-bb (comp-block-name (comp--bb-maybe-add (comp-limplify-pc comp-pass) stack-depth)))) (unless (comp-block-closed bb) - (comp-emit `(jump ,next-bb)))) + (comp--emit `(jump ,next-bb)))) (cl-return))) - until (comp-lap-eob-p inst))) + until (comp--lap-eob-p inst))) -(defun comp-limplify-function (func) +(defun comp--limplify-function (func) "Limplify a single function FUNC." (let* ((frame-size (comp-func-frame-size func)) (comp-func func) (comp-pass (make-comp-limplify - :frame (comp-new-frame frame-size 0)))) - (comp-fill-label-h) + :frame (comp--new-frame frame-size 0)))) + (comp--fill-label-h) ;; Prologue - (comp-make-curr-block 'entry (comp-sp)) - (comp-emit-annotation (concat "Lisp function: " + (comp--make-curr-block 'entry (comp--sp)) + (comp--emit-annotation (concat "Lisp function: " (symbol-name (comp-func-name func)))) ;; Dynamic functions have parameters bound by the trampoline. (when (comp-func-l-p func) (let ((args (comp-func-l-args func))) (if (comp-args-p args) (cl-loop for i below (comp-args-max args) - do (cl-incf (comp-sp)) - (comp-emit `(set-par-to-local ,(comp-slot) ,i))) - (comp-emit-narg-prologue (comp-args-base-min args) + do (cl-incf (comp--sp)) + (comp--emit `(set-par-to-local ,(comp--slot) ,i))) + (comp--emit-narg-prologue (comp-args-base-min args) (comp-nargs-nonrest args) (comp-nargs-rest args))))) - (comp-emit '(jump bb_0)) + (comp--emit '(jump bb_0)) ;; Body - (comp-bb-maybe-add 0 (comp-sp)) + (comp--bb-maybe-add 0 (comp--sp)) (cl-loop for next-bb = (pop (comp-limplify-pending-blocks comp-pass)) while next-bb - do (comp-limplify-block next-bb)) + do (comp--limplify-block next-bb)) ;; Sanity check against block duplication. (cl-loop with addr-h = (make-hash-table) for bb being the hash-value in (comp-func-blocks func) @@ -1719,15 +1740,15 @@ into the C code forwarding the compilation unit." when addr do (cl-assert (null (gethash addr addr-h))) (puthash addr t addr-h)) - (comp-limplify-finalize-function func))) + (comp--limplify-finalize-function func))) -(defun comp-limplify (_) +(defun comp--limplify (_) "Compute LIMPLE IR for forms in `comp-ctxt'." - (maphash (lambda (_ f) (comp-limplify-function f)) + (maphash (lambda (_ f) (comp--limplify-function f)) (comp-ctxt-funcs-h comp-ctxt)) - (comp-add-func-to-ctxt (comp-limplify-top-level nil)) + (comp--add-func-to-ctxt (comp--limplify-top-level nil)) (when (comp-ctxt-with-late-load comp-ctxt) - (comp-add-func-to-ctxt (comp-limplify-top-level t)))) + (comp--add-func-to-ctxt (comp--limplify-top-level t)))) ;;; add-cstrs pass specific code. @@ -1751,22 +1772,22 @@ into the C code forwarding the compilation unit." ;; type specifier. -(defsubst comp-mvar-used-p (mvar) +(defsubst comp--mvar-used-p (mvar) "Non-nil when MVAR is used as lhs in the current function." (declare (gv-setter (lambda (val) `(puthash ,mvar ,val comp-pass)))) (gethash mvar comp-pass)) -(defun comp-collect-mvars (form) +(defun comp--collect-mvars (form) "Add rhs m-var present in FORM into `comp-pass'." (cl-loop for x in form if (consp x) - do (comp-collect-mvars x) + do (comp--collect-mvars x) else when (comp-mvar-p x) - do (setf (comp-mvar-used-p x) t))) + do (setf (comp--mvar-used-p x) t))) -(defun comp-collect-rhs () +(defun comp--collect-rhs () "Collect all lhs mvars into `comp-pass'." (cl-loop for b being each hash-value of (comp-func-blocks comp-func) @@ -1774,11 +1795,13 @@ into the C code forwarding the compilation unit." for insn in (comp-block-insns b) for (op . args) = insn if (comp--assign-op-p op) - do (comp-collect-mvars (cdr args)) + do (comp--collect-mvars (if (eq op 'setimm) + (cl-first args) + (cdr args))) else - do (comp-collect-mvars args)))) + do (comp--collect-mvars args)))) -(defun comp-negate-arithm-cmp-fun (function) +(defun comp--negate-arithm-cmp-fun (function) "Negate FUNCTION. Return nil if we don't want to emit constraints for its negation." (cl-ecase function @@ -1788,7 +1811,7 @@ Return nil if we don't want to emit constraints for its negation." (>= '<) (<= '>))) -(defun comp-reverse-arithm-fun (function) +(defun comp--reverse-arithm-fun (function) "Reverse FUNCTION." (cl-case function (= '=) @@ -1798,7 +1821,7 @@ Return nil if we don't want to emit constraints for its negation." (<= '>=) (t function))) -(defun comp-emit-assume (kind lhs rhs bb negated) +(defun comp--emit-assume (kind lhs rhs bb negated) "Emit an assume of kind KIND for mvar LHS being RHS. When NEGATED is non-nil, the assumption is negated. The assume is emitted at the beginning of the block BB." @@ -1808,41 +1831,41 @@ The assume is emitted at the beginning of the block BB." ((or 'and 'and-nhc) (if (comp-mvar-p rhs) (let ((tmp-mvar (if negated - (make-comp-mvar :slot (comp-mvar-slot rhs)) + (make--comp-mvar :slot (comp-mvar-slot rhs)) rhs))) - (push `(assume ,(make-comp-mvar :slot lhs-slot) + (push `(assume ,(make--comp-mvar :slot lhs-slot) (,kind ,lhs ,tmp-mvar)) (comp-block-insns bb)) (if negated (push `(assume ,tmp-mvar (not ,rhs)) (comp-block-insns bb)))) ;; If is only a constraint we can negate it directly. - (push `(assume ,(make-comp-mvar :slot lhs-slot) + (push `(assume ,(make--comp-mvar :slot lhs-slot) (,kind ,lhs ,(if negated (comp-cstr-negation-make rhs) rhs))) (comp-block-insns bb)))) ((pred comp--arithm-cmp-fun-p) (when-let ((kind (if negated - (comp-negate-arithm-cmp-fun kind) + (comp--negate-arithm-cmp-fun kind) kind))) - (push `(assume ,(make-comp-mvar :slot lhs-slot) + (push `(assume ,(make--comp-mvar :slot lhs-slot) (,kind ,lhs ,(if-let* ((vld (comp-cstr-imm-vld-p rhs)) (val (comp-cstr-imm rhs)) (ok (and (integerp val) (not (memq kind '(= !=)))))) val - (make-comp-mvar :slot (comp-mvar-slot rhs))))) + (make--comp-mvar :slot (comp-mvar-slot rhs))))) (comp-block-insns bb)))) (_ (cl-assert nil))) (setf (comp-func-ssa-status comp-func) 'dirty))) -(defun comp-maybe-add-vmvar (op cmp-res insns-seq) +(defun comp--maybe-add-vmvar (op cmp-res insns-seq) "If CMP-RES is clobbering OP emit a new constrained mvar and return it. Return OP otherwise." (if-let ((match (eql (comp-mvar-slot op) (comp-mvar-slot cmp-res))) - (new-mvar (make-comp-mvar + (new-mvar (make--comp-mvar :slot (- (cl-incf (comp-func-vframe-size comp-func)))))) (progn @@ -1850,7 +1873,7 @@ Return OP otherwise." new-mvar) op)) -(defun comp-add-new-block-between (bb-symbol bb-a bb-b) +(defun comp--add-new-block-between (bb-symbol bb-a bb-b) "Create a new basic-block named BB-SYMBOL and add it between BB-A and BB-B." (cl-loop with new-bb = (make-comp-block-cstr :name bb-symbol @@ -1873,7 +1896,7 @@ Return OP otherwise." finally (cl-assert nil))) ;; Cheap substitute to a copy propagation pass... -(defun comp-cond-cstrs-target-mvar (mvar exit-insn bb) +(defun comp--cond-cstrs-target-mvar (mvar exit-insn bb) "Given MVAR, search in BB the original mvar MVAR got assigned from. Keep on searching till EXIT-INSN is encountered." (cl-flet ((targetp (x) @@ -1890,7 +1913,7 @@ Keep on searching till EXIT-INSN is encountered." (setf res rhs))) finally (cl-assert nil)))) -(defun comp-add-cond-cstrs-target-block (curr-bb target-bb-sym) +(defun comp--add-cond-cstrs-target-block (curr-bb target-bb-sym) "Return the appropriate basic block to add constraint assumptions into. CURR-BB is the current basic block. TARGET-BB-SYM is the symbol name of the target block." @@ -1910,10 +1933,10 @@ TARGET-BB-SYM is the symbol name of the target block." until (null (gethash new-name (comp-func-blocks comp-func))) finally ;; Add it. - (cl-return (comp-add-new-block-between new-name curr-bb target-bb)))))) + (cl-return (comp--add-new-block-between new-name curr-bb target-bb)))))) -(defun comp-add-cond-cstrs-simple () - "`comp-add-cstrs' worker function for each selected function." +(defun comp--add-cond-cstrs-simple () + "`comp--add-cstrs' worker function for each selected function." (cl-loop for b being each hash-value of (comp-func-blocks comp-func) do @@ -1929,26 +1952,26 @@ TARGET-BB-SYM is the symbol name of the target block." for branch-target-cell on blocks for branch-target = (car branch-target-cell) for negated in '(nil t) - when (comp-mvar-used-p tmp-mvar) + when (comp--mvar-used-p tmp-mvar) do - (let ((block-target (comp-add-cond-cstrs-target-block b branch-target))) + (let ((block-target (comp--add-cond-cstrs-target-block b branch-target))) (setf (car branch-target-cell) (comp-block-name block-target)) - (comp-emit-assume 'and tmp-mvar obj2 block-target negated)) + (comp--emit-assume 'and tmp-mvar obj2 block-target negated)) finally (cl-return-from in-the-basic-block))) (`((cond-jump ,obj1 ,obj2 . ,blocks)) (cl-loop for branch-target-cell on blocks for branch-target = (car branch-target-cell) for negated in '(nil t) - when (comp-mvar-used-p obj1) + when (comp--mvar-used-p obj1) do - (let ((block-target (comp-add-cond-cstrs-target-block b branch-target))) + (let ((block-target (comp--add-cond-cstrs-target-block b branch-target))) (setf (car branch-target-cell) (comp-block-name block-target)) - (comp-emit-assume 'and obj1 obj2 block-target negated)) + (comp--emit-assume 'and obj1 obj2 block-target negated)) finally (cl-return-from in-the-basic-block))))))) -(defun comp-add-cond-cstrs () - "`comp-add-cstrs' worker function for each selected function." +(defun comp--add-cond-cstrs () + "`comp--add-cstrs' worker function for each selected function." (cl-loop for b being each hash-value of (comp-func-blocks comp-func) do @@ -1967,13 +1990,13 @@ TARGET-BB-SYM is the symbol name of the target block." (set ,(and (pred comp-mvar-p) mvar-3) (call memq ,(and (pred comp-mvar-p) mvar-1) ,(and (pred comp-mvar-p) mvar-2))) (cond-jump ,(and (pred comp-mvar-p) mvar-3) ,(pred comp-mvar-p) ,bb1 ,bb2)) - (comp-emit-assume 'and mvar-tested - (make-comp-mvar :type (comp-cstr-cl-tag mvar-tag)) - (comp-add-cond-cstrs-target-block b bb2) + (comp--emit-assume 'and mvar-tested + (make--comp-mvar :type (comp-cstr-cl-tag mvar-tag)) + (comp--add-cond-cstrs-target-block b bb2) nil) - (comp-emit-assume 'and mvar-tested - (make-comp-mvar :type (comp-cstr-cl-tag mvar-tag)) - (comp-add-cond-cstrs-target-block b bb1) + (comp--emit-assume 'and mvar-tested + (make--comp-mvar :type (comp-cstr-cl-tag mvar-tag)) + (comp--add-cond-cstrs-target-block b bb1) t)) (`((set ,(and (pred comp-mvar-p) cmp-res) (,(pred comp--call-op-p) @@ -1984,8 +2007,8 @@ TARGET-BB-SYM is the symbol name of the target block." ;; (comment ,_comment-str) (cond-jump ,cmp-res ,(pred comp-mvar-p) . ,blocks)) (cl-loop - with target-mvar1 = (comp-cond-cstrs-target-mvar op1 (car insns-seq) b) - with target-mvar2 = (comp-cond-cstrs-target-mvar op2 (car insns-seq) b) + with target-mvar1 = (comp--cond-cstrs-target-mvar op1 (car insns-seq) b) + with target-mvar2 = (comp--cond-cstrs-target-mvar op2 (car insns-seq) b) for branch-target-cell on blocks for branch-target = (car branch-target-cell) for negated in '(t nil) @@ -1994,61 +2017,51 @@ TARGET-BB-SYM is the symbol name of the target block." (eql 'and-nhc) (eq 'and) (t fun)) - when (or (comp-mvar-used-p target-mvar1) - (comp-mvar-used-p target-mvar2)) + when (or (comp--mvar-used-p target-mvar1) + (comp--mvar-used-p target-mvar2)) do - (let ((block-target (comp-add-cond-cstrs-target-block b branch-target))) + (let ((block-target (comp--add-cond-cstrs-target-block b branch-target))) (setf (car branch-target-cell) (comp-block-name block-target)) - (when (comp-mvar-used-p target-mvar1) - (comp-emit-assume kind target-mvar1 - (comp-maybe-add-vmvar op2 cmp-res prev-insns-seq) + (when (comp--mvar-used-p target-mvar1) + (comp--emit-assume kind target-mvar1 + (comp--maybe-add-vmvar op2 cmp-res prev-insns-seq) block-target negated)) - (when (comp-mvar-used-p target-mvar2) - (comp-emit-assume (comp-reverse-arithm-fun kind) + (when (comp--mvar-used-p target-mvar2) + (comp--emit-assume (comp--reverse-arithm-fun kind) target-mvar2 - (comp-maybe-add-vmvar op1 cmp-res prev-insns-seq) + (comp--maybe-add-vmvar op1 cmp-res prev-insns-seq) block-target negated))) finally (cl-return-from in-the-basic-block))) (`((set ,(and (pred comp-mvar-p) cmp-res) (,(pred comp--call-op-p) ,(and (pred comp--known-predicate-p) fun) ,op)) - ;; (comment ,_comment-str) - (cond-jump ,cmp-res ,(pred comp-mvar-p) . ,blocks)) - (cl-loop - with target-mvar = (comp-cond-cstrs-target-mvar op (car insns-seq) b) - with cstr = (comp--pred-to-cstr fun) - for branch-target-cell on blocks - for branch-target = (car branch-target-cell) - for negated in '(t nil) - when (comp-mvar-used-p target-mvar) - do - (let ((block-target (comp-add-cond-cstrs-target-block b branch-target))) - (setf (car branch-target-cell) (comp-block-name block-target)) - (comp-emit-assume 'and target-mvar cstr block-target negated)) - finally (cl-return-from in-the-basic-block))) - ;; Match predicate on the negated branch (unless). - (`((set ,(and (pred comp-mvar-p) cmp-res) - (,(pred comp--call-op-p) - ,(and (pred comp--known-predicate-p) fun) - ,op)) - (set ,neg-cmp-res (call eq ,cmp-res ,(pred comp-cstr-null-p))) - (cond-jump ,neg-cmp-res ,(pred comp-mvar-p) . ,blocks)) + . ,(or + ;; (comment ,_comment-str) + (and `((cond-jump ,cmp-res ,(pred comp-mvar-p) . ,blocks)) + (let negated-branch nil)) + (and `((set ,neg-cmp-res + (call eq ,cmp-res ,(pred comp-cstr-null-p))) + (cond-jump ,neg-cmp-res ,(pred comp-mvar-p) . ,blocks)) + (let negated-branch t)))) (cl-loop - with target-mvar = (comp-cond-cstrs-target-mvar op (car insns-seq) b) - with cstr = (comp--pred-to-cstr fun) + with target-mvar = (comp--cond-cstrs-target-mvar op (car insns-seq) b) for branch-target-cell on blocks for branch-target = (car branch-target-cell) - for negated in '(nil t) - when (comp-mvar-used-p target-mvar) + for negated in (if negated-branch '(nil t) '(t nil)) + when (comp--mvar-used-p target-mvar) do - (let ((block-target (comp-add-cond-cstrs-target-block b branch-target))) + (let ((block-target (comp--add-cond-cstrs-target-block + b branch-target))) (setf (car branch-target-cell) (comp-block-name block-target)) - (comp-emit-assume 'and target-mvar cstr block-target negated)) + (comp--emit-assume 'and target-mvar (if negated + (comp--pred-to-neg-cstr fun) + (comp--pred-to-pos-cstr fun)) + block-target nil)) finally (cl-return-from in-the-basic-block)))) (setf prev-insns-seq insns-seq)))) -(defsubst comp-insert-insn (insn insn-cell) +(defsubst comp--insert-insn (insn insn-cell) "Insert INSN as second insn of INSN-CELL." (let ((next-cell (cdr insn-cell)) (new-cell `(,insn))) @@ -2056,15 +2069,15 @@ TARGET-BB-SYM is the symbol name of the target block." (cdr new-cell) next-cell (comp-func-ssa-status comp-func) 'dirty))) -(defun comp-emit-call-cstr (mvar call-cell cstr) +(defun comp--emit-call-cstr (mvar call-cell cstr) "Emit a constraint CSTR for MVAR after CALL-CELL." - (let* ((new-mvar (make-comp-mvar :slot (comp-mvar-slot mvar))) + (let* ((new-mvar (make--comp-mvar :slot (comp-mvar-slot mvar))) ;; Have new-mvar as LHS *and* RHS to ensure monotonicity and ;; fwprop convergence!! (insn `(assume ,new-mvar (and ,new-mvar ,mvar ,cstr)))) - (comp-insert-insn insn call-cell))) + (comp--insert-insn insn call-cell))) -(defun comp-lambda-list-gen (lambda-list) +(defun comp--lambda-list-gen (lambda-list) "Return a generator to iterate over LAMBDA-LIST." (lambda () (cl-case (car lambda-list) @@ -2080,12 +2093,12 @@ TARGET-BB-SYM is the symbol name of the target block." (car lambda-list) (setf lambda-list (cdr lambda-list))))))) -(defun comp-add-call-cstr () +(defun comp--add-call-cstr () "Add args assumptions for each function of which the type specifier is known." (cl-loop for bb being each hash-value of (comp-func-blocks comp-func) do - (comp-loop-insn-in-block bb + (comp--loop-insn-in-block bb (when-let ((match (pcase insn (`(set ,lhs (,(pred comp--call-op-p) ,f . ,args)) @@ -2096,10 +2109,10 @@ TARGET-BB-SYM is the symbol name of the target block." (cl-values f cstr-f nil args)))))) (cl-multiple-value-bind (f cstr-f lhs args) match (cl-loop - with gen = (comp-lambda-list-gen (comp-cstr-f-args cstr-f)) + with gen = (comp--lambda-list-gen (comp-cstr-f-args cstr-f)) for arg in args for cstr = (funcall gen) - for target = (comp-cond-cstrs-target-mvar arg insn bb) + for target = (comp--cond-cstrs-target-mvar arg insn bb) unless (comp-cstr-p cstr) do (signal 'native-ice (list "Incoherent type specifier for function" f)) @@ -2110,9 +2123,9 @@ TARGET-BB-SYM is the symbol name of the target block." (or (null lhs) (not (eql (comp-mvar-slot lhs) (comp-mvar-slot target))))) - do (comp-emit-call-cstr target insn-cell cstr))))))) + do (comp--emit-call-cstr target insn-cell cstr))))))) -(defun comp-add-cstrs (_) +(defun comp--add-cstrs (_) "Rewrite conditional branches adding appropriate `assume' insns. This is introducing and placing `assume' insns in use by fwprop to propagate conditional branch test information on target basic @@ -2126,10 +2139,10 @@ blocks." (not (comp-func-has-non-local f))) (let ((comp-func f) (comp-pass (make-hash-table :test #'eq))) - (comp-collect-rhs) - (comp-add-cond-cstrs-simple) - (comp-add-cond-cstrs) - (comp-add-call-cstr) + (comp--collect-rhs) + (comp--add-cond-cstrs-simple) + (comp--add-cond-cstrs) + (comp--add-call-cstr) (comp--log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) @@ -2141,7 +2154,7 @@ blocks." ;; avoid optimizing-out functions and preventing their redefinition ;; being effective. -(defun comp-collect-calls (f) +(defun comp--collect-calls (f) "Return a list with all the functions called by F." (cl-loop with h = (make-hash-table :test #'eq) @@ -2161,17 +2174,17 @@ blocks." (comp-ctxt-funcs-h comp-ctxt))) f)))) -(defun comp-pure-infer-func (f) +(defun comp--pure-infer-func (f) "If all functions called by F are pure then F is pure too." (when (and (cl-every (lambda (x) (or (comp--function-pure-p x) (eq x (comp-func-name f)))) - (comp-collect-calls f)) + (comp--collect-calls f)) (not (eq (comp-func-pure f) t))) (comp-log (format "%s inferred to be pure" (comp-func-name f))) (setf (comp-func-pure f) t))) -(defun comp-ipa-pure (_) +(defun comp--ipa-pure (_) "Infer function purity." (cl-loop with pure-n = 0 @@ -2184,7 +2197,7 @@ blocks." when (and (>= (comp-func-speed f) 3) (comp-func-l-p f) (not (comp-func-pure f))) - do (comp-pure-infer-func f) + do (comp--pure-infer-func f) count (comp-func-pure f)))) finally (comp-log (format "ipa-pure iterated %d times" n)))) @@ -2198,13 +2211,13 @@ blocks." ;; this form is called 'minimal SSA form'. ;; This pass should be run every time basic blocks or m-var are shuffled. -(cl-defun make-comp-ssa-mvar (&rest rest &key _slot _constant _type) - "Same as `make-comp-mvar' but set the `id' slot." - (let ((mvar (apply #'make-comp-mvar rest))) +(cl-defun make--comp--ssa-mvar (&rest rest &key _slot _constant _type) + "Same as `make--comp-mvar' but set the `id' slot." + (let ((mvar (apply #'make--comp-mvar rest))) (setf (comp-mvar-id mvar) (sxhash-eq mvar)) mvar)) -(defun comp-clean-ssa (f) +(defun comp--clean-ssa (f) "Clean-up SSA for function F." (setf (comp-func-edges-h f) (make-hash-table)) (cl-loop @@ -2220,7 +2233,7 @@ blocks." unless (eq 'phi (car insn)) collect insn)))) -(defun comp-compute-edges () +(defun comp--compute-edges () "Compute the basic block edges for the current function." (cl-loop with blocks = (comp-func-blocks comp-func) for bb being each hash-value of blocks @@ -2256,7 +2269,7 @@ blocks." (comp-block-in-edges (comp-edge-dst edge)))) (comp--log-edges comp-func))) -(defun comp-collect-rev-post-order (basic-block) +(defun comp--collect-rev-post-order (basic-block) "Walk BASIC-BLOCK children and return their name in reversed post-order." (let ((visited (make-hash-table)) (acc ())) @@ -2271,7 +2284,7 @@ blocks." (collect-rec basic-block) acc))) -(defun comp-compute-dominator-tree () +(defun comp--compute-dominator-tree () "Compute immediate dominators for each basic block in current function." ;; Originally based on: "A Simple, Fast Dominance Algorithm" ;; Cooper, Keith D.; Harvey, Timothy J.; Kennedy, Ken (2001). @@ -2296,7 +2309,7 @@ blocks." ;; No point to go on if the only bb is 'entry'. (bb0 (gethash 'bb_0 blocks))) (cl-loop - with rev-bb-list = (comp-collect-rev-post-order entry) + with rev-bb-list = (comp--collect-rev-post-order entry) with changed = t while changed initially (progn @@ -2323,7 +2336,7 @@ blocks." new-idom) changed t)))))) -(defun comp-compute-dominator-frontiers () +(defun comp--compute-dominator-frontiers () "Compute the dominator frontier for each basic block in `comp-func'." ;; Originally based on: "A Simple, Fast Dominance Algorithm" ;; Cooper, Keith D.; Harvey, Timothy J.; Kennedy, Ken (2001). @@ -2338,7 +2351,7 @@ blocks." (puthash b-name b (comp-block-df runner)) (setf runner (comp-block-idom runner)))))) -(defun comp-log-block-info () +(defun comp--log-block-info () "Log basic blocks info for the current function." (maphash (lambda (name bb) (let ((dom (comp-block-idom bb)) @@ -2351,7 +2364,7 @@ blocks." 3))) (comp-func-blocks comp-func))) -(defun comp-place-phis () +(defun comp--place-phis () "Place phi insns into the current function." ;; Originally based on: Static Single Assignment Book ;; Algorithm 3.1: Standard algorithm for inserting phi-functions @@ -2392,7 +2405,7 @@ blocks." (unless (cl-find y defs-v) (push y w)))))))) -(defun comp-dom-tree-walker (bb pre-lambda post-lambda) +(defun comp--dom-tree-walker (bb pre-lambda post-lambda) "Dominator tree walker function starting from basic block BB. PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." (when pre-lambda @@ -2402,18 +2415,18 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." for child = (comp-edge-dst ed) when (eq bb (comp-block-idom child)) ;; Current block is the immediate dominator then recur. - do (comp-dom-tree-walker child pre-lambda post-lambda))) + do (comp--dom-tree-walker child pre-lambda post-lambda))) (when post-lambda (funcall post-lambda bb))) -(cl-defstruct (comp-ssa (:copier nil)) +(cl-defstruct (comp--ssa (:copier nil)) "Support structure used while SSA renaming." - (frame (comp-new-frame (comp-func-frame-size comp-func) + (frame (comp--new-frame (comp-func-frame-size comp-func) (comp-func-vframe-size comp-func) t) :type comp-vec :documentation "`comp-vec' of m-vars.")) -(defun comp-ssa-rename-insn (insn frame) +(defun comp--ssa-rename-insn (insn frame) (cl-loop for slot-n from (- (comp-func-vframe-size comp-func)) below (comp-func-frame-size comp-func) @@ -2424,17 +2437,19 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." (eql slot-n (comp-mvar-slot x)))) (new-lvalue () ;; If is an assignment make a new mvar and put it as l-value. - (let ((mvar (make-comp-ssa-mvar :slot slot-n))) + (let ((mvar (make--comp--ssa-mvar :slot slot-n))) (setf (comp-vec-aref frame slot-n) mvar (cadr insn) mvar)))) (pcase insn + (`(setimm ,(pred targetp) ,_imm) + (new-lvalue)) (`(,(pred comp--assign-op-p) ,(pred targetp) . ,_) (let ((mvar (comp-vec-aref frame slot-n))) (setf (cddr insn) (cl-nsubst-if mvar #'targetp (cddr insn)))) (new-lvalue)) (`(fetch-handler . ,_) ;; Clobber all no matter what! - (setf (comp-vec-aref frame slot-n) (make-comp-ssa-mvar :slot slot-n))) + (setf (comp-vec-aref frame slot-n) (make--comp--ssa-mvar :slot slot-n))) (`(phi ,n) (when (equal n slot-n) (new-lvalue))) @@ -2442,7 +2457,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." (let ((mvar (comp-vec-aref frame slot-n))) (setcdr insn (cl-nsubst-if mvar #'targetp (cdr insn))))))))) -(defun comp-ssa-rename () +(defun comp--ssa-rename () "Entry point to rename into SSA within the current function." (comp-log "Renaming\n" 2) (let ((visited (make-hash-table))) @@ -2450,7 +2465,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." (unless (gethash bb visited) (puthash bb t visited) (cl-loop for insn in (comp-block-insns bb) - do (comp-ssa-rename-insn insn in-frame)) + do (comp--ssa-rename-insn insn in-frame)) (setf (comp-block-final-frame bb) (copy-sequence in-frame)) (when-let ((out-edges (comp-block-out-edges bb))) @@ -2461,11 +2476,11 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." do (ssa-rename-rec child (comp-vec-copy in-frame))))))) (ssa-rename-rec (gethash 'entry (comp-func-blocks comp-func)) - (comp-new-frame (comp-func-frame-size comp-func) + (comp--new-frame (comp-func-frame-size comp-func) (comp-func-vframe-size comp-func) t))))) -(defun comp-finalize-phis () +(defun comp--finalize-phis () "Fixup r-values into phis in all basic blocks." (cl-flet ((finalize-phi (args b) ;; Concatenate into args all incoming m-vars for this phi. @@ -2482,7 +2497,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." when (eq op 'phi) do (finalize-phi args b))))) -(defun comp-remove-unreachable-blocks () +(defun comp--remove-unreachable-blocks () "Remove unreachable basic blocks. Return t when one or more block was removed, nil otherwise." (cl-loop @@ -2498,7 +2513,7 @@ Return t when one or more block was removed, nil otherwise." ret t) finally return ret)) -(defun comp-ssa () +(defun comp--ssa () "Port all functions into minimal SSA form." (maphash (lambda (_ f) (let* ((comp-func f) @@ -2506,15 +2521,15 @@ Return t when one or more block was removed, nil otherwise." (unless (eq ssa-status t) (cl-loop when (eq ssa-status 'dirty) - do (comp-clean-ssa f) - do (comp-compute-edges) - (comp-compute-dominator-tree) - until (null (comp-remove-unreachable-blocks))) - (comp-compute-dominator-frontiers) - (comp-log-block-info) - (comp-place-phis) - (comp-ssa-rename) - (comp-finalize-phis) + do (comp--clean-ssa f) + do (comp--compute-edges) + (comp--compute-dominator-tree) + until (null (comp--remove-unreachable-blocks))) + (comp--compute-dominator-frontiers) + (comp--log-block-info) + (comp--place-phis) + (comp--ssa-rename) + (comp--finalize-phis) (comp--log-func comp-func 3) (setf (comp-func-ssa-status f) t)))) (comp-ctxt-funcs-h comp-ctxt))) @@ -2526,12 +2541,12 @@ Return t when one or more block was removed, nil otherwise." ;; This is also responsible for removing function calls to pure functions if ;; possible. -(defconst comp-fwprop-max-insns-scan 4500 +(defconst comp--fwprop-max-insns-scan 4500 ;; Chosen as ~ the greatest required value for full convergence ;; native compiling all Emacs code-base. "Max number of scanned insn before giving-up.") -(defun comp-copy-insn (insn) +(defun comp--copy-insn-rec (insn) "Deep copy INSN." ;; Adapted from `copy-tree'. (if (consp insn) @@ -2539,16 +2554,23 @@ Return t when one or more block was removed, nil otherwise." (while (consp insn) (let ((newcar (car insn))) (if (or (consp (car insn)) (comp-mvar-p (car insn))) - (setf newcar (comp-copy-insn (car insn)))) + (setf newcar (comp--copy-insn (car insn)))) (push newcar result)) (setf insn (cdr insn))) (nconc (nreverse result) - (if (comp-mvar-p insn) (comp-copy-insn insn) insn))) + (if (comp-mvar-p insn) (comp--copy-insn insn) insn))) (if (comp-mvar-p insn) (copy-comp-mvar insn) insn))) -(defmacro comp-apply-in-env (func &rest args) +(defun comp--copy-insn (insn) + "Deep copy INSN." + (pcase insn + (`(setimm ,mvar ,imm) + `(setimm ,(copy-comp-mvar mvar) ,imm)) + (_ (comp--copy-insn-rec insn)))) + +(defmacro comp--apply-in-env (func &rest args) "Apply FUNC to ARGS in the current compilation environment." `(let ((env (cl-loop for f being the hash-value in (comp-ctxt-funcs-h comp-ctxt) @@ -2564,7 +2586,7 @@ Return t when one or more block was removed, nil otherwise." for (func-name . def) in env do (setf (symbol-function func-name) def))))) -(defun comp-fwprop-prologue () +(defun comp--fwprop-prologue () "Prologue for the propagate pass. Here goes everything that can be done not iteratively (read once). Forward propagate immediate involed in assignments." ; FIXME: Typo. Involved or invoked? @@ -2576,16 +2598,16 @@ Forward propagate immediate involed in assignments." ; FIXME: Typo. Involved or (`(setimm ,lval ,v) (setf (comp-cstr-imm lval) v)))))) -(defun comp-function-foldable-p (f args) +(defun comp--function-foldable-p (f args) "Given function F called with ARGS, return non-nil when optimizable." (and (comp--function-pure-p f) (cl-every #'comp-cstr-imm-vld-p args))) -(defun comp-function-call-maybe-fold (insn f args) +(defun comp--function-call-maybe-fold (insn f args) "Given INSN, when F is pure if all ARGS are known, remove the function call. Return non-nil if the function is folded successfully." (cl-flet ((rewrite-insn-as-setimm (insn value) - ;; See `comp-emit-setimm'. + ;; See `comp--emit-setimm'. (comp--add-const-to-relocs value) (setf (car insn) 'setimm (cddr insn) `(,value)))) @@ -2597,7 +2619,7 @@ Return non-nil if the function is folded successfully." comp-symbol-values-optimizable))) (rewrite-insn-as-setimm insn (symbol-value (comp-cstr-imm (car args)))))) - ((comp-function-foldable-p f args) + ((comp--function-foldable-p f args) (ignore-errors ;; No point to complain here in case of error because we ;; should do basic block pruning in order to be sure that this @@ -2608,14 +2630,14 @@ Return non-nil if the function is folded successfully." ;; and know to be pure. (comp-func-byte-func f-in-ctxt) f)) - (value (comp-apply-in-env f (mapcar #'comp-cstr-imm args)))) + (value (comp--apply-in-env f (mapcar #'comp-cstr-imm args)))) (rewrite-insn-as-setimm insn value))))))) -(defun comp-fwprop-call (insn lval f args) +(defun comp--fwprop-call (insn lval f args) "Propagate on a call INSN into LVAL. F is the function being called with arguments ARGS. Fold the call in case." - (unless (comp-function-call-maybe-fold insn f args) + (unless (comp--function-call-maybe-fold insn f args) (when (and (eq 'funcall f) (comp-cstr-imm-vld-p (car args))) (setf f (comp-cstr-imm (car args)) @@ -2636,16 +2658,16 @@ Fold the call in case." (comp-type-spec-to-cstr (comp-cstr-imm (car args))))))))) -(defun comp-fwprop-insn (insn) +(defun comp--fwprop-insn (insn) "Propagate within INSN." (pcase insn (`(set ,lval ,rval) (pcase rval (`(,(or 'call 'callref) ,f . ,args) - (comp-fwprop-call insn lval f args)) + (comp--fwprop-call insn lval f args)) (`(,(or 'direct-call 'direct-callref) ,f . ,args) (let ((f (comp-func-name (gethash f (comp-ctxt-funcs-h comp-ctxt))))) - (comp-fwprop-call insn lval f args))) + (comp--fwprop-call insn lval f args))) (_ (comp-cstr-shallow-copy lval rval)))) (`(assume ,lval ,(and (pred comp-mvar-p) rval)) @@ -2690,7 +2712,7 @@ Fold the call in case." (rvals (mapcar #'car rest))) (apply prop-fn lval rvals))))) -(defun comp-fwprop* () +(defun comp--fwprop* () "Propagate for set* and phi operands. Return t if something was changed." (cl-loop named outer @@ -2702,17 +2724,17 @@ Return t if something was changed." for insn in (comp-block-insns b) for orig-insn = (unless modified ;; Save consing after 1st change. - (comp-copy-insn insn)) + (comp--copy-insn insn)) do - (comp-fwprop-insn insn) + (comp--fwprop-insn insn) (cl-incf i) when (and (null modified) (not (equal insn orig-insn))) do (setf modified t)) - when (> i comp-fwprop-max-insns-scan) + when (> i comp--fwprop-max-insns-scan) do (cl-return-from outer nil) finally return modified)) -(defun comp-rewrite-non-locals () +(defun comp--rewrite-non-locals () "Make explicit in LIMPLE non-local exits if identified." (cl-loop for bb being each hash-value of (comp-func-blocks comp-func) @@ -2729,26 +2751,26 @@ Return t if something was changed." (cdr insn-seq) '((unreachable)) (comp-func-ssa-status comp-func) 'dirty)))) -(defun comp-fwprop (_) +(defun comp--fwprop (_) "Forward propagate types and consts within the lattice." - (comp-ssa) - (comp-dead-code) + (comp--ssa) + (comp--dead-code) (maphash (lambda (_ f) (when (and (>= (comp-func-speed f) 2) ;; FIXME remove the following condition when tested. (not (comp-func-has-non-local f))) (let ((comp-func f)) - (comp-fwprop-prologue) + (comp--fwprop-prologue) (cl-loop for i from 1 to 100 - while (comp-fwprop*) + while (comp--fwprop*) finally (when (= i 100) (display-warning 'comp (format "fwprop pass jammed into %s?" (comp-func-name f)))) (comp-log (format "Propagation run %d times\n" i) 2)) - (comp-rewrite-non-locals) + (comp--rewrite-non-locals) (comp--log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) @@ -2768,7 +2790,7 @@ Return t if something was changed." ;; the full compilation unit. ;; For this reason this is triggered only at native-comp-speed == 3. -(defun comp-func-in-unit (func) +(defun comp--func-in-unit (func) "Given FUNC return the `comp-fun' definition in the current context. FUNCTION can be a function-name or byte compiled function." (if (symbolp func) @@ -2776,11 +2798,11 @@ FUNCTION can be a function-name or byte compiled function." (cl-assert (byte-code-function-p func)) (gethash func (comp-ctxt-byte-func-to-func-h comp-ctxt)))) -(defun comp-call-optim-form-call (callee args) +(defun comp--call-optim-form-call (callee args) (cl-flet ((fill-args (args total) ;; Fill missing args to reach TOTAL (append args (cl-loop repeat (- total (length args)) - collect (make-comp-mvar :constant nil))))) + collect (make--comp-mvar :constant nil))))) (when (and callee (or (symbolp callee) (gethash callee (comp-ctxt-byte-func-to-func-h comp-ctxt))) @@ -2798,7 +2820,7 @@ FUNCTION can be a function-name or byte compiled function." ;; actually cheaper since it avoids the call to the ;; intermediate native trampoline (bug#67005). (subrp (subrp f)) - (comp-func-callee (comp-func-in-unit callee))) + (comp-func-callee (comp--func-in-unit callee))) (cond ((and subrp (not (subr-native-elisp-p f))) ;; Trampoline removal. @@ -2833,30 +2855,30 @@ FUNCTION can be a function-name or byte compiled function." ((comp--type-hint-p callee) `(call ,callee ,@args))))))) -(defun comp-call-optim-func () +(defun comp--call-optim-func () "Perform the trampoline call optimization for the current function." (cl-loop for b being each hash-value of (comp-func-blocks comp-func) - do (comp-loop-insn-in-block b + do (comp--loop-insn-in-block b (pcase insn (`(set ,lval (callref funcall ,f . ,rest)) (when-let ((ok (comp-cstr-imm-vld-p f)) - (new-form (comp-call-optim-form-call + (new-form (comp--call-optim-form-call (comp-cstr-imm f) rest))) (setf insn `(set ,lval ,new-form)))) (`(callref funcall ,f . ,rest) (when-let ((ok (comp-cstr-imm-vld-p f)) - (new-form (comp-call-optim-form-call + (new-form (comp--call-optim-form-call (comp-cstr-imm f) rest))) (setf insn new-form))))))) -(defun comp-call-optim (_) +(defun comp--call-optim (_) "Try to optimize out funcall trampoline usage when possible." (maphash (lambda (_ f) (when (and (>= (comp-func-speed f) 2) (comp-func-l-p f)) (let ((comp-func f)) - (comp-call-optim-func)))) + (comp--call-optim-func)))) (comp-ctxt-funcs-h comp-ctxt))) @@ -2867,16 +2889,16 @@ FUNCTION can be a function-name or byte compiled function." ;; ;; This pass can be run as last optim. -(defun comp-collect-mvar-ids (insn) +(defun comp--collect-mvar-ids (insn) "Collect the m-var unique identifiers into INSN." (cl-loop for x in insn if (consp x) - append (comp-collect-mvar-ids x) + append (comp--collect-mvar-ids x) else when (comp-mvar-p x) collect (comp-mvar-id x))) -(defun comp-dead-assignments-func () +(defun comp--dead-assignments-func () "Clean-up dead assignments into current function. Return the list of m-var ids nuked." (let ((l-vals ()) @@ -2889,9 +2911,10 @@ Return the list of m-var ids nuked." for (op arg0 . rest) = insn if (comp--assign-op-p op) do (push (comp-mvar-id arg0) l-vals) - (setf r-vals (nconc (comp-collect-mvar-ids rest) r-vals)) + (unless (eq op 'setimm) + (setf r-vals (nconc (comp--collect-mvar-ids rest) r-vals))) else - do (setf r-vals (nconc (comp-collect-mvar-ids insn) r-vals)))) + do (setf r-vals (nconc (comp--collect-mvar-ids insn) r-vals)))) ;; Every l-value appearing that does not appear as r-value has no right to ;; exist and gets nuked. (let ((nuke-list (cl-set-difference l-vals r-vals))) @@ -2903,7 +2926,7 @@ Return the list of m-var ids nuked." 3) (cl-loop for b being each hash-value of (comp-func-blocks comp-func) - do (comp-loop-insn-in-block b + do (comp--loop-insn-in-block b (cl-destructuring-bind (op &optional arg0 arg1 &rest rest) insn (when (and (comp--assign-op-p op) (memq (comp-mvar-id arg0) nuke-list)) @@ -2914,7 +2937,7 @@ Return the list of m-var ids nuked." insn)))))))) nuke-list))) -(defun comp-dead-code () +(defun comp--dead-code () "Dead code elimination." (maphash (lambda (_ f) (when (and (>= (comp-func-speed f) 2) @@ -2923,7 +2946,7 @@ Return the list of m-var ids nuked." (cl-loop for comp-func = f for i from 1 - while (comp-dead-assignments-func) + while (comp--dead-assignments-func) finally (comp-log (format "dead code rm run %d times\n" i) 2) (comp--log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) @@ -2931,14 +2954,14 @@ Return the list of m-var ids nuked." ;;; Tail Call Optimization pass specific code. -(defun comp-form-tco-call-seq (args) +(defun comp--form-tco-call-seq (args) "Generate a TCO sequence for ARGS." `(,@(cl-loop for arg in args for i from 0 - collect `(set ,(make-comp-mvar :slot i) ,arg)) + collect `(set ,(make--comp-mvar :slot i) ,arg)) (jump bb_0))) -(defun comp-tco-func () +(defun comp--tco-func () "Try to pattern match and perform TCO within the current function." (cl-loop for b being each hash-value of (comp-func-blocks comp-func) @@ -2951,20 +2974,20 @@ Return the list of m-var ids nuked." (return ,ret-val)) (when (and (string= func (comp-func-c-name comp-func)) (eq l-val ret-val)) - (let ((tco-seq (comp-form-tco-call-seq args))) + (let ((tco-seq (comp--form-tco-call-seq args))) (setf (car insns-seq) (car tco-seq) (cdr insns-seq) (cdr tco-seq) (comp-func-ssa-status comp-func) 'dirty) (cl-return-from in-the-basic-block)))))))) -(defun comp-tco (_) +(defun comp--tco (_) "Simple peephole pass performing self TCO." (maphash (lambda (_ f) (when (and (>= (comp-func-speed f) 3) (comp-func-l-p f) (not (comp-func-has-non-local f))) (let ((comp-func f)) - (comp-tco-func) + (comp--tco-func) (comp--log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) @@ -2974,54 +2997,88 @@ Return the list of m-var ids nuked." ;; This must run after all SSA prop not to have the type hint ;; information overwritten. -(defun comp-remove-type-hints-func () +(defun comp--remove-type-hints-func () "Remove type hints from the current function. These are substituted with a normal `set' op." (cl-loop for b being each hash-value of (comp-func-blocks comp-func) - do (comp-loop-insn-in-block b + do (comp--loop-insn-in-block b (pcase insn (`(set ,l-val (call ,(pred comp--type-hint-p) ,r-val)) (setf insn `(set ,l-val ,r-val))))))) -(defun comp-remove-type-hints (_) +(defun comp--remove-type-hints (_) "Dead code elimination." (maphash (lambda (_ f) (when (>= (comp-func-speed f) 2) (let ((comp-func f)) - (comp-remove-type-hints-func) + (comp--remove-type-hints-func) (comp--log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) -;;; Final pass specific code. +;;; Sanitizer pass specific code. -(defun comp-args-to-lambda-list (args) - "Return a lambda list for ARGS." - (cl-loop - with res - repeat (comp-args-base-min args) - do (push t res) - finally - (if (comp-args-p args) - (cl-loop - with n = (- (comp-args-max args) (comp-args-min args)) - initially (unless (zerop n) - (push '&optional res)) - repeat n - do (push t res)) +;; This pass aims to verify compile-time value-type predictions during +;; execution of the code. +;; The sanitizer pass injects a call to 'helper_sanitizer_assert' before +;; each conditional branch. 'helper_sanitizer_assert' will verify that +;; the variable tested by the conditional branch is of the predicted +;; value type, or signal an error otherwise. + +;;; Example: + +;; Assume we want to compile 'test.el' and test the function `foo' +;; defined in it. Then: + +;; - Native-compile 'test.el' instrumenting it for sanitizer usage: +;; (let ((comp-sanitizer-emit t)) +;; (load (native-compile "test.el"))) + +;; - Run `foo' with the sanitizer active: +;; (let ((comp-sanitizer-active t)) +;; (foo)) + +(defvar comp-sanitizer-emit nil + "Gates the sanitizer pass. +This is intended to be used only for development and verification of +the native compiler.") + +(defun comp--sanitizer (_) + (when comp-sanitizer-emit + (cl-loop + for f being each hash-value of (comp-ctxt-funcs-h comp-ctxt) + for comp-func = f + unless (comp-func-has-non-local comp-func) + do (cl-loop - with n = (- (comp-nargs-nonrest args) (comp-nargs-min args)) - initially (unless (zerop n) - (push '&optional res)) - repeat n - do (push t res) - finally (when (comp-nargs-rest args) - (push '&rest res) - (push 't res)))) - (cl-return (reverse res)))) + for b being each hash-value of (comp-func-blocks f) + do + (cl-loop + named in-the-basic-block + for insns-seq on (comp-block-insns b) + do (pcase insns-seq + (`((cond-jump ,(and (pred comp-mvar-p) mvar-tested) + ,(pred comp-mvar-p) ,_bb1 ,_bb2)) + (let ((type (comp-cstr-to-type-spec mvar-tested)) + (insn (car insns-seq))) + ;; No need to check if type is t. + (unless (eq type t) + (comp--add-const-to-relocs type) + (setcar + insns-seq + (comp--call 'helper_sanitizer_assert + mvar-tested + (make--comp-mvar :constant type))) + (setcdr insns-seq (list insn))) + ;; (setf (comp-func-ssa-status comp-func) 'dirty) + (cl-return-from in-the-basic-block)))))) + do (comp--log-func comp-func 3)))) + + +;;; Function types pass specific code. -(defun comp-compute-function-type (_ func) +(defun comp--compute-function-type (_ func) "Compute type specifier for `comp-func' FUNC. Set it into the `type' slot." (when (and (comp-func-l-p func) @@ -3041,13 +3098,45 @@ Set it into the `type' slot." (`(return ,mvar) (push mvar res)))) finally return res))) - (type `(function ,(comp-args-to-lambda-list (comp-func-l-args func)) + (type `(function ,(comp--args-to-lambda-list (comp-func-l-args func)) ,(comp-cstr-to-type-spec res-mvar)))) (comp--add-const-to-relocs type) ;; Fix it up. (setf (comp-cstr-imm (comp-func-type func)) type)))) -(defun comp-finalize-container (cont) +(defun comp--compute-function-types (_) + "Compute and store the type specifier for all functions." + (maphash #'comp--compute-function-type (comp-ctxt-funcs-h comp-ctxt))) + + +;;; Final pass specific code. + +(defun comp--args-to-lambda-list (args) + "Return a lambda list for ARGS." + (cl-loop + with res + repeat (comp-args-base-min args) + do (push t res) + finally + (if (comp-args-p args) + (cl-loop + with n = (- (comp-args-max args) (comp-args-min args)) + initially (unless (zerop n) + (push '&optional res)) + repeat n + do (push t res)) + (cl-loop + with n = (- (comp-nargs-nonrest args) (comp-nargs-min args)) + initially (unless (zerop n) + (push '&optional res)) + repeat n + do (push t res) + finally (when (comp-nargs-rest args) + (push '&rest res) + (push 't res)))) + (cl-return (reverse res)))) + +(defun comp--finalize-container (cont) "Finalize data container CONT." (setf (comp-data-container-l cont) (cl-loop with h = (comp-data-container-idx cont) @@ -3065,7 +3154,7 @@ Set it into the `type' slot." 'lambda-fixup obj)))) -(defun comp-finalize-relocs () +(defun comp--finalize-relocs () "Finalize data containers for each relocation class. Remove immediate duplicates within relocation classes. Update all insn accordingly." @@ -3081,7 +3170,7 @@ Update all insn accordingly." (d-ephemeral (comp-ctxt-d-ephemeral comp-ctxt)) (d-ephemeral-idx (comp-data-container-idx d-ephemeral))) ;; We never want compiled lambdas ending up in pure space. A copy must - ;; be already present in impure (see `comp-emit-lambda-for-top-level'). + ;; be already present in impure (see `comp--emit-lambda-for-top-level'). (cl-loop for obj being each hash-keys of d-default-idx when (gethash obj (comp-ctxt-lambda-fixups-h comp-ctxt)) do (cl-assert (gethash obj d-impure-idx)) @@ -3097,7 +3186,7 @@ Update all insn accordingly." do (remhash obj d-ephemeral-idx)) ;; Fix-up indexes in each relocation class and fill corresponding ;; reloc lists. - (mapc #'comp-finalize-container (list d-default d-impure d-ephemeral)) + (mapc #'comp--finalize-container (list d-default d-impure d-ephemeral)) ;; Make a vector from the function documentation hash table. (cl-loop with h = (comp-ctxt-function-docs comp-ctxt) with v = (make-vector (hash-table-count h) nil) @@ -3121,11 +3210,11 @@ Update all insn accordingly." (comp-mvar-range mvar) (list (cons idx idx))) (puthash idx t reverse-h)))) -(defun comp-compile-ctxt-to-file (name) +(defun comp--compile-ctxt-to-file (name) "Compile as native code the current context naming it NAME. Prepare every function for final compilation and drive the C back-end." (let ((dir (file-name-directory name))) - (comp-finalize-relocs) + (comp--finalize-relocs) (maphash (lambda (_ f) (comp--log-func f 1)) (comp-ctxt-funcs-h comp-ctxt)) @@ -3133,12 +3222,12 @@ Prepare every function for final compilation and drive the C back-end." ;; In case it's created in the meanwhile. (ignore-error file-already-exists (make-directory dir t))) - (comp--compile-ctxt-to-file name))) + (comp--compile-ctxt-to-file0 name))) -(defun comp-final1 () +(defun comp--final1 () (comp--init-ctxt) (unwind-protect - (comp-compile-ctxt-to-file (comp-ctxt-output comp-ctxt)) + (comp--compile-ctxt-to-file (comp-ctxt-output comp-ctxt)) (comp--release-ctxt))) (defvar comp-async-compilation nil @@ -3147,17 +3236,16 @@ Prepare every function for final compilation and drive the C back-end." (defvar comp-running-batch-compilation nil "Non-nil when compilation is driven by any `batch-*-compile' function.") -(defun comp-final (_) +(defun comp--final (_) "Final pass driving the C back-end for code emission." - (maphash #'comp-compute-function-type (comp-ctxt-funcs-h comp-ctxt)) (unless comp-dry-run ;; Always run the C side of the compilation as a sub-process ;; unless during bootstrap or async compilation (bug#45056). GCC ;; leaks memory but also interfere with the ability of Emacs to ;; detect when a sub-process completes (TODO understand why). (if (or comp-running-batch-compilation comp-async-compilation) - (comp-final1) - ;; Call comp-final1 in a child process. + (comp--final1) + ;; Call comp--final1 in a child process. (let* ((output (comp-ctxt-output comp-ctxt)) (print-escape-newlines t) (print-length nil) @@ -3179,7 +3267,7 @@ Prepare every function for final compilation and drive the C back-end." load-path ',load-path) ,native-comp-async-env-modifier-form (message "Compiling %s..." ',output) - (comp-final1))) + (comp--final1))) (temp-file (make-temp-file (concat "emacs-int-comp-" (file-name-base output) "-") @@ -3223,7 +3311,7 @@ Prepare every function for final compilation and drive the C back-end." ;; Primitive function advice machinery -(defun comp-make-lambda-list-from-subr (subr) +(defun comp--make-lambda-list-from-subr (subr) "Given SUBR return the equivalent lambda-list." (pcase-let ((`(,min . ,max) (subr-arity subr)) (lambda-list '())) @@ -3267,7 +3355,7 @@ Prepare every function for final compilation and drive the C back-end." ;;;###autoload (defun comp-trampoline-compile (subr-name) "Synthesize compile and return a trampoline for SUBR-NAME." - (let* ((lambda-list (comp-make-lambda-list-from-subr + (let* ((lambda-list (comp--make-lambda-list-from-subr (symbol-function subr-name))) ;; The synthesized trampoline must expose the exact same ABI of ;; the primitive we are replacing in the function reloc table. @@ -3311,6 +3399,7 @@ filename (including FILE)." do (ignore-error file-error (comp-delete-or-replace-file f)))))) +;; In use by comp.c. (defun comp-delete-or-replace-file (oldfile &optional newfile) "Replace OLDFILE with NEWFILE. When NEWFILE is nil just delete OLDFILE. @@ -3399,16 +3488,18 @@ the deferred compilation mechanism." (if (and comp-async-compilation (not (eq (car err) 'native-compiler-error))) (progn - (message (if err-val - "%s: Error: %s %s" - "%s: Error %s") + (message "%s: Error %s" function-or-file - (get (car err) 'error-message) - (car-safe err-val)) + (error-message-string err)) (kill-emacs -1)) ;; Otherwise re-signal it adding the compilation input. + ;; FIXME: We can't just insert arbitrary info in the + ;; error-data part of an error: the handler may expect + ;; specific data at specific positions! (signal (car err) (if (consp err-val) (cons function-or-file err-val) + ;; FIXME: `err-val' is supposed to be + ;; a list, so it can only be nil here! (list function-or-file err-val))))))) (if (stringp function-or-file) data @@ -3492,7 +3583,8 @@ last directory in `native-comp-eln-load-path')." else collect (byte-compile-file file)))) -(defun comp-write-bytecode-file (eln-file) +;; In use by elisp-mode.el +(defun comp--write-bytecode-file (eln-file) "After native compilation write the bytecode file for ELN-FILE. Make sure that eln file is younger than byte-compiled one and return the filename of this last. @@ -3529,7 +3621,7 @@ variable \"NATIVE_DISABLED\" is set, only byte compile." (car (last native-comp-eln-load-path))) (byte-to-native-output-buffer-file nil) (eln-file (car (batch-native-compile)))) - (comp-write-bytecode-file eln-file) + (comp--write-bytecode-file eln-file) (setq command-line-args-left (cdr command-line-args-left))))) (defun native-compile-prune-cache () diff --git a/lisp/emacs-lisp/compat.el b/lisp/emacs-lisp/compat.el new file mode 100644 index 00000000000..f7037dc4101 --- /dev/null +++ b/lisp/emacs-lisp/compat.el @@ -0,0 +1,92 @@ +;;; compat.el --- Stub of the Compatibility Library -*- lexical-binding: t; -*- + +;; Copyright (C) 2021-2024 Free Software Foundation, Inc. + +;; Author: \ +;; Philip Kaludercic <philipk@posteo.net>, \ +;; Daniel Mendler <mail@daniel-mendler.de> +;; Maintainer: \ +;; Daniel Mendler <mail@daniel-mendler.de>, \ +;; Compat Development <~pkal/compat-devel@lists.sr.ht>, +;; emacs-devel@gnu.org +;; URL: https://github.com/emacs-compat/compat +;; Keywords: lisp, maint + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; The Compat package on ELPA provides forward-compatibility +;; definitions for other packages. While mostly transparent, a +;; minimal API is necessary whenever core definitions change calling +;; conventions (e.g. `plist-get' can be invoked with a predicate from +;; Emacs 29.1 onward). For core packages on ELPA to be able to take +;; advantage of this functionality, the macros `compat-function' and +;; `compat-call' have to be available in the core, usable even if +;; users do not have the Compat package installed, which this file +;; ensures. + +;; A basic introduction to Compat is given in the Info node `(elisp) +;; Forwards Compatibility'. Further details on Compat are documented +;; in the Info node `(compat) Top' (installed along with the Compat +;; package) or read the same manual online: +;; https://elpa.gnu.org/packages/doc/compat.html. + +;;; Code: + +(defmacro compat-function (fun) + "Return compatibility function symbol for FUN. +This is a pseudo-compatibility stub for core packages on ELPA, +that depend on the Compat package, whenever the user doesn't have +the package installed on their current system." + `#',fun) + +(defmacro compat-call (fun &rest args) + "Call compatibility function or macro FUN with ARGS. +This is a pseudo-compatibility stub for core packages on ELPA, +that depend on the Compat package, whenever the user doesn't have +the package installed on their current system." + (cons fun args)) + +;;;; Clever trick to avoid installing Compat if not necessary + +;; The versioning scheme of the Compat package follows that of Emacs, +;; to indicate the version of Emacs, that functionality is being +;; provided for. For example, the Compat version number 29.2.3.9 +;; would attempt to provide compatibility definitions up to Emacs +;; 29.2, while also designating that this is the third major release +;; and ninth minor release of Compat, for the specific Emacs release. + +;; The package version of this file is specified programmatically, +;; instead of giving a fixed version in the header of this file. This +;; is done to ensure that the version of compat.el provided by Emacs +;; always corresponds to the current version of Emacs. In addition to +;; the major-minor version, a large "major release" makes sure that +;; the built-in version of Compat is always preferred over an external +;; installation. This means that if a package specifies a dependency +;; on Compat which matches the current or an older version of Emacs +;; that is being used, no additional dependencies have to be +;; downloaded. +;; +;; Further details and background on this file can be found in the +;; bug#66554 discussion. + +;;;###autoload (push (list 'compat +;;;###autoload emacs-major-version +;;;###autoload emacs-minor-version +;;;###autoload 9999) +;;;###autoload package--builtin-versions) + +(provide 'compat) +;;; compat.el ends here diff --git a/lisp/emacs-lisp/debug-early.el b/lisp/emacs-lisp/debug-early.el index f2eb8792bfa..8a0dddc2679 100644 --- a/lisp/emacs-lisp/debug-early.el +++ b/lisp/emacs-lisp/debug-early.el @@ -27,14 +27,17 @@ ;; This file dumps a backtrace on stderr when an error is thrown. It ;; has no dependencies on any Lisp libraries and is thus used for ;; generating backtraces for bugs in the early parts of bootstrapping. -;; It is also always used in batch model. It was introduced in Emacs +;; It is also always used in batch mode. It was introduced in Emacs ;; 29, before which there was no backtrace available during early ;; bootstrap. ;;; Code: +;; For bootstrap reasons, we cannot use any macros here since they're +;; not defined yet. + (defalias 'debug-early-backtrace - #'(lambda () + #'(lambda (&optional base) "Print a trace of Lisp function calls currently active. The output stream used is the value of `standard-output'. @@ -51,26 +54,39 @@ of the build process." (require 'cl-print) (error nil))) #'cl-prin1 - #'prin1))) + #'prin1)) + (first t)) (mapbacktrace #'(lambda (evald func args _flags) - (let ((args args)) - (if evald + (if first + ;; The first is the debug-early entry point itself. + (setq first nil) + (let ((args args)) + (if evald + (progn + (princ " ") + (funcall prin1 func) + (princ "(")) (progn - (princ " ") - (funcall prin1 func) - (princ "(")) - (progn - (princ " (") - (setq args (cons func args)))) - (if args - (while (progn - (funcall prin1 (car args)) - (setq args (cdr args))) - (princ " "))) - (princ ")\n"))))))) - -(defalias 'debug-early + (princ " (") + (setq args (cons func args)))) + (if args + (while (progn + (funcall prin1 (car args)) + (setq args (cdr args))) + (princ " "))) + (princ ")\n")))) + base)))) + +(defalias 'debug--early + #'(lambda (error base) + (princ "\nError: ") + (prin1 (car error)) ; The error symbol. + (princ " ") + (prin1 (cdr error)) ; The error data. + (debug-early-backtrace base))) + +(defalias 'debug-early ;Called from C. #'(lambda (&rest args) "Print an error message with a backtrace of active Lisp function calls. The output stream used is the value of `standard-output'. @@ -88,10 +104,31 @@ support the latter, except in batch mode which always uses \(In versions of Emacs prior to Emacs 29, no backtrace was available before `debug' was usable.)" - (princ "\nError: ") - (prin1 (car (car (cdr args)))) ; The error symbol. - (princ " ") - (prin1 (cdr (car (cdr args)))) ; The error data. - (debug-early-backtrace))) + (debug--early (car (cdr args)) #'debug-early))) ; The error object. + +(defalias 'debug-early--handler ;Called from C. + #'(lambda (err) + (if backtrace-on-error-noninteractive + (debug--early err #'debug-early--handler)))) + +(defalias 'debug-early--muted ;Called from C. + #'(lambda (err) + (save-current-buffer + (set-buffer (get-buffer-create "*Redisplay-trace*")) + (goto-char (point-max)) + (if (bobp) nil + (let ((separator "\n\n\n\n")) + (save-excursion + ;; The C code tested `backtrace_yet', instead we + ;; keep a max of 10 backtraces. + (if (search-backward separator nil t 10) + (delete-region (point-min) (match-end 0)))) + (insert separator))) + (insert "-- Caught at " (current-time-string) "\n") + (let ((standard-output (current-buffer))) + (debug--early err #'debug-early--muted)) + (setq delayed-warnings-list + (cons '(error "Error in a redisplay Lisp hook. See buffer *Redisplay-trace*") + delayed-warnings-list))))) ;;; debug-early.el ends here. diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index 506b73f6fa2..ec947c1215d 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -153,6 +153,12 @@ where CAUSE can be: (insert (debugger--buffer-state-content state))) (goto-char (debugger--buffer-state-pos state))) +(defvar debugger--last-error nil) + +(defun debugger--duplicate-p (args) + (pcase args + (`(error ,err . ,_) (and (consp err) (eq err debugger--last-error))))) + ;;;###autoload (setq debugger 'debug) ;;;###autoload @@ -175,9 +181,14 @@ first will be printed into the backtrace buffer. If `inhibit-redisplay' is non-nil when this function is called, the debugger will not be entered." (interactive) - (if inhibit-redisplay - ;; Don't really try to enter debugger within an eval from redisplay. + (if (or inhibit-redisplay + (debugger--duplicate-p args)) + ;; Don't really try to enter debugger within an eval from redisplay + ;; or if we already popper into the debugger for this error, + ;; which can happen when we have several nested `handler-bind's that + ;; want to invoke the debugger. debugger-value + (setq debugger--last-error nil) (let ((non-interactive-frame (or noninteractive ;FIXME: Presumably redundant. ;; If we're in the initial-frame (where `message' just @@ -200,7 +211,7 @@ the debugger will not be entered." (let (debugger-value (debugger-previous-state (if (get-buffer "*Backtrace*") - (with-current-buffer (get-buffer "*Backtrace*") + (with-current-buffer "*Backtrace*" (debugger--save-buffer-state)))) (debugger-args args) (debugger-buffer (get-buffer-create "*Backtrace*")) @@ -318,6 +329,12 @@ the debugger will not be entered." (backtrace-mode)))) (with-timeout-unsuspend debugger-with-timeout-suspend) (set-match-data debugger-outer-match-data))) + (when (eq 'error (car-safe debugger-args)) + ;; Remember the error we just debugged, to avoid re-entering + ;; the debugger if some higher-up `handler-bind' invokes us + ;; again, oblivious that the error was already debugged from + ;; a more deeply nested `handler-bind'. + (setq debugger--last-error (nth 1 debugger-args))) (setq debug-on-next-call debugger-step-after-exit) debugger-value)))) @@ -651,7 +668,7 @@ Complete list of commands: (princ (debugger-eval-expression exp)) (terpri)) - (with-current-buffer (get-buffer debugger-record-buffer) + (with-current-buffer debugger-record-buffer (message "%s" (buffer-substring (line-beginning-position 0) (line-end-position 0))))) diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el index 5c224362708..2423426dca0 100644 --- a/lisp/emacs-lisp/derived.el +++ b/lisp/emacs-lisp/derived.el @@ -211,10 +211,10 @@ See Info node `(elisp)Derived Modes' for more details. (defvar ,hook nil) (unless (get ',hook 'variable-documentation) (put ',hook 'variable-documentation - ,(format "Hook run after entering %s mode. + ,(format "Hook run after entering `%S'. No problems result if this variable is not bound. `add-hook' automatically binds it. (This is true for all hook variables.)" - name))) + child))) (unless (boundp ',map) (put ',map 'definition-name ',child)) (with-no-warnings (defvar ,map (make-sparse-keymap))) @@ -365,137 +365,6 @@ which more-or-less shadow%s %s's corresponding table%s." docstring)) -;;; OBSOLETE -;; The functions below are only provided for backward compatibility with -;; code byte-compiled with versions of derived.el prior to Emacs-21. - -(defsubst derived-mode-setup-function-name (mode) - "Construct a setup-function name based on a MODE name." - (declare (obsolete nil "28.1")) - (intern (concat (symbol-name mode) "-setup"))) - - -;; Utility functions for defining a derived mode. - -;;;###autoload -(defun derived-mode-init-mode-variables (mode) - "Initialize variables for a new MODE. -Right now, if they don't already exist, set up a blank keymap, an -empty syntax table, and an empty abbrev table -- these will be merged -the first time the mode is used." - - (if (boundp (derived-mode-map-name mode)) - t - (eval `(defvar ,(derived-mode-map-name mode) - (make-sparse-keymap) - ,(format "Keymap for %s." mode))) - (put (derived-mode-map-name mode) 'derived-mode-unmerged t)) - - (if (boundp (derived-mode-syntax-table-name mode)) - t - (eval `(defvar ,(derived-mode-syntax-table-name mode) - ;; Make a syntax table which doesn't specify anything - ;; for any char. Valid data will be merged in by - ;; derived-mode-merge-syntax-tables. - (make-char-table 'syntax-table nil) - ,(format "Syntax table for %s." mode))) - (put (derived-mode-syntax-table-name mode) 'derived-mode-unmerged t)) - - (if (boundp (derived-mode-abbrev-table-name mode)) - t - (eval `(defvar ,(derived-mode-abbrev-table-name mode) - (progn - (define-abbrev-table (derived-mode-abbrev-table-name ',mode) nil) - (make-abbrev-table)) - ,(format "Abbrev table for %s." mode))))) - -;; Utility functions for running a derived mode. - -(defun derived-mode-set-keymap (mode) - "Set the keymap of the new MODE, maybe merging with the parent." - (let* ((map-name (derived-mode-map-name mode)) - (new-map (eval map-name)) - (old-map (current-local-map))) - (and old-map - (get map-name 'derived-mode-unmerged) - (derived-mode-merge-keymaps old-map new-map)) - (put map-name 'derived-mode-unmerged nil) - (use-local-map new-map))) - -(defun derived-mode-set-syntax-table (mode) - "Set the syntax table of the new MODE, maybe merging with the parent." - (let* ((table-name (derived-mode-syntax-table-name mode)) - (old-table (syntax-table)) - (new-table (eval table-name))) - (if (get table-name 'derived-mode-unmerged) - (derived-mode-merge-syntax-tables old-table new-table)) - (put table-name 'derived-mode-unmerged nil) - (set-syntax-table new-table))) - -(defun derived-mode-set-abbrev-table (mode) - "Set the abbrev table for MODE if it exists. -Always merge its parent into it, since the merge is non-destructive." - (let* ((table-name (derived-mode-abbrev-table-name mode)) - (old-table local-abbrev-table) - (new-table (eval table-name))) - (derived-mode-merge-abbrev-tables old-table new-table) - (setq local-abbrev-table new-table))) - -(defun derived-mode-run-hooks (mode) - "Run the mode hook for MODE." - (let ((hooks-name (derived-mode-hook-name mode))) - (if (boundp hooks-name) - (run-hooks hooks-name)))) - -;; Functions to merge maps and tables. - -(defun derived-mode-merge-keymaps (old new) - "Merge an OLD keymap into a NEW one. -The old keymap is set to be the last cdr of the new one, so that there will -be automatic inheritance." - ;; ?? Can this just use `set-keymap-parent'? - (let ((tail new)) - ;; Scan the NEW map for prefix keys. - (while (consp tail) - (and (consp (car tail)) - (let* ((key (vector (car (car tail)))) - (subnew (lookup-key new key)) - (subold (lookup-key old key))) - ;; If KEY is a prefix key in both OLD and NEW, merge them. - (and (keymapp subnew) (keymapp subold) - (derived-mode-merge-keymaps subold subnew)))) - (and (vectorp (car tail)) - ;; Search a vector of ASCII char bindings for prefix keys. - (let ((i (1- (length (car tail))))) - (while (>= i 0) - (let* ((key (vector i)) - (subnew (lookup-key new key)) - (subold (lookup-key old key))) - ;; If KEY is a prefix key in both OLD and NEW, merge them. - (and (keymapp subnew) (keymapp subold) - (derived-mode-merge-keymaps subold subnew))) - (setq i (1- i))))) - (setq tail (cdr tail)))) - (setcdr (nthcdr (1- (length new)) new) old)) - -(defun derived-mode-merge-syntax-tables (old new) - "Merge an OLD syntax table into a NEW one. -Where the new table already has an entry, nothing is copied from the old one." - (set-char-table-parent new old)) - -;; Merge an old abbrev table into a new one. -;; This function requires internal knowledge of how abbrev tables work, -;; presuming that they are obarrays with the abbrev as the symbol, the expansion -;; as the value of the symbol, and the hook as the function definition. -(defun derived-mode-merge-abbrev-tables (old new) - (if old - (mapatoms - (lambda (symbol) - (or (intern-soft (symbol-name symbol) new) - (define-abbrev new (symbol-name symbol) - (symbol-value symbol) (symbol-function symbol)))) - old))) - (provide 'derived) ;;; derived.el ends here diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el index a876e6b5744..850cc2085f7 100644 --- a/lisp/emacs-lisp/disass.el +++ b/lisp/emacs-lisp/disass.el @@ -54,7 +54,7 @@ (defun disassemble (object &optional buffer indent interactive-p) "Print disassembled code for OBJECT in (optional) BUFFER. OBJECT can be a symbol defined as a function, or a function itself -\(a lambda expression or a compiled-function object). +\(a lambda expression or a byte-code-function object). If OBJECT is not already compiled, we compile it, but do not redefine OBJECT if it is a symbol." (interactive @@ -70,7 +70,7 @@ redefine OBJECT if it is a symbol." (save-excursion (if (or interactive-p (null buffer)) (with-output-to-temp-buffer "*Disassemble*" - (set-buffer "*Disassemble*") + (set-buffer standard-output) (let ((lexical-binding lb)) (disassemble-internal object indent (not interactive-p)))) (set-buffer buffer) @@ -191,8 +191,6 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler." (if (consp obj) (setq bytes (car (cdr obj)) ;the byte code constvec (car (cdr (cdr obj)))) ;constant vector - ;; If it is lazy-loaded, load it now - (fetch-bytecode obj) (setq bytes (aref obj 1) constvec (aref obj 2))) (cl-assert (not (multibyte-string-p bytes))) @@ -252,29 +250,22 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler." ;; if the succeeding op is byte-switch, display the jump table ;; used (cond ((eq (car-safe (car-safe (cdr lap))) 'byte-switch) - (insert (format "<jump-table-%s (" (hash-table-test arg))) - (let ((first-time t)) - (maphash #'(lambda (value tag) - (if first-time - (setq first-time nil) - (insert " ")) - (insert (format "%s %s" value (cadr tag)))) - arg)) - (insert ")>")) - ;; if the value of the constant is compiled code, then - ;; recursively disassemble it. - ((or (byte-code-function-p arg) - (and (consp arg) (functionp arg) - (assq 'byte-code arg)) + (insert (format "<jump-table-%s (" (hash-table-test arg))) + (let ((first-time t)) + (maphash #'(lambda (value tag) + (if first-time + (setq first-time nil) + (insert " ")) + (insert (format "%s %s" value (cadr tag)))) + arg)) + (insert ")>")) + ;; if the value of the constant is compiled code, then + ;; recursively disassemble it. + ((or (byte-code-function-p arg) (and (eq (car-safe arg) 'macro) - (or (byte-code-function-p (cdr arg)) - (and (consp (cdr arg)) - (functionp (cdr arg)) - (assq 'byte-code (cdr arg)))))) + (byte-code-function-p (cdr arg)))) (cond ((byte-code-function-p arg) (insert "<compiled-function>\n")) - ((functionp arg) - (insert "<compiled lambda>")) (t (insert "<compiled macro>\n"))) (disassemble-internal arg @@ -287,7 +278,7 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler." (+ indent disassemble-recursive-indent))) ((eq (car-safe (car-safe arg)) 'byte-code) (insert "(<byte code>...)\n") - (mapc ;recurse on list of byte-code objects + (mapc ;Recurse on list of byte-code objects. (lambda (obj) (disassemble-1 obj diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 05b23a86fc0..4fa05008dd8 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -132,7 +132,7 @@ it is disabled.") (string-replace "'" "\\='" (format "%S" getter))))) (let ((start (point))) (insert argdoc) - (when (fboundp 'fill-region) + (when (fboundp 'fill-region) ;Don't break bootstrap! (fill-region start (point) 'left t)))) ;; Finally, insert the keymap. (when (and (boundp keymap-sym) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index a8a51502503..b27ffbca908 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -193,11 +193,15 @@ Use this with caution since it is not debugged." (defcustom edebug-print-length 50 - "If non-nil, default value of `print-length' for printing results in Edebug." - :type '(choice integer (const nil))) + "Maximum length of list to print before abbreviating, when in Edebug. +If this is nil, use the value of `print-length' instead." + :type '(choice (integer :tag "A number") + (const :tag "Use `print-length'" nil))) (defcustom edebug-print-level 50 - "If non-nil, default value of `print-level' for printing results in Edebug." - :type '(choice integer (const nil))) + "Maximum depth of list nesting to print before abbreviating, when in Edebug. +If nil, use the value of `print-level' instead." + :type '(choice (integer :tag "A number") + (const :tag "Use `print-level'" nil))) (defcustom edebug-print-circle t "If non-nil, default value of `print-circle' for printing results in Edebug." :type 'boolean) @@ -481,7 +485,7 @@ just FUNCTION is printed." (edebug--eval-defun #'eval-defun edebug-it))) ;;;###autoload -(defalias 'edebug-defun 'edebug-eval-top-level-form) +(defalias 'edebug-defun #'edebug-eval-top-level-form) ;;;###autoload (defun edebug-eval-top-level-form () @@ -1225,10 +1229,12 @@ purpose by adding an entry to this alist, and setting ;; But the list will just be reversed. ,@(nreverse edebug-def-args)) 'nil) - ;; Make sure `forms' is not nil so we don't accidentally return - ;; the magic keyword. Mark the closure so we don't throw away - ;; unused vars (bug#59213). - #'(lambda () :closure-dont-trim-context ,@(or forms '(nil))))) + #'(lambda () + ;; Mark the closure so we don't throw away unused vars (bug#59213). + :closure-dont-trim-context + ;; Make sure `forms' is not nil so we don't accidentally return + ;; the magic keyword. + ,@(or forms '(nil))))) (defvar edebug-form-begin-marker) ; the mark for def being instrumented @@ -1266,55 +1272,48 @@ Does not unwrap inside vectors, records, structures, or hash tables." (pcase sexp (`(edebug-after ,_before-form ,_after-index ,form) form) - (`(lambda ,args (edebug-enter ',_sym ,_arglist - (function (lambda nil . ,body)))) - `(lambda ,args ,@body)) - (`(closure ,env ,args (edebug-enter ',_sym ,_arglist - (function (lambda nil . ,body)))) - `(closure ,env ,args ,@body)) - (`(edebug-enter ',_sym ,_args (function (lambda nil . ,body))) + (`(edebug-enter ',_sym ,_args + #'(lambda nil :closure-dont-trim-context . ,body)) (macroexp-progn body)) (_ sexp))) +(defconst edebug--unwrap-cache + (make-hash-table :test 'eq :weakness 'key) + "Hash-table containing the results of unwrapping cons cells. +These results are reused to avoid redundant work but also to avoid +infinite loops when the code/environment contains a circular object.") + (defun edebug-unwrap* (sexp) "Return the SEXP recursively unwrapped." - (let ((ht (make-hash-table :test 'eq))) - (edebug--unwrap1 sexp ht))) - -(defun edebug--unwrap1 (sexp hash-table) - "Unwrap SEXP using HASH-TABLE of things already unwrapped. -HASH-TABLE contains the results of unwrapping cons cells within -SEXP, which are reused to avoid infinite loops when SEXP is or -contains a circular object." - (let ((new-sexp (edebug-unwrap sexp))) - (while (not (eq sexp new-sexp)) - (setq sexp new-sexp - new-sexp (edebug-unwrap sexp))) - (if (consp new-sexp) - (let ((result (gethash new-sexp hash-table nil))) - (unless result - (let ((remainder new-sexp) - current) - (setq result (cons nil nil) - current result) - (while - (progn - (puthash remainder current hash-table) - (setf (car current) - (edebug--unwrap1 (car remainder) hash-table)) - (setq remainder (cdr remainder)) - (cond - ((atom remainder) - (setf (cdr current) - (edebug--unwrap1 remainder hash-table)) - nil) - ((gethash remainder hash-table nil) - (setf (cdr current) (gethash remainder hash-table nil)) - nil) - (t (setq current - (setf (cdr current) (cons nil nil))))))))) - result) - new-sexp))) + (while (not (eq sexp (setq sexp (edebug-unwrap sexp))))) + (cond + ((consp sexp) + (or (gethash sexp edebug--unwrap-cache nil) + (let ((remainder sexp) + (current (cons nil nil))) + (prog1 current + (while + (progn + (puthash remainder current edebug--unwrap-cache) + (setf (car current) + (edebug-unwrap* (car remainder))) + (setq remainder (cdr remainder)) + (cond + ((atom remainder) + (setf (cdr current) + (edebug-unwrap* remainder)) + nil) + ((gethash remainder edebug--unwrap-cache nil) + (setf (cdr current) (gethash remainder edebug--unwrap-cache nil)) + nil) + (t (setq current + (setf (cdr current) (cons nil nil))))))))))) + ((byte-code-function-p sexp) + (apply #'make-byte-code + (aref sexp 0) (aref sexp 1) + (vconcat (mapcar #'edebug-unwrap* (aref sexp 2))) + (nthcdr 3 (append sexp ())))) + (t sexp))) (defun edebug-defining-form (cursor form-begin form-end speclist) @@ -1729,7 +1728,7 @@ contains a circular object." (defun edebug-match-form (cursor) (list (edebug-form cursor))) -(defalias 'edebug-match-place 'edebug-match-form) +(defalias 'edebug-match-place #'edebug-match-form) ;; Currently identical to edebug-match-form. ;; This is for common lisp setf-style place arguments. @@ -2277,12 +2276,7 @@ only be active while Edebug is. It checks `debug-on-error' to see whether it should call the debugger. When execution is resumed, the error is signaled again." (if (and (listp debug-on-error) (memq signal-name debug-on-error)) - (edebug 'error (cons signal-name signal-data))) - ;; If we reach here without another non-local exit, then send signal again. - ;; i.e. the signal is not continuable, yet. - ;; Avoid infinite recursion. - (let ((signal-hook-function nil)) - (signal signal-name signal-data))) + (edebug 'error (cons signal-name signal-data)))) ;;; Entering Edebug @@ -2326,6 +2320,12 @@ and run its entry function, and set up `edebug-before' and (debug-on-error (or debug-on-error edebug-on-error)) (debug-on-quit edebug-on-quit)) (unwind-protect + ;; FIXME: We could replace this `signal-hook-function' with + ;; a cleaner `handler-bind' but then we wouldn't be able to + ;; install it here (i.e. once and for all when entering + ;; an Edebugged function), but instead it would have to + ;; be installed into a modified `edebug-after' which wraps + ;; the `handler-bind' around its argument(s). :-( (let ((signal-hook-function #'edebug-signal)) (setq edebug-execution-mode (or edebug-next-execution-mode edebug-initial-mode @@ -3348,7 +3348,7 @@ With prefix argument, make it a temporary breakpoint." (message "%s" msg))) -(defalias 'edebug-step-through-mode 'edebug-step-mode) +(defalias 'edebug-step-through-mode #'edebug-step-mode) (defun edebug-step-mode () "Proceed to next stop point." @@ -3836,12 +3836,12 @@ be installed in `emacs-lisp-mode-map'.") ;; Global GUD bindings for all emacs-lisp-mode buffers. (unless edebug-inhibit-emacs-lisp-mode-bindings - (define-key emacs-lisp-mode-map "\C-x\C-a\C-s" 'edebug-step-mode) - (define-key emacs-lisp-mode-map "\C-x\C-a\C-n" 'edebug-next-mode) - (define-key emacs-lisp-mode-map "\C-x\C-a\C-c" 'edebug-go-mode) - (define-key emacs-lisp-mode-map "\C-x\C-a\C-l" 'edebug-where) + (define-key emacs-lisp-mode-map "\C-x\C-a\C-s" #'edebug-step-mode) + (define-key emacs-lisp-mode-map "\C-x\C-a\C-n" #'edebug-next-mode) + (define-key emacs-lisp-mode-map "\C-x\C-a\C-c" #'edebug-go-mode) + (define-key emacs-lisp-mode-map "\C-x\C-a\C-l" #'edebug-where) ;; The following isn't a GUD binding. - (define-key emacs-lisp-mode-map "\C-x\C-a\C-m" 'edebug-set-initial-mode)) + (define-key emacs-lisp-mode-map "\C-x\C-a\C-m" #'edebug-set-initial-mode)) (defvar-keymap edebug-mode-map :parent emacs-lisp-mode-map @@ -4234,13 +4234,13 @@ Remove frames for Edebug's functions and the lambdas in and after-index fields in both FRAMES and the returned list of deinstrumented frames, for those frames where the source code location is known." - (let (skip-next-lambda def-name before-index after-index results - (index (length frames))) + (let ((index (length frames)) + skip-next-lambda def-name before-index after-index results) (dolist (frame (reverse frames)) (let ((new-frame (copy-edebug--frame frame)) (fun (edebug--frame-fun frame)) (args (edebug--frame-args frame))) - (cl-decf index) + (cl-decf index) ;; FIXME: Not used? (pcase fun ('edebug-enter (setq skip-next-lambda t @@ -4250,38 +4250,46 @@ code location is known." (nth 1 (nth 0 args)) (nth 0 args)) after-index (nth 1 args))) - ((pred edebug--symbol-not-prefixed-p) - (edebug--unwrap-frame new-frame) - (edebug--add-source-info new-frame def-name before-index after-index) - (edebug--add-source-info frame def-name before-index after-index) - (push new-frame results) - (setq before-index nil - after-index nil)) - (`(,(or 'lambda 'closure) . ,_) + ;; Just skip all our own frames. + ((pred edebug--symbol-prefixed-p) nil) + (_ + (when (and skip-next-lambda + (not (memq (car-safe fun) '(closure lambda)))) + (warn "Edebug--strip-instrumentation expected an interpreted function:\n%S" fun)) (unless skip-next-lambda (edebug--unwrap-frame new-frame) - (edebug--add-source-info frame def-name before-index after-index) (edebug--add-source-info new-frame def-name before-index after-index) + (edebug--add-source-info frame def-name before-index after-index) (push new-frame results)) - (setq before-index nil + (setq before-index nil after-index nil skip-next-lambda nil))))) results)) -(defun edebug--symbol-not-prefixed-p (sym) - "Return non-nil if SYM is a symbol not prefixed by \"edebug-\"." +(defun edebug--symbol-prefixed-p (sym) + "Return non-nil if SYM is a symbol prefixed by \"edebug-\"." (and (symbolp sym) - (not (string-prefix-p "edebug-" (symbol-name sym))))) + (string-prefix-p "edebug-" (symbol-name sym)))) (defun edebug--unwrap-frame (frame) "Remove Edebug's instrumentation from FRAME. Strip it from the function and any unevaluated arguments." - (setf (edebug--frame-fun frame) (edebug-unwrap* (edebug--frame-fun frame))) - (unless (edebug--frame-evald frame) - (let (results) - (dolist (arg (edebug--frame-args frame)) - (push (edebug-unwrap* arg) results)) - (setf (edebug--frame-args frame) (nreverse results))))) + (cl-callf edebug-unwrap* (edebug--frame-fun frame)) + ;; We used to try to be careful to apply `edebug-unwrap' only to source + ;; expressions and not to values, so we did not apply unwrap to the arguments + ;; of the frame if they had already been evaluated. + ;; But this was not careful enough since `edebug-unwrap*' gleefully traverses + ;; its argument without paying attention to its syntactic structure so it + ;; also "mistakenly" descends into the values contained within the "source + ;; code". In practice this *very* rarely leads to undesired results. + ;; On the contrary, it's often useful to descend into values because they + ;; may contain interpreted closures and hence source code where we *do* + ;; want to apply `edebug-unwrap'. + ;; So based on this experience, we now also apply `edebug-unwrap*' to + ;; the already evaluated arguments. + ;;(unless (edebug--frame-evald frame) + (cl-callf (lambda (xs) (mapcar #'edebug-unwrap* xs)) + (edebug--frame-args frame))) (defun edebug--add-source-info (frame def-name before-index after-index) "Update FRAME with the additional info needed by an edebug--frame. diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index 9c526f67204..cf8bd749f2a 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -191,7 +191,7 @@ Abstract classes cannot be instantiated." ;; We autoload this because it's used in `make-autoload'. ;;;###autoload -(defun eieio-defclass-autoload (cname _superclasses filename doc) +(defun eieio-defclass-autoload (cname superclasses filename doc) "Create autoload symbols for the EIEIO class CNAME. SUPERCLASSES are the superclasses that CNAME inherits from. DOC is the docstring for CNAME. @@ -199,15 +199,9 @@ This function creates a mock-class for CNAME and adds it into SUPERCLASSES as children. It creates an autoload function for CNAME's constructor." ;; Assume we've already debugged inputs. - - ;; We used to store the list of superclasses in the `parent' slot (as a list - ;; of class names). But now this slot holds a list of class objects, and - ;; those parents may not exist yet, so the corresponding class objects may - ;; simply not exist yet. So instead we just don't store the list of parents - ;; here in eieio-defclass-autoload at all, since it seems that they're just - ;; not needed before the class is actually loaded. (let* ((oldc (cl--find-class cname)) - (newc (eieio--class-make cname))) + (newc (eieio--class-make cname)) + (parents (mapcar #'cl-find-class superclasses))) (if (eieio--class-p oldc) nil ;; Do nothing if we already have this class. @@ -218,6 +212,12 @@ It creates an autoload function for CNAME's constructor." use '%s or turn off `eieio-backward-compatibility' instead" cname) "25.1")) + (when (memq nil parents) + ;; If some parents aren't yet fully defined, just ignore them for now. + (setq parents (delq nil parents))) + (unless parents + (setq parents (list (cl--find-class 'eieio-default-superclass)))) + (setf (cl--class-parents newc) parents) (setf (cl--find-class cname) newc) ;; Create an autoload on top of our constructor function. @@ -293,8 +293,7 @@ See `defclass' for more information." ;; reloading the file that does the `defclass', we don't ;; want to create a new class object. (eieio--class-make cname))) - (groups nil) ;; list of groups id'd from slots - (clearparent nil)) + (groups nil)) ;; list of groups id'd from slots ;; If this class already existed, and we are updating its structure, ;; make sure we keep the old child list. This can cause bugs, but @@ -317,6 +316,9 @@ See `defclass' for more information." (setf (eieio--class-children newc) children) (remhash cname eieio-defclass-autoload-map)))) + (unless (or superclasses (eq cname 'eieio-default-superclass)) + (setq superclasses '(eieio-default-superclass))) + (if superclasses (progn (dolist (p superclasses) @@ -336,16 +338,13 @@ See `defclass' for more information." (push c (eieio--class-parents newc)))))) ;; Reverse the list of our parents so that they are prioritized in ;; the same order as specified in the code. - (cl-callf nreverse (eieio--class-parents newc))) - ;; If there is nothing to loop over, then inherit from the - ;; default superclass. - (unless (eq cname 'eieio-default-superclass) - ;; adopt the default parent here, but clear it later... - (setq clearparent t) - ;; save new child in parent - (cl-pushnew cname (eieio--class-children eieio-default-superclass)) - ;; save parent in child - (setf (eieio--class-parents newc) (list eieio-default-superclass)))) + (cl-callf nreverse (eieio--class-parents newc)) + ;; Before adding new slots, let's add all the methods and classes + ;; in from the parent class. + (eieio-copy-parents-into-subclass newc)) + + (cl-assert (eq cname 'eieio-default-superclass)) + (setf (eieio--class-parents newc) (list (cl--find-class 'record)))) ;; turn this into a usable self-pointing symbol; FIXME: Why? (when eieio-backward-compatibility @@ -376,10 +375,6 @@ See `defclass' for more information." cname) "25.1"))) - ;; Before adding new slots, let's add all the methods and classes - ;; in from the parent class. - (eieio-copy-parents-into-subclass newc) - ;; Store the new class vector definition into the symbol. We need to ;; do this first so that we can call defmethod for the accessor. ;; The vector will be updated by the following while loop and will not @@ -512,10 +507,6 @@ See `defclass' for more information." ;; Set up the options we have collected. (setf (eieio--class-options newc) options) - ;; if this is a superclass, clear out parent (which was set to the - ;; default superclass eieio-default-superclass) - (if clearparent (setf (eieio--class-parents newc) nil)) - ;; Create the cached default object. (let ((cache (make-record newc (+ (length (eieio--class-slots newc)) @@ -967,19 +958,13 @@ need be... May remove that later...)" (cdr tuple) nil))) -(defsubst eieio--class/struct-parents (class) - (or (eieio--class-parents class) - `(,eieio-default-superclass))) - (defun eieio--class-precedence-c3 (class) "Return all parents of CLASS in c3 order." - (let ((parents (eieio--class-parents class))) + (let ((parents (cl--class-parents class))) (cons class (merge-ordered-lists (append - (or - (mapcar #'eieio--class-precedence-c3 parents) - `((,eieio-default-superclass))) + (mapcar #'eieio--class-precedence-c3 parents) (list parents)) (lambda (remaining-inputs) (signal 'inconsistent-class-hierarchy @@ -989,17 +974,15 @@ need be... May remove that later...)" (defun eieio--class-precedence-dfs (class) "Return all parents of CLASS in depth-first order." - (let* ((parents (eieio--class-parents class)) + (let* ((parents (cl--class-parents class)) (classes (copy-sequence (apply #'append (list class) - (or - (mapcar - (lambda (parent) - (cons parent - (eieio--class-precedence-dfs parent))) - parents) - `((,eieio-default-superclass)))))) + (mapcar + (lambda (parent) + (cons parent + (eieio--class-precedence-dfs parent))) + parents)))) (tail classes)) ;; Remove duplicates. (while tail @@ -1012,13 +995,12 @@ need be... May remove that later...)" (defun eieio--class-precedence-bfs (class) "Return all parents of CLASS in breadth-first order." (let* ((result) - (queue (eieio--class/struct-parents class))) + (queue (cl--class-parents class))) (while queue (let ((head (pop queue))) (unless (member head result) (push head result) - (unless (eq head eieio-default-superclass) - (setq queue (append queue (eieio--class/struct-parents head))))))) + (setq queue (append queue (cl--class-parents head)))))) (cons class (nreverse result))) ) @@ -1058,6 +1040,14 @@ method invocation orders of the involved classes." ;;;; General support to dispatch based on the type of the argument. +;; FIXME: We could almost use the typeof-generalizer (i.e. the same as +;; used for cl-structs), except that that generalizer doesn't support +;; `:method-invocation-order' :-( + +(defun cl--generic-struct-tag (name &rest _) + ;; Use exactly the same code as for `typeof'. + `(cl-type-of ,name)) + (cl-generic-define-generalizer eieio--generic-generalizer ;; Use the exact same tagcode as for cl-struct, so that methods ;; that dispatch on both kinds of objects get to share this @@ -1066,8 +1056,7 @@ method invocation orders of the involved classes." (lambda (tag &rest _) (let ((class (cl--find-class tag))) (and (eieio--class-p class) - (mapcar #'eieio--class-name - (eieio--class-precedence-list class)))))) + (cl--class-allparents class))))) (cl-defmethod cl-generic-generalizers :extra "class" (specializer) "Support for dispatch on types defined by EIEIO's `defclass'." @@ -1089,10 +1078,11 @@ method invocation orders of the involved classes." ;; Instead, we add a new "subclass" specializer. (defun eieio--generic-subclass-specializers (tag &rest _) - (when (eieio--class-p tag) - (mapcar (lambda (class) - `(subclass ,(eieio--class-name class))) - (eieio--class-precedence-list tag)))) + (when (cl--class-p tag) + (when (eieio--class-p tag) + (setq tag (eieio--full-class-object tag))) ;Autoload, if applicable. + (mapcar (lambda (class) `(subclass ,class)) + (cl--class-allparents tag)))) (cl-generic-define-generalizer eieio--generic-subclass-generalizer 60 (lambda (name &rest _) `(and (symbolp ,name) (cl--find-class ,name))) diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index 893f8cd7e7f..bf6be1690e4 100644 --- a/lisp/emacs-lisp/eieio-opt.el +++ b/lisp/emacs-lisp/eieio-opt.el @@ -50,7 +50,7 @@ variable `eieio-default-superclass'." (if (not root-class) (setq root-class 'eieio-default-superclass)) (cl-check-type root-class class) (display-buffer (get-buffer-create "*EIEIO OBJECT BROWSE*") t) - (with-current-buffer (get-buffer "*EIEIO OBJECT BROWSE*") + (with-current-buffer "*EIEIO OBJECT BROWSE*" (erase-buffer) (goto-char 0) (eieio-browse-tree root-class "" "") diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index df85a64baf3..74f5e21db7d 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -387,9 +387,9 @@ contents of field NAME is matched against PAT, or they can be of ,@(mapcar (lambda (field) (pcase-exhaustive field (`(,name ,pat) - `(app (pcase--flip eieio-oref ',name) ,pat)) + `(app (eieio-oref _ ',name) ,pat)) ((pred symbolp) - `(app (pcase--flip eieio-oref ',field) ,field)))) + `(app (eieio-oref _ ',field) ,field)))) fields))) ;;; Simple generators, and query functions. None of these would do @@ -449,7 +449,12 @@ If EXTRA, include that in the string returned to represent the symbol." (defun eieio-class-parents (class) ;; FIXME: What does "(overload of variable)" mean here? "Return parent classes to CLASS. (overload of variable)." - (eieio--class-parents (eieio--full-class-object class))) + ;; (declare (obsolete cl--class-parents "30.1")) + (let ((parents (eieio--class-parents (eieio--full-class-object class)))) + (if (and (null (cdr parents)) + (eq (car parents) (cl--find-class 'eieio-default-superclass))) + nil + parents))) (define-obsolete-function-alias 'class-parents #'eieio-class-parents "24.4") @@ -497,7 +502,7 @@ If EXTRA, include that in the string returned to represent the symbol." (setq class (eieio--class-object class)) (cl-check-type class eieio--class) (while (and child (not (eq child class))) - (setq p (append p (eieio--class-parents child)) + (setq p (append p (cl--class-parents child)) child (pop p))) (if child t)))) @@ -680,8 +685,7 @@ If SLOT is unbound, do nothing." (defclass eieio-default-superclass nil nil "Default parent class for classes with no specified parent class. -Its slots are automatically adopted by classes with no specified parents. -This class is not stored in the `parent' slot of a class vector." +Its slots are automatically adopted by classes with no specified parents." :abstract t) (setq eieio-default-superclass (cl--find-class 'eieio-default-superclass)) diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index 06970d40e8a..24afd03fbe6 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -155,7 +155,7 @@ Remember to keep it a prime number to improve hash performance.") (defvar eldoc-message-commands ;; Don't define as `defconst' since it would then go to (read-only) purespace. - (make-vector eldoc-message-commands-table-size 0) + (obarray-make eldoc-message-commands-table-size) "Commands after which it is appropriate to print in the echo area. ElDoc does not try to print function arglists, etc., after just any command, because some commands print their own messages in the echo area and these @@ -191,7 +191,7 @@ It should receive the same arguments as `message'.") When `eldoc-print-after-edit' is non-nil, ElDoc messages are only printed after commands contained in this obarray." - (let ((cmds (make-vector 31 0)) + (let ((cmds (obarray-make 31)) (re (regexp-opt '("delete" "insert" "edit" "electric" "newline")))) (mapatoms (lambda (s) (and (commandp s) @@ -312,9 +312,11 @@ Otherwise, it displays the message like `message' would." (not (and (listp mode-line-format) (assq 'eldoc-mode-line-string mode-line-format)))) (setq mode-line-format - (list "" '(eldoc-mode-line-string - (" " eldoc-mode-line-string " ")) - mode-line-format))) + (funcall + (if (listp mode-line-format) #'append #'list) + (list "" '(eldoc-mode-line-string + (" " eldoc-mode-line-string " "))) + mode-line-format))) (setq eldoc-mode-line-string (when (stringp format-string) (apply #'format-message format-string args))) diff --git a/lisp/emacs-lisp/elint.el b/lisp/emacs-lisp/elint.el index a8bc4bdd1e0..27c169cc657 100644 --- a/lisp/emacs-lisp/elint.el +++ b/lisp/emacs-lisp/elint.el @@ -266,6 +266,7 @@ This environment can be passed to `macroexpand'." (insert-file-contents file) (let ((buffer-file-name file) (max-lisp-eval-depth (max 1000 max-lisp-eval-depth))) + (hack-local-variables) (with-syntax-table emacs-lisp-mode-syntax-table (mapc 'elint-top-form (elint-update-env))))) (elint-set-mode-line) diff --git a/lisp/emacs-lisp/ert-font-lock.el b/lisp/emacs-lisp/ert-font-lock.el index 29114712f92..e77c8945dc3 100644 --- a/lisp/emacs-lisp/ert-font-lock.el +++ b/lisp/emacs-lisp/ert-font-lock.el @@ -39,16 +39,33 @@ (require 'newcomment) (require 'pcase) -(defconst ert-font-lock--assertion-re +(defconst ert-font-lock--face-symbol-re + (rx (one-or-more (or alphanumeric "-" "_" "."))) + "A face symbol matching regex.") + +(defconst ert-font-lock--face-symbol-list-re + (rx "(" + (* whitespace) + (one-or-more + (seq (regexp ert-font-lock--face-symbol-re) + (* whitespace))) + ")") + "A face symbol list matching regex.") + +(defconst ert-font-lock--assertion-line-re (rx - ;; column specifiers + ;; leading column assertion (arrow/caret) (group (or "^" "<-")) - (one-or-more " ") + (zero-or-more whitespace) + ;; possible to have many carets on an assertion line + (group (zero-or-more (seq "^" (zero-or-more whitespace)))) ;; optional negation of the face specification (group (optional "!")) - ;; face symbol name - (group (one-or-more (or alphanumeric "-" "_" ".")))) - "An ert-font-lock assertion regex.") + (zero-or-more whitespace) + ;; face symbol name or a list of symbols + (group (or (regexp ert-font-lock--face-symbol-re) + (regexp ert-font-lock--face-symbol-list-re)))) + "An ert-font-lock assertion line regex.") (defun ert-font-lock--validate-major-mode (mode) "Validate if MODE is a valid major mode." @@ -212,7 +229,7 @@ be used through `ert'. (save-excursion (beginning-of-line) (skip-syntax-forward " ") - (re-search-forward ert-font-lock--assertion-re + (re-search-forward ert-font-lock--assertion-line-re (line-end-position) t 1))) (defun ert-font-lock--goto-first-char () @@ -252,8 +269,8 @@ be used through `ert'. (throw 'nextline t)) - ;; Collect the assertion - (when (re-search-forward ert-font-lock--assertion-re + ;; Collect the first line assertion (caret or arrow) + (when (re-search-forward ert-font-lock--assertion-line-re (line-end-position) t 1) (unless (> linetocheck -1) @@ -266,21 +283,38 @@ be used through `ert'. (- (match-beginning 1) (line-beginning-position)) (ert-font-lock--get-first-char-column))) ;; negate the face? - (negation (string-equal (match-string-no-properties 2) "!")) + (negation (string-equal (match-string-no-properties 3) "!")) ;; the face that is supposed to be in the position specified - (face (match-string-no-properties 3))) + (face (read (match-string-no-properties 4)))) + ;; Collect the first assertion on the line (push (list :line-checked linetocheck :line-assert curline :column-checked column-checked :face face :negation negation) - tests)))) + tests) + + ;; Collect all the other line carets (if present) + (goto-char (match-beginning 2)) + (while (equal (following-char) ?^) + (setq column-checked (- (point) (line-beginning-position))) + (push (list :line-checked linetocheck + :line-assert curline + :column-checked column-checked + :face face + :negation negation) + tests) + (forward-char) + (skip-syntax-forward " "))))) ;; next line (setq curline (1+ curline)) (forward-line 1)) + (unless tests + (user-error "No test assertions found")) + (reverse tests))) (defun ert-font-lock--point-at-line-and-column (line column) @@ -307,21 +341,30 @@ The function is meant to be run from within an ERT test." (let* ((line-checked (plist-get test :line-checked)) (line-assert (plist-get test :line-assert)) (column-checked (plist-get test :column-checked)) - (expected-face (intern (plist-get test :face))) + (expected-face (plist-get test :face)) (negation (plist-get test :negation)) (actual-face (get-text-property (ert-font-lock--point-at-line-and-column line-checked column-checked) 'face)) (line-str (ert-font-lock--get-line line-checked)) (line-assert-str (ert-font-lock--get-line line-assert))) - (when (not (eq actual-face expected-face)) + ;; normalize both expected and resulting face - these can be + ;; either symbols, nils or lists of symbols + (when (not (listp actual-face)) + (setq actual-face (list actual-face))) + (when (not (listp expected-face)) + (setq expected-face (list expected-face))) + + ;; fail when lists are not 'equal and the assertion is *not negated* + (when (and (not negation) (not (equal actual-face expected-face))) (ert-fail (list (format "Expected face %S, got %S on line %d column %d" expected-face actual-face line-checked column-checked) :line line-str :assert line-assert-str))) - (when (and negation (eq actual-face expected-face)) + ;; fail when lists are 'equal and the assertion is *negated* + (when (and negation (equal actual-face expected-face)) (ert-fail (list (format "Did not expect face %S face on line %d, column %d" actual-face line-checked column-checked) diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el index 05da0f1844e..cd60f9f457f 100644 --- a/lisp/emacs-lisp/ert-x.el +++ b/lisp/emacs-lisp/ert-x.el @@ -540,10 +540,10 @@ The same keyword arguments are supported as in (when (and (featurep 'tramp) (getenv "EMACS_HYDRA_CI")) (add-to-list 'tramp-remote-path 'tramp-own-remote-path)) -;; If this defconst is used in a test file, `tramp' shall be loaded +;; If this defvar is used in a test file, `tramp' shall be loaded ;; prior `ert-x'. There is no default value on w32 systems, which ;; could work out of the box. -(defconst ert-remote-temporary-file-directory +(defvar ert-remote-temporary-file-directory (when (featurep 'tramp) (cond ((getenv "REMOTE_TEMPORARY_FILE_DIRECTORY")) diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index 353c1bd09d2..8ab57d2b238 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -278,14 +278,6 @@ DATA is displayed to the user and should state the reason for skipping." (when ert--should-execution-observer (funcall ert--should-execution-observer form-description))) -;; See Bug#24402 for why this exists -(defun ert--should-signal-hook (error-symbol data) - "Stupid hack to stop `condition-case' from catching ert signals. -It should only be stopped when ran from inside `ert--run-test-internal'." - (when (and (not (symbolp debugger)) ; only run on anonymous debugger - (memq error-symbol '(ert-test-failed ert-test-skipped))) - (funcall debugger 'error (cons error-symbol data)))) - (defun ert--special-operator-p (thing) "Return non-nil if THING is a symbol naming a special operator." (and (symbolp thing) @@ -324,8 +316,7 @@ It should only be stopped when ran from inside `ert--run-test-internal'." (default-value (gensym "ert-form-evaluation-aborted-"))) `(let* ((,fn (function ,fn-name)) (,args (condition-case err - (let ((signal-hook-function #'ert--should-signal-hook)) - (list ,@arg-forms)) + (list ,@arg-forms) (error (progn (setq ,fn #'signal) (list (car err) (cdr err))))))) @@ -728,78 +719,68 @@ in front of the value of MESSAGE-FORM." ;; value and test execution should be terminated. Should not ;; return. (exit-continuation (cl-assert nil)) - ;; The binding of `debugger' outside of the execution of the test. - next-debugger ;; The binding of `ert-debug-on-error' that is in effect for the ;; execution of the current test. We store it to avoid being ;; affected by any new bindings the test itself may establish. (I ;; don't remember whether this feature is important.) ert-debug-on-error) -(defun ert--run-test-debugger (info args) - "During a test run, `debugger' is bound to a closure that calls this function. +(defun ert--run-test-debugger (info condition debugfun) + "Error handler used during the test run. This function records failures and errors and either terminates the test silently or calls the interactive debugger, as appropriate. -INFO is the ert--test-execution-info corresponding to this test -run. ARGS are the arguments to `debugger'." - (cl-destructuring-bind (first-debugger-arg &rest more-debugger-args) - args - (cl-ecase first-debugger-arg - ((lambda debug t exit nil) - (apply (ert--test-execution-info-next-debugger info) args)) - (error - (let* ((condition (car more-debugger-args)) - (type (cl-case (car condition) - ((quit) 'quit) - ((ert-test-skipped) 'skipped) - (otherwise 'failed))) - ;; We store the backtrace in the result object for - ;; `ert-results-pop-to-backtrace-for-test-at-point'. - ;; This means we have to limit `print-level' and - ;; `print-length' when printing result objects. That - ;; might not be worth while when we can also use - ;; `ert-results-rerun-test-at-point-debugging-errors', - ;; (i.e., when running interactively) but having the - ;; backtrace ready for printing is important for batch - ;; use. - ;; - ;; Grab the frames above the debugger. - (backtrace (cdr (backtrace-get-frames debugger))) - (infos (reverse ert--infos))) - (setf (ert--test-execution-info-result info) - (cl-ecase type - (quit - (make-ert-test-quit :condition condition - :backtrace backtrace - :infos infos)) - (skipped - (make-ert-test-skipped :condition condition - :backtrace backtrace - :infos infos)) - (failed - (make-ert-test-failed :condition condition - :backtrace backtrace - :infos infos)))) - ;; Work around Emacs's heuristic (in eval.c) for detecting - ;; errors in the debugger. - (cl-incf num-nonmacro-input-events) - ;; FIXME: We should probably implement more fine-grained - ;; control a la non-t `debug-on-error' here. - (cond - ((ert--test-execution-info-ert-debug-on-error info) - (apply (ert--test-execution-info-next-debugger info) args)) - (t)) - (funcall (ert--test-execution-info-exit-continuation info))))))) +INFO is the `ert--test-execution-info' corresponding to this test run. +ERR is the error object." + (let* ((type (cl-case (car condition) + ((quit) 'quit) + ((ert-test-skipped) 'skipped) + (otherwise 'failed))) + ;; We store the backtrace in the result object for + ;; `ert-results-pop-to-backtrace-for-test-at-point'. + ;; This means we have to limit `print-level' and + ;; `print-length' when printing result objects. That + ;; might not be worth while when we can also use + ;; `ert-results-rerun-test-at-point-debugging-errors', + ;; (i.e., when running interactively) but having the + ;; backtrace ready for printing is important for batch + ;; use. + ;; + ;; Grab the frames above ourselves. + (backtrace (cdr (backtrace-get-frames debugfun))) + (infos (reverse ert--infos))) + (setf (ert--test-execution-info-result info) + (cl-ecase type + (quit + (make-ert-test-quit :condition condition + :backtrace backtrace + :infos infos)) + (skipped + (make-ert-test-skipped :condition condition + :backtrace backtrace + :infos infos)) + (failed + (make-ert-test-failed :condition condition + :backtrace backtrace + :infos infos)))) + ;; FIXME: We should probably implement more fine-grained + ;; control a la non-t `debug-on-error' here. + (cond + ((ert--test-execution-info-ert-debug-on-error info) + ;; The `debugfun' arg tells `debug' which backtrace frame starts + ;; the "entering the debugger" code so it can hide those frames + ;; from the backtrace. + (funcall debugger 'error condition :backtrace-base debugfun)) + (t)) + (funcall (ert--test-execution-info-exit-continuation info)))) (defun ert--run-test-internal (test-execution-info) "Low-level function to run a test according to TEST-EXECUTION-INFO. This mainly sets up debugger-related bindings." - (setf (ert--test-execution-info-next-debugger test-execution-info) debugger - (ert--test-execution-info-ert-debug-on-error test-execution-info) + (setf (ert--test-execution-info-ert-debug-on-error test-execution-info) ert-debug-on-error) (catch 'ert--pass ;; For now, each test gets its own temp buffer and its own @@ -807,26 +788,14 @@ This mainly sets up debugger-related bindings." ;; too expensive, we can remove it. (with-temp-buffer (save-window-excursion - ;; FIXME: Use `signal-hook-function' instead of `debugger' to - ;; handle ert errors. Once that's done, remove - ;; `ert--should-signal-hook'. See Bug#24402 and Bug#11218 for - ;; details. - (let ((lexical-binding t) - (debugger (lambda (&rest args) - (ert--run-test-debugger test-execution-info - args))) - (debug-on-error t) - ;; Don't infloop if the error being called is erroring - ;; out, and we have `debug-on-error' bound to nil inside - ;; the test. - (backtrace-on-error-noninteractive nil) - (debug-on-quit t) - ;; FIXME: Do we need to store the old binding of this - ;; and consider it in `ert--run-test-debugger'? - (debug-ignored-errors nil) + (let ((lexical-binding t) ;;FIXME: Why? (ert--infos '())) - (funcall (ert-test-body (ert--test-execution-info-test - test-execution-info)))))) + (letrec ((debugfun (lambda (err) + (ert--run-test-debugger test-execution-info + err debugfun)))) + (handler-bind (((error quit) debugfun)) + (funcall (ert-test-body (ert--test-execution-info-test + test-execution-info)))))))) (ert-pass)) (setf (ert--test-execution-info-result test-execution-info) (make-ert-test-passed)) diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index 63f547ebeb8..411602ef166 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -60,6 +60,7 @@ ine\\(?:-global\\)?-minor-mode\\|ine-compilation-mode\\|un-cvs-mode\\|\ foo\\|\\(?:[^icfgv]\\|g[^r]\\)\\(\\w\\|\\s_\\)+\\*?\\)\\|easy-mmode-define-[a-z-]+\\|easy-menu-define\\|\ cl-\\(?:defun\\|defmethod\\|defgeneric\\)\\|\ +transient-define-\\(?:prefix\\|suffix\\|infix\\|argument\\)\\|\ menu-bar-make-toggle\\|menu-bar-make-toggle-command\\)" find-function-space-re "\\('\\|(quote \\)?%s\\(\\s-\\|$\\|[()]\\)") diff --git a/lisp/emacs-lisp/icons.el b/lisp/emacs-lisp/icons.el index a35a00ec1f3..f9591661688 100644 --- a/lisp/emacs-lisp/icons.el +++ b/lisp/emacs-lisp/icons.el @@ -164,7 +164,7 @@ If OBJECT is an icon, return the icon properties." (defun icon-elements (name) "Return the elements of icon NAME. The elements are represented as a plist where the keys are -`string', `face' and `display'. The `image' element is only +`string', `face' and `image'. The `image' element is only present if the icon is represented by an image." (let ((string (icon-string name))) (list 'face (get-text-property 0 'face string) @@ -187,11 +187,13 @@ present if the icon is represented by an image." merged) (cl-defmethod icons--create ((_type (eql 'image)) icon keywords) - (let ((file (if (file-name-absolute-p icon) - icon - (and (fboundp 'image-search-load-path) - (image-search-load-path icon))))) - (and (display-images-p) + (let* ((file (if (file-name-absolute-p icon) + icon + (and (fboundp 'image-search-load-path) + (image-search-load-path icon)))) + (file-exists (and (stringp file) (file-readable-p file)))) + (and file-exists + (display-images-p) (fboundp 'image-supported-file-p) (image-supported-file-p file) (propertize diff --git a/lisp/emacs-lisp/inline.el b/lisp/emacs-lisp/inline.el index c774296084e..ddbd6fdc017 100644 --- a/lisp/emacs-lisp/inline.el +++ b/lisp/emacs-lisp/inline.el @@ -80,7 +80,9 @@ (error "inline-const-p can only be used within define-inline")) (defmacro inline-const-val (_exp) - "Return the value of EXP." + "Return the value of EXP. +During inlining, if the value of EXP is not yet known, this aborts the +inlining and makes us revert to a non-inlined function call." (declare (debug t)) (error "inline-const-val can only be used within define-inline")) diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 1bb9c2fdc2e..3475d944337 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -343,7 +343,7 @@ This will generate compile-time constants from BINDINGS." (lisp-vdefs '("defvar")) (lisp-kw '("cond" "if" "while" "let" "let*" "progn" "prog1" "prog2" "lambda" "unwind-protect" "condition-case" - "when" "unless" "with-output-to-string" + "when" "unless" "with-output-to-string" "handler-bind" "ignore-errors" "dotimes" "dolist" "declare")) (lisp-errs '("warn" "error" "signal")) ;; Elisp constructs. Now they are update dynamically @@ -376,7 +376,7 @@ This will generate compile-time constants from BINDINGS." (cl-kw '("block" "break" "case" "ccase" "compiler-let" "ctypecase" "declaim" "destructuring-bind" "do" "do*" "ecase" "etypecase" "eval-when" "flet" "flet*" - "go" "handler-case" "handler-bind" "in-package" ;; "inline" + "go" "handler-case" "in-package" ;; "inline" "labels" "letf" "locally" "loop" "macrolet" "multiple-value-bind" "multiple-value-prog1" "proclaim" "prog" "prog*" "progv" @@ -1346,9 +1346,7 @@ Lisp function does not specify a special indentation." (put 'catch 'lisp-indent-function 1) (put 'condition-case 'lisp-indent-function 2) (put 'handler-case 'lisp-indent-function 1) ;CL -(put 'handler-bind 'lisp-indent-function 1) ;CL (put 'unwind-protect 'lisp-indent-function 1) -(put 'with-output-to-temp-buffer 'lisp-indent-function 1) (put 'closure 'lisp-indent-function 2) (defun indent-sexp (&optional endpos) @@ -1421,14 +1419,15 @@ A prefix argument specifies pretty-printing." ;;;; Lisp paragraph filling commands. -(defcustom emacs-lisp-docstring-fill-column 65 +(defcustom emacs-lisp-docstring-fill-column 72 "Value of `fill-column' to use when filling a docstring. Any non-integer value means do not use a different value of `fill-column' when filling docstrings." :type '(choice (integer) (const :tag "Use the current `fill-column'" t)) :safe (lambda (x) (or (eq x t) (integerp x))) - :group 'lisp) + :group 'lisp + :version "30.1") (defun lisp-fill-paragraph (&optional justify) "Like \\[fill-paragraph], but handle Emacs Lisp comments and docstrings. diff --git a/lisp/emacs-lisp/loaddefs-gen.el b/lisp/emacs-lisp/loaddefs-gen.el index 5f152d3b509..581053f6304 100644 --- a/lisp/emacs-lisp/loaddefs-gen.el +++ b/lisp/emacs-lisp/loaddefs-gen.el @@ -183,7 +183,9 @@ expression, in which case we want to handle forms differently." (loaddefs-generate--shorten-autoload `(autoload ,(nth 1 form) ,file ,doc ,interactive ,type)))) - ((and expansion (memq car '(progn prog1))) + ;; Look inside `progn', and `eval-and-compile', since these + ;; are often used in the expansion of things like `pcase-defmacro'. + ((and expansion (memq car '(progn prog1 eval-and-compile))) (let ((end (memq :autoload-end form))) (when end ;Cut-off anything after the :autoload-end marker. (setq form (copy-sequence form)) @@ -199,8 +201,7 @@ expression, in which case we want to handle forms differently." define-globalized-minor-mode defun defmacro easy-mmode-define-minor-mode define-minor-mode define-inline cl-defun cl-defmacro cl-defgeneric - cl-defstruct pcase-defmacro iter-defun cl-iter-defun - transient-define-prefix)) + cl-defstruct pcase-defmacro iter-defun cl-iter-defun)) (macrop car) (setq expand (let ((load-true-file-name file) (load-file-name file)) @@ -216,13 +217,17 @@ expression, in which case we want to handle forms differently." define-globalized-minor-mode easy-mmode-define-minor-mode define-minor-mode cl-defun defun* cl-defmacro defmacro* - define-overloadable-function)) + define-overloadable-function + transient-define-prefix transient-define-suffix + transient-define-infix transient-define-argument)) (let* ((macrop (memq car '(defmacro cl-defmacro defmacro*))) (name (nth 1 form)) (args (pcase car ((or 'defun 'defmacro 'defun* 'defmacro* 'cl-defun 'cl-defmacro - 'define-overloadable-function) + 'define-overloadable-function + 'transient-define-prefix 'transient-define-suffix + 'transient-define-infix 'transient-define-argument) (nth 2 form)) ('define-skeleton '(&optional str arg)) ((or 'define-generic-mode 'define-derived-mode @@ -244,7 +249,11 @@ expression, in which case we want to handle forms differently." define-global-minor-mode define-globalized-minor-mode easy-mmode-define-minor-mode - define-minor-mode)) + define-minor-mode + transient-define-prefix + transient-define-suffix + transient-define-infix + transient-define-argument)) t) (and (eq (car-safe (car body)) 'interactive) ;; List of modes or just t. @@ -378,6 +387,7 @@ don't include." (let ((defs nil) (load-name (loaddefs-generate--file-load-name file main-outfile)) (compute-prefixes t) + read-symbol-shorthands local-outfile inhibit-autoloads) (with-temp-buffer (insert-file-contents file) @@ -399,7 +409,22 @@ don't include." (setq inhibit-autoloads (read (current-buffer))))) (save-excursion (when (re-search-forward "autoload-compute-prefixes: *" nil t) - (setq compute-prefixes (read (current-buffer)))))) + (setq compute-prefixes (read (current-buffer))))) + (save-excursion + ;; Since we're "open-coding", we have to repeat more + ;; complicated logic in `hack-local-variables'. + (when-let ((beg + (re-search-forward "read-symbol-shorthands: *" nil t))) + ;; `read-symbol-shorthands' alist ends with two parens. + (let* ((end (re-search-forward ")[;\n\s]*)")) + (commentless (replace-regexp-in-string + "\n\\s-*;+" "" + (buffer-substring beg end))) + (unsorted-shorthands (car (read-from-string commentless)))) + (setq read-symbol-shorthands + (sort unsorted-shorthands + (lambda (sh1 sh2) + (> (length (car sh1)) (length (car sh2)))))))))) ;; We always return the package version (even for pre-dumped ;; files). @@ -473,27 +498,35 @@ don't include." (when (and autoload-compute-prefixes compute-prefixes) - (when-let ((form (loaddefs-generate--compute-prefixes load-name))) - ;; This output needs to always go in the main loaddefs.el, - ;; regardless of `generated-autoload-file'. - (push (list main-outfile file form) defs))))) + (with-demoted-errors "%S" + (when-let + ((form (loaddefs-generate--compute-prefixes load-name))) + ;; This output needs to always go in the main loaddefs.el, + ;; regardless of `generated-autoload-file'. + (push (list main-outfile file form) defs)))))) defs)) (defun loaddefs-generate--compute-prefixes (load-name) (goto-char (point-min)) - (let ((prefs nil)) + (let ((prefs nil) + (temp-obarray (obarray-make))) ;; Avoid (defvar <foo>) by requiring a trailing space. (while (re-search-forward "^(\\(def[^ \t\n]+\\)[ \t\n]+['(]*\\([^' ()\"\n]+\\)[\n \t]" nil t) (unless (member (match-string 1) autoload-ignored-definitions) - (let ((name (match-string-no-properties 2))) - (when (save-excursion - (goto-char (match-beginning 0)) - (or (bobp) - (progn - (forward-line -1) - (not (looking-at ";;;###autoload"))))) - (push name prefs))))) + (let* ((name (match-string-no-properties 2)) + ;; Consider `read-symbol-shorthands'. + (probe (let ((obarray temp-obarray)) + (car (read-from-string name))))) + (when (symbolp probe) + (setq name (symbol-name probe)) + (when (save-excursion + (goto-char (match-beginning 0)) + (or (bobp) + (progn + (forward-line -1) + (not (looking-at ";;;###autoload"))))) + (push name prefs)))))) (loaddefs-generate--make-prefixes prefs load-name))) (defun loaddefs-generate--rubric (file &optional type feature compile) diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 0e4fd3ea521..b87b749dd76 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -42,14 +42,8 @@ condition-case handling a signaled error.") (defmacro macroexp--with-extended-form-stack (expr &rest body) "Evaluate BODY with EXPR pushed onto `byte-compile-form-stack'." (declare (indent 1)) - ;; FIXME: We really should just be using a simple dynamic let-binding here, - ;; but these explicit push and pop make the extended stack value visible - ;; to error handlers. Remove that need for that! - `(progn - (push ,expr byte-compile-form-stack) - (prog1 - (progn ,@body) - (pop byte-compile-form-stack)))) + `(let ((byte-compile-form-stack (cons ,expr byte-compile-form-stack))) + ,@body)) ;; Bound by the top-level `macroexpand-all', and modified to include any ;; macros defined by `defmacro'. diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el index ffbb29615da..d3d71a36ee4 100644 --- a/lisp/emacs-lisp/map.el +++ b/lisp/emacs-lisp/map.el @@ -608,18 +608,30 @@ This allows using default values for `map-elt', which can't be done using `pcase--flip'. KEY is the key sought in the map. DEFAULT is the default value." + ;; It's obsolete in Emacs>29, but `map.el' is distributed via GNU ELPA + ;; for earlier Emacsen. + (declare (obsolete _ "30.1")) `(map-elt ,map ,key ,default)) (defun map--make-pcase-bindings (args) "Return a list of pcase bindings from ARGS to the elements of a map." - (mapcar (lambda (elt) - (cond ((consp elt) - `(app (map--pcase-map-elt ,(car elt) ,(caddr elt)) - ,(cadr elt))) - ((keywordp elt) - (let ((var (intern (substring (symbol-name elt) 1)))) - `(app (pcase--flip map-elt ,elt) ,var))) - (t `(app (pcase--flip map-elt ',elt) ,elt)))) + (mapcar (if (< emacs-major-version 30) + (lambda (elt) + (cond ((consp elt) + `(app (map--pcase-map-elt ,(car elt) ,(caddr elt)) + ,(cadr elt))) + ((keywordp elt) + (let ((var (intern (substring (symbol-name elt) 1)))) + `(app (pcase--flip map-elt ,elt) ,var))) + (t `(app (pcase--flip map-elt ',elt) ,elt)))) + (lambda (elt) + (cond ((consp elt) + `(app (map-elt _ ,(car elt) ,(caddr elt)) + ,(cadr elt))) + ((keywordp elt) + (let ((var (intern (substring (symbol-name elt) 1)))) + `(app (map-elt _ ,elt) ,var))) + (t `(app (map-elt _ ',elt) ,elt))))) args)) (defun map--make-pcase-patterns (args) diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 0d45b4b95fa..5326c520601 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -189,7 +189,7 @@ DOC is a string where \"FUNCTION\" and \"OLDFUN\" are expected.") if (cl-assert (eq 'interactive (car if))) (let ((form (cadr if))) - (if (macroexp-const-p form) + (if (macroexp-const-p form) ;Common case: a string. if ;; The interactive is expected to be run in the static context ;; that the function captured. @@ -539,6 +539,32 @@ Contrary to `remove-function', this also works when SYMBOL is a macro or an autoload and it preserves `fboundp'. Instead of the actual function to remove, FUNCTION can also be the `name' of the piece of advice." + (interactive + (let* ((pred (lambda (sym) (advice--p (advice--symbol-function sym)))) + (default (when-let* ((f (function-called-at-point)) + ((funcall pred f))) + (symbol-name f))) + (prompt (format-prompt "Remove advice from function" default)) + (symbol (intern (completing-read prompt obarray pred t nil nil default))) + advices) + (advice-mapc (lambda (f p) + (let ((k (or (alist-get 'name p) f))) + (push (cons + ;; "name" (string) and 'name (symbol) are + ;; considered different names so we use + ;; `prin1-to-string' even if the name is + ;; a string to distinguish between these + ;; two cases. + (prin1-to-string k) + ;; We use `k' here instead of `f' because + ;; the same advice can have multiple + ;; names. + k) + advices))) + symbol) + (list symbol (cdr (assoc-string + (completing-read "Advice to remove: " advices nil t) + advices))))) (let ((f (symbol-function symbol))) (remove-function (cond ;This is `advice--symbol-function' but as a "place". ((get symbol 'advice--pending) @@ -559,8 +585,8 @@ of the piece of advice." (defmacro define-advice (symbol args &rest body) "Define an advice and add it to function named SYMBOL. See `advice-add' and `add-function' for explanation on the -arguments. Note if NAME is nil the advice is anonymous; -otherwise it is named `SYMBOL@NAME'. +arguments. If NAME is non-nil, the advice is named `SYMBOL@NAME' +and installed with the name NAME; otherwise, the advice is anonymous. \(fn SYMBOL (HOW LAMBDA-LIST &optional NAME DEPTH) &rest BODY)" (declare (indent 2) (doc-string 3) (debug (sexp sexp def-body))) @@ -571,7 +597,9 @@ otherwise it is named `SYMBOL@NAME'. (lambda-list (nth 1 args)) (name (nth 2 args)) (depth (nth 3 args)) - (props (and depth `((depth . ,depth)))) + (props (append + (and depth `((depth . ,depth))) + (and name `((name . ,name))))) (advice (cond ((null name) `(lambda ,lambda-list ,@body)) ((or (stringp name) (symbolp name)) (intern (format "%s@%s" symbol name))) diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el index 26cd8594dfc..4da8e61aaa7 100644 --- a/lisp/emacs-lisp/oclosure.el +++ b/lisp/emacs-lisp/oclosure.el @@ -139,12 +139,15 @@ (:include cl--class) (:copier nil)) "Metaclass for OClosure classes." + ;; The `allparents' slot is used for the predicate that checks if a given + ;; object is an OClosure of a particular type. (allparents nil :read-only t :type (list-of symbol))) (setf (cl--find-class 'oclosure) (oclosure--class-make 'oclosure - "The root parent of all OClosure classes" - nil nil '(oclosure))) + "The root parent of all OClosure types" + nil (list (cl--find-class 'function)) + '(oclosure))) (defun oclosure--p (oclosure) (not (not (oclosure-type oclosure)))) @@ -434,7 +437,7 @@ This has 2 uses: - For compiled code, this is used as a marker which cconv uses to check that immutable fields are indeed not mutated." (if (byte-code-function-p oclosure) - ;; Actually, this should never happen since the `cconv.el' should have + ;; Actually, this should never happen since `cconv.el' should have ;; optimized away the call to this function. oclosure ;; For byte-coded functions, we store the type as a symbol in the docstring diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index db0cc515e46..ef056c7909b 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -501,8 +501,10 @@ This includes downloading missing dependencies, generating autoloads, generating a package description file (used to identify a package as a VC package later on), building documentation and marking the package as installed." - (let ((pkg-spec (package-vc--desc->spec pkg-desc)) - missing) + (let* ((pkg-spec (package-vc--desc->spec pkg-desc)) + (lisp-dir (plist-get pkg-spec :lisp-dir)) + (lisp-path (file-name-concat pkg-dir lisp-dir)) + missing) ;; In case the package was installed directly from source, the ;; dependency list wasn't know beforehand, and they might have @@ -519,7 +521,7 @@ documentation and marking the package as installed." "\\|") regexp-unmatchable)) (deps '())) - (dolist (file (directory-files pkg-dir t "\\.el\\'" t)) + (dolist (file (directory-files lisp-path t "\\.el\\'" t)) (unless (string-match-p ignored-files file) (with-temp-buffer (insert-file-contents file) @@ -532,6 +534,7 @@ documentation and marking the package as installed." (setq deps)))))) (dolist (dep deps) (cl-callf version-to-list (cadr dep))) + (setf (package-desc-reqs pkg-desc) deps) (setf missing (package-vc-install-dependencies (delete-dups deps))) (setf missing (delq (assq (package-desc-name pkg-desc) missing) @@ -541,10 +544,8 @@ documentation and marking the package as installed." (pkg-file (expand-file-name (package--description-file pkg-dir) pkg-dir))) ;; Generate autoloads (let* ((name (package-desc-name pkg-desc)) - (auto-name (format "%s-autoloads.el" name)) - (lisp-dir (plist-get pkg-spec :lisp-dir))) - (package-generate-autoloads - name (file-name-concat pkg-dir lisp-dir)) + (auto-name (format "%s-autoloads.el" name))) + (package-generate-autoloads name lisp-path) (when lisp-dir (write-region (with-temp-buffer @@ -938,8 +939,8 @@ for the last released version of the package." (interactive (let* ((name (package-vc--read-package-name "Fetch package source: "))) (list (cadr (assoc name package-archive-contents #'string=)) - (read-file-name "Clone into new or empty directory: " nil nil t nil - (lambda (dir) (or (not (file-exists-p dir)) + (read-directory-name "Clone into new or empty directory: " nil nil + (lambda (dir) (or (not (file-exists-p dir)) (directory-empty-p dir)))) (and current-prefix-arg :last-release)))) (package-vc--archives-initialize) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 80f746d7429..3428b2375d7 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -2611,7 +2611,8 @@ This is meant to be used only in the case the byte-compiled files are invalid due to changed byte-code, macros or the like." (interactive) (pcase-dolist (`(_ ,pkg-desc) package-alist) - (package-recompile pkg-desc))) + (with-demoted-errors "Error while recompiling: %S" + (package-recompile pkg-desc)))) ;;;###autoload (defun package-autoremove () @@ -2805,8 +2806,7 @@ Helper function for `describe-package'." (status (if desc (package-desc-status desc) "orphan")) (incompatible-reason (package--incompatible-p desc)) (signed (if desc (package-desc-signed desc))) - (maintainers (or (cdr (assoc :maintainers extras)) - (list (cdr (assoc :maintainer extras))))) + (maintainers (cdr (assoc :maintainer extras))) (authors (cdr (assoc :authors extras))) (news (and-let* (pkg-dir ((not built-in)) @@ -2942,7 +2942,7 @@ Helper function for `describe-package'." (insert " ")) (insert "\n")) (when maintainers - (unless (proper-list-p maintainers) + (when (stringp (car maintainers)) (setq maintainers (list maintainers))) (package--print-help-section (if (cdr maintainers) "Maintainers" "Maintainer")) @@ -4071,8 +4071,8 @@ invocations." (defun package-menu--version-predicate (A B) "Predicate to sort \"*Packages*\" buffer by the version column. This is used for `tabulated-list-format' in `package-menu-mode'." - (let ((vA (or (version-to-list (aref (cadr A) 1)) '(0))) - (vB (or (version-to-list (aref (cadr B) 1)) '(0)))) + (let ((vA (or (ignore-error error (version-to-list (aref (cadr A) 1))) '(0))) + (vB (or (ignore-error error (version-to-list (aref (cadr B) 1))) '(0)))) (if (version-list-= vA vB) (package-menu--name-predicate A B) (version-list-< vA vB)))) @@ -4700,18 +4700,23 @@ will be signaled in that case." (let* ((name (package-desc-name pkg-desc)) (extras (package-desc-extras pkg-desc)) (maint (alist-get :maintainer extras))) + (unless (listp (cdr maint)) + (setq maint (list maint))) (cond ((and (null maint) (null no-error)) (user-error "Package `%s' has no explicit maintainer" name)) ((and (not (progn (require 'ietf-drums) - (ietf-drums-parse-address (cdr maint)))) + (ietf-drums-parse-address (cdar maint)))) (null no-error)) (user-error "Package `%s' has no maintainer address" name)) - ((not (null maint)) + (t (with-temp-buffer - (package--print-email-button maint) - (string-trim (substring-no-properties (buffer-string)))))))) + (mapc #'package--print-email-button maint) + (replace-regexp-in-string + "\n" ", " (string-trim + (buffer-substring-no-properties + (point-min) (point-max))))))))) ;;;###autoload (defun package-report-bug (desc) @@ -4721,17 +4726,19 @@ DESC must be a `package-desc' object." package-menu-mode) (let ((maint (package-maintainers desc)) (name (symbol-name (package-desc-name desc))) + (pkgdir (package-desc-dir desc)) vars) - (dolist-with-progress-reporter (group custom-current-group-alist) - "Scanning for modified user options..." - (when (and (car group) - (file-in-directory-p (car group) (package-desc-dir desc))) - (dolist (ent (get (cdr group) 'custom-group)) - (when (and (custom-variable-p (car ent)) - (boundp (car ent)) - (not (eq (custom--standard-value (car ent)) - (default-toplevel-value (car ent))))) - (push (car ent) vars))))) + (when pkgdir + (dolist-with-progress-reporter (group custom-current-group-alist) + "Scanning for modified user options..." + (when (and (car group) + (file-in-directory-p (car group) pkgdir)) + (dolist (ent (get (cdr group) 'custom-group)) + (when (and (custom-variable-p (car ent)) + (boundp (car ent)) + (not (eq (custom--standard-value (car ent)) + (default-toplevel-value (car ent))))) + (push (car ent) vars)))))) (dlet ((reporter-prompt-for-summary-p t)) (reporter-submit-bug-report maint name vars)))) diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 5ac4b289a80..23f1bac600c 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -42,6 +42,14 @@ ;; - ideally we'd want (pcase s ((re RE1) E1) ((re RE2) E2)) to be able to ;; generate a lex-style DFA to decide whether to run E1 or E2. +;; While the first version was written before I knew about Racket's `match' +;; construct, the second version was significantly influenced by it, +;; so a good presentation of the underlying ideas can be found at: +;; +;; Extensible Pattern Matching in an Extensible Language +;; Sam Tobin-Hochstadt, 2010 +;; https://arxiv.org/abs/1106.2578 + ;;; Code: (require 'macroexp) @@ -123,6 +131,8 @@ FUN in `pred' and `app' can take one of the forms: call it with one argument (F ARG1 .. ARGn) call F with ARG1..ARGn and EXPVAL as n+1'th argument + (F ARG1 .. _ .. ARGn) + call F, passing EXPVAL at the _ position. FUN, BOOLEXP, and subsequent PAT can refer to variables bound earlier in the pattern by a SYMBOL pattern. @@ -155,8 +165,12 @@ Emacs Lisp manual for more information and examples." ;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-2) expansion)))) -(declare-function help-fns--signature "help-fns" - (function doc real-def real-function buffer)) +(defconst pcase--find-macro-def-regexp "(pcase-defmacro[\s\t\n]+%s[\s\t\n]*(") + +(with-eval-after-load 'find-func + (defvar find-function-regexp-alist) + (add-to-list 'find-function-regexp-alist + `(pcase-macro . pcase--find-macro-def-regexp))) ;; FIXME: Obviously, this will collide with nadvice's use of ;; function-documentation if we happen to advise `pcase'. @@ -166,9 +180,10 @@ Emacs Lisp manual for more information and examples." (defun pcase--make-docstring () (let* ((main (documentation (symbol-function 'pcase) 'raw)) (ud (help-split-fundoc main 'pcase))) - ;; So that eg emacs -Q -l cl-lib --eval "(documentation 'pcase)" works, - ;; where cl-lib is anything using pcase-defmacro. (require 'help-fns) + (declare-function help-fns-short-filename "help-fns" (filename)) + (declare-function help-fns--signature "help-fns" + (function doc real-def real-function buffer)) (with-temp-buffer (insert (or (cdr ud) main)) ;; Presentation Note: For conceptual continuity, we guarantee @@ -189,11 +204,20 @@ Emacs Lisp manual for more information and examples." (let* ((pair (pop more)) (symbol (car pair)) (me (cdr pair)) - (doc (documentation me 'raw))) + (doc (documentation me 'raw)) + (filename (find-lisp-object-file-name me 'defun))) (insert "\n\n-- ") (setq doc (help-fns--signature symbol doc me (indirect-function me) nil)) + (when filename + (save-excursion + (forward-char -1) + (insert (format-message " in `")) + (help-insert-xref-button (help-fns-short-filename filename) + 'help-function-def symbol filename + 'pcase-macro) + (insert (format-message "'.")))) (insert "\n" (or doc "Not documented."))))) (let ((combined-doc (buffer-string))) (if ud (help-add-fundoc-usage combined-doc (car ud)) combined-doc))))) @@ -261,8 +285,8 @@ As with `pcase-let', BINDINGS are of the form (PATTERN EXP), but the EXP in each binding in BINDINGS can use the results of the destructuring bindings that precede it in BINDINGS' order. -Each EXP should match (i.e. be of compatible structure) to its -respective PATTERN; a mismatch may signal an error or may go +Each EXP should match its respective PATTERN (i.e. be of structure +compatible to PATTERN); a mismatch may signal an error or may go undetected, binding variables to arbitrary values, such as nil." (declare (indent 1) (debug ((&rest (pcase-PAT &optional form)) body))) @@ -283,8 +307,8 @@ All EXPs are evaluated first, and then used to perform destructuring bindings by matching each EXP against its respective PATTERN. Then BODY is evaluated with those bindings in effect. -Each EXP should match (i.e. be of compatible structure) to its -respective PATTERN; a mismatch may signal an error or may go +Each EXP should match its respective PATTERN (i.e. be of structure +compatible to PATTERN); a mismatch may signal an error or may go undetected, binding variables to arbitrary values, such as nil." (declare (indent 1) (debug pcase-let*)) (if (null (cdr bindings)) @@ -599,62 +623,84 @@ recording whether the var has been referenced by earlier parts of the match." (defun pcase--and (match matches) (if matches `(and ,match ,@matches) match)) -(defconst pcase-mutually-exclusive-predicates - '((symbolp . integerp) - (symbolp . numberp) - (symbolp . consp) - (symbolp . arrayp) - (symbolp . vectorp) - (symbolp . stringp) - (symbolp . byte-code-function-p) - (symbolp . compiled-function-p) - (symbolp . recordp) - (null . integerp) - (null . numberp) - (null . numberp) - (null . consp) - (null . arrayp) - (null . vectorp) - (null . stringp) - (null . byte-code-function-p) - (null . compiled-function-p) - (null . recordp) - (integerp . consp) - (integerp . arrayp) - (integerp . vectorp) - (integerp . stringp) - (integerp . byte-code-function-p) - (integerp . compiled-function-p) - (integerp . recordp) - (numberp . consp) - (numberp . arrayp) - (numberp . vectorp) - (numberp . stringp) - (numberp . byte-code-function-p) - (numberp . compiled-function-p) - (numberp . recordp) - (consp . arrayp) - (consp . atom) - (consp . vectorp) - (consp . stringp) - (consp . byte-code-function-p) - (consp . compiled-function-p) - (consp . recordp) - (arrayp . byte-code-function-p) - (arrayp . compiled-function-p) - (vectorp . byte-code-function-p) - (vectorp . compiled-function-p) - (vectorp . recordp) - (stringp . vectorp) - (stringp . recordp) - (stringp . byte-code-function-p) - (stringp . compiled-function-p))) - +(defun pcase--subtype-bitsets () + (let ((built-in-types ())) + (mapatoms (lambda (sym) + (let ((class (get sym 'cl--class))) + (when (and (built-in-class-p class) + (get sym 'cl-deftype-satisfies)) + (push (list sym + (get sym 'cl-deftype-satisfies) + (cl--class-allparents class)) + built-in-types))))) + ;; The "true" predicate for `function' type is `cl-functionp'. + (setcar (nthcdr 1 (assq 'function built-in-types)) 'cl-functionp) + ;; Sort the types from deepest in the hierarchy so all children + ;; are processed before their parent. It also gives lowest + ;; numbers to those types that are subtypes of the largest number + ;; of types, which minimize the need to use bignums. + (setq built-in-types (sort built-in-types + (lambda (x y) + (> (length (nth 2 x)) (length (nth 2 y)))))) + + (let ((bitsets (make-hash-table)) + (i 1)) + (dolist (x built-in-types) + ;; Don't dedicate any bit to those predicates which already + ;; have a bitset, since it means they're already represented + ;; by their subtypes. + (unless (and (nth 1 x) (gethash (nth 1 x) bitsets)) + (dolist (parent (nth 2 x)) + (let ((pred (nth 1 (assq parent built-in-types)))) + (unless (or (eq parent t) (null pred)) + (puthash pred (+ i (gethash pred bitsets 0)) + bitsets)))) + (setq i (+ i i)))) + + ;; Extra predicates that don't have matching types. + (dolist (pred-types '((functionp cl-functionp consp symbolp) + (keywordp symbolp) + (characterp fixnump) + (natnump integerp) + (facep symbolp stringp) + (plistp listp) + (cl-struct-p recordp) + ;; ;; FIXME: These aren't quite in the same + ;; ;; category since they'll signal errors. + (fboundp symbolp) + )) + (puthash (car pred-types) + (apply #'logior + (mapcar (lambda (pred) + (gethash pred bitsets)) + (cdr pred-types))) + bitsets)) + bitsets))) + +(defconst pcase--subtype-bitsets + (if (fboundp 'built-in-class-p) + (pcase--subtype-bitsets) + ;; Early bootstrap: we don't have the built-in classes yet, so just + ;; use an empty table for now. + (prog1 (make-hash-table) + ;; The empty table leads to significantly worse code, so upgrade + ;; to the real table as soon as possible (most importantly: before we + ;; start compiling code, and hence baking the result into files). + (with-eval-after-load 'cl-preloaded + (defconst pcase--subtype-bitsets (pcase--subtype-bitsets))))) + "Hash table mapping type predicates to their sets of types. +The table maps each type predicate, such as `numberp' and `stringp', +to the set of built-in types for which the predicate may return non-nil. +The sets are represented as bitsets (integers) where each bit represents +a specific leaf type. Which bit represents which type is unspecified.") + +;; Extra predicates (defun pcase--mutually-exclusive-p (pred1 pred2) - (or (member (cons pred1 pred2) - pcase-mutually-exclusive-predicates) - (member (cons pred2 pred1) - pcase-mutually-exclusive-predicates))) + (let ((subtypes1 (gethash pred1 pcase--subtype-bitsets))) + (when subtypes1 + (let ((subtypes2 (gethash pred2 pcase--subtype-bitsets))) + (when subtypes2 + (zerop (logand subtypes1 subtypes2))))))) (defun pcase--split-match (sym splitter match) (cond @@ -790,12 +836,13 @@ A and B can be one of: ((vectorp (cadr pat)) #'vectorp) ((compiled-function-p (cadr pat)) #'compiled-function-p)))) - (pcase--mutually-exclusive-p (cadr upat) otherpred)) + (and otherpred + (pcase--mutually-exclusive-p (cadr upat) otherpred))) '(:pcase--fail . nil)) - ;; Since we turn (or 'a 'b 'c) into (pred (pcase--flip (memq '(a b c)))) + ;; Since we turn (or 'a 'b 'c) into (pred (memq _ '(a b c))) ;; try and preserve the info we get from that memq test. - ((and (eq 'pcase--flip (car-safe (cadr upat))) - (memq (cadr (cadr upat)) '(memq member memql)) + ((and (memq (car-safe (cadr upat)) '(memq member memql)) + (eq (cadr (cadr upat)) '_) (eq 'quote (car-safe (nth 2 (cadr upat)))) (eq 'quote (car-safe pat))) (let ((set (cadr (nth 2 (cadr upat))))) @@ -843,7 +890,7 @@ A and B can be one of: (defmacro pcase--flip (fun arg1 arg2) "Helper function, used internally to avoid (funcall (lambda ...) ...)." - (declare (debug (sexp body))) + (declare (debug (sexp body)) (obsolete _ "30.1")) `(,fun ,arg2 ,arg1)) (defun pcase--funcall (fun arg vars) @@ -864,9 +911,13 @@ A and B can be one of: (let ((newsym (gensym "x"))) (push (list newsym arg) env) (setq arg newsym))) - (if (or (functionp fun) (not (consp fun))) - `(funcall #',fun ,arg) - `(,@fun ,arg))))) + (cond + ((or (functionp fun) (not (consp fun))) + `(funcall #',fun ,arg)) + ((memq '_ fun) + (mapcar (lambda (x) (if (eq '_ x) arg x)) fun)) + (t + `(,@fun ,arg)))))) (if (null env) call ;; Let's not replace `vars' in `fun' since it's @@ -927,7 +978,7 @@ Otherwise, it defers to REST which is a list of branches of the form ;; Yes, we can use `memql' (or `member')! ((> (length simples) 1) (pcase--u1 (cons `(match ,var - . (pred (pcase--flip ,mem-fun ',simples))) + . (pred (,mem-fun _ ',simples))) (cdr matches)) code vars (if (null others) rest @@ -1074,12 +1125,13 @@ The predicate is the logical-AND of: (declare (debug (pcase-QPAT))) (cond ((eq (car-safe qpat) '\,) (cadr qpat)) + ((eq (car-safe qpat) '\,@) (error "Unsupported QPAT: %S" qpat)) ((vectorp qpat) `(and (pred vectorp) (app length ,(length qpat)) ,@(let ((upats nil)) (dotimes (i (length qpat)) - (push `(app (pcase--flip aref ,i) ,(list '\` (aref qpat i))) + (push `(app (aref _ ,i) ,(list '\` (aref qpat i))) upats)) (nreverse upats)))) ((consp qpat) diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el index 1d722051406..d586fc59939 100644 --- a/lisp/emacs-lisp/pp.el +++ b/lisp/emacs-lisp/pp.el @@ -166,12 +166,19 @@ it inserts and pretty-prints that arg at point." (interactive "r") (if (null end) (pp--object beg #'pp-fill) (goto-char beg) - (let ((end (copy-marker end t)) - (newline (lambda () - (skip-chars-forward ")]}") - (unless (save-excursion (skip-chars-forward " \t") (eolp)) - (insert "\n") - (indent-according-to-mode))))) + (let* ((end (copy-marker end t)) + (avoid-unbreakable + (lambda () + (and (memq (char-before) '(?# ?s ?f)) + (memq (char-after) '(?\[ ?\()) + (looking-back "#[sf]?" (- (point) 2)) + (goto-char (match-beginning 0))))) + (newline (lambda () + (skip-chars-forward ")]}") + (unless (save-excursion (skip-chars-forward " \t") (eolp)) + (funcall avoid-unbreakable) + (insert "\n") + (indent-according-to-mode))))) (while (progn (forward-comment (point-max)) (< (point) end)) (let ((beg (point)) @@ -193,11 +200,18 @@ it inserts and pretty-prints that arg at point." (and (save-excursion (goto-char beg) - (if (save-excursion (skip-chars-backward " \t({[',") - (bolp)) - ;; The sexp was already on its own line. - nil - (skip-chars-backward " \t") + ;; We skip backward over open parens because cutting + ;; the line right after an open paren does not help + ;; reduce the indentation depth. + ;; Similarly, we prefer to cut before a "." than after + ;; it because it reduces the indentation depth. + (while + (progn + (funcall avoid-unbreakable) + (not (zerop (skip-chars-backward " \t({[',."))))) + (if (bolp) + ;; The sexp already starts on its own line. + (progn (goto-char beg) nil) (setq beg (copy-marker beg t)) (if paired (setq paired (copy-marker paired t))) ;; We could try to undo this insertion if it @@ -346,6 +360,23 @@ after OUT-BUFFER-NAME." (setq buffer-read-only nil) (setq-local font-lock-verbose nil))))) +(defun pp-insert-short-sexp (sexp &optional width) + "Insert a short description of SEXP in the current buffer. +WIDTH is the maximum width to use for it and it defaults to the +space available between point and the window margin." + (let ((printed (format "%S" sexp))) + (if (and (not (string-search "\n" printed)) + (<= (string-width printed) + (or width (- (window-width) (current-column))))) + (insert printed) + (insert-text-button + "[Show]" + 'follow-link t + 'action (lambda (&rest _ignore) + ;; FIXME: Why "eval output"? + (pp-display-expression sexp "*Pp Eval Output*")) + 'help-echo "mouse-2, RET: pretty print value in another buffer")))) + ;;;###autoload (defun pp-eval-expression (expression) "Evaluate EXPRESSION and pretty-print its value. @@ -430,23 +461,33 @@ the bounds of a region containing Lisp code to pretty-print." (replace-match "")) (insert-into-buffer obuf))))) +(defvar pp--quoting-syntaxes + `((quote . "'") + (function . "#'") + (,backquote-backquote-symbol . "`") + (,backquote-unquote-symbol . ",") + (,backquote-splice-symbol . ",@"))) + +(defun pp--quoted-or-unquoted-form-p (cons) + ;; Return non-nil when CONS has one of the forms 'X, `X, ,X or ,@X + (let ((head (car cons))) + (and (symbolp head) + (assq head pp--quoting-syntaxes) + (let ((rest (cdr cons))) + (and (consp rest) (null (cdr rest))))))) + (defun pp--insert-lisp (sexp) (cl-case (type-of sexp) (vector (pp--format-vector sexp)) (cons (cond ((consp (cdr sexp)) - (if (and (length= sexp 2) - (memq (car sexp) '(quote function))) - (cond - ((symbolp (cadr sexp)) - (let ((print-quoted t)) - (prin1 sexp (current-buffer)))) - ((consp (cadr sexp)) - (insert (if (eq (car sexp) 'quote) - "'" "#'")) - (pp--format-list (cadr sexp) - (set-marker (make-marker) (1- (point)))))) - (pp--format-list sexp))) + (let ((head (car sexp))) + (if-let (((null (cddr sexp))) + (syntax-entry (assq head pp--quoting-syntaxes))) + (progn + (insert (cdr syntax-entry)) + (pp--insert-lisp (cadr sexp))) + (pp--format-list sexp)))) (t (prin1 sexp (current-buffer))))) ;; Print some of the smaller integers as characters, perhaps? @@ -458,6 +499,8 @@ the bounds of a region containing Lisp code to pretty-print." (string (let ((print-escape-newlines t)) (prin1 sexp (current-buffer)))) + (symbol + (prin1 sexp (current-buffer))) (otherwise (princ sexp (current-buffer))))) (defun pp--format-vector (sexp) @@ -468,15 +511,29 @@ the bounds of a region containing Lisp code to pretty-print." (insert "]")) (defun pp--format-list (sexp &optional start) - (if (and (symbolp (car sexp)) - (not pp--inhibit-function-formatting) - (not (keywordp (car sexp)))) + (if (not (let ((head (car sexp))) + (or pp--inhibit-function-formatting + (not (symbolp head)) + (keywordp head) + (let ((l sexp)) + (catch 'not-funcall + (while l + (when (or + (atom l) ; SEXP is a dotted list + ;; Does SEXP have a form like (ELT... . ,X) ? + (pp--quoted-or-unquoted-form-p l)) + (throw 'not-funcall t)) + (setq l (cdr l))) + nil))))) (pp--format-function sexp) (insert "(") (pp--insert start (pop sexp)) (while sexp (if (consp sexp) - (pp--insert " " (pop sexp)) + (if (not (pp--quoted-or-unquoted-form-p sexp)) + (pp--insert " " (pop sexp)) + (pp--insert " . " sexp) + (setq sexp nil)) (pp--insert " . " sexp) (setq sexp nil))) (insert ")"))) diff --git a/lisp/emacs-lisp/re-builder.el b/lisp/emacs-lisp/re-builder.el index 0a47cca0231..c5307f70d08 100644 --- a/lisp/emacs-lisp/re-builder.el +++ b/lisp/emacs-lisp/re-builder.el @@ -825,7 +825,7 @@ If SUBEXP is non-nil mark only the corresponding sub-expressions." (defun reb-restart-font-lock () "Restart `font-lock-mode' to fit current regexp format." - (with-current-buffer (get-buffer reb-buffer) + (with-current-buffer reb-buffer (let ((font-lock-is-on font-lock-mode)) (font-lock-mode -1) (kill-local-variable 'font-lock-set-defaults) diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index 4c6553972c2..a20cff16982 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -362,8 +362,7 @@ the result. The result is a sequence of the same type as SEQUENCE." (seq-concatenate - (let ((type (type-of sequence))) - (if (eq type 'cons) 'list type)) + (if (listp sequence) 'list (type-of sequence)) (seq-subseq sequence 0 n) (seq-subseq sequence (1+ n)))) @@ -619,12 +618,12 @@ SEQUENCE must be a sequence of numbers or markers." (unless rest-marker (pcase name (`&rest - (progn (push `(app (pcase--flip seq-drop ,index) + (progn (push `(app (seq-drop _ ,index) ,(seq--elt-safe args (1+ index))) bindings) (setq rest-marker t))) (_ - (push `(app (pcase--flip seq--elt-safe ,index) ,name) bindings)))) + (push `(app (seq--elt-safe _ ,index) ,name) bindings)))) (setq index (1+ index))) bindings)) diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index 17cbf6b2d31..a1e49b50510 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -51,6 +51,17 @@ "Face used for a section.") ;;;###autoload +(defun shortdoc--check (group functions) + (let ((keywords '( :no-manual :args :eval :no-eval :no-value :no-eval* + :result :result-string :eg-result :eg-result-string :doc))) + (dolist (f functions) + (when (consp f) + (dolist (x f) + (when (and (keywordp x) (not (memq x keywords))) + (error "Shortdoc %s function `%s': bad keyword `%s'" + group (car f) x))))))) + +;;;###autoload (progn (defvar shortdoc--groups nil) @@ -118,6 +129,7 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), `:no-eval*', `:result', `:result-string', `:eg-result' and `:eg-result-string' properties." (declare (indent defun)) + (shortdoc--check group functions) `(progn (setq shortdoc--groups (delq (assq ',group shortdoc--groups) shortdoc--groups)) @@ -572,10 +584,7 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), :result-string "#s(hash-table ...)") (hash-table-count :no-eval (hash-table-count table) - :eg-result 15) - (hash-table-size - :no-eval (hash-table-size table) - :eg-result 65)) + :eg-result 15)) (define-short-documentation-group list "Making Lists" @@ -718,7 +727,7 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), :eval (plist-get '(a 1 b 2 c 3) 'b)) (plist-put :no-eval (setq plist (plist-put plist 'd 4)) - :eq-result (a 1 b 2 c 3 d 4)) + :eg-result (a 1 b 2 c 3 d 4)) (plist-member :eval (plist-member '(a 1 b 2 c 3) 'b)) "Data About Lists" @@ -738,9 +747,13 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), (intern :eval (intern "abc")) (intern-soft + :eval (intern-soft "list") :eval (intern-soft "Phooey!")) (make-symbol :eval (make-symbol "abc")) + (gensym + :no-eval (gensym) + :eg-result g37) "Comparing symbols" (eq :eval (eq 'abc 'abc) @@ -751,7 +764,20 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), :eval (equal 'abc 'abc)) "Name" (symbol-name - :eval (symbol-name 'abc))) + :eval (symbol-name 'abc)) + "Obarrays" + (obarray-make + :eval (obarray-make)) + (obarrayp + :eval (obarrayp (obarray-make)) + :eval (obarrayp nil)) + (unintern + :no-eval (unintern "abc" my-obarray) + :eg-result t) + (mapatoms + :no-eval (mapatoms (lambda (symbol) (print symbol)) my-obarray)) + (obarray-clear + :no-eval (obarray-clear my-obarray))) (define-short-documentation-group comparison "General-purpose" @@ -1755,7 +1781,7 @@ With prefix numeric argument ARG, do it that many times." (interactive) (save-excursion (goto-char (pos-bol)) - (when-let* ((re (rx bol "(" (group (+ (not (in " ")))))) + (when-let* ((re (rx bol "(" (group (+ (not (in " )")))))) (string (and (or (looking-at re) (re-search-backward re nil t)) diff --git a/lisp/emacs-lisp/shorthands.el b/lisp/emacs-lisp/shorthands.el index 6348aaccf93..379fb0baec9 100644 --- a/lisp/emacs-lisp/shorthands.el +++ b/lisp/emacs-lisp/shorthands.el @@ -52,38 +52,26 @@ :version "28.1" :group 'font-lock-faces) -(defun shorthands--mismatch-from-end (str1 str2) - "Tell index of first mismatch in STR1 and STR2, from end. -The index is a valid 0-based index on STR1. Returns nil if STR1 -equals STR2. Return 0 if STR1 is a suffix of STR2." - (cl-loop with l1 = (length str1) with l2 = (length str2) - for i from 1 - for i1 = (- l1 i) for i2 = (- l2 i) - while (eq (aref str1 i1) (aref str2 i2)) - if (zerop i2) return (if (zerop i1) nil i1) - if (zerop i1) return 0 - finally (return i1))) - (defun shorthands-font-lock-shorthands (limit) + "Font lock until LIMIT considering `read-symbol-shorthands'." (when read-symbol-shorthands (while (re-search-forward (concat "\\_<\\(" (rx lisp-mode-symbol) "\\)\\_>") limit t) (let* ((existing (get-text-property (match-beginning 1) 'face)) + (print-name (match-string 1)) (probe (and (not (memq existing '(font-lock-comment-face font-lock-string-face))) - (intern-soft (match-string 1)))) - (sname (and probe (symbol-name probe))) - (mismatch (and sname (shorthands--mismatch-from-end - (match-string 1) sname))) - (guess (and mismatch (1+ mismatch)))) - (when guess - (when (and (< guess (1- (length (match-string 1)))) - ;; In bug#67390 we allow other separators - (eq (char-syntax (aref (match-string 1) guess)) ?_)) - (setq guess (1+ guess))) + (intern-soft print-name))) + (symbol-name (and probe (symbol-name probe))) + (prefix (and symbol-name + (not (string-equal print-name symbol-name)) + (car (assoc print-name + read-symbol-shorthands + #'string-prefix-p))))) + (when prefix (add-face-text-property (match-beginning 1) - (+ (match-beginning 1) guess) + (+ (match-beginning 1) (length prefix)) 'elisp-shorthand-font-lock-face)))))) (font-lock-add-keywords 'emacs-lisp-mode '((shorthands-font-lock-shorthands)) t) diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el index 9884a2fc24b..c86e3f9c5df 100644 --- a/lisp/emacs-lisp/tabulated-list.el +++ b/lisp/emacs-lisp/tabulated-list.el @@ -139,6 +139,21 @@ If `tabulated-list-entries' is a function, it is called with no arguments and must return a list of the above form.") (put 'tabulated-list-entries 'permanent-local t) +(defvar-local tabulated-list-groups nil + "Groups displayed in the current Tabulated List buffer. +This should be either a function, or a list. +If a list, each element has the form (GROUP-NAME ENTRIES), +where: + + - GROUP-NAME is a group name as a string, which is displayed + at the top line of each group. + + - ENTRIES is a list described in `tabulated-list-entries'. + +If `tabulated-list-groups' is a function, it is called with no +arguments and must return a list of the above form.") +(put 'tabulated-list-groups 'permanent-local t) + (defvar-local tabulated-list-padding 0 "Number of characters preceding each Tabulated List mode entry. By default, lines are padded with spaces, but you can use the @@ -362,15 +377,17 @@ Do nothing if `tabulated-list--header-string' is nil." (if tabulated-list--header-overlay (move-overlay tabulated-list--header-overlay (point-min) (point)) (setq-local tabulated-list--header-overlay - (make-overlay (point-min) (point)))) - (overlay-put tabulated-list--header-overlay - 'face 'tabulated-list-fake-header)))) + (make-overlay (point-min) (point))) + (overlay-put tabulated-list--header-overlay 'fake-header t) + (overlay-put tabulated-list--header-overlay + 'face 'tabulated-list-fake-header))))) (defsubst tabulated-list-header-overlay-p (&optional pos) "Return non-nil if there is a fake header. Optional arg POS is a buffer position where to look for a fake header; defaults to `point-min'." - (overlays-at (or pos (point-min)))) + (seq-find (lambda (o) (overlay-get o 'fake-header)) + (overlays-at (or pos (point-min))))) (defun tabulated-list-revert (&rest _ignored) "The `revert-buffer-function' for `tabulated-list-mode'. @@ -427,6 +444,9 @@ This sorts the `tabulated-list-entries' list if sorting is specified by `tabulated-list-sort-key'. It then erases the buffer and inserts the entries with `tabulated-list-printer'. +If `tabulated-list-groups' is non-nil, each group of entries +is printed and sorted separately. + Optional argument REMEMBER-POS, if non-nil, means to move point to the entry with the same ID element as the current line. @@ -437,6 +457,9 @@ be removed from entries that haven't changed (see `tabulated-list-put-tag'). Don't use this immediately after changing `tabulated-list-sort-key'." (let ((inhibit-read-only t) + (groups (if (functionp tabulated-list-groups) + (funcall tabulated-list-groups) + tabulated-list-groups)) (entries (if (functionp tabulated-list-entries) (funcall tabulated-list-entries) tabulated-list-entries)) @@ -447,7 +470,14 @@ changing `tabulated-list-sort-key'." (setq saved-col (current-column))) ;; Sort the entries, if necessary. (when sorter - (setq entries (sort entries sorter))) + (if groups + (setq groups + (mapcar (lambda (group) + (cons (car group) (sort (cdr group) sorter))) + groups)) + (setq entries (sort entries sorter)))) + (unless (functionp tabulated-list-groups) + (setq tabulated-list-groups groups)) (unless (functionp tabulated-list-entries) (setq tabulated-list-entries entries)) ;; Without a sorter, we have no way to just update. @@ -459,6 +489,25 @@ changing `tabulated-list-sort-key'." (unless tabulated-list-use-header-line (tabulated-list-print-fake-header))) ;; Finally, print the resulting list. + (if groups + (dolist (group groups) + (insert (car group) ?\n) + (when-let ((saved-pt-new (tabulated-list-print-entries + (cdr group) sorter update entry-id))) + (setq saved-pt saved-pt-new))) + (setq saved-pt (tabulated-list-print-entries + entries sorter update entry-id))) + (when update + (delete-region (point) (point-max))) + (set-buffer-modified-p nil) + ;; If REMEMBER-POS was specified, move to the "old" location. + (if saved-pt + (progn (goto-char saved-pt) + (move-to-column saved-col)) + (goto-char (point-min))))) + +(defun tabulated-list-print-entries (entries sorter update entry-id) + (let (saved-pt) (while entries (let* ((elt (car entries)) (tabulated-list--near-rows @@ -495,14 +544,7 @@ changing `tabulated-list-sort-key'." (forward-line 1) (delete-region old (point)))))) (setq entries (cdr entries))) - (when update - (delete-region (point) (point-max))) - (set-buffer-modified-p nil) - ;; If REMEMBER-POS was specified, move to the "old" location. - (if saved-pt - (progn (goto-char saved-pt) - (move-to-column saved-col)) - (goto-char (point-min))))) + saved-pt)) (defun tabulated-list-print-entry (id cols) "Insert a Tabulated List entry at point. diff --git a/lisp/emacs-lisp/trace.el b/lisp/emacs-lisp/trace.el index 2c8b913ec33..1ed1528c6d5 100644 --- a/lisp/emacs-lisp/trace.el +++ b/lisp/emacs-lisp/trace.el @@ -156,44 +156,43 @@ (defun trace-values (&rest values) "Helper function to get internal values. You can call this function to add internal values in the trace buffer." - (unless inhibit-trace - (with-current-buffer (get-buffer-create trace-buffer) - (goto-char (point-max)) - (insert - (trace-entry-message - 'trace-values trace-level values ""))))) + (trace--entry-message + 'trace-values trace-level values (lambda () ""))) -(defun trace-entry-message (function level args context) +(defun trace--entry-message (function level args context) "Generate a string that describes that FUNCTION has been entered. -LEVEL is the trace level, ARGS is the list of arguments passed to FUNCTION, -and CONTEXT is a string describing the dynamic context (e.g. values of -some global variables)." - (let ((print-circle t) - (print-escape-newlines t)) - (format "%s%s%d -> %s%s\n" - (mapconcat #'char-to-string (make-string (max 0 (1- level)) ?|) " ") - (if (> level 1) " " "") - level - ;; FIXME: Make it so we can click the function name to jump to its - ;; definition and/or untrace it. - (cl-prin1-to-string (cons function args)) - context))) - -(defun trace-exit-message (function level value context) +LEVEL is the trace level, ARGS is the list of arguments passed to FUNCTION." + (unless inhibit-trace + (trace--insert + (let ((ctx (funcall context)) + (print-circle t) + (print-escape-newlines t)) + (format "%s%s%d -> %s%s\n" + (mapconcat #'char-to-string + (make-string (max 0 (1- level)) ?|) " ") + (if (> level 1) " " "") + level + ;; FIXME: Make it so we can click the function name to + ;; jump to its definition and/or untrace it. + (cl-prin1-to-string (cons function args)) + ctx))))) + +(defun trace--exit-message (function level value context) "Generate a string that describes that FUNCTION has exited. -LEVEL is the trace level, VALUE value returned by FUNCTION, -and CONTEXT is a string describing the dynamic context (e.g. values of -some global variables)." - (let ((print-circle t) - (print-escape-newlines t)) - (format "%s%s%d <- %s: %s%s\n" - (mapconcat 'char-to-string (make-string (1- level) ?|) " ") - (if (> level 1) " " "") - level - function - ;; Do this so we'll see strings: - (cl-prin1-to-string value) - context))) +LEVEL is the trace level, VALUE value returned by FUNCTION." + (unless inhibit-trace + (trace--insert + (let ((ctx (funcall context)) + (print-circle t) + (print-escape-newlines t)) + (format "%s%s%d <- %s: %s%s\n" + (mapconcat 'char-to-string (make-string (1- level) ?|) " ") + (if (> level 1) " " "") + level + function + ;; Do this so we'll see strings: + (cl-prin1-to-string value) + ctx))))) (defvar trace--timer nil) @@ -208,43 +207,40 @@ some global variables)." (setq trace--timer nil) (display-buffer buf nil 0)))))) +(defun trace--insert (msg) + (if noninteractive + (message "%s" (if (eq ?\n (aref msg (1- (length msg)))) + (substring msg 0 -1) msg)) + (with-current-buffer trace-buffer + (setq-local window-point-insertion-type t) + (goto-char (point-max)) + (let ((deactivate-mark nil)) ;Protect deactivate-mark. + (insert msg))))) (defun trace-make-advice (function buffer background context) "Build the piece of advice to be added to trace FUNCTION. FUNCTION is the name of the traced function. BUFFER is the buffer where the trace should be printed. BACKGROUND if nil means to display BUFFER. -CONTEXT if non-nil should be a function that returns extra info that should -be printed along with the arguments in the trace." +CONTEXT should be a function that returns extra text that should +be printed after the arguments in the trace." (lambda (body &rest args) (let ((trace-level (1+ trace-level)) - (trace-buffer (get-buffer-create buffer)) - (deactivate-mark nil) ;Protect deactivate-mark. - (ctx (funcall context))) + (trace-buffer (get-buffer-create buffer))) + ;; Insert a separator from previous trace output: (unless inhibit-trace - (with-current-buffer trace-buffer - (setq-local window-point-insertion-type t) - (unless background (trace--display-buffer trace-buffer)) - (goto-char (point-max)) - ;; Insert a separator from previous trace output: - (if (= trace-level 1) (insert trace-separator)) - (insert - (trace-entry-message - function trace-level args ctx)))) + (unless background (trace--display-buffer trace-buffer)) + (if (= trace-level 1) (trace--insert trace-separator))) + (trace--entry-message + function trace-level args context) (let ((result)) (unwind-protect (setq result (list (apply body args))) - (unless inhibit-trace - (let ((ctx (funcall context))) - (with-current-buffer trace-buffer - (unless background (trace--display-buffer trace-buffer)) - (goto-char (point-max)) - (insert - (trace-exit-message - function - trace-level - (if result (car result) '\!non-local\ exit\!) - ctx)))))) + (trace--exit-message + function + trace-level + (if result (car result) '\!non-local\ exit\!) + context)) (car result))))) (defun trace-function-internal (function buffer background context) diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el index 02020552e7f..d8e5136c666 100644 --- a/lisp/emacs-lisp/vtable.el +++ b/lisp/emacs-lisp/vtable.el @@ -283,8 +283,16 @@ If it can't be found, return nil and don't move point." (goto-char (prop-match-beginning match)) (end-of-line))) -(defun vtable-update-object (table object old-object) - "Replace OLD-OBJECT in TABLE with OBJECT." +(defun vtable-update-object (table object &optional old-object) + "Update OBJECT's representation in TABLE. +If OLD-OBJECT is non-nil, replace OLD-OBJECT with OBJECT and display it. +In either case, if the existing object is not found in the table (being +compared with `equal'), signal an error. Note a limitation: if TABLE's +buffer is not in a visible window, or if its window has changed width +since it was updated, updating the TABLE is not possible, and an error +is signaled." + (unless old-object + (setq old-object object)) (let* ((objects (vtable-objects table)) (inhibit-read-only t)) ;; First replace the object in the object storage. @@ -300,26 +308,31 @@ If it can't be found, return nil and don't move point." (error "Can't find the old object")) (setcar (cdr objects) object)) ;; Then update the cache... - (let* ((line-number (seq-position old-object (car (vtable--cache table)))) - (line (elt (car (vtable--cache table)) line-number))) - (unless line - (error "Can't find cached object")) - (setcar line object) - (setcdr line (vtable--compute-cached-line table object)) - ;; ... and redisplay the line in question. - (save-excursion - (vtable-goto-object old-object) - (let ((keymap (get-text-property (point) 'keymap)) - (start (point))) - (delete-line) - (vtable--insert-line table line line-number - (nth 1 (vtable--cache table)) - (vtable--spacer table)) - (add-text-properties start (point) (list 'keymap keymap - 'vtable table)))) - ;; We may have inserted a non-numerical value into a previously - ;; all-numerical table, so recompute. - (vtable--recompute-numerical table (cdr line))))) + ;; FIXME: If the table's buffer has no visible window, or if its + ;; width has changed since the table was updated, the cache key will + ;; not match and the object can't be updated. (Bug #69837). + (if-let ((line-number (seq-position (car (vtable--cache table)) old-object + (lambda (a b) + (equal (car a) b)))) + (line (elt (car (vtable--cache table)) line-number))) + (progn + (setcar line object) + (setcdr line (vtable--compute-cached-line table object)) + ;; ... and redisplay the line in question. + (save-excursion + (vtable-goto-object old-object) + (let ((keymap (get-text-property (point) 'keymap)) + (start (point))) + (delete-line) + (vtable--insert-line table line line-number + (nth 1 (vtable--cache table)) + (vtable--spacer table)) + (add-text-properties start (point) (list 'keymap keymap + 'vtable table)))) + ;; We may have inserted a non-numerical value into a previously + ;; all-numerical table, so recompute. + (vtable--recompute-numerical table (cdr line))) + (error "Can't find cached object in vtable")))) (defun vtable-remove-object (table object) "Remove OBJECT from TABLE. @@ -741,7 +754,7 @@ If NEXT, do the next column." (seq-do-indexed (lambda (elem index) (when (and (vtable-column--numerical (elt columns index)) - (not (numberp elem))) + (not (numberp (car elem)))) (setq recompute t))) line) (when recompute diff --git a/lisp/emulation/viper-cmd.el b/lisp/emulation/viper-cmd.el index 9c42f38dc45..192eb99a570 100644 --- a/lisp/emulation/viper-cmd.el +++ b/lisp/emulation/viper-cmd.el @@ -4637,7 +4637,7 @@ sensitive for VI-style look-and-feel." (insert (substitute-command-keys " Please specify your level of familiarity with the venomous VI PERil \(and the VI Plan for Emacs Rescue). -You can change it at any time by typing `\\[viper-set-expert-level]' +You can change it at any time by typing \\[viper-set-expert-level] 1 -- BEGINNER: Almost all Emacs features are suppressed. Feels almost like straight Vi. File name completion and diff --git a/lisp/emulation/viper-init.el b/lisp/emulation/viper-init.el index 30750951887..9f724551239 100644 --- a/lisp/emulation/viper-init.el +++ b/lisp/emulation/viper-init.el @@ -257,11 +257,11 @@ that deletes a file.") (defvar viper-expert-level (if (boundp 'viper-expert-level) viper-expert-level 0) "User's expert level. -The minor mode viper-vi-diehard-minor-mode is in effect when -viper-expert-level is 1 or 2 or when viper-want-emacs-keys-in-vi is t. -The minor mode viper-insert-diehard-minor-mode is in effect when -viper-expert-level is 1 or 2 or if viper-want-emacs-keys-in-insert is t. -Use `\\[viper-set-expert-level]' to change this.") +The minor mode `viper-vi-diehard-minor-mode' is in effect when +`viper-expert-level' is 1 or 2 or when `viper-want-emacs-keys-in-vi' is t. +The minor mode `viper-insert-diehard-minor-mode' is in effect when +`viper-expert-level' is 1 or 2 or if `viper-want-emacs-keys-in-insert' is t. +Use \\[viper-set-expert-level] to change this.") ;; Max expert level supported by Viper. This is NOT a user option. ;; It is here to make it hard for the user from resetting it. diff --git a/lisp/emulation/viper.el b/lisp/emulation/viper.el index 83fcdf89375..287292a24dc 100644 --- a/lisp/emulation/viper.el +++ b/lisp/emulation/viper.el @@ -388,7 +388,6 @@ widget." idl-mode perl-mode - cperl-mode javascript-mode tcl-mode python-mode diff --git a/lisp/epa-ks.el b/lisp/epa-ks.el index c3c11bb0b0b..13840da0bd9 100644 --- a/lisp/epa-ks.el +++ b/lisp/epa-ks.el @@ -47,11 +47,8 @@ This is used by `epa-search-keys', for looking up public keys." (repeat :tag "Random pool" (string :tag "Keyserver address")) (const "keyring.debian.org") - (const "keys.gnupg.net") (const "keyserver.ubuntu.com") (const "pgp.mit.edu") - (const "pool.sks-keyservers.net") - (const "zimmermann.mayfirst.org") (string :tag "Custom keyserver")) :version "28.1") diff --git a/lisp/epa.el b/lisp/epa.el index 53da3bf6cce..c29df18bb58 100644 --- a/lisp/epa.el +++ b/lisp/epa.el @@ -73,6 +73,17 @@ The command `epa-mail-encrypt' uses this." :group 'epa :version "24.4") +(defcustom epa-keys-select-method 'buffer + "Method used to select keys in `epa-select-keys'. +If the value is \\='buffer, the default, keys are selected via a +pop-up buffer. If the value is \\='minibuffer, keys are selected +via the minibuffer instead, using `completing-read-multiple'. +Any other value is treated as \\='buffer." + :type '(choice (const :tag "Read keys from a pop-up buffer" buffer) + (const :tag "Read keys from minibuffer" minibuffer)) + :group 'epa + :version "30.1") + ;;; Faces (defgroup epa-faces nil @@ -450,6 +461,25 @@ q trust status questionable. - trust status unspecified. (epa--marked-keys)) (kill-buffer epa-keys-buffer))))) +(defun epa--select-keys-in-minibuffer (prompt keys) + (let* ((prompt (pcase-let ((`(,first ,second ,third) + (string-split prompt "\\.")) + (hint "(separated by comma)")) + (if third + (format "%s %s. %s: " first hint second) + (format "%s %s: " first hint)))) + (keys-alist + (seq-map + (lambda (key) + (cons (substring-no-properties + (epa--button-key-text key)) + key)) + keys)) + (selected-keys (completing-read-multiple prompt keys-alist))) + (seq-map + (lambda (key) (cdr (assoc key keys-alist))) + selected-keys))) + ;;;###autoload (defun epa-select-keys (context prompt &optional names secret) "Display a user's keyring and ask him to select keys. @@ -459,7 +489,9 @@ NAMES is a list of strings to be matched with keys. If it is nil, all the keys are listed. If SECRET is non-nil, list secret keys instead of public keys." (let ((keys (epg-list-keys context names secret))) - (epa--select-keys prompt keys))) + (pcase epa-keys-select-method + ('minibuffer (epa--select-keys-in-minibuffer prompt keys)) + (_ (epa--select-keys prompt keys))))) ;;;; Key Details diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el index 4162df00595..9fc8a4d29f4 100644 --- a/lisp/erc/erc-backend.el +++ b/lisp/erc/erc-backend.el @@ -158,7 +158,6 @@ (declare-function erc-parse-user "erc" (string)) (declare-function erc-process-away "erc" (proc away-p)) (declare-function erc-process-ctcp-query "erc" (proc parsed nick login host)) -(declare-function erc-query-buffer-p "erc" (&optional buffer)) (declare-function erc-remove-channel-member "erc" (channel nick)) (declare-function erc-remove-channel-users "erc" nil) (declare-function erc-remove-user "erc" (nick)) @@ -254,6 +253,11 @@ Entries are of the form: or (PARAMETER) if no value is provided. +where PARAMETER is a string and VALUE is a string or nil. For +compatibility, a raw parameter of the form \"FOO=\" becomes +(\"FOO\" . \"\") even though it's equivalent to the preferred +canonical form \"FOO\" and its lisp representation (\"FOO\"). + Some examples of possible parameters sent by servers: CHANMODES=b,k,l,imnpst - list of supported channel modes CHANNELLEN=50 - maximum length of channel names @@ -273,7 +277,8 @@ WALLCHOPS - supports sending messages to all operators in a channel") (defvar-local erc--isupport-params nil "Hash map of \"ISUPPORT\" params. Keys are symbols. Values are lists of zero or more strings with hex -escapes removed.") +escapes removed. ERC normalizes incoming parameters of the form +\"FOO=\" to (FOO).") ;;; Server and connection state @@ -433,7 +438,11 @@ and optionally alter the attempts tally." (defcustom erc-split-line-length 440 "The maximum length of a single message. -If a message exceeds this size, it is broken into multiple ones. +ERC normally splits chat input submitted at its prompt into +multiple messages when the initial size exceeds this value in +bytes. Modules can tell ERC to forgo splitting entirely by +setting this to zero locally or, preferably, by binding it around +a remapped `erc-send-current-line' command. IRC allows for lines up to 512 bytes. Two of them are CR LF. And a typical message looks like this: @@ -596,7 +605,8 @@ escape hatch for inhibiting their transmission.") (if (= (car cmp) (point-min)) (goto-char (nth 1 cmp)) (goto-char (car cmp))))) - (cl-assert (/= (point-min) (point))) + (when (= (point-min) (point)) + (goto-char (point-max))) (push (buffer-substring-no-properties (point-min) (point)) out) (delete-region (point-min) (point))) (or (nreverse out) (list ""))) @@ -1469,10 +1479,12 @@ for decoding." (let ((args (erc-response.command-args parsed-response)) (decode-target nil) (decoded-args ())) + ;; FIXME this should stop after the first match. (dolist (arg args nil) (when (string-match "^[#&].*" arg) (setq decode-target arg))) (when (stringp decode-target) + ;; FIXME `decode-target' should be passed as TARGET. (setq decode-target (erc-decode-string-from-target decode-target nil))) (setf (erc-response.unparsed parsed-response) (erc-decode-string-from-target @@ -2145,10 +2157,6 @@ Then display the welcome message." ;; ;; > The server SHOULD send "X", not "X="; this is the normalized form. ;; - ;; Note: for now, assume the server will only send non-empty values, - ;; possibly with printable ASCII escapes. Though in practice, the - ;; only two escapes we're likely to see are backslash and space, - ;; meaning the pattern is too liberal. (let (case-fold-search) (mapcar (lambda (v) @@ -2159,7 +2167,9 @@ Then display the welcome message." (string-match "[\\]x[0-9A-F][0-9A-F]" v start)) (setq m (substring v (+ 2 (match-beginning 0)) (match-end 0)) c (string-to-number m 16)) - (if (<= ?\ c ?~) + ;; In practice, this range is too liberal. The only + ;; escapes we're likely to see are ?\\, ?=, and ?\s. + (if (<= ?\s c ?~) (setq v (concat (substring v 0 (match-beginning 0)) (string c) (substring v (match-end 0))) @@ -2184,8 +2194,9 @@ primitive value." (or erc-server-parameters (erc-with-server-buffer erc-server-parameters))))) - (if (cdr v) - (erc--parse-isupport-value (cdr v)) + (if-let ((val (cdr v)) + ((not (string-empty-p val)))) + (erc--parse-isupport-value val) '--empty--))))) (pcase value ('--empty-- (unless single (list key))) @@ -2196,7 +2207,9 @@ primitive value." ;; While it's better to depend on interfaces than specific types, ;; using `cl-struct-slot-value' or similar to extract a known slot at ;; runtime would incur a small "ducktyping" tax, which should probably -;; be avoided when running dozens of times per incoming message. +;; be avoided when running hundreds of times per incoming message. +;; Instead of separate keys per data type, we could increment a +;; counter whenever a new 005 arrives. (defmacro erc--with-isupport-data (param var &rest body) "Return structured data stored in VAR for \"ISUPPORT\" PARAM. Expect VAR's value to be an instance of `erc--isupport-data'. If diff --git a/lisp/erc/erc-button.el b/lisp/erc/erc-button.el index 27406a76f59..4b4930e5bff 100644 --- a/lisp/erc/erc-button.el +++ b/lisp/erc/erc-button.el @@ -443,7 +443,7 @@ of the channel. However, don't bother creating an actual Instead, just spoof an `erc-server-user' and stash it during \"PRIVMSG\" handling via `erc--cmem-from-nick-function' and retrieve it during buttonizing via -`erc-button--fallback-user-function'." +`erc-button--fallback-cmem-function'." :interactive nil (if erc-button--phantom-users-mode (progn @@ -528,7 +528,8 @@ that `erc-button-add-button' adds, except for the face." '(erc-callback nil erc-data nil mouse-face nil - keymap nil))) + keymap nil)) + (erc--restore-important-text-props '(mouse-face))) (defun erc-button-add-button (from to fun nick-p &optional data regexp) "Create a button between FROM and TO with callback FUN and data DATA. diff --git a/lisp/erc/erc-common.el b/lisp/erc/erc-common.el index b8ba0673355..8388efe062c 100644 --- a/lisp/erc/erc-common.el +++ b/lisp/erc/erc-common.el @@ -37,6 +37,7 @@ (defvar erc-session-server) (declare-function erc--get-isupport-entry "erc-backend" (key &optional single)) +(declare-function erc--init-cusr-fallback-status "erc" (v h o a q)) (declare-function erc-get-buffer "erc" (target &optional proc)) (declare-function erc-server-buffer "erc" nil) (declare-function widget-apply-action "wid-edit" (widget &optional event)) @@ -49,15 +50,30 @@ (declare-function widget-type "wid-edit" (widget)) (cl-defstruct erc-input - string insertp sendp) + "Object shared among members of `erc-pre-send-functions'. +Any use outside of the hook is not supported." + ( string "" :type string + :documentation "String to send and, without `substxt', insert. +ERC treats separate lines as separate messages.") + ( insertp nil :type boolean + :documentation "Whether to insert outgoing message. +When nil, ERC still sends `string'.") + ( sendp nil :type boolean + :documentation "Whether to send and (for compat reasons) insert. +To insert without sending, define a (slash) command.") + ( substxt nil :type (or function string null) + :documentation "Alternate string to insert without splitting. +The function form is for internal use.") + ( refoldp nil :type boolean + :documentation "Whether to resplit a possibly overlong `string'. +ERC only refolds `string', never `substxt'.")) (cl-defstruct (erc--input-split (:include erc-input - (string :read-only) + (string "" :read-only t) (insertp erc-insert-this) (sendp (with-suppressed-warnings ((obsolete erc-send-this)) erc-send-this)))) - (refoldp nil :type boolean) (lines nil :type (list-of string)) (abortp nil :type (list-of symbol)) (cmdp nil :type boolean)) @@ -76,11 +92,11 @@ make-erc-channel-user ( &key voice halfop op admin owner last-message-time - &aux (status (+ (if voice 1 0) - (if halfop 2 0) - (if op 4 0) - (if admin 8 0) - (if owner 16 0))))) + &aux (status + (if (or voice halfop op admin owner) + (erc--init-cusr-fallback-status + voice halfop op admin owner) + 0)))) :named) "Object containing channel-specific data for a single user." ;; voice halfop op admin owner @@ -140,9 +156,12 @@ For use with the macro `erc--with-isupport-data'." (cl-defstruct (erc--parsed-prefix (:include erc--isupport-data)) "Server-local data for recognized membership-status prefixes. Derived from the advertised \"PREFIX\" ISUPPORT parameter." - (letters "qaohv" :type string) - (statuses "~&@%+" :type string) - (alist nil :type (list-of cons))) + ( letters "vhoaq" :type string + :documentation "Status letters ranked lowest to highest.") + ( statuses "+%@&~" :type string + :documentation "Status prefixes ranked lowest to highest.") + ( alist nil :type (list-of cons) + :documentation "Alist of letters-prefix pairs.")) (cl-defstruct (erc--channel-mode-types (:include erc--isupport-data)) "Server-local \"CHANMODES\" data." @@ -152,7 +171,7 @@ Derived from the advertised \"PREFIX\" ISUPPORT parameter." ;; After dropping 28, we can use prefixed "erc-autoload" cookies. (defun erc--normalize-module-symbol (symbol) - "Return preferred SYMBOL for `erc--modules'." + "Return preferred SYMBOL for `erc--module'." (while-let ((canonical (get symbol 'erc--module)) ((not (eq canonical symbol)))) (setq symbol canonical)) @@ -333,6 +352,7 @@ instead of a `set' state, which precludes any actual saving." (read (current-buffer)))) (defmacro erc--find-feature (name alias) + ;; Don't use this outside of the file that defines NAME. `(pcase (erc--find-group ',name ,(and alias (list 'quote alias))) ('erc (and-let* ((file (or (macroexp-file-name) buffer-file-name))) (intern (file-name-base file)))) @@ -350,8 +370,12 @@ See Info node `(elisp) Defining Minor Modes' for more.") (defmacro define-erc-module (name alias doc enable-body disable-body &optional local-p) "Define a new minor mode using ERC conventions. -Symbol NAME is the name of the module. -Symbol ALIAS is the alias to use, or nil. +Expect NAME to be the module's name and ALIAS, when non-nil, to +be a retired name used only for compatibility purposes. In new +code, assume NAME is the same symbol users should specify when +customizing `erc-modules' (see info node `(erc) Module Loading' +for more on naming). + DOC is the documentation string to use for the minor mode. ENABLE-BODY is a list of expressions used to enable the mode. DISABLE-BODY is a list of expressions used to disable the mode. @@ -382,7 +406,10 @@ Example: (let* ((sn (symbol-name name)) (mode (intern (format "erc-%s-mode" (downcase sn)))) (enable (intern (format "erc-%s-enable" (downcase sn)))) - (disable (intern (format "erc-%s-disable" (downcase sn))))) + (disable (intern (format "erc-%s-disable" (downcase sn)))) + (nmodule (erc--normalize-module-symbol name)) + (amod (and alias (intern (format "erc-%s-mode" + (downcase (symbol-name alias))))))) `(progn (define-minor-mode ,mode @@ -399,13 +426,9 @@ if ARG is omitted or nil. (if ,mode (,enable) (,disable)))) ,(erc--assemble-toggle local-p name enable mode t enable-body) ,(erc--assemble-toggle local-p name disable mode nil disable-body) - ,@(and-let* ((alias) - ((not (eq name alias))) - (aname (intern (format "erc-%s-mode" - (downcase (symbol-name alias)))))) - `((defalias ',aname #',mode) - (put ',aname 'erc-module ',(erc--normalize-module-symbol name)))) - (put ',mode 'erc-module ',(erc--normalize-module-symbol name)) + ,@(and amod `((defalias ',amod #',mode) + (put ',amod 'erc-module ',nmodule))) + (put ',mode 'erc-module ',nmodule) ;; For find-function and find-variable. (put ',mode 'definition-name ',name) (put ',enable 'definition-name ',name) @@ -462,10 +485,9 @@ If no server buffer exists, return nil." ,@body))))) (defmacro erc-with-all-buffers-of-server (process pred &rest forms) - "Execute FORMS in all buffers which have same process as this server. -FORMS will be evaluated in all buffers having the process PROCESS and -where PRED matches or in all buffers of the server process if PRED is -nil." + "Evaluate FORMS in all buffers of PROCESS in which PRED returns non-nil. +When PROCESS is nil, do so in all ERC buffers. When PRED is nil, +run FORMS unconditionally." (declare (indent 2) (debug (form form body))) (macroexp-let2 nil pred pred `(erc-buffer-filter (lambda () @@ -554,9 +576,21 @@ See `erc-define-message-format-catalog' for the meaning of ENTRIES, an alist, and `erc-tests-common-pp-propertized-parts' in tests/lisp/erc/erc-tests.el for a convenience command to convert a literal string into a sequence of `propertize' forms, which are -much easier to review and edit." +much easier to review and edit. When ENTRIES begins with a +sequence of keyword-value pairs remove them and consider their +evaluated values before processing the alist proper. + +Currently, the only recognized keyword is `:parent', which tells +ERC to search recursively for a given template key using the +keyword's associated value, another catalog symbol, if not found +in catalog NAME." (declare (indent 1)) (let (out) + (while (keywordp (car entries)) + (push (pcase-exhaustive (pop entries) + (:parent `(put ',name 'erc--base-format-catalog + ,(pop entries)))) + out)) (dolist (e entries (cons 'progn (nreverse out))) (push `(defvar ,(intern (format "erc-message-%s-%s" name (car e))) ,(cdr e) @@ -575,9 +609,14 @@ symbol, and FORMAT evaluates to a format string compatible with `format-spec'. Expect modules that only define a handful of entries to do so manually, instead of using this macro, so that the resulting variables will end up with more useful doc strings." - (declare (indent 1)) + (declare (indent 1) + (debug (symbolp [&rest [keywordp form]] &rest (symbolp . form)))) `(erc--define-catalog ,language ,entries)) +(define-inline erc--strpos (char string) + "Return position of CHAR in STRING or nil if not found." + (inline-quote (string-search (string ,char) ,string))) + (defmacro erc--doarray (spec &rest body) "Map over ARRAY, running BODY with VAR bound to iteration element. Behave more or less like `seq-doseq', but tailor operations for diff --git a/lisp/erc/erc-compat.el b/lisp/erc/erc-compat.el index dede833a93d..b5b8fbaf8ab 100644 --- a/lisp/erc/erc-compat.el +++ b/lisp/erc/erc-compat.el @@ -31,51 +31,11 @@ ;;; Code: -(require 'compat nil 'noerror) +(require 'compat) (eval-when-compile (require 'cl-lib)) -;; Except for the "erc-" namespacing, these two definitions should be -;; continuously updated to match the latest upstream ones verbatim. -;; Although they're pretty simple, it's likely not worth checking for -;; and possibly deferring to the non-prefixed versions. -;; -;; BEGIN Compat macros - -;;;; Macros for extended compatibility function calls - -(defmacro erc-compat-function (fun) - "Return compatibility function symbol for FUN. - -If the Emacs version provides a sufficiently recent version of -FUN, the symbol FUN is returned itself. Otherwise the macro -returns the symbol of a compatibility function which supports the -behavior and calling convention of the current stable Emacs -version. For example Compat 29.1 will provide compatibility -functions which implement the behavior and calling convention of -Emacs 29.1. - -See also `compat-call' to directly call compatibility functions." - (let ((compat (intern (format "compat--%s" fun)))) - `#',(if (fboundp compat) compat fun))) - -(defmacro erc-compat-call (fun &rest args) - "Call compatibility function or macro FUN with ARGS. - -A good example function is `plist-get' which was extended with an -additional predicate argument in Emacs 29.1. The compatibility -function, which supports this additional argument, can be -obtained via (compat-function plist-get) and called -via (compat-call plist-get plist prop predicate). It is not -possible to directly call (plist-get plist prop predicate) on -Emacs older than 29.1, since the original `plist-get' function -does not yet support the predicate argument. Note that the -Compat library never overrides existing functions. - -See also `compat-function' to lookup compatibility functions." - (let ((compat (intern (format "compat--%s" fun)))) - `(,(if (fboundp compat) compat fun) ,@args))) - -;; END Compat macros +(define-obsolete-function-alias 'erc-compat-function #'compat-function "30.1") +(define-obsolete-function-alias 'erc-compat-call #'compat-call "30.1") ;;;###autoload(autoload 'erc-define-minor-mode "erc-compat") (define-obsolete-function-alias 'erc-define-minor-mode @@ -102,7 +62,7 @@ See `erc-encoding-coding-alist'." (defun erc-set-write-file-functions (new-val) (declare (obsolete nil "28.1")) - (set (make-local-variable 'write-file-functions) new-val)) + (setq-local write-file-functions new-val)) (defvar erc-emacs-build-time (if (or (stringp emacs-build-time) (not emacs-build-time)) diff --git a/lisp/erc/erc-dcc.el b/lisp/erc/erc-dcc.el index 522973a0156..b8e16df755b 100644 --- a/lisp/erc/erc-dcc.el +++ b/lisp/erc/erc-dcc.el @@ -619,7 +619,7 @@ It lists the current state of `erc-dcc-list' in an easy to read manner." (buffer-live-p (get-buffer (plist-get elt :file))) (plist-member elt :size)) (let ((byte-count (with-current-buffer - (get-buffer (plist-get elt :file)) + (plist-get elt :file) (+ (buffer-size) 0.0 erc-dcc-byte-count)))) (format " (%d%%)" diff --git a/lisp/erc/erc-desktop-notifications.el b/lisp/erc/erc-desktop-notifications.el index 2e905097f97..9bb89fbfc81 100644 --- a/lisp/erc/erc-desktop-notifications.el +++ b/lisp/erc/erc-desktop-notifications.el @@ -54,6 +54,9 @@ (defvar dbus-debug) ; used in the macroexpansion of dbus-ignore-errors +(declare-function haiku-notifications-notify "haikuselect.c") +(declare-function android-notifications-notify "androidselect.c") + (defun erc-notifications-notify (nick msg &optional privp) "Notify that NICK send some MSG, where PRIVP should be non-nil for PRIVMSGs. This will replace the last notification sent with this function." @@ -64,14 +67,19 @@ This will replace the last notification sent with this function." (let* ((channel (if privp (erc-get-buffer nick) (current-buffer))) (title (format "%s in %s" (xml-escape-string nick t) channel)) (body (xml-escape-string (erc-controls-strip msg) t))) - (notifications-notify :bus erc-notifications-bus - :title title - :body body - :replaces-id erc-notifications-last-notification - :app-icon erc-notifications-icon - :actions '("default" "Switch to buffer") - :on-action (lambda (&rest _) - (pop-to-buffer channel))))))) + (funcall (cond ((featurep 'android) + #'android-notifications-notify) + ((featurep 'haiku) + #'haiku-notifications-notify) + (t #'notifications-notify)) + :bus erc-notifications-bus + :title title + :body body + :replaces-id erc-notifications-last-notification + :app-icon erc-notifications-icon + :actions '("default" "Switch to buffer") + :on-action (lambda (&rest _) + (pop-to-buffer channel))))))) (defun erc-notifications-PRIVMSG (_proc parsed) (let ((nick (car (erc-parse-user (erc-response.sender parsed)))) diff --git a/lisp/erc/erc-fill.el b/lisp/erc/erc-fill.el index b91ce007087..aa12b807fbc 100644 --- a/lisp/erc/erc-fill.el +++ b/lisp/erc/erc-fill.el @@ -44,11 +44,7 @@ (define-erc-module fill nil "Manage filling in ERC buffers. ERC fill mode is a global minor mode. When enabled, messages in -the channel buffers are filled." - ;; FIXME ensure a consistent ordering relative to hook members from - ;; other modules. Ideally, this module's processing should happen - ;; after "morphological" modifications to a message's text but - ;; before superficial decorations. +channel buffers are filled. See also `erc-fill-wrap-mode'." ((add-hook 'erc-insert-modify-hook #'erc-fill 60) (add-hook 'erc-send-modify-hook #'erc-fill 60)) ((remove-hook 'erc-insert-modify-hook #'erc-fill) @@ -425,8 +421,11 @@ is 0, reset to value of `erc-fill-wrap-visual-keys'." "<remap> <erc-bol>" #'erc-fill--wrap-beginning-of-line) (defvar erc-button-mode) +(defvar erc-scrolltobottom-mode) (defvar erc-legacy-invisible-bounds-p) +(defvar erc--fill-wrap-scrolltobottom-exempt-p nil) + (defun erc-fill--wrap-ensure-dependencies () (with-suppressed-warnings ((obsolete erc-legacy-invisible-bounds-p)) (when erc-legacy-invisible-bounds-p @@ -439,6 +438,10 @@ is 0, reset to value of `erc-fill-wrap-visual-keys'." (unless erc-fill-mode (push 'fill missing-deps) (erc-fill-mode +1)) + (unless (or erc-scrolltobottom-mode erc--fill-wrap-scrolltobottom-exempt-p + (memq 'scrolltobottom erc-modules)) + (push 'scrolltobottom missing-deps) + (erc-scrolltobottom-mode +1)) (when erc-fill-wrap-merge (require 'erc-button) (unless erc-button-mode @@ -459,27 +462,25 @@ is 0, reset to value of `erc-fill-wrap-visual-keys'." ;;;###autoload(put 'fill-wrap 'erc--feature 'erc-fill) (define-erc-module fill-wrap nil "Fill style leveraging `visual-line-mode'. + This module displays nicks overhanging leftward to a common -offset, as determined by the option `erc-fill-static-center'. -And it \"wraps\" messages at a common margin width, as determined -by the option `erc-fill-wrap-margin-width'. To use it, either -include `fill-wrap' in `erc-modules' or set `erc-fill-function' -to `erc-fill-wrap'. Most users will want to enable the -`scrolltobottom' module as well. - -During sessions in which this module is active, use -\\[erc-fill-wrap-nudge] to adjust the width of the indent and the -stamp margin, and use \\[erc-fill-wrap-toggle-truncate-lines] for -cycling between logical- and screen-line oriented command -movement. Similarly, use \\[erc-fill-wrap-refill-buffer] to fix -alignment problems after running certain commands, like -`text-scale-adjust'. Also see related stylistic options -`erc-fill-wrap-merge', and `erc-fill-wrap-merge-indicator'. -\(Hint: in narrow windows, where is space tight, try setting -`erc-fill-static-center' to 1. And if you also use the option -`erc-fill-wrap-merge-indicator', set that to value-menu item -\"Leading MIDDLE DOT sans gap\" or one of the various -\"trailing\" items.) +offset, as determined by the option `erc-fill-static-center'. It +also \"wraps\" messages at a common width, as determined by the +option `erc-fill-wrap-margin-width'. To use it, either include +`fill-wrap' in `erc-modules' or set `erc-fill-function' to +`erc-fill-wrap'. + +Once enabled, use \\[erc-fill-wrap-nudge] to adjust the width of +the indent and the stamp margin. And For cycling between +logical- and screen-line oriented command movement, see +\\[erc-fill-wrap-toggle-truncate-lines]. Similarly, use +\\[erc-fill-wrap-refill-buffer] to fix alignment problems after +running certain commands, like `text-scale-adjust'. Also see +related stylistic options `erc-fill-wrap-merge', and +`erc-fill-wrap-merge-indicator'. (Hint: in narrow windows, try +setting `erc-fill-static-center' to 1, and if you use +`erc-fill-wrap-merge-indicator', choose \"Leading MIDDLE DOT sans +gap\" or one of the \"trailing\" items from the Customize menu.) This module imposes various restrictions on the appearance of timestamps. Most notably, it insists on displaying them in the @@ -497,11 +498,12 @@ a workaround provided by `erc-stamp-prefix-log-filter', which strips trailing stamps from logged messages and instead prepends them to every line. -As a so-called \"local\" module, `fill-wrap' depends on the -global modules `fill', `stamp', and `button'; it activates them -as needed when initializing. Please note that enabling and -disabling this module by invoking one of its minor-mode toggles -is not recommended." +A so-called \"local\" module, `fill-wrap' depends on the global +modules `fill', `stamp', `button', and `scrolltobottom'. It +activates them as needed when initializing and leaves them +enabled when shutting down. To opt out of `scrolltobottom' +specifically, disable its minor mode, `erc-scrolltobottom-mode', +via `erc-fill-wrap-mode-hook'." ((erc-fill--wrap-ensure-dependencies) (erc--restore-initialize-priors erc-fill-wrap-mode erc-fill--wrap-visual-keys erc-fill-wrap-visual-keys @@ -832,7 +834,7 @@ decorations applied by third-party modules." (line (count-screen-lines (window-start) (window-point)))) (when (zerop arg) (setq arg 1)) - (erc-compat-call + (compat-call set-transient-map (let ((map (make-sparse-keymap))) (dolist (key '(?= ?- ?0)) diff --git a/lisp/erc/erc-goodies.el b/lisp/erc/erc-goodies.el index c5ab25bea98..fe44c3bdfcb 100644 --- a/lisp/erc/erc-goodies.el +++ b/lisp/erc/erc-goodies.el @@ -83,7 +83,7 @@ be experimental. It currently only works with Emacs 28+." (when (and erc-scrolltobottom-all (< emacs-major-version 28)) (erc-button--display-error-notice-with-keys "Option `erc-scrolltobottom-all' requires Emacs 28+. Disabling.") - (setopt erc-scrolltobottom-all nil)) + (setq erc-scrolltobottom-all nil)) (unless erc--updating-modules-p (erc-buffer-do #'erc--scrolltobottom-setup)) (if erc-scrolltobottom-all (progn @@ -331,14 +331,15 @@ buffer than the window's start." (defvar-local erc--keep-place-indicator-overlay nil "Overlay for `erc-keep-place-indicator-mode'.") -(defun erc--keep-place-indicator-on-window-buffer-change (window) +(defun erc--keep-place-indicator-on-window-buffer-change (_) "Maybe sync `erc--keep-place-indicator-overlay'. Do so only when switching to a new buffer in the same window if the replaced buffer is no longer visible in another window and its `window-start' at the time of switching is strictly greater than the indicator's position." (when-let ((erc-keep-place-indicator-follow) - ((eq window (selected-window))) + (window (selected-window)) + ((not (eq window (active-minibuffer-window)))) (old-buffer (window-old-buffer window)) ((buffer-live-p old-buffer)) ((not (eq old-buffer (current-buffer)))) @@ -352,67 +353,70 @@ than the indicator's position." (with-current-buffer old-buffer (erc-keep-place-move old-start)))) -(defun erc--keep-place-indicator-setup () - "Initialize buffer for maintaining `erc--keep-place-indicator-overlay'." - (require 'fringe) - (erc--restore-initialize-priors erc-keep-place-indicator-mode - erc--keep-place-indicator-overlay (make-overlay 0 0)) - (add-hook 'erc-keep-place-mode-hook - #'erc--keep-place-indicator-on-global-module nil t) - (add-hook 'window-buffer-change-functions - #'erc--keep-place-indicator-on-window-buffer-change 40 t) - (when-let* (((memq erc-keep-place-indicator-style '(t arrow))) - (ov-property (if (zerop (fringe-columns 'left)) - 'after-string - 'before-string)) - (display (if (zerop (fringe-columns 'left)) - `((margin left-margin) ,overlay-arrow-string) - '(left-fringe right-triangle - erc-keep-place-indicator-arrow))) - (bef (propertize " " 'display display))) - (overlay-put erc--keep-place-indicator-overlay ov-property bef)) - (when (memq erc-keep-place-indicator-style '(t face)) - (overlay-put erc--keep-place-indicator-overlay 'face - 'erc-keep-place-indicator-line))) - ;;;###autoload(put 'keep-place-indicator 'erc--feature 'erc-goodies) +;;;###autoload(autoload 'erc-keep-place-indicator-mode "erc-goodies" nil t) (define-erc-module keep-place-indicator nil "Buffer-local `keep-place' with fringe arrow and/or highlighted face. Play nice with global module `keep-place' but don't depend on it. Expect that users may want different combinations of `keep-place' -and `keep-place-indicator' in different buffers. Unlike global -`keep-place', when `switch-to-buffer-preserve-window-point' is -enabled, don't forcibly sync point in all windows where buffer -has previously been shown because that defeats the purpose of -having a placeholder." +and `keep-place-indicator' in different buffers." ((cond (erc-keep-place-mode) ((memq 'keep-place erc-modules) (erc-keep-place-mode +1)) ;; Enable a local version of `keep-place-mode'. (t (add-hook 'erc-insert-pre-hook #'erc-keep-place 65 t))) + (require 'fringe) + (add-hook 'window-buffer-change-functions + #'erc--keep-place-indicator-on-window-buffer-change 40) + (add-hook 'erc-keep-place-mode-hook + #'erc--keep-place-indicator-on-global-module 40) (if (pcase erc-keep-place-indicator-buffer-type ('target erc--target) ('server (not erc--target)) ('t t)) - (erc--keep-place-indicator-setup) + (progn + (erc--restore-initialize-priors erc-keep-place-indicator-mode + erc--keep-place-indicator-overlay (make-overlay 0 0)) + (when-let (((memq erc-keep-place-indicator-style '(t arrow))) + (ov-property (if (zerop (fringe-columns 'left)) + 'after-string + 'before-string)) + (display (if (zerop (fringe-columns 'left)) + `((margin left-margin) ,overlay-arrow-string) + '(left-fringe right-triangle + erc-keep-place-indicator-arrow))) + (bef (propertize " " 'display display))) + (overlay-put erc--keep-place-indicator-overlay ov-property bef)) + (when (memq erc-keep-place-indicator-style '(t face)) + (overlay-put erc--keep-place-indicator-overlay 'face + 'erc-keep-place-indicator-line))) (erc-keep-place-indicator-mode -1))) ((when erc--keep-place-indicator-overlay (delete-overlay erc--keep-place-indicator-overlay)) - (remove-hook 'window-buffer-change-functions - #'erc--keep-place-indicator-on-window-buffer-change t) + (let ((buffer (current-buffer))) + ;; Remove global hooks unless others exist with mode enabled. + (unless (erc-buffer-filter (lambda () + (and (not (eq buffer (current-buffer))) + erc-keep-place-indicator-mode))) + (remove-hook 'erc-keep-place-mode-hook + #'erc--keep-place-indicator-on-global-module) + (remove-hook 'window-buffer-change-functions + #'erc--keep-place-indicator-on-window-buffer-change))) + (when (local-variable-p 'erc-insert-pre-hook) + (remove-hook 'erc-insert-pre-hook #'erc-keep-place t)) (remove-hook 'erc-keep-place-mode-hook #'erc--keep-place-indicator-on-global-module t) - (remove-hook 'erc-insert-pre-hook #'erc-keep-place t) (kill-local-variable 'erc--keep-place-indicator-overlay)) 'local) (defun erc--keep-place-indicator-on-global-module () - "Ensure `keep-place-indicator' can cope with `erc-keep-place-mode'. -That is, ensure the local module can survive a user toggling the -global one." - (if erc-keep-place-mode - (remove-hook 'erc-insert-pre-hook #'erc-keep-place t) - (add-hook 'erc-insert-pre-hook #'erc-keep-place 65 t))) + "Ensure `keep-place-indicator' survives toggling `erc-keep-place-mode'. +Do this by simulating `keep-place' in all buffers where +`keep-place-indicator' is enabled." + (erc-with-all-buffers-of-server nil (lambda () erc-keep-place-indicator-mode) + (if erc-keep-place-mode + (remove-hook 'erc-insert-pre-hook #'erc-keep-place t) + (add-hook 'erc-insert-pre-hook #'erc-keep-place 65 t)))) (defun erc-keep-place-move (pos) "Move keep-place indicator to current line or POS. @@ -579,15 +583,18 @@ Do nothing if the variable `erc-command-indicator' is nil." "Insert `erc-input' STATE's message if it's an echoed command." (cl-assert erc-command-indicator-mode) (when (erc--input-split-cmdp state) - (setf (erc--input-split-insertp state) #'erc--command-indicator-display) + (setf (erc--input-split-insertp state) t + (erc--input-split-substxt state) #'erc--command-indicator-display) (erc-send-distinguish-noncommands state))) ;; This function used to be called `erc-display-command'. It was ;; neutered in ERC 5.3.x (Emacs 24.5), commented out in 5.4, removed ;; in 5.5, and restored in 5.6. -(defun erc--command-indicator-display (line) +(defun erc--command-indicator-display (line &rest rest) "Insert command LINE as echoed input resembling that of REPLs and shells." (when erc-insert-this + (when rest + (setq line (string-join (cons line rest) "\n"))) (save-excursion (erc--assert-input-bounds) (let ((insert-position (marker-position (goto-char erc-insert-marker))) @@ -618,6 +625,48 @@ Do nothing if the variable `erc-command-indicator' is nil." erc--msg-props)))) (erc--refresh-prompt)))) +;;;###autoload +(defun erc-load-irc-script-lines (lines &optional force noexpand) + "Process a list of LINES as prompt input submissions. +If optional NOEXPAND is non-nil, do not expand script-specific +substitution sequences via `erc-process-script-line' and instead +process LINES as literal prompt input. With FORCE, bypass flood +protection." + ;; The various erc-cmd-CMDs were designed to return non-nil when + ;; their command line should be echoed. But at some point, these + ;; handlers began displaying their own output, which naturally + ;; appeared *above* the echoed command. This tries to intercept + ;; these insertions, deferring them until the command has returned + ;; and its command line has been printed. + (cl-assert (eq 'erc-mode major-mode)) + (let ((args (and erc-script-args + (if (string-match "^ " erc-script-args) + (substring erc-script-args 1) + erc-script-args)))) + (with-silent-modifications + (dolist (line lines) + (erc-log (concat "erc-load-script: CMD: " line)) + (unless (string-match (rx bot (* (syntax whitespace)) eot) line) + (unless noexpand + (setq line (erc-process-script-line line args))) + (let ((erc--current-line-input-split (erc--make-input-split line)) + calls insertp) + (add-function :around (local 'erc--send-message-nested-function) + (lambda (&rest args) (push args calls)) + '((name . erc-script-lines-fn) (depth . -80))) + (add-function :around (local 'erc--send-action-function) + (lambda (&rest args) (push args calls)) + '((name . erc-script-lines-fn) (depth . -80))) + (setq insertp + (unwind-protect (erc-process-input-line line force) + (remove-function (local 'erc--send-action-function) + 'erc-script-lines-fn) + (remove-function (local 'erc--send-message-nested-function) + 'erc-script-lines-fn))) + (when (and insertp erc-script-echo) + (erc--command-indicator-display line) + (dolist (call calls) + (apply (car call) (cdr call)))))))))) ;;; IRC control character processing. (defgroup erc-control-characters nil @@ -654,13 +703,11 @@ The value `erc-interpret-controls-p' must also be t for this to work." :group 'erc-faces) (defface erc-inverse-face - '((t :foreground "White" :background "Black")) + '((t :inverse-video t)) "ERC inverse face." :group 'erc-faces) -(defface erc-spoiler-face - '((((background light)) :foreground "DimGray" :background "DimGray") - (((background dark)) :foreground "LightGray" :background "LightGray")) +(defface erc-spoiler-face '((t :inherit default)) "ERC spoiler face." :group 'erc-faces) @@ -668,6 +715,8 @@ The value `erc-interpret-controls-p' must also be t for this to work." "ERC underline face." :group 'erc-faces) +;; FIXME rename these to something like `erc-control-color-N-fg', +;; and deprecate the old names via `define-obsolete-face-alias'. (defface fg:erc-color-face0 '((t :foreground "White")) "ERC face." :group 'erc-faces) @@ -797,7 +846,7 @@ The value `erc-interpret-controls-p' must also be t for this to work." (intern (concat "bg:erc-color-face" (number-to-string n)))) ((< 15 n 99) (list :background (aref erc--controls-additional-colors (- n 16)))) - (t (erc-log (format " Wrong color: %s" n)) '(default))))) + (t (erc-log (format " Wrong color: %s" n)) nil)))) (defun erc-get-fg-color-face (n) "Fetches the right face for foreground color N (0-15)." @@ -813,12 +862,12 @@ The value `erc-interpret-controls-p' must also be t for this to work." (intern (concat "fg:erc-color-face" (number-to-string n)))) ((< 15 n 99) (list :foreground (aref erc--controls-additional-colors (- n 16)))) - (t (erc-log (format " Wrong color: %s" n)) '(default))))) + (t (erc-log (format " Wrong color: %s" n)) nil)))) ;;;###autoload(autoload 'erc-irccontrols-mode "erc-goodies" nil t) (define-erc-module irccontrols nil "This mode enables the interpretation of IRC control chars." - ((add-hook 'erc-insert-modify-hook #'erc-controls-highlight) + ((add-hook 'erc-insert-modify-hook #'erc-controls-highlight -50) (add-hook 'erc-send-modify-hook #'erc-controls-highlight) (erc--modify-local-map t "C-c C-c" #'erc-toggle-interpret-controls)) ((remove-hook 'erc-insert-modify-hook #'erc-controls-highlight) @@ -868,7 +917,7 @@ See `erc-interpret-controls-p' and `erc-interpret-mirc-color' for options." (setq s (replace-match "" nil nil s 1)) (cond ((and erc-interpret-mirc-color (or fg-color bg-color)) (setq fg fg-color) - (setq bg bg-color)) + (when bg-color (setq bg bg-color))) ((string= control "\C-b") (setq boldp (not boldp))) ((string= control "\C-]") @@ -929,7 +978,7 @@ Also see `erc-interpret-controls-p' and `erc-interpret-mirc-color'." (replace-match "" nil nil nil 1) (cond ((and erc-interpret-mirc-color (or fg-color bg-color)) (setq fg fg-color) - (setq bg bg-color)) + (when bg-color (setq bg bg-color))) ((string= control "\C-b") (setq boldp (not boldp))) ((string= control "\C-]") @@ -961,13 +1010,16 @@ Also see `erc-interpret-controls-p' and `erc-interpret-mirc-color'." "Prepend properties from IRC control characters between FROM and TO. If optional argument STR is provided, apply to STR, otherwise prepend properties to a region in the current buffer." - (if (and fg bg (equal fg bg)) - (progn - (setq fg 'erc-spoiler-face - bg nil) - (put-text-property from to 'mouse-face 'erc-inverse-face str)) - (when fg (setq fg (erc-get-fg-color-face fg))) - (when bg (setq bg (erc-get-bg-color-face bg)))) + (when (and fg bg (equal fg bg) (not (equal fg "99"))) + (add-text-properties from to '( mouse-face erc-spoiler-face + cursor-face erc-spoiler-face) + str) + (erc--reserve-important-text-props from to + '( mouse-face erc-spoiler-face + cursor-face erc-spoiler-face) + str)) + (when fg (setq fg (erc-get-fg-color-face fg))) + (when bg (setq bg (erc-get-bg-color-face bg))) (font-lock-prepend-text-property from to diff --git a/lisp/erc/erc-networks.el b/lisp/erc/erc-networks.el index 99c3c0563d0..1b26afa1164 100644 --- a/lisp/erc/erc-networks.el +++ b/lisp/erc/erc-networks.el @@ -1123,10 +1123,27 @@ TARGET to be an `erc--target' object." (lambda () (when (and erc--target (eq (erc--target-symbol erc--target) (erc--target-symbol target))) - (let ((oursp (if (erc--target-channel-local-p target) - (equal announced erc-server-announced-name) - (erc-networks--id-equal-p identity erc-networks--id)))) - (funcall (if oursp on-dupe on-collision)))))))) + ;; When a server sends administrative queries immediately + ;; after connection registration and before the session has a + ;; net-id, the buffer remains orphaned until reassociated + ;; here retroactively. + (unless erc-networks--id + (let ((id (erc-with-server-buffer erc-networks--id)) + (server-buffer (process-buffer erc-server-process))) + (apply #'erc-button--display-error-notice-with-keys + server-buffer + (concat "Missing network session (ID) for %S. " + (if id "Using `%S' from %S." "Ignoring.")) + (current-buffer) + (and id (list (erc-networks--id-symbol + (setq erc-networks--id id)) + server-buffer))))) + (when erc-networks--id + (let ((oursp (if (erc--target-channel-local-p target) + (equal announced erc-server-announced-name) + (erc-networks--id-equal-p identity + erc-networks--id)))) + (funcall (if oursp on-dupe on-collision))))))))) (defconst erc-networks--qualified-sep "@" "Separator used for naming a target buffer.") diff --git a/lisp/erc/erc-pcomplete.el b/lisp/erc/erc-pcomplete.el index 52ebdc83e5e..05cbaf3872f 100644 --- a/lisp/erc/erc-pcomplete.el +++ b/lisp/erc/erc-pcomplete.el @@ -58,7 +58,9 @@ add this string to nicks completed." ;;;###autoload(put 'Completion 'erc--module 'completion) ;;;###autoload(put 'pcomplete 'erc--module 'completion) +;;;###autoload(put 'completion 'erc--feature 'erc-pcomplete) ;;;###autoload(autoload 'erc-completion-mode "erc-pcomplete" nil t) +(put 'completion 'erc-group 'erc-pcomplete) (define-erc-module pcomplete Completion "In ERC Completion mode, the TAB key does completion whenever possible." ((add-hook 'erc-mode-hook #'pcomplete-erc-setup) diff --git a/lisp/erc/erc-speedbar.el b/lisp/erc/erc-speedbar.el index 5fcea056e3e..a81a3869436 100644 --- a/lisp/erc/erc-speedbar.el +++ b/lisp/erc/erc-speedbar.el @@ -545,6 +545,30 @@ The INDENT level is ignored." (speedbar-set-mode-line-format)))) (defvar erc-speedbar--shutting-down-p nil) +(defvar erc-speedbar--force-update-interval-secs 5 "Speedbar update period.") + +(defvar-local erc-speedbar--last-ran nil + "When non-nil, a lisp timestamp updated when the speedbar timer runs.") + +(defun erc-speedbar--run-timer-on-post-insert () + "Refresh speedbar if idle for `erc-speedbar--force-update-interval-secs'." + (when speedbar-buffer + (with-current-buffer speedbar-buffer + (when-let + ((dframe-timer) + ((erc--check-msg-prop 'erc--cmd 'PRIVMSG)) + (interval erc-speedbar--force-update-interval-secs) + ((or (null erc-speedbar--last-ran) + (time-less-p erc-speedbar--last-ran + (time-subtract (current-time) interval))))) + (run-at-time 0 nil #'dframe-timer-fn))))) + +(defun erc-speedbar--reset-last-ran-on-timer () + "Reset `erc-speedbar--last-ran'." + (when speedbar-buffer + (with-suppressed-warnings ((obsolete buffer-local-value)) ; <=29 + (setf (buffer-local-value 'erc-speedbar--last-ran speedbar-buffer) + (current-time))))) ;;;###autoload(autoload 'erc-nickbar-mode "erc-speedbar" nil t) (define-erc-module nickbar nil @@ -559,6 +583,8 @@ raising of frames or the stealing of input focus. If you witness such a thing and can reproduce it, please file a bug report with \\[erc-bug]." ((add-hook 'erc--setup-buffer-hook #'erc-speedbar--ensure) + (add-hook 'erc-insert-post-hook #'erc-speedbar--run-timer-on-post-insert) + (add-hook 'speedbar-timer-hook #'erc-speedbar--reset-last-ran-on-timer) (erc-speedbar--ensure) (unless (or erc--updating-modules-p (and-let* ((speedbar-buffer) @@ -569,6 +595,8 @@ such a thing and can reproduce it, please file a bug report with (with-current-buffer buf (erc-speedbar--ensure 'force))))) ((remove-hook 'erc--setup-buffer-hook #'erc-speedbar--ensure) + (remove-hook 'erc-insert-post-hook #'erc-speedbar--run-timer-on-post-insert) + (remove-hook 'speedbar-timer-hook #'erc-speedbar--reset-last-ran-on-timer) (when erc-track-mode (setq erc-track--switch-fallback-blockers (remove '(derived-mode . speedbar-mode) diff --git a/lisp/erc/erc-stamp.el b/lisp/erc/erc-stamp.el index 558afd19427..bcb9b4aafef 100644 --- a/lisp/erc/erc-stamp.el +++ b/lisp/erc/erc-stamp.el @@ -184,7 +184,7 @@ from entering them and instead jump over them." (add-hook 'erc-mode-hook #'erc-stamp--recover-on-reconnect) (add-hook 'erc--pre-clear-functions #'erc-stamp--reset-on-clear 40) (unless erc--updating-modules-p (erc-buffer-do #'erc-stamp--setup))) - ((remove-hook 'erc-mode-hook #'erc-munge-invisibility-spec) + ((remove-hook 'erc-mode-hook #'erc-stamp--setup) (remove-hook 'erc-insert-modify-hook #'erc-add-timestamp) (remove-hook 'erc-send-modify-hook #'erc-add-timestamp) (remove-hook 'erc-mode-hook #'erc-stamp--recover-on-reconnect) @@ -198,6 +198,7 @@ from entering them and instead jump over them." "Escape hatch for omitting stamps when first char is invisible.") (defun erc-stamp--recover-on-reconnect () + "Attempt to restore \"last-inserted\" snapshots from prior session." (when-let ((priors (or erc--server-reconnecting erc--target-priors))) (dolist (var '(erc-timestamp-last-inserted erc-timestamp-last-inserted-left @@ -622,6 +623,7 @@ printed just after each line's text (no alignment)." ((guard erc-stamp--display-margin-mode) (let ((s (propertize (substring-no-properties string) 'invisible erc-stamp--invisible-property))) + (insert " ") (put-text-property 0 (length string) 'display `((margin right-margin) ,s) string))) @@ -722,9 +724,6 @@ inserted is a date stamp." 'hash-table)) (erc-timestamp-last-inserted-left rendered) erc-timestamp-format erc-away-timestamp-format) - ;; FIXME delete once convinced adjustment correct. - (cl-assert (string= rendered - (erc-stamp--format-date-stamp aligned))) (erc-add-timestamp)) (setq erc-timestamp-last-inserted-left rendered))))) @@ -827,11 +826,16 @@ left-sided stamps and date stamps inserted by this function." ;; perform day alignments via this function only when needed. (defun erc-stamp--time-as-day (current-time) "Discard hour, minute, and second info from timestamp CURRENT-TIME." + (defvar current-time-list) ; <=28 (let* ((current-time-list) ; flag (decoded (decode-time current-time erc-stamp--tz))) (setf (decoded-time-second decoded) 0 (decoded-time-minute decoded) 0 - (decoded-time-hour decoded) 0) + (decoded-time-hour decoded) 0 + (decoded-time-dst decoded) -1 + (decoded-time-weekday decoded) nil + (decoded-time-zone decoded) + (and erc-stamp--tz (car (current-time-zone nil erc-stamp--tz)))) (encode-time decoded))) ; may return an integer (defun erc-format-timestamp (time format) @@ -854,12 +858,20 @@ Return the empty string if FORMAT is nil." (defvar-local erc-stamp--csf-props-updated-p nil) -;; This function is used to munge `buffer-invisibility-spec' to an -;; appropriate value. Currently, it only handles timestamps, thus its -;; location. If you add other features which affect invisibility, -;; please modify this function and move it to a more appropriate -;; location. -(defun erc-munge-invisibility-spec () +(define-obsolete-function-alias 'erc-munge-invisibility-spec + #'erc-stamp--manage-local-options-state "30.1" + "Perform setup and teardown of `stamp'-owned options. + +Note that this function's role in practice has long defied its +stated mandate as claimed in a now deleted comment, which +envisioned it as evolving into a central toggle for modifying +`buffer-invisibility-spec' on behalf of options and features +ERC-wide.") +(defun erc-stamp--manage-local-options-state () + "Perform local setup and teardown for `stamp'-owned options. +For `erc-timestamp-intangible', toggle `cursor-intangible-mode'. +For `erc-echo-timestamps', integrate with `cursor-sensor-mode'. +For `erc-hide-timestamps, modify `buffer-invisibility-spec'." (if erc-timestamp-intangible (cursor-intangible-mode +1) ; idempotent (when (bound-and-true-p cursor-intangible-mode) @@ -869,10 +881,12 @@ Return the empty string if FORMAT is nil." (unless erc-stamp--permanent-cursor-sensor-functions (dolist (hook '(erc-insert-post-hook erc-send-post-hook)) (add-hook hook #'erc-stamp--add-csf-on-post-modify nil t)) - (erc--restore-initialize-priors erc-stamp-mode - erc-stamp--csf-props-updated-p nil) + (setq erc-stamp--csf-props-updated-p + (alist-get 'erc-stamp--csf-props-updated-p + (or erc--server-reconnecting erc--target-priors))) (unless erc-stamp--csf-props-updated-p (setq erc-stamp--csf-props-updated-p t) + ;; Spoof `erc--ts' as being non-nil. (let ((erc--msg-props (map-into '((erc--ts . t)) 'hash-table))) (with-silent-modifications (erc--traverse-inserted @@ -902,9 +916,9 @@ Return the empty string if FORMAT is nil." (defun erc-stamp--setup () "Enable or disable buffer-local `erc-stamp-mode' modifications." (if erc-stamp-mode - (erc-munge-invisibility-spec) + (erc-stamp--manage-local-options-state) (let (erc-echo-timestamps erc-hide-timestamps erc-timestamp-intangible) - (erc-munge-invisibility-spec)) + (erc-stamp--manage-local-options-state)) ;; Undo local mods from `erc-insert-timestamp-left-and-right'. (erc-stamp--date-mode -1) ; kills `erc-timestamp-last-inserted-left' (kill-local-variable 'erc-stamp--last-stamp) @@ -916,7 +930,7 @@ Return the empty string if FORMAT is nil." "Hide timestamp information from display." (interactive) (setq erc-hide-timestamps t) - (erc-munge-invisibility-spec)) + (erc-stamp--manage-local-options-state)) (defun erc-show-timestamps () "Show timestamp information on display. @@ -924,7 +938,7 @@ This function only works if `erc-timestamp-format' was previously set, and timestamping is already active." (interactive) (setq erc-hide-timestamps nil) - (erc-munge-invisibility-spec)) + (erc-stamp--manage-local-options-state)) (defun erc-toggle-timestamps () "Hide or show timestamps in ERC buffers. @@ -938,7 +952,7 @@ enabled when the message was inserted." (setq erc-hide-timestamps t)) (mapc (lambda (buffer) (with-current-buffer buffer - (erc-munge-invisibility-spec))) + (erc-stamp--manage-local-options-state))) (erc-buffer-list))) (defvar-local erc-stamp--last-stamp nil) diff --git a/lisp/erc/erc-track.el b/lisp/erc/erc-track.el index 7e5ed165fb9..04ee76a9349 100644 --- a/lisp/erc/erc-track.el +++ b/lisp/erc/erc-track.el @@ -924,7 +924,7 @@ and expected types. This function should return a face or nil.") Expect RANKS to be a list of faces and both NORMALS and the car of NEW-FACES to be hash tables mapping faces to non-nil values. Assume the latter's makeup and that of RANKS to resemble -`erc-track-face-normal-list' and `erc-track-faces-priority-list'. +`erc-track-faces-normal-list' and `erc-track-faces-priority-list'. If NEW-FACES has a cdr, expect it to be its car's contents ordered from most recently seen (later in the buffer) to earliest. In general, act like `erc-track-select-mode-line-face' diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 0565440f357..0750463a4e7 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -13,7 +13,7 @@ ;; Michael Olson (mwolson@gnu.org) ;; Kelvin White (kwhite@gnu.org) ;; Version: 5.6-git -;; Package-Requires: ((emacs "27.1") (compat "29.1.4.3")) +;; Package-Requires: ((emacs "27.1") (compat "29.1.4.4")) ;; Keywords: IRC, chat, client, Internet ;; URL: https://www.gnu.org/software/emacs/erc.html @@ -135,6 +135,13 @@ concerning buffers." "Running scripts at startup and with /LOAD." :group 'erc) +;; Add `custom-loads' features for group symbols missing from a +;; supported Emacs version, possibly because they belong to a new ERC +;; library. These groups all share their library's feature name. +;;;###autoload(dolist (symbol '( erc-sasl erc-spelling ; 29 +;;;###autoload erc-imenu erc-nicks)) ; 30 +;;;###autoload (custom-add-load symbol symbol)) + (defvar erc-message-parsed) ; only known to this file (defvar erc--msg-props nil @@ -386,6 +393,16 @@ If nil, only \"> \" will be shown." (const "PART") (const "QUIT") (const "MODE") + (const :tag "Away notices (RPL_AWAY 301)" "301") + (const :tag "Self back notice (REP_UNAWAY 305)" "305") + (const :tag "Self away notice (REP_NOWAWAY 306)" "306") + (const :tag "Channel modes on join (RPL_CHANNELMODEIS 324)" "324") + (const :tag "Channel creation time (RPL_CREATIONTIME 329)" "329") + (const :tag "Channel no-topic on join (RPL_NOTOPIC 331)" "331") + (const :tag "Channel topic on join (RPL_TOPIC 332)" "332") + (const :tag "Topic author and time on join (RPL_TOPICWHOTIME 333)" "333") + (const :tag "Invitation success notice (RPL_INVITING 341)" "341") + (const :tag "Channel member names (353 RPL_NAMEREPLY)" "353") (repeat :inline t :tag "Others" (string :tag "IRC Message Type")))) (defcustom erc-hide-list nil @@ -598,28 +615,52 @@ Removes all users in the current channel. This is called by erc-channel-users) (clrhash erc-channel-users))) -(defmacro erc--define-channel-user-status-compat-getter (name n) +(defmacro erc--define-channel-user-status-compat-getter (name c d) "Define a gv getter for historical `erc-channel-user' status slot NAME. -Expect NAME to be a string and N to be its associated power-of-2 -\"enumerated flag\" integer." +Expect NAME to be a string, C to be its traditionally associated +letter, and D to be its fallback power-of-2 integer for non-ERC +buffers." `(defun ,(intern (concat "erc-channel-user-" name)) (u) ,(format "Get equivalent of pre-5.6 `%s' slot for `erc-channel-user'." name) (declare (gv-setter (lambda (v) (macroexp-let2 nil v v - (,'\`(let ((val (erc-channel-user-status ,',u))) + (,'\`(let ((val (erc-channel-user-status ,',u)) + (n (or (erc--get-prefix-flag ,c) ,d))) (setf (erc-channel-user-status ,',u) (if ,',v - (logior val ,n) - (logand val ,(lognot n)))) + (logior val n) + (logand val (lognot n)))) ,',v)))))) - (= ,n (logand ,n (erc-channel-user-status u))))) - -(erc--define-channel-user-status-compat-getter "voice" 1) -(erc--define-channel-user-status-compat-getter "halfop" 2) -(erc--define-channel-user-status-compat-getter "op" 4) -(erc--define-channel-user-status-compat-getter "admin" 8) -(erc--define-channel-user-status-compat-getter "owner" 16) + (let ((n (or (erc--get-prefix-flag ,c) ,d))) + (= n (logand n (erc-channel-user-status u)))))) + +(erc--define-channel-user-status-compat-getter "voice" ?v 1) +(erc--define-channel-user-status-compat-getter "halfop" ?h 2) +(erc--define-channel-user-status-compat-getter "op" ?o 4) +(erc--define-channel-user-status-compat-getter "admin" ?a 8) +(erc--define-channel-user-status-compat-getter "owner" ?q 16) + +;; This is a generalized version of the compat-oriented getters above. +(defun erc--cusr-status-p (nick-or-cusr letter) + "Return non-nil if NICK-OR-CUSR has channel membership status LETTER." + (and-let* ((cusr (or (and (erc-channel-user-p nick-or-cusr) nick-or-cusr) + (cdr (erc-get-channel-member nick-or-cusr)))) + (n (erc--get-prefix-flag letter))) + (= n (logand n (erc-channel-user-status cusr))))) + +(defun erc--cusr-change-status (nick-or-cusr letter enablep &optional resetp) + "Add or remove membership status associated with LETTER for NICK-OR-CUSR. +With RESETP, clear the user's status info completely. If ENABLEP +is non-nil, add the status value associated with LETTER." + (when-let ((cusr (or (and (erc-channel-user-p nick-or-cusr) nick-or-cusr) + (cdr (erc-get-channel-member nick-or-cusr)))) + (n (erc--get-prefix-flag letter))) + (cl-callf (lambda (v) + (if resetp + (if enablep n 0) + (if enablep (logior v n) (logand v (lognot n))))) + (erc-channel-user-status cusr)))) (defun erc-channel-user-owner-p (nick) "Return non-nil if NICK is an owner of the current channel." @@ -1211,30 +1252,30 @@ anyway." (make-obsolete-variable 'erc-send-pre-hook 'erc-pre-send-functions "27.1") (defcustom erc-pre-send-functions nil - "Special hook run to possibly alter the string that is sent. -The functions are called with one argument, an `erc-input' struct, -and should alter that struct. - -The struct has three slots: + "Special hook to possibly alter the string to send and insert. +ERC calls the member functions with one argument, an `erc-input' +struct instance to modify as needed. - `string': The current input string. - `insertp': Whether the string should be inserted into the erc buffer. - `sendp': Whether the string should be sent to the irc server. - -And one \"phony\" slot only accessible by hook members at runtime: +The struct has five slots: - `refoldp': Whether the string should be re-split per protocol limits. + `string': String to send, originally from prompt input. + `insertp': Whether a string should be inserted in the buffer. + `sendp': Whether `string' should be sent to the IRC server. + `substxt': String to display (but not send) instead of `string'. + `refoldp': Whether to re-split `string' per protocol limits. This hook runs after protocol line splitting has taken place, so -the value of `string' is originally \"pre-filled\". If you need -ERC to refill the entire payload before sending it, set the phony -`refoldp' slot to a non-nil value. Note that this refilling is -only a convenience, and modules with special needs, such as -preserving \"preformatted\" text or encoding for subprotocol -\"tunneling\", should handle splitting manually." - :group 'erc - :type 'hook - :version "27.1") +the value of `string' comes \"pre-split\" according to the option +`erc-split-line-length'. If you need ERC to refill the entire +payload before sending it, set the `refoldp' slot to a non-nil +value. Note that this refilling is only a convenience, and +modules with special needs, such as preserving \"preformatted\" +text or encoding for subprotocol \"tunneling\", should handle +splitting manually and possibly also specify replacement text to +display via the `substxt' slot." + :package-version '(ERC . "5.3") + :group 'erc-hooks + :type 'hook) (define-obsolete-variable-alias 'erc--pre-send-split-functions 'erc--input-review-functions "30.1") @@ -1278,8 +1319,8 @@ of `erc-insert-this' is t. ERC runs this hook with the buffer narrowed to the bounds of the inserted message plus a trailing newline. Built-in modules place -their hook members at depths between 20 and 80, with those from -the stamp module always running last. Use the functions +their hook members in two depth ranges: the first between -80 and +-20 and the second between 20 and 80. Use the functions `erc-find-parsed-property' and `erc-get-parsed-vector' to locate and extract the `erc-response' object for the inserted message." :group 'erc-hooks @@ -1497,7 +1538,7 @@ Bound to local variables from an existing (logical) session's buffer during local-module setup and `erc-mode-hook' activation.") (defmacro erc--restore-initialize-priors (mode &rest vars) - "Restore local VARS for MODE from a previous session." + "Restore local VARS for local minor MODE from a previous session." (declare (indent 1)) (let ((priors (make-symbol "priors")) (initp (make-symbol "initp")) @@ -1507,6 +1548,8 @@ buffer during local-module setup and `erc-mode-hook' activation.") (push `(,k (if ,initp (alist-get ',k ,priors) ,(pop vars))) forms)) `(let* ((,priors (or erc--server-reconnecting erc--target-priors)) (,initp (and ,priors (alist-get ',mode ,priors)))) + (unless (local-variable-if-set-p ',mode) + (error "Not a local minor mode var: %s" ',mode)) (setq ,@(mapcan #'identity (nreverse forms)))))) (defun erc--target-from-string (string) @@ -1620,11 +1663,7 @@ If BUFFER is nil, the current buffer is used." (defun erc-query-buffer-p (&optional buffer) "Return non-nil if BUFFER is an ERC query buffer. If BUFFER is nil, the current buffer is used." - (with-current-buffer (or buffer (current-buffer)) - (let ((target (erc-target))) - (and (eq major-mode 'erc-mode) - target - (not (memq (aref target 0) '(?# ?& ?+ ?!))))))) + (not (erc-channel-p (or buffer (current-buffer))))) (defun erc-ison-p (nick) "Return non-nil if NICK is online." @@ -1691,7 +1730,7 @@ Defaults to the server buffer." (defconst erc-default-server "irc.libera.chat" "IRC server to use if it cannot be detected otherwise.") -(defconst erc-default-port 6667 +(defvar erc-default-port 6667 "IRC port to use if it cannot be detected otherwise.") (defconst erc-default-port-tls 6697 @@ -1839,18 +1878,20 @@ buries those." :group 'erc-buffers :type 'boolean) -(defun erc-channel-p (channel) - "Return non-nil if CHANNEL seems to be an IRC channel name." - (cond ((stringp channel) - (memq (aref channel 0) - (if-let ((types (erc--get-isupport-entry 'CHANTYPES 'single))) - (append types nil) - '(?# ?& ?+ ?!)))) - ((and-let* (((bufferp channel)) - ((buffer-live-p channel)) - (target (buffer-local-value 'erc--target channel))) - (erc-channel-p (erc--target-string target)))) - (t nil))) +(defvar erc--fallback-channel-prefixes "#&" + "Prefix chars for distinguishing channel targets when CHANTYPES is unknown.") + +(defun erc-channel-p (target) + "Return non-nil if TARGET is a valid channel name or a channel buffer." + (cond ((stringp target) + (and-let* + (((not (string-empty-p target))) + (value (let ((entry (erc--get-isupport-entry 'CHANTYPES))) + (if entry (cadr entry) erc--fallback-channel-prefixes))) + ((erc--strpos (aref target 0) value))))) + ((and-let* (((buffer-live-p target)) + (target (buffer-local-value 'erc--target target)) + ((erc--target-channel-p target))))))) ;; For the sake of compatibility, a historical quirk concerning this ;; option, when nil, has been preserved: all buffers are suffixed with @@ -2149,13 +2190,17 @@ buffer rather than a server buffer.") (cl-pushnew mod (if (get mod 'erc--module) built-in third-party))) `(,@(sort built-in #'string-lessp) ,@(nreverse third-party)))) +;;;###autoload(custom-autoload 'erc-modules "erc") + (defcustom erc-modules '( autojoin button completion fill imenu irccontrols list match menu move-to-prompt netsplit networks readonly ring stamp track) - "A list of modules which ERC should enable. -If you set the value of this without using `customize' remember to call -\(erc-update-modules) after you change it. When using `customize', modules -removed from the list will be disabled." + "Modules to enable while connecting. +When modifying this option in lisp code, use a Custom-friendly +facilitator, like `setopt', or call `erc-update-modules' +afterward. This ensures a consistent ordering and disables +removed modules. It also gives packages access to the hook +`erc-before-connect'." :get (lambda (sym) ;; replace outdated names with their newer equivalents (erc-migrate-modules (symbol-value sym))) @@ -2439,29 +2484,22 @@ nil." (cl-assert (= (point) (point-max))))) (defun erc-open (&optional server port nick full-name - connect passwd tgt-list channel process + connect passwd _tgt-list channel process client-certificate user id) - "Connect to SERVER on PORT as NICK with USER and FULL-NAME. - -If CONNECT is non-nil, connect to the server. Otherwise assume -already connected and just create a separate buffer for the new -target given by CHANNEL, meaning these parameters are mutually -exclusive. Note that CHANNEL may also be a query; its name has -been retained for historical reasons. - -Use PASSWD as user password on the server. If TGT-LIST is -non-nil, use it to initialize `erc-default-recipients'. - -CLIENT-CERTIFICATE, if non-nil, should either be a list where the -first element is the file name of the private key corresponding -to a client certificate and the second element is the file name -of the client certificate itself to use when connecting over TLS, -or t, which means that `auth-source' will be queried for the -private key and the certificate. - -When non-nil, ID should be a symbol for identifying the connection. - -Returns the buffer for the given server or channel." + "Return a new or reinitialized server or target buffer. +If CONNECT is non-nil, connect to SERVER and return its new or +reassociated buffer. Otherwise, assume PROCESS is non-nil and belongs +to an active session, and return a new or refurbished target buffer for +CHANNEL, which may also be a query target (the parameter name remains +for historical reasons). Pass SERVER, PORT, NICK, USER, FULL-NAME, and +PASSWD to `erc-determine-parameters' for preserving as session-local +variables. Do something similar for CLIENT-CERTIFICATE and ID, which +should be as described by `erc-tls'. + +Note that ERC ignores TGT-LIST and initializes `erc-default-recipients' +with CHANNEL as its only member. Note also that this function has the +side effect of setting the current buffer to the one it returns. Use +`with-current-buffer' or `save-excursion' to nullify this effect." (let* ((target (and channel (erc--target-from-string channel))) (buffer (erc-get-buffer-create server port nil target id)) (old-buffer (current-buffer)) @@ -2498,7 +2536,7 @@ Returns the buffer for the given server or channel." ;; connection parameters (setq erc-server-process process) ;; stack of default recipients - (setq erc-default-recipients tgt-list) + (when channel (setq erc-default-recipients (list channel))) (when target (setq erc--target target erc-network (erc-network))) @@ -2637,8 +2675,11 @@ typically the same as that reported by `erc-current-nick'." ;;;###autoload (defun erc-select-read-args () - "Prompt the user for values of nick, server, port, and password. -With prefix arg, also prompt for user and full name." + "Prompt for connection parameters and return them in a plist. +By default, collect `:server', `:port', `:nickname', and +`:password'. With a non-nil prefix argument, also prompt for +`:user' and `:full-name'. Also return various environmental +properties needed by entry-point commands, like `erc-tls'." (let* ((input (let ((d (erc-compute-server))) (if erc--prompt-for-server-function (funcall erc--prompt-for-server-function) @@ -2692,7 +2733,7 @@ With prefix arg, also prompt for user and full name." (setq passwd nil)) `( :server ,server :port ,port :nick ,nick ,@(and user `(:user ,user)) ,@(and passwd `(:password ,passwd)) ,@(and full `(:full-name ,full)) - ,@(and env `(&interactive-env ,env))))) + ,@(and env `(--interactive-env-- ,env))))) (defmacro erc--with-entrypoint-environment (env &rest body) "Run BODY with bindings from ENV alist." @@ -2721,30 +2762,41 @@ With prefix arg, also prompt for user and full name." (full-name (erc-compute-full-name)) id ;; Used by interactive form - ((&interactive-env --interactive-env--))) - "ERC is a powerful, modular, and extensible IRC client. -This function is the main entry point for ERC. - -It allows selecting connection parameters, and then starts ERC. - -Non-interactively, it takes the keyword arguments - (server (erc-compute-server)) - (port (erc-compute-port)) - (nick (erc-compute-nick)) - (user (erc-compute-user)) - password - (full-name (erc-compute-full-name)) - id - -That is, if called with + ((--interactive-env-- --interactive-env--))) + "Connect to an Internet Relay Chat SERVER on a non-TLS PORT. +Use NICK and USER, when non-nil, to inform the IRC commands of +the same name, possibly factoring in a non-nil FULL-NAME as well. +When PASSWORD is non-nil, also send an opening server password +via the \"PASS\" command. Interactively, prompt for SERVER, +PORT, NICK, and PASSWORD, along with USER and FULL-NAME when +given a prefix argument. Non-interactively, expect the rarely +needed ID parameter, when non-nil, to be a symbol or a string for +naming the server buffer and identifying the connection +unequivocally. Once connected, return the server buffer. (See +Info node `(erc) Connecting' for details about all mentioned +parameters.) + +Together with `erc-tls', this command serves as the main entry +point for ERC, the powerful, modular, and extensible IRC client. +Non-interactively, both commands accept the following keyword +arguments, with their defaults supplied by the indicated +\"compute\" functions: + + :server `erc-compute-server' + :port `erc-compute-port' + :nick `erc-compute-nick' + :user `erc-compute-user' + :password N/A + :full-name `erc-compute-full-name' + :id' N/A + +For example, when called in the following manner (erc :server \"irc.libera.chat\" :full-name \"J. Random Hacker\") -then the server and full-name will be set to those values, -whereas `erc-compute-port' and `erc-compute-nick' will be invoked -for the values of the other parameters. - -See `erc-tls' for the meaning of ID. +ERC assigns SERVER and FULL-NAME the associated keyword values +and defers to `erc-compute-port', `erc-compute-user', and +`erc-compute-nick' for those respective parameters. \(fn &key SERVER PORT NICK USER PASSWORD FULL-NAME ID)" (interactive (let ((erc--display-context `((erc-interactive-display . erc) @@ -2770,51 +2822,26 @@ See `erc-tls' for the meaning of ID. client-certificate id ;; Used by interactive form - ((&interactive-env --interactive-env--))) - "ERC is a powerful, modular, and extensible IRC client. -This function is the main entry point for ERC over TLS. - -It allows selecting connection parameters, and then starts ERC -over TLS. - -Non-interactively, it takes the keyword arguments - (server (erc-compute-server)) - (port (erc-compute-port)) - (nick (erc-compute-nick)) - (user (erc-compute-user)) - password - (full-name (erc-compute-full-name)) - client-certificate - id - -That is, if called with - - (erc-tls :server \"irc.libera.chat\" :full-name \"J. Random Hacker\") - -then the server and full-name will be set to those values, -whereas `erc-compute-port' and `erc-compute-nick' will be invoked -for the values of their respective parameters. - -CLIENT-CERTIFICATE, if non-nil, should either be a list where the -first element is the certificate key file name, and the second -element is the certificate file name itself, or t, which means -that `auth-source' will be queried for the key and the -certificate. Authenticating using a TLS client certificate is -also referred to as \"CertFP\" (Certificate Fingerprint) -authentication by various IRC networks. - -Example usage: + ((--interactive-env-- --interactive-env--))) + "Connect to an IRC server over a TLS-encrypted connection. +Interactively, prompt for SERVER, PORT, NICK, and PASSWORD, along +with USER and FULL-NAME when given a prefix argument. +Non-interactively, also accept a CLIENT-CERTIFICATE, which should +be a list containing the file name of the certificate's key +followed by that of the certificate itself. Alternatively, +accept a value of t instead of a list, to tell ERC to query +`auth-source' for the certificate's details. + +Example client certificate (CertFP) usage: (erc-tls :server \"irc.libera.chat\" :port 6697 :client-certificate \\='(\"/home/bandali/my-cert.key\" \"/home/bandali/my-cert.crt\")) -When present, ID should be a symbol or a string to use for naming -the server buffer and identifying the connection unequivocally. -See Info node `(erc) Network Identifier' for details. Like -CLIENT-CERTIFICATE, this parameter cannot be specified -interactively. +See the alternative entry-point command `erc' as well as Info +node `(erc) Connecting' for a fuller description of the various +parameters, like ID. \(fn &key SERVER PORT NICK USER PASSWORD FULL-NAME CLIENT-CERTIFICATE ID)" (interactive @@ -3505,6 +3532,40 @@ repeatedly with VAL set to each of VAL's members." old (get-text-property pos prop object) end (next-single-property-change pos prop object to))))) +(defun erc--reserve-important-text-props (beg end plist &optional object) + "Record text-property pairs in PLIST as important between BEG and END. +Also mark the message being inserted as containing these important props +so modules performing destructive modifications can later restore them. +Expect to run in a narrowed buffer at message-insertion time." + (when erc--msg-props + (let ((existing (erc--check-msg-prop 'erc--important-prop-names))) + (puthash 'erc--important-prop-names (cl-union existing (map-keys plist)) + erc--msg-props))) + (erc--merge-prop beg end 'erc--important-props plist object)) + +(defun erc--restore-important-text-props (props &optional beg end) + "Restore PROPS where recorded in the accessible portion of the buffer. +Expect to run in a narrowed buffer at message-insertion time. Limit the +effect to the region between buffer positions BEG and END, when non-nil. + +Callers should be aware that this function fails if the property +`erc--important-props' has an empty value almost anywhere along the +affected region. Use the function `erc--remove-from-prop-value-list' to +ensure that props with empty values are excised completely." + (when-let ((registered (erc--check-msg-prop 'erc--important-prop-names)) + (present (seq-intersection props registered)) + (b (or beg (point-min))) + (e (or end (point-max)))) + (while-let + (((setq b (text-property-not-all b e 'erc--important-props nil))) + (val (get-text-property b 'erc--important-props)) + (q (next-single-property-change b 'erc--important-props nil e))) + (while-let ((k (pop val)) + (v (pop val))) + (when (memq k present) + (put-text-property b q k v))) + (setq b q)))) + (defvar erc-legacy-invisible-bounds-p nil "Whether to hide trailing rather than preceding newlines. Beginning in ERC 5.6, invisibility extends from a message's @@ -3806,14 +3867,14 @@ TYPE, when non-nil, to be a symbol handled by string MSG). Expect BUFFER to be among the sort accepted by the function `erc-display-line'. -Expect BUFFER to be a live `erc-mode' buffer, a list of such -buffers, or the symbols `all' or `active'. If `all', insert -STRING in all buffers for the current session. If `active', -defer to the function `erc-active-buffer', which may return the -session's server buffer if the previously active buffer has been -killed. If BUFFER is nil or a network process, pretend it's set -to the appropriate server buffer. Otherwise, use the current -buffer. +When non-nil, expect BUFFER to be a live `erc-mode' buffer, a +list of such buffers, or the symbols `all' or `active'. If +`all', insert STRING in all buffers for the current session. If +`active', defer to the function `erc-active-buffer', which may +return the session's server buffer if the previously active +buffer has been killed. If BUFFER is nil or a network process, +pretend it's set to the appropriate server buffer. Otherwise, +use the current buffer. When TYPE is a list of symbols, call handlers from left to right without influencing how they behave when encountering existing @@ -3826,11 +3887,10 @@ being (erc-error-face erc-notice-face) throughout MSG when `erc-notice-highlight-type' is left at its default, `all'. As of ERC 5.6, assume third-party code will use this function -instead of lower-level ones, like `erc-insert-line', when needing -ERC to process arbitrary informative messages as if they'd been -sent from a server. That is, guarantee \"local\" messages, for -which PARSED is typically nil, will be subject to buttonizing, -filling, and other effects." +instead of lower-level ones, like `erc-insert-line', to insert +arbitrary informative messages as if sent by the server. That +is, tell modules to treat a \"local\" message for which PARSED is +nil like any other server-sent message." (let* ((erc--msg-props (or erc--msg-props (let ((table (make-hash-table)) @@ -3912,6 +3972,10 @@ for other purposes.") (defun erc-send-input-line (target line &optional force) "Send LINE to TARGET." + (when-let ((target) + (cmem (erc-get-channel-member (erc-current-nick)))) + (setf (erc-channel-user-last-message-time (cdr cmem)) + (erc-compat--current-lisp-time))) (when (and (not erc--allow-empty-outgoing-lines-p) (string= line "\n")) (setq line " \n")) (erc-message "PRIVMSG" (concat target " " line) force)) @@ -3940,17 +4004,19 @@ erc-cmd-FOO, this returns a string /FOO." command-name))) (defun erc-process-input-line (line &optional force no-command) - "Translate LINE to an RFC1459 command and send it based. -Returns non-nil if the command is actually sent to the server, and nil -otherwise. - -If the command in the LINE is not bound as a function `erc-cmd-<COMMAND>', -it is passed to `erc-cmd-default'. If LINE is not a command (i.e. doesn't -start with /<COMMAND>) then it is sent as a message. - -An optional FORCE argument forces sending the line when flood -protection is in effect. The optional NO-COMMAND argument prohibits -this function from interpreting the line as a command." + "Dispatch a slash-command or chat-input handler from user-input LINE. +If simplistic validation fails, print an error and return nil. +Otherwise, defer to an appropriate handler. For \"slash\" commands, +like \"/JOIN\", expect a handler, like `erc-cmd-JOIN', to return non-nil +if LINE is fit for echoing as a command line when executing scripts. +For normal chat input, expect a handler to return non-nil if a message +was successfully processed as an outgoing \"PRIVMSG\". If LINE is a +slash command, and ERC can't find a corresponding handler of the form +`erc-cmd-<COMMAND>', pass LINE to `erc-cmd-default', treating it as a +catch-all handler. Otherwise, for normal chat input, pass LINE and the +boolean argument FORCE to `erc-send-input-line-function'. With a +non-nil NO-COMMAND, always treat LINE as normal chat input rather than a +slash command." (let ((command-list (erc-extract-command-from-line line))) (if (and command-list (not no-command)) @@ -4016,16 +4082,42 @@ this function from interpreting the line as a command." ;; Input commands handlers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun erc-cmd-AMSG (line) - "Send LINE to all channels of the current server that you are on." - (interactive "sSend to all channels you're on: ") - (setq line (erc-trim-string line)) +(defun erc--connected-and-joined-p () + (and (erc--current-buffer-joined-p) + erc-server-connected)) + +(defun erc-cmd-GMSG (line) + "Send LINE to all channels on all networks you are on." + (setq line (string-remove-prefix " " line)) (erc-with-all-buffers-of-server nil - (lambda () - (erc-channel-p (erc-default-target))) + #'erc--connected-and-joined-p + (erc-send-message line))) +(put 'erc-cmd-GMSG 'do-not-parse-args t) + +(defun erc-cmd-AMSG (line) + "Send LINE to all channels of the current network. +Interactively, prompt for the line of text to send." + (interactive "sSend to all channels on this network: ") + (setq line (string-remove-prefix " " line)) + (erc-with-all-buffers-of-server erc-server-process + #'erc--connected-and-joined-p (erc-send-message line))) (put 'erc-cmd-AMSG 'do-not-parse-args t) +(defun erc-cmd-GME (line) + "Send LINE as an action to all channels on all networks you are on." + (erc-with-all-buffers-of-server nil + #'erc--connected-and-joined-p + (erc-cmd-ME line))) +(put 'erc-cmd-GME 'do-not-parse-args t) + +(defun erc-cmd-AME (line) + "Send LINE as an action to all channels on the current network." + (erc-with-all-buffers-of-server erc-server-process + #'erc--connected-and-joined-p + (erc-cmd-ME line))) +(put 'erc-cmd-AME 'do-not-parse-args t) + (defun erc-cmd-SAY (line) "Send LINE to the current query or channel as a message, not a command. @@ -6153,17 +6245,15 @@ return a possibly empty string." (catch 'done (pcase-dolist (`(,letter . ,pfx) (erc--parsed-prefix-alist pfx-obj)) - (pcase letter - ((and ?q (guard (erc-channel-user-owner nick-or-cusr))) - (throw 'done (propertize (string pfx) 'help-echo "owner"))) - ((and ?a (guard (erc-channel-user-admin nick-or-cusr))) - (throw 'done (propertize (string pfx) 'help-echo "admin"))) - ((and ?o (guard (erc-channel-user-op nick-or-cusr))) - (throw 'done (propertize (string pfx) 'help-echo "operator"))) - ((and ?h (guard (erc-channel-user-halfop nick-or-cusr))) - (throw 'done (propertize (string pfx) 'help-echo "half-op"))) - ((and ?v (guard (erc-channel-user-voice nick-or-cusr))) - (throw 'done (propertize (string pfx) 'help-echo "voice"))))) + (when (erc--cusr-status-p nick-or-cusr letter) + (throw 'done + (pcase letter + (?q (propertize (string pfx) 'help-echo "owner")) + (?a (propertize (string pfx) 'help-echo "admin")) + (?o (propertize (string pfx) 'help-echo "operator")) + (?h (propertize (string pfx) 'help-echo "half-op")) + (?v (propertize (string pfx) 'help-echo "voice")) + (_ (string pfx)))))) ""))) (t (cond ((erc-channel-user-owner nick-or-cusr) @@ -6775,12 +6865,52 @@ parameter advertised by the current server, with the original ordering intact. If no such parameter has yet arrived, return a stand-in from the fallback value \"(qaohv)~&@%+\"." (erc--with-isupport-data PREFIX erc--parsed-prefix - (let ((alist (nreverse (erc-parse-prefix)))) + (let ((alist (erc-parse-prefix))) (make-erc--parsed-prefix :key key :letters (apply #'string (map-keys alist)) :statuses (apply #'string (map-values alist)) - :alist alist)))) + :alist (nreverse alist))))) + +(defun erc--get-prefix-flag (char &optional parsed-prefix from-prefix-p) + "Return numeric rank for CHAR or nil if unknown. +For example, given letters \"qaohv\" return 1 for ?v, 2 for ?h, +and 4 for ?o, etc. If given, expect PARSED-PREFIX to be a +`erc--parsed-prefix' object. With FROM-PREFIX-P, expect CHAR to +be a prefix instead." + (and-let* ((obj (or parsed-prefix (erc--parsed-prefix))) + (pos (erc--strpos char (if from-prefix-p + (erc--parsed-prefix-statuses obj) + (erc--parsed-prefix-letters obj))))) + (ash 1 pos))) + +(defun erc--init-cusr-fallback-status (voice halfop op admin owner) + "Return channel-membership based on traditional status semantics. +Massage boolean switches VOICE, HALFOP, OP, ADMIN, and OWNER into +an internal numeric value suitable for the `status' slot of a new +`erc-channel-user' object." + (let ((pfx (erc--parsed-prefix))) + (+ (if voice (if pfx (or (erc--get-prefix-flag ?v pfx) 0) 1) 0) + (if halfop (if pfx (or (erc--get-prefix-flag ?h pfx) 0) 2) 0) + (if op (if pfx (or (erc--get-prefix-flag ?o pfx) 0) 4) 0) + (if admin (if pfx (or (erc--get-prefix-flag ?a pfx) 0) 8) 0) + (if owner (if pfx (or (erc--get-prefix-flag ?q pfx) 0) 16) 0)))) + +(defun erc--compute-cusr-fallback-status (current v h o a q) + "Return current channel membership after toggling V H O A Q as requested. +Assume `erc--parsed-prefix' is non-nil in the current buffer. +Expect status switches V, H, O, A, Q, when non-nil, to be the +symbol `on' or `off'. Return an internal numeric value suitable +for the `status' slot of an `erc-channel-user' object." + (let (on off) + (when v (push (or (erc--get-prefix-flag ?v) 0) (if (eq v 'on) on off))) + (when h (push (or (erc--get-prefix-flag ?h) 0) (if (eq h 'on) on off))) + (when o (push (or (erc--get-prefix-flag ?o) 0) (if (eq o 'on) on off))) + (when a (push (or (erc--get-prefix-flag ?a) 0) (if (eq a 'on) on off))) + (when q (push (or (erc--get-prefix-flag ?q) 0) (if (eq q 'on) on off))) + (when on (setq current (apply #'logior current on))) + (when off (setq current (apply #'logand current (mapcar #'lognot off))))) + current) (defcustom erc-channel-members-changed-hook nil "This hook is called every time the variable `channel-members' changes. @@ -6788,48 +6918,40 @@ The buffer where the change happened is current while this hook is called." :group 'erc-hooks :type 'hook) -(defun erc-channel-receive-names (names-string) - "This function is for internal use only. +(defun erc--partition-prefixed-names (name) + "From NAME, return a list of (STATUS NICK LOGIN HOST). +Expect NAME to be a prefixed name, like @bob." + (unless (string-empty-p name) + (let* ((status (erc--get-prefix-flag (aref name 0) nil 'from-prefix-p)) + (nick (if status (substring name 1) name))) + (unless (string-empty-p nick) + (list status nick nil nil))))) -Update `erc-channel-users' according to NAMES-STRING. -NAMES-STRING is a string listing some of the names on the -channel." - (let* ((prefix (erc--parsed-prefix-alist (erc--parsed-prefix))) - (voice-ch (cdr (assq ?v prefix))) - (op-ch (cdr (assq ?o prefix))) - (hop-ch (cdr (assq ?h prefix))) - (adm-ch (cdr (assq ?a prefix))) - (own-ch (cdr (assq ?q prefix))) - (names (delete "" (split-string names-string))) - name op voice halfop admin owner) - (let ((erc-channel-members-changed-hook nil)) - (dolist (item names) - (let ((updatep t) - (ch (aref item 0))) - (setq name item op 'off voice 'off halfop 'off admin 'off owner 'off) - (if (rassq ch prefix) - (if (= (length item) 1) - (setq updatep nil) - (setq name (substring item 1)) - (setf (pcase ch - ((pred (eq voice-ch)) voice) - ((pred (eq hop-ch)) halfop) - ((pred (eq op-ch)) op) - ((pred (eq adm-ch)) admin) - ((pred (eq own-ch)) owner) - (_ (message "Unknown prefix char `%S'" ch) voice)) - 'on))) - (when updatep +(defun erc-channel-receive-names (names-string) + "Update `erc-channel-members' from NAMES-STRING. +Expect NAMES-STRING to resemble the trailing argument of a 353 +RPL_NAMREPLY. Call internal handlers for parsing individual +names, whose expected composition may differ depending on enabled +extensions." + (let ((names (delete "" (split-string names-string))) + (erc-channel-members-changed-hook nil)) + (dolist (name names) + (when-let ((args (erc--partition-prefixed-names name))) + (pcase-let* ((`(,status ,nick ,login ,host) args) + (cmem (erc-get-channel-user nick))) + (progn ;; If we didn't issue the NAMES request (consider two clients ;; talking to an IRC proxy), `erc-channel-begin-receiving-names' ;; will not have been called, so we have to do it here. (unless erc-channel-new-member-names (erc-channel-begin-receiving-names)) - (puthash (erc-downcase name) t - erc-channel-new-member-names) - (erc-update-current-channel-member - name name t voice halfop op admin owner))))) - (run-hooks 'erc-channel-members-changed-hook))) + (puthash (erc-downcase nick) t erc-channel-new-member-names) + (if cmem + (erc--update-current-channel-member cmem status nil + nick host login) + (erc--create-current-channel-member nick status nil + nick host login))))))) + (run-hooks 'erc-channel-members-changed-hook)) (defun erc-update-user-nick (nick &optional new-nick host login full-name info) @@ -6881,17 +7003,85 @@ which USER is a member, and t is returned." (run-hooks 'erc-channel-members-changed-hook)))))) changed)) +(defun erc--create-current-channel-member + (nick status timep &optional new-nick host login full-name info) + "Add an `erc-channel-member' entry for NICK. +Create a new `erc-server-users' entry if necessary, and ensure +`erc-channel-members-changed-hook' runs exactly once, regardless. +Pass STATUS to the `erc-channel-user' constructor. With TIMEP, +assume NICK has just spoken, and initialize `last-message-time'. +Pass NEW-NICK, HOST, LOGIN, FULL-NAME, and INFO to +`erc-update-user' if a server user exists and otherwise to the +`erc-server-user' constructor." + (cl-assert (null (erc-get-channel-member nick))) + (let* ((user-changed-p nil) + (down (erc-downcase nick)) + (user (gethash down (erc-with-server-buffer erc-server-users)))) + (if user + (progn + (cl-pushnew (current-buffer) (erc-server-user-buffers user)) + ;; Update *after* ^ so hook has chance to run. + (setf user-changed-p (erc-update-user user new-nick host login + full-name info))) + (erc-add-server-user nick + (setq user (make-erc-server-user + :nickname (or new-nick nick) + :host host + :full-name full-name + :login login + :info nil + :buffers (list (current-buffer)))))) + (let ((cusr (erc-channel-user--make + :status (or status 0) + :last-message-time (and timep + (erc-compat--current-lisp-time))))) + (puthash down (cons user cusr) erc-channel-users)) + ;; An existing `cusr' was changed or a new one was added, and + ;; `user' was not updated, though possibly just created (since + ;; `erc-update-user' runs this same hook in all a user's buffers). + (unless user-changed-p + (run-hooks 'erc-channel-members-changed-hook)) + t)) + +(defun erc--update-current-channel-member (cmem status timep &rest user-args) + "Update existing `erc-channel-member' entry. +Set the `status' slot of the entry's `erc-channel-user' side to +STATUS and, with TIMEP, update its `last-message-time'. When +actual changes are made, run `erc-channel-members-changed-hook', +and return non-nil." + (cl-assert cmem) + (let ((cusr (cdr cmem)) + (user (car cmem)) + cusr-changed-p user-changed-p) + (when (and status (/= status (erc-channel-user-status cusr))) + (setf (erc-channel-user-status cusr) status + cusr-changed-p t)) + (when timep + (setf (erc-channel-user-last-message-time cusr) + (erc-compat--current-lisp-time))) + ;; Ensure `erc-channel-members-changed-hook' runs on change. + (cl-assert (memq (current-buffer) (erc-server-user-buffers user))) + (setq user-changed-p (apply #'erc-update-user user user-args)) + ;; An existing `cusr' was changed or a new one was added, and + ;; `user' was not updated, though possibly just created (since + ;; `erc-update-user' runs this same hook in all a user's buffers). + (when (and cusr-changed-p (null user-changed-p)) + (run-hooks 'erc-channel-members-changed-hook)) + (erc-log (format "update-member: user = %S, cusr = %S" user cusr)) + (or cusr-changed-p user-changed-p))) + (defun erc-update-current-channel-member - (nick new-nick &optional addp voice halfop op admin owner host login full-name info - update-message-time) + (nick new-nick &optional addp voice halfop op admin owner host login + full-name info update-message-time) "Update or create entry for NICK in current `erc-channel-members' table. -With ADDP, ensure an entry exists. If one already does, call -`erc-update-user' to handle updates to HOST, LOGIN, FULL-NAME, -INFO, and NEW-NICK. Expect any non-nil membership status -switches among VOICE, HALFOP, OP, ADMIN, and OWNER to be the -symbol `on' or `off' when needing to influence a new or existing -`erc-channel-user' object's `status' slot. Likewise, when -UPDATE-MESSAGE-TIME is non-nil, update or initialize the +With ADDP, ensure an entry exists. When an entry does exist or +when ADDP is non-nil and an `erc-server-users' entry already +exists, call `erc-update-user' with NEW-NICK, HOST, LOGIN, +FULL-NAME, and INFO. Expect any non-nil membership +status switches among VOICE, HALFOP, OP, ADMIN, and OWNER to be +the symbol `on' or `off' when needing to influence a new or +existing `erc-channel-user' object's `status' slot. Likewise, +when UPDATE-MESSAGE-TIME is non-nil, update or initialize the `last-message-time' slot to the current-time. If changes occur, including creation, run `erc-channel-members-changed-hook'. Return non-nil when meaningful changes, including creation, have @@ -6901,62 +7091,26 @@ Without ADDP, do nothing unless a `erc-channel-members' entry exists. When it doesn't, assume the sender is a non-joined entity, like the server itself or a historical speaker, or assume the prior buffer for the channel was killed without parting." - (let* (cusr-changed-p - user-changed-p - (cmem (erc-get-channel-member nick)) - (cusr (cdr cmem)) - (down (erc-downcase nick)) - (user (or (car cmem) - (gethash down (erc-with-server-buffer erc-server-users))))) - (if cusr - (progn - (erc-log (format "update-member: user = %S, cusr = %S" user cusr)) - (when-let (((or voice halfop op admin owner)) - (existing (erc-channel-user-status cusr))) - (when voice (setf (erc-channel-user-voice cusr) (eq voice 'on))) - (when halfop (setf (erc-channel-user-halfop cusr) (eq halfop 'on))) - (when op (setf (erc-channel-user-op cusr) (eq op 'on))) - (when admin (setf (erc-channel-user-admin cusr) (eq admin 'on))) - (when owner (setf (erc-channel-user-owner cusr) (eq owner 'on))) - (setq cusr-changed-p (= existing (erc-channel-user-status cusr)))) - (when update-message-time - (setf (erc-channel-user-last-message-time cusr) (current-time))) - ;; Assume `user' exists and its `buffers' slot contains the - ;; current buffer so that `erc-channel-members-changed-hook' - ;; will run if changes are made. - (setq user-changed-p - (erc-update-user user new-nick - host login full-name info))) - (when addp - (if (null user) - (progn - (setq user (make-erc-server-user - :nickname nick - :host host - :full-name full-name - :login login - :info info - :buffers (list (current-buffer)))) - (erc-add-server-user nick user)) - (setf (erc-server-user-buffers user) - (cons (current-buffer) - (erc-server-user-buffers user)))) - (setq cusr (make-erc-channel-user - :voice (and voice (eq voice 'on)) - :halfop (and halfop (eq halfop 'on)) - :op (and op (eq op 'on)) - :admin (and admin (eq admin 'on)) - :owner (and owner (eq owner 'on)) - :last-message-time (if update-message-time - (current-time)))) - (puthash down (cons user cusr) erc-channel-users) - (setq cusr-changed-p t))) - ;; An existing `cusr' was changed or a new one was added, and - ;; `user' was not updated, though possibly just created (since - ;; `erc-update-user' runs this same hook in all a user's buffers). - (when (and cusr-changed-p (null user-changed-p)) - (run-hooks 'erc-channel-members-changed-hook)) - (or cusr-changed-p user-changed-p))) +(let* ((cmem (erc-get-channel-member nick)) + (status (and (or voice halfop op admin owner) + (if cmem + (erc--compute-cusr-fallback-status + (erc-channel-user-status (cdr cmem)) + voice halfop op admin owner) + (erc--init-cusr-fallback-status + (and voice (eq voice 'on)) + (and halfop (eq halfop 'on)) + (and op (eq op 'on)) + (and admin (eq admin 'on)) + (and owner (eq owner 'on))))))) + (if cmem + (erc--update-current-channel-member cmem status update-message-time + new-nick host login + full-name info) + (when addp + (erc--create-current-channel-member nick status update-message-time + new-nick host login + full-name info))))) (defun erc-update-channel-member (channel nick new-nick &optional add voice halfop op admin owner host login @@ -7146,16 +7300,6 @@ person who changed the modes." ;; nick modes - ignored at this point (t nil)))) -(defun erc--update-membership-prefix (nick letter state) - "Update status prefixes for NICK in current channel buffer. -Expect LETTER to be a status char and STATE to be a boolean." - (erc-update-current-channel-member nick nil nil - (and (= letter ?v) state) - (and (= letter ?h) state) - (and (= letter ?o) state) - (and (= letter ?a) state) - (and (= letter ?q) state))) - (defvar-local erc--channel-modes nil "When non-nil, a hash table of current channel modes. Keys are characters. Values are either a string, for types A-C, @@ -7201,7 +7345,7 @@ complement relevant letters in STRING." (cond ((= ?+ c) (setq +p t)) ((= ?- c) (setq +p nil)) ((and status-letters (string-search (string c) status-letters)) - (erc--update-membership-prefix (pop args) c (if +p 'on 'off))) + (erc--cusr-change-status (pop args) c +p)) ((and-let* ((group (or (aref table c) (and fallbackp ?d)))) (erc--handle-channel-mode group c +p (and (/= group ?d) @@ -7523,6 +7667,12 @@ See associated unit test for precise behavior." (match-string 2 string) (match-string 3 string)))) +(defun erc--shuffle-nuh-nickward (nick login host) + "Interpret results of `erc--parse-nuh', promoting loners to nicks." + (cond (nick (cl-assert (null login)) (list nick login host)) + ((and (null login) host) (list host nil nil)) + ((and login (null host)) (list login nil nil)))) + (defun erc-extract-nick (string) "Return the nick corresponding to a user specification STRING. @@ -7821,26 +7971,10 @@ When all lines are empty, remove all but the first." "Partition non-command input into lines of protocol-compliant length." ;; Prior to ERC 5.6, line splitting used to be predicated on ;; `erc-flood-protect' being non-nil. - (unless (erc--input-split-cmdp state) + (unless (or (zerop erc-split-line-length) (erc--input-split-cmdp state)) (setf (erc--input-split-lines state) (mapcan #'erc--split-line (erc--input-split-lines state))))) -(defun erc--input-ensure-hook-context () - (unless (erc--input-split-p erc--current-line-input-split) - (error "Invoked outside of `erc-pre-send-functions'"))) - -(defun erc-input-refoldp (_) - "Impersonate accessor for phony `erc-input' `refoldp' slot. -This function only works inside `erc-pre-send-functions' members." - (declare (gv-setter (lambda (v) - `(progn - (erc--input-ensure-hook-context) - (setf (erc--input-split-refoldp - erc--current-line-input-split) - ,v))))) - (erc--input-ensure-hook-context) - (erc--input-split-refoldp erc--current-line-input-split)) - (defun erc--run-send-hooks (lines-obj) "Run send-related hooks that operate on the entire prompt input. Sequester some of the back and forth involved in honoring old @@ -7858,12 +7992,17 @@ queue. Expect LINES-OBJ to be an `erc--input-split' object." (state (progn ;; This may change `str' and `erc-*-this'. (run-hook-with-args 'erc-send-pre-hook str) - (make-erc-input :string str - :insertp erc-insert-this - :sendp erc-send-this)))) + (make-erc-input + :string str + :insertp erc-insert-this + :sendp erc-send-this + :substxt (erc--input-split-substxt lines-obj) + :refoldp (erc--input-split-refoldp lines-obj))))) (run-hook-with-args 'erc-pre-send-functions state) (setf (erc--input-split-sendp lines-obj) (erc-input-sendp state) (erc--input-split-insertp lines-obj) (erc-input-insertp state) + (erc--input-split-substxt lines-obj) (erc-input-substxt state) + (erc--input-split-refoldp lines-obj) (erc-input-refoldp state) ;; See note in test of same name re trailing newlines. (erc--input-split-lines lines-obj) (let ((lines (split-string (erc-input-string state) @@ -7878,17 +8017,22 @@ queue. Expect LINES-OBJ to be an `erc--input-split' object." (user-error "Multiline command detected" )) lines-obj) -(cl-defmethod erc--send-input-lines (lines-obj) +(defun erc--send-input-lines (lines-obj) "Send lines in `erc--input-split-lines' object LINES-OBJ." (when (erc--input-split-sendp lines-obj) - (dolist (line (erc--input-split-lines lines-obj)) - (when (erc--input-split-insertp lines-obj) - (if (functionp (erc--input-split-insertp lines-obj)) - (funcall (erc--input-split-insertp lines-obj) line) - (erc-display-msg line))) - (erc-process-input-line (concat line "\n") - (null erc-flood-protect) - (not (erc--input-split-cmdp lines-obj)))))) + (let ((insertp (erc--input-split-insertp lines-obj)) + (substxt (erc--input-split-substxt lines-obj))) + (when (and insertp substxt) + (setq insertp nil) + (if (functionp substxt) + (apply substxt (erc--input-split-lines lines-obj)) + (erc-display-msg substxt))) + (dolist (line (erc--input-split-lines lines-obj)) + (when insertp + (erc-display-msg line)) + (erc-process-input-line (concat line "\n") + (null erc-flood-protect) + (not (erc--input-split-cmdp lines-obj))))))) (defun erc-send-input (input &optional skip-ws-chk) "Treat INPUT as typed in by the user. @@ -7972,9 +8116,18 @@ as outgoing chat messages and echoed slash commands." (when (fboundp cmd) cmd))) (defun erc-extract-command-from-line (line) - "Extract command and args from the input LINE. -If no command was given, return nil. If command matches, return a -list of the form: (command args) where both elements are strings." + "Extract a \"slash command\" and its args from a prompt-input LINE. +If LINE doesn't start with a slash command, return nil. If it +does, meaning the pattern `erc-command-regexp' matches, return a +list of the form (COMMAND ARGS), where COMMAND is either a symbol +for a known handler function or `erc-cmd-default' if unknown. +When COMMAND has the symbol property `do-not-parse-args', return +a string in place of ARGS: that is, either LINE itself, when LINE +consists of only whitespace, or LINE stripped of any trailing +whitespace, including a final newline. When COMMAND lacks the +symbol property `do-not-parse-args', return a possibly empty list +of non-whitespace tokens. Do not perform any shell-style parsing +of quoted or escaped substrings." (when (string-match erc-command-regexp line) (let* ((cmd (erc-command-symbol (match-string 1 line))) ;; note: return is nil, we apply this simply for side effects @@ -8045,7 +8198,6 @@ See also `erc-downcase'." (defun erc--current-buffer-joined-p () "Return non-nil if the current buffer is a channel and is joined." - (cl-assert erc--target) (and (erc--target-channel-p erc--target) (erc--target-channel-joined-p erc--target) t)) @@ -8362,7 +8514,8 @@ and so on." ((string-match "^%[Ss]$" esc) server) ((string-match "^%[Nn]$" esc) nick) ((string-match "^%\\(.\\)$" esc) (match-string 1 esc)) - (t (erc-log (format "BUG in erc-process-script-line: bad escape sequence: %S\n" esc)) + (t (erc-log (format "Bad escape sequence in %s: %S\n" + 'erc-process-script-line esc)) (message "BUG IN ERC: esc=%S" esc) ""))) (setq line tail) @@ -8381,37 +8534,6 @@ and so on." (buffer-string)))) (erc-load-irc-script-lines (erc-split-multiline-safe str) force))) -(defun erc-load-irc-script-lines (lines &optional force noexpand) - "Load IRC script LINES (a list of strings). - -If optional NOEXPAND is non-nil, do not expand script-specific -sequences, process the lines verbatim. Use this for multiline -user input." - (let* ((cb (current-buffer)) - (s "") - (sp (or (and (bound-and-true-p erc-command-indicator-mode) - (fboundp 'erc-command-indicator) - (erc-command-indicator)) - (erc-prompt))) - (args (and (boundp 'erc-script-args) erc-script-args))) - (if (and args (string-match "^ " args)) - (setq args (substring args 1))) - ;; prepare the prompt string for echo - (erc-put-text-property 0 (length sp) - 'font-lock-face 'erc-command-indicator-face sp) - (while lines - (setq s (car lines)) - (erc-log (concat "erc-load-script: CMD: " s)) - (unless (string-match "^\\s-*$" s) - (let ((line (if noexpand s (erc-process-script-line s args)))) - (if (and (erc-process-input-line line force) - erc-script-echo) - (progn - (erc-put-text-property 0 (length line) - 'font-lock-face 'erc-input-face line) - (erc-display-line (concat sp line) cb))))) - (setq lines (cdr lines))))) - ;; authentication (defun erc--unfun (maybe-fn) @@ -9319,6 +9441,12 @@ if yet untried." (unless catalog (setq catalog erc-current-message-catalog)) (symbol-value (or (erc--make-message-variable-name catalog key 'softp) + (let ((parent catalog) + last) + (while (and (setq parent (get parent 'erc--base-format-catalog)) + (not (setq last (erc--make-message-variable-name + parent key 'softp))))) + last) (let ((default (default-toplevel-value 'erc-current-message-catalog))) (or (and (not (eq default catalog)) (erc--make-message-variable-name default key 'softp)) @@ -9395,6 +9523,7 @@ guarantee that the input method functions properly for the purpose of typing within the ERC prompt." (when (and (eq major-mode 'erc-mode) (fboundp 'set-text-conversion-style)) + (defvar text-conversion-style) ; avoid free variable warning on <=29 (if (>= (point) (erc-beg-of-input-line)) (unless (eq text-conversion-style 'action) (set-text-conversion-style 'action)) diff --git a/lisp/eshell/em-basic.el b/lisp/eshell/em-basic.el index 8f68a750bd7..6ec53ef9412 100644 --- a/lisp/eshell/em-basic.el +++ b/lisp/eshell/em-basic.el @@ -160,6 +160,18 @@ or `eshell-printn' for display." :preserve-args :usage "[-S] [mode]") (cond + (args + (let* ((mask (car args)) + (modes + (if (stringp mask) + (if (string-match (rx bos (+ (any "0-7")) eos) mask) + (- #o777 (string-to-number mask 8)) + (file-modes-symbolic-to-number + mask (default-file-modes))) + (- #o777 mask)))) + (set-default-file-modes modes) + (eshell-print + "Warning: umask changed for all new files created by Emacs.\n"))) (symbolic-p (let ((mode (default-file-modes))) (eshell-printn @@ -173,17 +185,9 @@ or `eshell-printn' for display." (concat (and (= (logand mode 1) 1) "r") (and (= (logand mode 2) 2) "w") (and (= (logand mode 4) 4) "x")))))) - ((not args) - (eshell-printn (format "%03o" (logand (lognot (default-file-modes)) - #o777)))) (t - (when (stringp (car args)) - (if (string-match "^[0-7]+$" (car args)) - (setcar args (string-to-number (car args) 8)) - (error "Setting umask symbolically is not yet implemented"))) - (set-default-file-modes (- #o777 (car args))) - (eshell-print - "Warning: umask changed for all new files created by Emacs.\n"))) + (eshell-printn (format "%03o" (logand (lognot (default-file-modes)) + #o777))))) nil)) (put 'eshell/umask 'eshell-no-numeric-conversions t) diff --git a/lisp/eshell/em-dirs.el b/lisp/eshell/em-dirs.el index cf90a8bb230..07063afc286 100644 --- a/lisp/eshell/em-dirs.el +++ b/lisp/eshell/em-dirs.el @@ -262,6 +262,7 @@ Thus, this does not include the current directory.") (defun eshell-parse-user-reference () "An argument beginning with ~ is a filename to be expanded." (when (and (not eshell-current-argument) + (not eshell-current-quoted) (eq (char-after) ?~)) ;; Apply this modifier fairly early so it happens before things ;; like glob expansion. @@ -316,7 +317,7 @@ Thus, this does not include the current directory.") (`(boundaries . ,suffix) `(boundaries 0 . ,(string-search "/" suffix)))))))))) -(defun eshell/pwd (&rest _args) +(defun eshell/pwd () "Change output from `pwd' to be cleaner." (let* ((path default-directory) (len (length path))) diff --git a/lisp/eshell/em-glob.el b/lisp/eshell/em-glob.el index b0c3e6e7a11..7fc6958a00f 100644 --- a/lisp/eshell/em-glob.el +++ b/lisp/eshell/em-glob.el @@ -190,6 +190,12 @@ interpretation." '(("**/" . recurse) ("***/" . recurse-symlink))) +(defsubst eshell-glob-chars-regexp () + "Return the lazily-created value for `eshell-glob-chars-regexp'." + (or eshell-glob-chars-regexp + (setq-local eshell-glob-chars-regexp + (format "[%s]+" (apply 'string eshell-glob-chars-list))))) + (defun eshell-glob-regexp (pattern) "Convert glob-pattern PATTERN to a regular expression. The basic syntax is: @@ -210,11 +216,8 @@ set to true, then these characters will match themselves in the resulting regular expression." (let ((matched-in-pattern 0) ; How much of PATTERN handled regexp) - (while (string-match - (or eshell-glob-chars-regexp - (setq-local eshell-glob-chars-regexp - (format "[%s]+" (apply 'string eshell-glob-chars-list)))) - pattern matched-in-pattern) + (while (string-match (eshell-glob-chars-regexp) + pattern matched-in-pattern) (let* ((op-begin (match-beginning 0)) (op-char (aref pattern op-begin))) (setq regexp @@ -239,6 +242,10 @@ resulting regular expression." (regexp-quote (substring pattern matched-in-pattern)) "\\'"))) +(defun eshell-glob-p (pattern) + "Return non-nil if PATTERN has any special glob characters." + (string-match (eshell-glob-chars-regexp) pattern)) + (defun eshell-glob-convert-1 (glob &optional last) "Convert a GLOB matching a single element of a file name to regexps. If LAST is non-nil, this glob is the last element of a file name. @@ -291,14 +298,13 @@ The result is a list of three elements: symlinks. 3. A boolean indicating whether to match directories only." - (let ((globs (eshell-split-path glob)) - (isdir (eq (aref glob (1- (length glob))) ?/)) + (let ((globs (eshell-split-filename glob)) + (isdir (string-suffix-p "/" glob)) start-dir result last-saw-recursion) (if (and (cdr globs) (file-name-absolute-p (car globs))) - (setq start-dir (car globs) - globs (cdr globs)) - (setq start-dir ".")) + (setq start-dir (pop globs)) + (setq start-dir (file-name-as-directory "."))) (while globs (if-let ((recurse (cdr (assoc (car globs) eshell-glob-recursive-alist)))) @@ -306,11 +312,15 @@ The result is a list of three elements: (setcar result recurse) (push recurse result) (setq last-saw-recursion t)) - (push (eshell-glob-convert-1 (car globs) (null (cdr globs))) - result) + (if (or result (eshell-glob-p (car globs))) + (push (eshell-glob-convert-1 (car globs) (null (cdr globs))) + result) + ;; We haven't seen a glob yet, so instead append to the start + ;; directory. + (setq start-dir (file-name-concat start-dir (car globs)))) (setq last-saw-recursion nil)) (setq globs (cdr globs))) - (list (file-name-as-directory start-dir) + (list start-dir (nreverse result) isdir))) diff --git a/lisp/eshell/em-tramp.el b/lisp/eshell/em-tramp.el index 90f9c6cf78d..efb37225651 100644 --- a/lisp/eshell/em-tramp.el +++ b/lisp/eshell/em-tramp.el @@ -121,12 +121,11 @@ Uses the system sudo through Tramp's sudo method." :usage "[(-u | --user) USER] (-s | --shell) | COMMAND Execute a COMMAND as the superuser or another USER.") (let ((dir (eshell--method-wrap-directory default-directory "sudo" user))) - (if shell - (throw 'eshell-replace-command - (eshell-parse-command "cd" (list dir))) - (throw 'eshell-external - (let ((default-directory dir)) - (eshell-named-command (car args) (cdr args)))))))) + (throw 'eshell-replace-command + (if shell + (eshell-parse-command "cd" (list dir)) + `(let ((default-directory ,dir)) + (eshell-named-command ',(car args) ',(cdr args)))))))) (put 'eshell/sudo 'eshell-no-numeric-conversions t) @@ -144,12 +143,11 @@ Uses the system doas through Tramp's doas method." :usage "[(-u | --user) USER] (-s | --shell) | COMMAND Execute a COMMAND as the superuser or another USER.") (let ((dir (eshell--method-wrap-directory default-directory "doas" user))) - (if shell - (throw 'eshell-replace-command - (eshell-parse-command "cd" (list dir))) - (throw 'eshell-external - (let ((default-directory dir)) - (eshell-named-command (car args) (cdr args)))))))) + (throw 'eshell-replace-command + (if shell + (eshell-parse-command "cd" (list dir)) + `(let ((default-directory ,dir)) + (eshell-named-command ',(car args) ',(cdr args)))))))) (put 'eshell/doas 'eshell-no-numeric-conversions t) diff --git a/lisp/eshell/em-unix.el b/lisp/eshell/em-unix.el index 75afaf1c104..751f13cc715 100644 --- a/lisp/eshell/em-unix.el +++ b/lisp/eshell/em-unix.el @@ -166,9 +166,9 @@ Otherwise, Emacs will attempt to use rsh to invoke du on the remote machine." (add-hook 'pcomplete-try-first-hook 'eshell-complete-host-reference nil t)) (setq-local eshell-complex-commands - (append '("grep" "egrep" "fgrep" "agrep" "rgrep" - "glimpse" "locate" "cat" "time" "cp" "mv" - "make" "du" "diff") + (append '("compile" "grep" "egrep" "fgrep" "agrep" + "rgrep" "glimpse" "locate" "cat" "time" "cp" + "mv" "make" "du" "diff") eshell-complex-commands))) (defalias 'eshell/date 'current-time-string) @@ -590,7 +590,7 @@ Rename SOURCE to DEST, or move SOURCE(s) to DIRECTORY. :external "cp" :show-usage :usage "[OPTION]... SOURCE DEST - or: cp [OPTION]... SOURCE... DIRECTORY + or: cp [OPTION]... SOURCE... DIRECTORY Copy SOURCE to DEST, or multiple SOURCE(s) to DIRECTORY.") (if archive (setq preserve t no-dereference t em-recursive t)) @@ -618,11 +618,11 @@ Copy SOURCE to DEST, or multiple SOURCE(s) to DIRECTORY.") :preserve-args :external "ln" :show-usage - :usage "[OPTION]... TARGET [LINK_NAME] - or: ln [OPTION]... TARGET... DIRECTORY -Create a link to the specified TARGET with optional LINK_NAME. If there is -more than one TARGET, the last argument must be a directory; create links -in DIRECTORY to each TARGET. Create hard links by default, symbolic links + :usage "[OPTION]... TARGET LINK_NAME + or: ln [OPTION]... TARGET... DIRECTORY +Create a link to the specified TARGET with LINK_NAME. If there is more +than one TARGET, the last argument must be a directory; create links in +DIRECTORY to each TARGET. Create hard links by default, symbolic links with `--symbolic'. When creating hard links, each TARGET must exist.") (let ((no-dereference t)) (eshell-mvcpln-template "ln" "linking" @@ -741,7 +741,7 @@ Fallback to standard make when called synchronously." (eshell-compile "make" args ;; Use plain output unless we're executing in the ;; background. - (not eshell-current-subjob-p))) + (unless eshell-current-subjob-p 'plain))) (put 'eshell/make 'eshell-no-numeric-conversions t) @@ -789,7 +789,7 @@ available..." (ignore-errors (occur (car args)))) (if (get-buffer "*Occur*") - (with-current-buffer (get-buffer "*Occur*") + (with-current-buffer "*Occur*" (setq string (buffer-string)) (kill-buffer (current-buffer))))) (if string (insert string)) @@ -940,7 +940,7 @@ external command." "display data only this many levels of data") (?h "human-readable" 1024 human-readable "print sizes in human readable format") - (?H "is" 1000 human-readable + (?H "si" 1000 human-readable "likewise, but use powers of 1000 not 1024") (?k "kilobytes" 1024 block-size "like --block-size 1024") @@ -1018,7 +1018,7 @@ Show wall-clock time elapsed during execution of COMMAND.") (eshell-stringify-list (flatten-tree (cdr time-args)))))))) -(defun eshell/whoami (&rest _args) +(defun eshell/whoami () "Make \"whoami\" Tramp aware." (eshell-user-login-name)) diff --git a/lisp/eshell/esh-arg.el b/lisp/eshell/esh-arg.el index 1880cc03885..78cf28d785a 100644 --- a/lisp/eshell/esh-arg.el +++ b/lisp/eshell/esh-arg.el @@ -285,7 +285,7 @@ QUOTED is passed to `eshell-concat' (which see) and, if non-nil, allows values to be converted to numbers where appropriate. ARGS should be a list of lists of arguments, such as that -produced by `eshell-prepare-slice'. \"Adjacent\" values of +produced by `eshell-prepare-splice'. \"Adjacent\" values of consecutive arguments will be passed to `eshell-concat'. For example, if ARGS is @@ -440,6 +440,7 @@ Point is left at the end of the arguments." (defsubst eshell-looking-at-backslash-return (pos) "Test whether a backslash-return sequence occurs at POS." + (declare (obsolete nil "30.1")) (and (eq (char-after pos) ?\\) (or (= (1+ pos) (point-max)) (and (eq (char-after (1+ pos)) ?\n) @@ -464,8 +465,8 @@ backslash is ignored and the character after is returned. If the backslash is in a quoted string, the backslash and the character after are both returned." (when (eq (char-after) ?\\) - (when (eshell-looking-at-backslash-return (point)) - (throw 'eshell-incomplete "\\")) + (when (= (1+ (point)) (point-max)) + (throw 'eshell-incomplete "\\")) (forward-char 2) ; Move one char past the backslash. (let ((special-chars (if eshell-current-quoted eshell-special-chars-inside-quoting diff --git a/lisp/eshell/esh-cmd.el b/lisp/eshell/esh-cmd.el index 2746800ea78..30494bafb48 100644 --- a/lisp/eshell/esh-cmd.el +++ b/lisp/eshell/esh-cmd.el @@ -934,48 +934,52 @@ This yields the SUBCOMMANDs when found in forms like (dolist (elem haystack) (cond ((eq (car-safe elem) 'eshell-as-subcommand) - (iter-yield (cdr elem))) + (iter-yield (cadr elem))) ((listp elem) (iter-yield-from (eshell--find-subcommands elem)))))) -(defun eshell--invoke-command-directly (command) +(defun eshell--invoke-command-directly-p (command) "Determine whether the given COMMAND can be invoked directly. COMMAND should be a non-top-level Eshell command in parsed form. A command can be invoked directly if all of the following are true: * The command is of the form - \"(eshell-trap-errors (eshell-named-command NAME ARGS))\", - where ARGS is optional. + (eshell-with-copied-handles + (eshell-trap-errors (eshell-named-command NAME [ARGS])) _). * NAME is a string referring to an alias function and isn't a complex command (see `eshell-complex-commands'). * Any subcommands in ARGS can also be invoked directly." - (when (and (eq (car command) 'eshell-trap-errors) - (eq (car (cadr command)) 'eshell-named-command)) - (let ((name (cadr (cadr command))) - (args (cdr-safe (nth 2 (cadr command))))) - (and name (stringp name) - (not (member name eshell-complex-commands)) - (catch 'simple - (dolist (pred eshell-complex-commands t) - (when (and (functionp pred) - (funcall pred name)) - (throw 'simple nil)))) - (eshell-find-alias-function name) - (catch 'indirect-subcommand - (iter-do (subcommand (eshell--find-subcommands args)) - (unless (eshell--invoke-command-directly subcommand) - (throw 'indirect-subcommand nil))) - t))))) - -(defun eshell-invoke-directly (command) + (pcase command + (`(eshell-with-copied-handles + (eshell-trap-errors (eshell-named-command ,name . ,args)) + ,_) + (and name (stringp name) + (not (member name eshell-complex-commands)) + (catch 'simple + (dolist (pred eshell-complex-commands t) + (when (and (functionp pred) + (funcall pred name)) + (throw 'simple nil)))) + (eshell-find-alias-function name) + (catch 'indirect-subcommand + (iter-do (subcommand (eshell--find-subcommands (car args))) + (unless (eshell--invoke-command-directly-p subcommand) + (throw 'indirect-subcommand nil))) + t))))) + +(defun eshell-invoke-directly-p (command) "Determine whether the given COMMAND can be invoked directly. COMMAND should be a top-level Eshell command in parsed form, as produced by `eshell-parse-command'." - (let ((base (cadr (nth 2 (nth 2 (cadr command)))))) - (eshell--invoke-command-directly base))) + (pcase command + (`(eshell-commands (progn ,_ (unwind-protect (progn ,base) . ,_))) + (eshell--invoke-command-directly-p base)))) + +(define-obsolete-function-alias 'eshell-invoke-directly + 'eshell-invoke-directly-p "30.1") (defun eshell-eval-argument (argument) "Evaluate a single Eshell ARGUMENT and return the result." diff --git a/lisp/eshell/esh-ext.el b/lisp/eshell/esh-ext.el index dc2b93e574b..44861c222b8 100644 --- a/lisp/eshell/esh-ext.el +++ b/lisp/eshell/esh-ext.el @@ -253,10 +253,10 @@ An external command simply means external to Emacs." "Add a set of paths to PATH." (eshell-eval-using-options "addpath" args - '((?b "begin" nil prepend "add path element at beginning") + '((?b "begin" nil prepend "add to beginning of $PATH") (?h "help" nil nil "display this usage message") - :usage "[-b] PATH -Adds the given PATH to $PATH.") + :usage "[-b] DIR... +Adds the given DIR to $PATH.") (let ((path (eshell-get-path t))) (if args (progn diff --git a/lisp/eshell/esh-mode.el b/lisp/eshell/esh-mode.el index 21e3f00086f..b15f99a0359 100644 --- a/lisp/eshell/esh-mode.el +++ b/lisp/eshell/esh-mode.el @@ -290,7 +290,7 @@ non-interactive sessions, such as when using `eshell-command'.") "C-e" #'eshell-show-maximum-output "C-f" #'eshell-forward-argument "C-m" #'eshell-copy-old-input - "C-o" #'eshell-kill-output + "C-o" #'eshell-delete-output "C-r" #'eshell-show-output "C-t" #'eshell-truncate-buffer "C-u" #'eshell-kill-input @@ -619,14 +619,14 @@ If NO-NEWLINE is non-nil, the input is sent without an implied final newline." (interactive "P") ;; Note that the input string does not include its terminal newline. - (let ((proc-running-p (and (eshell-head-process) - (not queue-p))) - (inhibit-modification-hooks t)) - (unless (and proc-running-p + (let* ((proc-running-p (eshell-head-process)) + (send-to-process-p (and proc-running-p (not queue-p))) + (inhibit-modification-hooks t)) + (unless (and send-to-process-p (not (eq (process-status (eshell-head-process)) 'run))) - (if (or proc-running-p + (if (or send-to-process-p (>= (point) eshell-last-output-end)) (goto-char (point-max)) (let ((copy (eshell-get-old-input use-region))) @@ -634,7 +634,7 @@ newline." (insert-and-inherit copy))) (unless (or no-newline (and eshell-send-direct-to-subprocesses - proc-running-p)) + send-to-process-p)) (insert-before-markers-and-inherit ?\n)) ;; Delete and reinsert input. This seems like a no-op, except ;; for the resulting entries in the undo list: undoing this @@ -644,7 +644,7 @@ newline." (inhibit-read-only t)) (delete-region eshell-last-output-end (point)) (insert text)) - (if proc-running-p + (if send-to-process-p (progn (eshell-update-markers eshell-last-output-end) (if (or eshell-send-direct-to-subprocesses @@ -673,7 +673,8 @@ newline." (run-hooks 'eshell-input-filter-functions) (and (catch 'eshell-terminal (ignore - (if (eshell-invoke-directly cmd) + (if (and (not proc-running-p) + (eshell-invoke-directly-p cmd)) (eval cmd) (eshell-eval-command cmd input)))) (eshell-life-is-too-much))))) @@ -831,15 +832,23 @@ This function should be in the list `eshell-output-filter-functions'." eshell-last-output-start eshell-last-output-end)) -(defun eshell-kill-output () - "Kill all output from interpreter since last input. -Does not delete the prompt." - (interactive) +(defun eshell-delete-output (&optional kill) + "Delete all output from interpreter since last input. +If KILL is non-nil (interactively, the prefix), save the killed text in +the kill ring. + +This command does not delete the prompt." + (interactive "P") (save-excursion (goto-char (eshell-beginning-of-output)) (insert "*** output flushed ***\n") + (when kill + (copy-region-as-kill (point) (eshell-end-of-output))) (delete-region (point) (eshell-end-of-output)))) +(define-obsolete-function-alias 'eshell-kill-output + #'eshell-delete-output "30.1") + (defun eshell-show-output (&optional arg) "Display start of this batch of interpreter output at top of window. Sets mark to the value of point when this command is run. diff --git a/lisp/eshell/esh-opt.el b/lisp/eshell/esh-opt.el index d01e3569d57..e6f5fc9629a 100644 --- a/lisp/eshell/esh-opt.el +++ b/lisp/eshell/esh-opt.el @@ -100,29 +100,37 @@ the new process for its value. Lastly, any remaining arguments will be available in the locally let-bound variable `args'." (declare (debug (form form sexp body))) - `(let* ((temp-args - ,(if (memq ':preserve-args (cadr options)) - (list 'copy-tree macro-args) - (list 'eshell-stringify-list - (list 'flatten-tree macro-args)))) - (processed-args (eshell--do-opts ,name ,options temp-args ,macro-args)) - ,@(delete-dups - (delq nil (mapcar (lambda (opt) - (and (listp opt) (nth 3 opt) - `(,(nth 3 opt) (pop processed-args)))) - ;; `options' is of the form (quote OPTS). - (cadr options)))) - (args processed-args)) - ;; Silence unused lexical variable warning if body does not use `args'. - (ignore args) - ,@body-forms)) + (let ((option-syms (eshell--get-option-symbols + ;; `options' is of the form (quote OPTS). + (cadr options)))) + `(let* ((temp-args + ,(if (memq ':preserve-args (cadr options)) + (list 'copy-tree macro-args) + (list 'eshell-stringify-list + (list 'flatten-tree macro-args)))) + (args (eshell--do-opts ,name temp-args ,macro-args + ,options ',option-syms)) + ;; Bind all the option variables. When done, `args' will + ;; contain any remaining positional arguments. + ,@(mapcar (lambda (sym) `(,sym (pop args))) option-syms)) + ;; Silence unused lexical variable warning if body does not use `args'. + (ignore args) + ,@body-forms))) ;;; Internal Functions: ;; Documented part of the interface; see eshell-eval-using-options. (defvar eshell--args) -(defun eshell--do-opts (name options args orig-args) +(defun eshell--get-option-symbols (options) + "Get a list of symbols for the specified OPTIONS. +OPTIONS is a list of command-line options from +`eshell-eval-using-options' (which see)." + (delete-dups + (delq nil (mapcar (lambda (opt) (and (listp opt) (nth 3 opt))) + options)))) + +(defun eshell--do-opts (name args orig-args options option-syms) "Helper function for `eshell-eval-using-options'. This code doesn't really need to be macro expanded everywhere." (require 'esh-ext) @@ -134,7 +142,8 @@ This code doesn't really need to be macro expanded everywhere." (if (and (= (length args) 0) (memq ':show-usage options)) (eshell-show-usage name options) - (setq args (eshell--process-args name args options)) + (setq args (eshell--process-args name args options + option-syms)) nil)))) (when usage-msg (user-error "%s" usage-msg)))))) @@ -269,16 +278,13 @@ triggered to say that the switch is unrecognized." "%s: unrecognized option --%s") name (car switch))))))) -(defun eshell--process-args (name args options) - "Process the given ARGS using OPTIONS." - (let* ((seen ()) - (opt-vals (delq nil (mapcar (lambda (opt) - (when (listp opt) - (let ((sym (nth 3 opt))) - (when (and sym (not (memq sym seen))) - (push sym seen) - (list sym))))) - options))) +(defun eshell--process-args (name args options option-syms) + "Process the given ARGS for the command NAME using OPTIONS. +OPTION-SYMS is a list of symbols that will hold the processed arguments. + +Return a list of values corresponding to each element in OPTION-SYMS, +followed by any additional positional arguments." + (let* ((opt-vals (mapcar #'list option-syms)) (ai 0) arg (eshell--args args) (pos-argument-found nil)) diff --git a/lisp/eshell/esh-proc.el b/lisp/eshell/esh-proc.el index 2bb0043bddb..35c81f6a4b2 100644 --- a/lisp/eshell/esh-proc.el +++ b/lisp/eshell/esh-proc.el @@ -193,7 +193,7 @@ This is like `process-live-p', but additionally checks whether (defalias 'eshell/wait #'eshell-wait-for-process) -(defun eshell/jobs (&rest _args) +(defun eshell/jobs () "List processes, if there are any." (and (fboundp 'process-list) (process-list) diff --git a/lisp/eshell/esh-util.el b/lisp/eshell/esh-util.el index f0acfecb701..129134814e3 100644 --- a/lisp/eshell/esh-util.el +++ b/lisp/eshell/esh-util.el @@ -447,29 +447,34 @@ Prepend remote identification of `default-directory', if any." (parse-colon-path path-env)) (parse-colon-path path-env)))) -(defun eshell-split-path (path) - "Split a path into multiple subparts." - (let ((len (length path)) - (i 0) (li 0) - parts) - (if (and (eshell-under-windows-p) - (> len 2) - (eq (aref path 0) ?/) - (eq (aref path 1) ?/)) - (setq i 2)) - (while (< i len) - (if (and (eq (aref path i) ?/) - (not (get-text-property i 'escaped path))) - (setq parts (cons (if (= li i) "/" - (substring path li (1+ i))) parts) - li (1+ i))) - (setq i (1+ i))) - (if (< li i) - (setq parts (cons (substring path li i) parts))) - (if (and (eshell-under-windows-p) - (string-match "\\`[A-Za-z]:\\'" (car (last parts)))) - (setcar (last parts) (concat (car (last parts)) "/"))) - (nreverse parts))) +(defun eshell-split-filename (filename) + "Split a FILENAME into a list of file/directory components." + (let* ((remote (file-remote-p filename)) + (filename (file-local-name filename)) + (len (length filename)) + (index 0) (curr-start 0) + parts) + (when (and (eshell-under-windows-p) + (string-prefix-p "//" filename)) + (setq index 2)) + (while (< index len) + (when (and (eq (aref filename index) ?/) + (not (get-text-property index 'escaped filename))) + (push (if (= curr-start index) "/" + (substring filename curr-start (1+ index))) + parts) + (setq curr-start (1+ index))) + (setq index (1+ index))) + (when (< curr-start len) + (push (substring filename curr-start) parts)) + (setq parts (nreverse parts)) + (when (and (eshell-under-windows-p) + (string-match "\\`[A-Za-z]:\\'" (car parts))) + (setcar parts (concat (car parts) "/"))) + (if remote (cons remote parts) parts))) + +(define-obsolete-function-alias 'eshell-split-path + 'eshell-split-filename "30.1") (defun eshell-to-flat-string (value) "Make value a string. If separated by newlines change them to spaces." diff --git a/lisp/eshell/esh-var.el b/lisp/eshell/esh-var.el index ae0b18cd13a..02b5c785625 100644 --- a/lisp/eshell/esh-var.el +++ b/lisp/eshell/esh-var.el @@ -255,6 +255,20 @@ copied (a.k.a. \"exported\") to the environment of created subprocesses." (defvar-keymap eshell-var-mode-map "C-c M-v" #'eshell-insert-envvar) +;;; Internal Variables: + +(defvar eshell-in-local-scope-p nil + "Non-nil if the current command has a local variable scope. +This is set to t in `eshell-local-variable-bindings' (which see).") + +(defvar eshell-local-variable-bindings + '((eshell-in-local-scope-p t) + (process-environment (eshell-copy-environment)) + (eshell-variable-aliases-list eshell-variable-aliases-list) + (eshell-path-env-list eshell-path-env-list) + (comint-pager comint-pager)) + "A list of `let' bindings for local variable (and subcommand) environments.") + ;;; Functions: (define-minor-mode eshell-var-mode @@ -271,12 +285,10 @@ copied (a.k.a. \"exported\") to the environment of created subprocesses." (setq-local process-environment (eshell-copy-environment))) (make-local-variable 'comint-pager) (setq-local eshell-subcommand-bindings - (append - '((process-environment (eshell-copy-environment)) - (eshell-variable-aliases-list eshell-variable-aliases-list) - (eshell-path-env-list eshell-path-env-list) - (comint-pager comint-pager)) - eshell-subcommand-bindings)) + (append eshell-local-variable-bindings + eshell-subcommand-bindings)) + (setq-local eshell-complex-commands + (append '("env") eshell-complex-commands)) (setq-local eshell-special-chars-inside-quoting (append eshell-special-chars-inside-quoting '(?$))) @@ -294,32 +306,36 @@ copied (a.k.a. \"exported\") to the environment of created subprocesses." (add-hook 'pcomplete-try-first-hook #'eshell-complete-variable-assignment nil t))) -(defun eshell-handle-local-variables () - "Allow for the syntax `VAR=val <command> <args>'." - ;; Eshell handles local variable settings (e.g. 'CFLAGS=-O2 make') - ;; by making the whole command into a subcommand, and calling - ;; `eshell-set-variable' immediately before the command is invoked. - ;; This means that 'FOO=x cd bar' won't work exactly as expected, - ;; but that is by no means a typical use of local environment - ;; variables. +(defun eshell-parse-local-variables (args) + "Parse a list of ARGS, looking for variable assignments. +Variable assignments are of the form \"VAR=value\". If ARGS +begins with any such assignments, throw `eshell-replace-command' +with a form that will temporarily set those variables. +Otherwise, return nil." + ;; Handle local variable settings by let-binding the entries in + ;; `eshell-local-variable-bindings' and calling `eshell-set-variable' + ;; for each variable before the command is invoked. (let ((setvar "\\`\\([A-Za-z_][A-Za-z0-9_]*\\)=\\(.*\\)\\'") - (command eshell-last-command-name) - (args eshell-last-arguments)) - (when (and (stringp command) (string-match setvar command)) + (head (car args)) + (rest (cdr args))) + (when (and (stringp head) (string-match setvar head)) (throw 'eshell-replace-command - `(eshell-as-subcommand - (progn - ,@(let (locals) - (while (and (stringp command) - (string-match setvar command)) - (push `(eshell-set-variable - ,(match-string 1 command) - ,(match-string 2 command)) - locals) - (setq command (pop args))) - (nreverse locals)) - (eshell-named-command ,command ,(list 'quote args))) - ))))) + `(let ,eshell-local-variable-bindings + ,@(let (locals) + (while (and (stringp head) + (string-match setvar head)) + (push `(eshell-set-variable + ,(match-string 1 head) + ,(match-string 2 head)) + locals) + (setq head (pop rest))) + (nreverse locals)) + (eshell-named-command ,head ',rest)))))) + +(defun eshell-handle-local-variables () + "Allow for the syntax `VAR=val <command> <args>'." + (eshell-parse-local-variables (cons eshell-last-command-name + eshell-last-arguments))) (defun eshell-interpolate-variable () "Parse a variable interpolation. @@ -409,19 +425,22 @@ the values of nil for each." obarray #'boundp)) (pcomplete-here)))) -;; FIXME the real "env" command does more than this, it runs a program -;; in a modified environment. (defun eshell/env (&rest args) "Implementation of `env' in Lisp." - (eshell-init-print-buffer) (eshell-eval-using-options "env" args - '((?h "help" nil nil "show this usage screen") + '(;; FIXME: Support more "env" options, like "--unset". + (?h "help" nil nil "show this usage screen") :external "env" - :usage "<no arguments>") - (dolist (setting (sort (eshell-environment-variables) 'string-lessp)) - (eshell-buffered-print setting "\n")) - (eshell-flush))) + :parse-leading-options-only + :usage "[NAME=VALUE]... [COMMAND]...") + (if args + (or (eshell-parse-local-variables args) + (eshell-named-command (car args) (cdr args))) + (eshell-init-print-buffer) + (dolist (setting (sort (eshell-environment-variables) 'string-lessp)) + (eshell-buffered-print setting "\n")) + (eshell-flush)))) (defun eshell-insert-envvar (envvar-name) "Insert ENVVAR-NAME into the current buffer at point." @@ -709,7 +728,7 @@ to a Lisp variable)." ((functionp target) (funcall target nil value)) ((null target) - (unless eshell-in-subcommand-p + (unless eshell-in-local-scope-p (error "Variable `%s' is not settable" (eshell-stringify name))) (push `(,name ,(lambda () value) t t) eshell-variable-aliases-list) diff --git a/lisp/faces.el b/lisp/faces.el index d5120f42b92..c3a54a08a3d 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -651,11 +651,11 @@ Optional argument INHERIT is passed to `face-attribute'." If FACE is a face-alias, get the documentation for the target face." (let ((alias (get face 'face-alias))) (if alias - (let ((doc (get alias 'face-documentation))) + (let ((doc (documentation-property alias 'face-documentation))) (format "%s is an alias for the face `%s'.%s" face alias (if doc (format "\n%s" doc) ""))) - (get face 'face-documentation)))) + (documentation-property face 'face-documentation)))) (defun set-face-documentation (face string) diff --git a/lisp/ffap.el b/lisp/ffap.el index 3492dcbf17a..b2b681b7c44 100644 --- a/lisp/ffap.el +++ b/lisp/ffap.el @@ -1065,6 +1065,9 @@ If a given RFC isn't in these then `ffap-rfc-path' is offered." ;; (La)TeX: don't allow braces (latex-mode "--:\\\\$+<>@-Z_[:alpha:]~*?" "<@" "@>;.,!:") (tex-mode "--:\\\\$+<>@-Z_[:alpha:]~*?" "<@" "@>;.,!:") + ;; XML: don't allow angle brackets + (xml-mode "--:\\\\${}+@-Z_[:alpha:]~*?#" "{<@" "@>;.,!:}") + (nxml-mode "--:\\\\${}+@-Z_[:alpha:]~*?#" "{<@" "@>;.,!:}") ) "Alist of (MODE CHARS BEG END), where MODE is a symbol. This is possibly a major-mode name, or one of the symbols @@ -1098,12 +1101,12 @@ Suppose the cursor is somewhere that might be near end of file, the guessing would position point before punctuation (like comma) after the file extension: - C:\temp\file.log, which contain .... + C:\\temp\\file.log, which contain .... =============================== (before) ---------------- (after) - C:\temp\file.log on Windows or /tmp/file.log on Unix + C:\\temp\\file.log on Windows or /tmp/file.log on Unix =============================== (before) ---------------- (after) diff --git a/lisp/files-x.el b/lisp/files-x.el index fccb2fa4a9f..f70be5f7ff3 100644 --- a/lisp/files-x.el +++ b/lisp/files-x.el @@ -929,19 +929,23 @@ earlier in the `setq-connection-local'. The return value of the ;;;###autoload (defmacro connection-local-p (variable &optional application) "Non-nil if VARIABLE has a connection-local binding in `default-directory'. +`default-directory' must be a remote file name. If APPLICATION is nil, the value of `connection-local-default-application' is used." (declare (debug (symbolp &optional form))) (unless (symbolp variable) (signal 'wrong-type-argument (list 'symbolp variable))) - `(let (connection-local-variables-alist file-local-variables-alist) - (hack-connection-local-variables - (connection-local-criteria-for-default-directory ,application)) - (and (assq ',variable connection-local-variables-alist) t))) + `(let ((criteria + (connection-local-criteria-for-default-directory ,application)) + connection-local-variables-alist file-local-variables-alist) + (when criteria + (hack-connection-local-variables criteria) + (and (assq ',variable connection-local-variables-alist) t)))) ;;;###autoload (defmacro connection-local-value (variable &optional application) "Return connection-local VARIABLE for APPLICATION in `default-directory'. +`default-directory' must be a remote file name. If APPLICATION is nil, the value of `connection-local-default-application' is used. If VARIABLE does not have a connection-local binding, the return @@ -949,12 +953,15 @@ value is the default binding of the variable." (declare (debug (symbolp &optional form))) (unless (symbolp variable) (signal 'wrong-type-argument (list 'symbolp variable))) - `(let (connection-local-variables-alist file-local-variables-alist) - (hack-connection-local-variables - (connection-local-criteria-for-default-directory ,application)) - (if-let ((result (assq ',variable connection-local-variables-alist))) - (cdr result) - ,variable))) + `(let ((criteria + (connection-local-criteria-for-default-directory ,application)) + connection-local-variables-alist file-local-variables-alist) + (if (not criteria) + ,variable + (hack-connection-local-variables criteria) + (if-let ((result (assq ',variable connection-local-variables-alist))) + (cdr result) + ,variable)))) ;;;###autoload (defun path-separator () diff --git a/lisp/files.el b/lisp/files.el index 8b4e4394e5a..20d63d33fef 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -698,6 +698,14 @@ Also see the `permanently-enabled-local-variables' and Some modes may wish to set this to nil to prevent directory-local settings being applied, but still respect file-local ones.") +(defvar-local untrusted-content nil + "Non-nil means that current buffer originated from an untrusted source. +Email clients and some other modes may set this non-nil to mark the +buffer contents as untrusted. + +This variable might be subject to change without notice.") +(put 'untrusted-content 'permanent-local t) + ;; This is an odd variable IMO. ;; You might wonder why it is needed, when we could just do: ;; (setq-local enable-local-variables nil) @@ -2747,6 +2755,10 @@ Fifth arg NOMODES non-nil means don't alter the file's modes. Finishes by calling the functions in `find-file-hook' unless NOMODES is non-nil." (setq buffer-read-only (not (file-writable-p buffer-file-name))) + ;; The above is sufficiently like turning on read-only-mode, so run + ;; the mode hook here by hand. + (if buffer-read-only + (run-hooks 'read-only-mode-hook)) (if noninteractive nil (let* (not-serious @@ -3059,7 +3071,7 @@ ARC\\|ZIP\\|LZH\\|LHA\\|ZOO\\|[JEW]AR\\|XPI\\|RAR\\|CBR\\|7Z\\|SQUASHFS\\)\\'" . ("\\.docbook\\'" . sgml-mode) ("\\.com\\'" . dcl-mode) ("/config\\.\\(?:bat\\|log\\)\\'" . fundamental-mode) - ("/\\.\\(authinfo\\|netrc\\)\\'" . authinfo-mode) + ("/\\.?\\(authinfo\\|netrc\\)\\'" . authinfo-mode) ;; Windows candidates may be opened case sensitively on Unix ("\\.\\(?:[iI][nN][iI]\\|[lL][sS][tT]\\|[rR][eE][gG]\\|[sS][yY][sS]\\)\\'" . conf-mode) ("\\.la\\'" . conf-unix-mode) @@ -3270,7 +3282,16 @@ and `inhibit-local-variables-suffixes'. If ;; Optional group 1: env(1) invocation. "\\(" "[^ \t\n]*/bin/env[ \t]*" - "\\(?:-S[ \t]*\\|--split-string\\(?:=\\|[ \t]*\\)\\)?" + ;; Within group 1: possible -S/--split-string and environment + ;; adjustments. + "\\(?:" + ;; -S/--split-string + "\\(?:-[0a-z]*S[ \t]*\\|--split-string=\\)" + ;; More env arguments. + "\\(?:-[^ \t\n]+[ \t]+\\)*" + ;; Interpreter environment modifications. + "\\(?:[^ \t\n]+=[^ \t\n]*[ \t]+\\)*" + "\\)?" "\\)?" ;; Group 2: interpreter. "\\([^ \t\n]+\\)")) @@ -3400,7 +3421,7 @@ checks if it uses an interpreter listed in `interpreter-mode-alist', matches the buffer beginning against `magic-mode-alist', compares the file name against the entries in `auto-mode-alist', then matches the buffer beginning against `magic-fallback-mode-alist'. -It also obeys `major-mode-remap-alist'. +It also obeys `major-mode-remap-alist' and `major-mode-remap-defaults'. If `enable-local-variables' is nil, or if the file name matches `inhibit-local-variables-regexps', this function does not check @@ -3412,7 +3433,7 @@ set the major mode only if that would change it. In other words we don't actually set it to the same mode the buffer already has." ;; Look for -*-MODENAME-*- or -*- ... mode: MODENAME; ... -*- (let ((try-locals (not (inhibit-local-variables-p))) - end done mode modes) + end modes) ;; Once we drop the deprecated feature where mode: is also allowed to ;; specify minor-modes (ie, there can be more than one "mode:"), we can ;; remove this section and just let (hack-local-variables t) handle it. @@ -3443,100 +3464,96 @@ we don't actually set it to the same mode the buffer already has." (push (intern (concat (downcase (buffer-substring (point) end)) "-mode")) modes)))) - ;; If we found modes to use, invoke them now, outside the save-excursion. - (if modes - (catch 'nop - (dolist (mode (nreverse modes)) - (if (not (functionp mode)) - (message "Ignoring unknown mode `%s'" mode) - (setq done t) - (or (set-auto-mode-0 mode keep-mode-if-same) - ;; continuing would call minor modes again, toggling them off - (throw 'nop nil)))))) - ;; Check for auto-mode-alist entry in dir-locals. - (unless done - (with-demoted-errors "Directory-local variables error: %s" - ;; Note this is a no-op if enable-local-variables is nil. - (let* ((mode-alist (cdr (hack-dir-local--get-variables - (lambda (key) (eq key 'auto-mode-alist)))))) - (setq done (set-auto-mode--apply-alist mode-alist - keep-mode-if-same t))))) - (and (not done) - (setq mode (hack-local-variables t (not try-locals))) - (not (memq mode modes)) ; already tried and failed - (if (not (functionp mode)) - (message "Ignoring unknown mode `%s'" mode) - (setq done t) - (set-auto-mode-0 mode keep-mode-if-same))) - ;; If we didn't, look for an interpreter specified in the first line. - ;; As a special case, allow for things like "#!/bin/env perl", which - ;; finds the interpreter anywhere in $PATH. - (and (not done) - (setq mode (save-excursion - (goto-char (point-min)) - (if (looking-at auto-mode-interpreter-regexp) - (match-string 2)))) - ;; Map interpreter name to a mode, signaling we're done at the - ;; same time. - (setq done (assoc-default - (file-name-nondirectory mode) - (mapcar (lambda (e) - (cons - (format "\\`%s\\'" (car e)) - (cdr e))) - interpreter-mode-alist) - #'string-match-p)) - ;; If we found an interpreter mode to use, invoke it now. - (set-auto-mode-0 done keep-mode-if-same)) - ;; Next try matching the buffer beginning against magic-mode-alist. - (unless done - (if (setq done (save-excursion - (goto-char (point-min)) - (save-restriction - (narrow-to-region (point-min) - (min (point-max) - (+ (point-min) magic-mode-regexp-match-limit))) - (assoc-default - nil magic-mode-alist - (lambda (re _dummy) - (cond - ((functionp re) - (funcall re)) - ((stringp re) - (let ((case-fold-search nil)) - (looking-at re))) - (t - (error - "Problem in magic-mode-alist with element %s" - re)))))))) - (set-auto-mode-0 done keep-mode-if-same))) - ;; Next compare the filename against the entries in auto-mode-alist. - (unless done - (setq done (set-auto-mode--apply-alist auto-mode-alist - keep-mode-if-same nil))) - ;; Next try matching the buffer beginning against magic-fallback-mode-alist. - (unless done - (if (setq done (save-excursion - (goto-char (point-min)) - (save-restriction - (narrow-to-region (point-min) - (min (point-max) - (+ (point-min) magic-mode-regexp-match-limit))) - (assoc-default nil magic-fallback-mode-alist - (lambda (re _dummy) - (cond - ((functionp re) - (funcall re)) - ((stringp re) - (let ((case-fold-search nil)) - (looking-at re))) - (t - (error - "Problem with magic-fallback-mode-alist element: %s" - re)))))))) - (set-auto-mode-0 done keep-mode-if-same))) - (unless done - (set-buffer-major-mode (current-buffer))))) + (or + ;; If we found modes to use, invoke them now, outside the save-excursion. + ;; Presume `modes' holds a major mode followed by minor modes. + (let ((done ())) + (dolist (mode (nreverse modes)) + (if (eq done :keep) + ;; `keep-mode-if-same' is set and the (major) mode + ;; was already set. Refrain from calling the following + ;; minor modes since they have already been set. + ;; It was especially important in the past when calling + ;; minor modes without an arg would toggle them, but it's + ;; still preferable to avoid re-enabling them, + nil + (let ((res (set-auto-mode-0 mode keep-mode-if-same))) + (setq done (or res done))))) + done) + ;; Check for auto-mode-alist entry in dir-locals. + (with-demoted-errors "Directory-local variables error: %s" + ;; Note this is a no-op if enable-local-variables is nil. + (let* ((mode-alist (cdr (hack-dir-local--get-variables + (lambda (key) (eq key 'auto-mode-alist)))))) + (set-auto-mode--apply-alist mode-alist keep-mode-if-same t))) + (let ((mode (hack-local-variables t (not try-locals)))) + (unless (memq mode modes) ; already tried and failed + (set-auto-mode-0 mode keep-mode-if-same))) + ;; If we didn't, look for an interpreter specified in the first line. + ;; As a special case, allow for things like "#!/bin/env perl", which + ;; finds the interpreter anywhere in $PATH. + (when-let + ((interp (save-excursion + (goto-char (point-min)) + (if (looking-at auto-mode-interpreter-regexp) + (match-string 2)))) + ;; Map interpreter name to a mode, signaling we're done at the + ;; same time. + (mode (assoc-default + (file-name-nondirectory interp) + (mapcar (lambda (e) + (cons + (format "\\`%s\\'" (car e)) + (cdr e))) + interpreter-mode-alist) + #'string-match-p))) + ;; If we found an interpreter mode to use, invoke it now. + (set-auto-mode-0 mode keep-mode-if-same)) + ;; Next try matching the buffer beginning against magic-mode-alist. + (let ((mode (save-excursion + (goto-char (point-min)) + (save-restriction + (narrow-to-region (point-min) + (min (point-max) + (+ (point-min) magic-mode-regexp-match-limit))) + (assoc-default + nil magic-mode-alist + (lambda (re _dummy) + (cond + ((functionp re) + (funcall re)) + ((stringp re) + (let ((case-fold-search nil)) + (looking-at re))) + (t + (error + "Problem in magic-mode-alist with element %s" + re))))))))) + (set-auto-mode-0 mode keep-mode-if-same)) + ;; Next compare the filename against the entries in auto-mode-alist. + (set-auto-mode--apply-alist auto-mode-alist + keep-mode-if-same nil) + ;; Next try matching the buffer beginning against magic-fallback-mode-alist. + (let ((mode (save-excursion + (goto-char (point-min)) + (save-restriction + (narrow-to-region (point-min) + (min (point-max) + (+ (point-min) magic-mode-regexp-match-limit))) + (assoc-default nil magic-fallback-mode-alist + (lambda (re _dummy) + (cond + ((functionp re) + (funcall re)) + ((stringp re) + (let ((case-fold-search nil)) + (looking-at re))) + (t + (error + "Problem with magic-fallback-mode-alist element: %s" + re))))))))) + (set-auto-mode-0 mode keep-mode-if-same)) + (set-buffer-major-mode (current-buffer))))) (defvar-local set-auto-mode--last nil "Remember the mode we have set via `set-auto-mode-0'.") @@ -3546,9 +3563,22 @@ we don't actually set it to the same mode the buffer already has." Every entry is of the form (MODE . FUNCTION) which means that in order to activate the major mode MODE (specified via something like `auto-mode-alist', file-local variables, ...) we should actually call -FUNCTION instead." +FUNCTION instead. +FUNCTION can be nil to hide other entries (either in this var or in +`major-mode-remap-defaults') and means that we should call MODE." :type '(alist (symbol) (function))) +(defvar major-mode-remap-defaults nil + "Alist mapping file-specified mode to actual mode. +This works like `major-mode-remap-alist' except it has lower priority +and it is meant to be modified by packages rather than users.") + +(defun major-mode-remap (mode) + "Return the function to use to enable MODE." + (or (cdr (or (assq mode major-mode-remap-alist) + (assq mode major-mode-remap-defaults))) + mode)) + ;; When `keep-mode-if-same' is set, we are working on behalf of ;; set-visited-file-name. In that case, if the major mode specified is the ;; same one we already have, don't actually reset it. We don't want to lose @@ -3557,18 +3587,29 @@ FUNCTION instead." "Apply MODE and return it. If optional arg KEEP-MODE-IF-SAME is non-nil, MODE is chased of any aliases and compared to current major mode. If they are the -same, do nothing and return nil." - (unless (and keep-mode-if-same - (or (eq (indirect-function mode) - (indirect-function major-mode)) - (and set-auto-mode--last - (eq mode (car set-auto-mode--last)) - (eq major-mode (cdr set-auto-mode--last))))) - (when mode - (funcall (alist-get mode major-mode-remap-alist mode)) - (unless (eq mode major-mode) - (setq set-auto-mode--last (cons mode major-mode))) - mode))) +same, do nothing and return `:keep'. +Return nil if MODE could not be applied." + (when mode + (if (and keep-mode-if-same + (or (eq (indirect-function mode) + (indirect-function major-mode)) + (and set-auto-mode--last + (eq mode (car set-auto-mode--last)) + (eq major-mode (cdr set-auto-mode--last))))) + :keep + (let ((modefun (major-mode-remap mode))) + (if (not (functionp modefun)) + (progn + (message "Ignoring unknown mode `%s'%s" mode + (if (eq mode modefun) "" + (format " (remapped to `%S')" modefun))) + nil) + (funcall modefun) + (unless (or (eq mode major-mode) ;`set-auto-mode--last' is overkill. + ;; `modefun' is something like a minor mode. + (local-variable-p 'set-auto-mode--last)) + (setq set-auto-mode--last (cons mode major-mode))) + mode))))) (defvar file-auto-mode-skip "^\\(#!\\|'\\\\\"\\)" "Regexp of lines to skip when looking for file-local settings. @@ -3754,7 +3795,8 @@ function is allowed to change the contents of this alist. This hook is called only if there is at least one file-local variable to set.") -(defvar permanently-enabled-local-variables '(lexical-binding) +(defvar permanently-enabled-local-variables + '(lexical-binding read-symbol-shorthands) "A list of file-local variables that are always enabled. This overrides any `enable-local-variables' setting.") @@ -4174,8 +4216,9 @@ major-mode." (not (string-match "-minor\\'" (setq val2 (downcase (symbol-name val))))) - ;; Allow several mode: elements. - (push (intern (concat val2 "-mode")) result)) + (let ((mode (intern (concat val2 "-mode")))) + (when (fboundp (major-mode-remap mode)) + (setq result mode)))) (cond ((eq var 'coding)) ((eq var 'lexical-binding) (unless hack-local-variables--warned-lexical @@ -4190,6 +4233,13 @@ major-mode." ;; to use 'thisbuf's name in the ;; warning message. (or (buffer-file-name thisbuf) "")))))) + ((eq var 'read-symbol-shorthands) + ;; Sort automatically by shorthand length + ;; in descending order. + (setq val (sort val + (lambda (sh1 sh2) (> (length (car sh1)) + (length (car sh2)))))) + (push (cons 'read-symbol-shorthands val) result)) ((and (eq var 'mode) handle-mode)) (t (ignore-errors @@ -4199,10 +4249,7 @@ major-mode." val) result)))))) (forward-line 1))))))) - (if (eq handle-mode t) - ;; Return the final mode: setting that's defined. - (car (seq-filter #'fboundp result)) - result))) + result)) (defun hack-local-variables-apply () "Apply the elements of `file-local-variables-alist'. @@ -4331,10 +4378,8 @@ already the major mode." (pcase var ('mode (let ((mode (intern (concat (downcase (symbol-name val)) - "-mode")))) - (unless (eq (indirect-function mode) - (indirect-function major-mode)) - (funcall mode)))) + "-mode")))) + (set-auto-mode-0 mode t))) ('eval (pcase val (`(add-hook ',hook . ,_) (hack-one-local-variable--obsolete hook))) @@ -4414,6 +4459,12 @@ to see whether it should be considered." (funcall predicate key) (or (not key) (derived-mode-p key))) + ;; If KEY is an extra parent it may remain not loaded + ;; (hence with some of its mode-specific vars missing their + ;; `safe-local-variable' property), leading to spurious + ;; prompts about unsafe vars (bug#68246). + (if (and (symbolp key) (autoloadp (indirect-function key))) + (ignore-errors (autoload-do-load (indirect-function key)))) (let* ((alist (cdr entry)) (subdirs (assq 'subdirs alist))) (if (or (not subdirs) diff --git a/lisp/filesets.el b/lisp/filesets.el index 7332687d46d..68133ba2255 100644 --- a/lisp/filesets.el +++ b/lisp/filesets.el @@ -161,18 +161,9 @@ COND-FN takes one argument: the current element." (define-obsolete-function-alias 'filesets-member #'cl-member "28.1") (define-obsolete-function-alias 'filesets-sublist #'seq-subseq "28.1") -(defun filesets-select-command (cmd-list) - "Select one command from CMD-LIST -- a string with space separated names." - (let ((this (shell-command-to-string - (format "which --skip-alias %s 2> %s | head -n 1" - cmd-list null-device)))) - (if (equal this "") - nil - (file-name-nondirectory (substring this 0 (- (length this) 1)))))) - (defun filesets-which-command (cmd) "Call \"which CMD\"." - (shell-command-to-string (format "which %s" cmd))) + (shell-command-to-string (format "which %s" (shell-quote-argument cmd)))) (defun filesets-which-command-p (cmd) "Call \"which CMD\" and return non-nil if the command was found." @@ -286,7 +277,7 @@ See `easy-menu-add-item' for documentation." ) (defcustom filesets-menu-in-menu nil - "Use that instead of `current-menubar' as the menu to change. + "Use that instead of `current-global-map' as the menu to change. See `easy-menu-add-item' for documentation." :set #'filesets-set-default :type 'sexp) @@ -547,16 +538,6 @@ the filename." (defcustom filesets-external-viewers (let - ;; ((ps-cmd (or (and (boundp 'my-ps-viewer) my-ps-viewer) - ;; (filesets-select-command "ggv gv"))) - ;; (pdf-cmd (or (and (boundp 'my-ps-viewer) my-pdf-viewer) - ;; (filesets-select-command "xpdf acroread"))) - ;; (dvi-cmd (or (and (boundp 'my-ps-viewer) my-dvi-viewer) - ;; (filesets-select-command "xdvi tkdvi"))) - ;; (doc-cmd (or (and (boundp 'my-ps-viewer) my-doc-viewer) - ;; (filesets-select-command "antiword"))) - ;; (pic-cmd (or (and (boundp 'my-ps-viewer) my-pic-viewer) - ;; (filesets-select-command "gqview ee display")))) ((ps-cmd "ggv") (pdf-cmd "xpdf") (dvi-cmd "xdvi") @@ -1084,10 +1065,6 @@ Return full path if FULL-FLAG is non-nil." (t (error "Filesets: %s does not exist" dir)))) -(defun filesets-quote (txt) - "Return TXT in quotes." - (concat "\"" txt "\"")) - (defun filesets-get-selection () "Get the text between mark and point -- i.e. the selection or region." (let ((m (mark)) @@ -1098,7 +1075,7 @@ Return full path if FULL-FLAG is non-nil." (defun filesets-get-quoted-selection () "Return the currently selected text in quotes." - (filesets-quote (filesets-get-selection))) + (shell-quote-argument (filesets-get-selection))) (defun filesets-get-shortcut (n) "Create menu shortcuts based on number N." @@ -1245,12 +1222,13 @@ Use the viewer defined in EV-ENTRY (a valid element of (if fmt (mapconcat (lambda (this) - (if (stringp this) (format this file) - (format "%S" (if (functionp this) - (funcall this) - this)))) + (if (stringp this) + (format this (shell-quote-argument file)) + (shell-quote-argument (if (functionp this) + (funcall this) + this)))) fmt "") - (format "%S" file)))) + (shell-quote-argument file)))) (output (cond ((and (functionp vwr) co-flag) @@ -1259,7 +1237,7 @@ Use the viewer defined in EV-ENTRY (a valid element of (funcall vwr file) nil) (co-flag - (shell-command-to-string (format "%s %s" vwr args))) + (shell-command-to-string (format "%s %s" vwr args))) (t (shell-command (format "%s %s&" vwr args)) nil)))) @@ -1767,7 +1745,7 @@ If no fileset name is provided, prompt for NAME." (add-to-list 'filesets-data (list name '(:files))) (message (substitute-command-keys - "Fileset %s created. Call `\\[filesets-save-config]' to save.") + "Fileset %s created. Call \\[filesets-save-config] to save.") name) (car filesets-data)))))) (if entry @@ -2483,11 +2461,15 @@ Set up hooks, load the cache file -- if existing -- and build the menu." (setq filesets-menu-use-cached-flag t))) (filesets-build-menu))) +;;; obsolete + (defun filesets-error (_class &rest args) "`error' wrapper." (declare (obsolete error "28.1")) (error "%s" (mapconcat #'identity args " "))) +(define-obsolete-function-alias 'filesets-quote #'shell-quote-argument "30.1") + (provide 'filesets) ;;; filesets.el ends here diff --git a/lisp/follow.el b/lisp/follow.el index 316c85b1629..874e546bd6d 100644 --- a/lisp/follow.el +++ b/lisp/follow.el @@ -413,8 +413,8 @@ being able to use 144 or 216 lines instead of the normal 72... (your mileage may vary). To split one large window into two side-by-side windows, the commands -`\\[split-window-right]' or \ -`\\[follow-delete-other-windows-and-split]' can be used. +\\[split-window-right] or \ +\\[follow-delete-other-windows-and-split] can be used. Only windows displayed in the same frame follow each other. @@ -874,6 +874,7 @@ from the bottom." (when (< dest win-s) (setq follow-internal-force-redisplay t)))))) +(put 'follow-recenter 'isearch-scroll t) (defun follow-redraw () "Arrange windows displaying the same buffer in successor order. diff --git a/lisp/format-spec.el b/lisp/format-spec.el index cf34017b994..73f9fccd793 100644 --- a/lisp/format-spec.el +++ b/lisp/format-spec.el @@ -38,7 +38,7 @@ For instance: (?l . \"ls\"))) Each %-spec may contain optional flag, width, and precision -modifiers, as follows: +specifiers, as follows: %<flags><width><precision>character @@ -51,7 +51,7 @@ The following flags are allowed: * ^: Convert to upper case. * _: Convert to lower case. -The width and truncation modifiers behave like the corresponding +The width and precision specifiers behave like the corresponding ones in `format' when applied to %s. For example, \"%<010b\" means \"substitute into the output the @@ -145,7 +145,7 @@ is returned, where each format spec is its own element." "Return STR formatted according to FLAGS, WIDTH, and TRUNC. FLAGS is a list of keywords as returned by `format-spec--parse-flags'. WIDTH and TRUNC are either nil or -string widths corresponding to `format-spec' modifiers." +string widths corresponding to `format-spec' specifiers." (let (diff str-width) ;; Truncate original string first, like `format' does. (when trunc diff --git a/lisp/forms.el b/lisp/forms.el index e38fa7ae873..3a3160a0c8b 100644 --- a/lisp/forms.el +++ b/lisp/forms.el @@ -343,7 +343,7 @@ suitable for forms processing.") (defvar forms-write-file-filter nil "The name of a function that is called before writing the data file. -This can be used to undo the effects of `form-read-file-hook'.") +This can be used to undo the effects of `forms-read-file-filter'.") (defvar forms-new-record-filter nil "The name of a function that is called when a new record is created.") diff --git a/lisp/generic-x.el b/lisp/generic-x.el index b4ae0225943..373bfad92dd 100644 --- a/lisp/generic-x.el +++ b/lisp/generic-x.el @@ -1491,6 +1491,7 @@ like an INI file. You can add this hook to `find-file-hook'." "cd9660" "cfs" "cgroup" + "cgroup2" "cifs" "coda" "coherent" diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el index 3ee93031119..0928b179787 100644 --- a/lisp/gnus/gnus-agent.el +++ b/lisp/gnus/gnus-agent.el @@ -2910,13 +2910,9 @@ The following commands are available: (car func) (gnus-byte-compile `(lambda () ,func))))) -(defun gnus-agent-true () - "Return t." - t) +(defalias 'gnus-agent-true #'always) -(defun gnus-agent-false () - "Return nil." - nil) +(defalias 'gnus-agent-false #'ignore) (defun gnus-category-make-function-1 (predicate) "Make a function from PREDICATE." @@ -2924,8 +2920,9 @@ The following commands are available: ;; Functions are just returned as is. ((or (symbolp predicate) (functionp predicate)) - `(,(or (cdr (assq predicate gnus-category-predicate-alist)) - predicate))) + (let ((fun (or (cdr (assq predicate gnus-category-predicate-alist)) + predicate))) + (if (symbolp fun) `(,fun) `(funcall ',fun)))) ;; More complex predicate. ((consp predicate) `(,(cond diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index c3c5eab7d89..9f313108089 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -694,7 +694,7 @@ used as possible file names." (defcustom gnus-page-delimiter "^\^L" "Regexp describing what to use as article page delimiters. -The default value is \"^\^L\", which is a form linefeed at the +The default value is \"^\\^L\", which is a form linefeed at the beginning of a line." :type 'regexp :group 'gnus-article-various) diff --git a/lisp/gnus/gnus-cite.el b/lisp/gnus/gnus-cite.el index 04abdfc0d1b..3fde9baa0fe 100644 --- a/lisp/gnus/gnus-cite.el +++ b/lisp/gnus/gnus-cite.el @@ -1122,31 +1122,17 @@ Returns nil if there is no such line before LIMIT, t otherwise." When enabled, it automatically turns on `font-lock-mode'." :lighter "" (when (derived-mode-p 'message-mode) - ;; FIXME: Use font-lock-add-keywords! - (let ((defaults (car font-lock-defaults)) - default) ;; keywords - (while defaults - (setq default (if (consp defaults) - (pop defaults) - (prog1 - defaults - (setq defaults nil)))) - (if gnus-message-citation-mode - ;; `gnus-message-citation-keywords' should be the last - ;; elements of the keywords because the others are unlikely - ;; to have the OVERRIDE flags -- XEmacs applies a keyword - ;; having no OVERRIDE flag to matched text even if it has - ;; already other faces, while Emacs doesn't. - (set (make-local-variable default) - (append (default-value default) - gnus-message-citation-keywords)) - (kill-local-variable default)))) - ;; Force `font-lock-set-defaults' to update `font-lock-keywords'. - (setq font-lock-set-defaults nil) - (font-lock-set-defaults) - (if font-lock-mode - (font-lock-flush) - (gnus-message-citation-mode (font-lock-mode 1))))) + (if (not font-lock-mode) + (gnus-message-citation-mode (font-lock-mode 1)) + (if gnus-message-citation-mode + ;; `gnus-message-citation-keywords' should be the last + ;; elements of the keywords because the others are unlikely + ;; to have the OVERRIDE flags -- XEmacs applies a keyword + ;; having no OVERRIDE flag to matched text even if it has + ;; already other faces, while Emacs doesn't. + (font-lock-add-keywords nil gnus-message-citation-keywords t) + (font-lock-remove-keywords nil gnus-message-citation-keywords)) + (font-lock-flush)))) (defun turn-on-gnus-message-citation-mode () "Turn on `gnus-message-citation-mode'." diff --git a/lisp/gnus/gnus-dired.el b/lisp/gnus/gnus-dired.el index 48c1aef968b..f33c5f7f2e5 100644 --- a/lisp/gnus/gnus-dired.el +++ b/lisp/gnus/gnus-dired.el @@ -111,6 +111,12 @@ See `mail-user-agent' for more information." (autoload 'gnus-completing-read "gnus-util") +(defcustom gnus-dired-attach-at-end t + "Non-nil means that files should be attached at the end of a buffer." + :group 'mail ;; dired? + :version "30.1" + :type 'boolean) + ;; Method to attach files to a mail composition. (defun gnus-dired-attach (files-to-attach) "Attach dired's marked files to a gnus message composition. @@ -161,7 +167,8 @@ filenames." ;; set buffer to destination buffer, and attach files (set-buffer destination) - (goto-char (point-max)) ;attach at end of buffer + (when gnus-dired-attach-at-end + (goto-char (point-max))) ;attach at end of buffer (while files-to-attach (mml-attach-file (car files-to-attach) (or (mm-default-file-type (car files-to-attach)) diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index 9664d603019..71bfaa639fa 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -1064,11 +1064,11 @@ When FORCE, rebuild the tool bar." All normal editing commands are switched off. \\<gnus-group-mode-map> The group buffer lists (some of) the groups available. For instance, -`\\[gnus-group-list-groups]' will list all subscribed groups with unread articles, while `\\[gnus-group-list-zombies]' +\\[gnus-group-list-groups] will list all subscribed groups with unread articles, while \\[gnus-group-list-zombies] lists all zombie groups. -Groups that are displayed can be entered with `\\[gnus-group-read-group]'. To subscribe -to a group not displayed, type `\\[gnus-group-toggle-subscription]'. +Groups that are displayed can be entered with \\[gnus-group-read-group]. To subscribe +to a group not displayed, type \\[gnus-group-toggle-subscription]. For more in-depth information on this mode, read the manual (`\\[gnus-info-find-node]'). @@ -4638,7 +4638,7 @@ and the second element is the address." "Mark ARTICLE in GROUP with MARK, whether the group is displayed or not." (let ((buffer (gnus-summary-buffer-name group))) (if (gnus-buffer-live-p buffer) - (with-current-buffer (get-buffer buffer) + (with-current-buffer buffer (gnus-summary-add-mark article mark)) (gnus-add-marked-articles group (cdr (assq mark gnus-article-mark-lists)) (list article))))) diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el index fdf97e1aabd..b18ede58fbf 100644 --- a/lisp/gnus/gnus-msg.el +++ b/lisp/gnus/gnus-msg.el @@ -1189,12 +1189,12 @@ Uses the process/prefix convention. The reply will include all From/Cc headers from the original messages as the To/Cc headers. -If prefix argument YANK is non-nil, the original article(s) will +If prefix argument YANK is non-nil, the original article will be yanked automatically." (interactive (list (and current-prefix-arg (gnus-summary-work-articles 1))) gnus-summary-mode) - (gnus-summary-reply yank t (gnus-summary-work-articles yank))) + (gnus-summary-reply yank t (gnus-summary-work-articles current-prefix-arg))) (defun gnus-summary-very-wide-reply-with-original (n) "Start composing a very wide reply mail a set of messages. diff --git a/lisp/gnus/gnus-notifications.el b/lisp/gnus/gnus-notifications.el index f34f5ea0e26..e4c3d2c0381 100644 --- a/lisp/gnus/gnus-notifications.el +++ b/lisp/gnus/gnus-notifications.el @@ -75,35 +75,55 @@ not get notifications." (when group-article (let ((group (cadr group-article)) (article (nth 2 group-article))) - (cond ((string= key "read") + (cond ((or (equal key "read") + (equal key "default")) (gnus-fetch-group group (list article)) (select-frame-set-input-focus (selected-frame))) - ((string= key "mark-read") + ((equal key "mark-read") (gnus-update-read-articles group (delq article (gnus-list-of-unread-articles group))) ;; gnus-group-refresh-group - (gnus-group-update-group group))))))) + (gnus-group-update-group group)))))) + ;; Notifications are removed unless otherwise specified once they (or + ;; an action of theirs) are selected + (assoc-delete-all id gnus-notifications-id-to-msg)) + +(defun gnus-notifications-close (id _reason) + "Remove ID from the alist of notification identifiers to messages. +REASON is ignored." + (assoc-delete-all id gnus-notifications-id-to-msg)) (defun gnus-notifications-notify (from subject photo-file) "Send a notification about a new mail. Return a notification id if any, or t on success." - (if (fboundp 'notifications-notify) + (if (featurep 'android) (gnus-funcall-no-warning - 'notifications-notify + 'android-notifications-notify :title from :body subject :actions '("read" "Read" "mark-read" "Mark As Read") :on-action 'gnus-notifications-action - :app-icon (gnus-funcall-no-warning - 'image-search-load-path "gnus/gnus.png") - :image-path photo-file - :app-name "Gnus" - :category "email.arrived" + :on-close 'gnus-notifications-close + :group "Email arrivals" :timeout gnus-notifications-timeout) - (message "New message from %s: %s" from subject) - ;; Don't return an id - t)) + (if (fboundp 'notifications-notify) + (gnus-funcall-no-warning + 'notifications-notify + :title from + :body subject + :actions '("read" "Read" "mark-read" "Mark As Read") + :on-action 'gnus-notifications-action + :on-close 'gnus-notifications-close + :app-icon (gnus-funcall-no-warning + 'image-search-load-path "gnus/gnus.png") + :image-path photo-file + :app-name "Gnus" + :category "email.arrived" + :timeout gnus-notifications-timeout) + (message "New message from %s: %s" from subject) + ;; Don't return an id + t))) (declare-function gravatar-retrieve-synchronously "gravatar.el" (mail-address)) diff --git a/lisp/gnus/gnus-score.el b/lisp/gnus/gnus-score.el index bd19e7d7cd7..479b7496cf1 100644 --- a/lisp/gnus/gnus-score.el +++ b/lisp/gnus/gnus-score.el @@ -893,9 +893,14 @@ If optional argument `EXTRA' is non-nil, it's a non-standard overview header." (t "permanent")) header (if (< score 0) "lower" "raise")) - (if (numberp match) - (int-to-string match) - match)))) + (cond ((numberp match) (int-to-string match)) + ((string= header "date") + (int-to-string + (- + (/ (car (time-convert (current-time) 1)) 86400) + (/ (car (time-convert (gnus-date-get-time match) 1)) + 86400)))) + (t match))))) ;; If this is an integer comparison, we transform from string to int. (if (eq (nth 2 (assoc header gnus-header-index)) 'gnus-score-integer) diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el index f337278994c..05ad4303b5c 100644 --- a/lisp/gnus/gnus-start.el +++ b/lisp/gnus/gnus-start.el @@ -2285,14 +2285,16 @@ If FORCE is non-nil, the .newsrc file is read." ;; doesn't change with each release) and the ;; function that must be applied to convert the ;; previous version into the current version. - '(("September Gnus v0.1" nil - gnus-convert-old-ticks) - ("Oort Gnus v0.08" "legacy-gnus-agent" - gnus-agent-convert-to-compressed-agentview) - ("Gnus v5.10.7" "legacy-gnus-agent" - gnus-agent-unlist-expire-days) - ("Gnus v5.10.7" "legacy-gnus-agent" - gnus-agent-unhook-expire-days))) + '(;;These all date back to 2004 or earlier! + ;; ("September Gnus v0.1" nil + ;; gnus-convert-old-ticks) + ;; ("Oort Gnus v0.08" "legacy-gnus-agent" + ;; gnus-agent-convert-to-compressed-agentview) + ;; ("Gnus v5.10.7" "legacy-gnus-agent" + ;; gnus-agent-unlist-expire-days) + ;; ("Gnus v5.10.7" "legacy-gnus-agent" + ;; gnus-agent-unhook-expire-days) + )) #'car-less-than-car))) ;; Skip converters older than the file version (while (and converters (>= fcv (caar converters))) diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index fd67e46a401..dc66e1375ab 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -3062,17 +3062,17 @@ the summary mode hooks are run.") "Major mode for reading articles. \\<gnus-summary-mode-map> Each line in this buffer represents one article. To read an -article, you can, for instance, type `\\[gnus-summary-next-page]'. To move forwards -and backwards while displaying articles, type `\\[gnus-summary-next-unread-article]' and `\\[gnus-summary-prev-unread-article]', +article, you can, for instance, type \\[gnus-summary-next-page]. To move forwards +and backwards while displaying articles, type \\[gnus-summary-next-unread-article] and \\[gnus-summary-prev-unread-article], respectively. You can also post articles and send mail from this buffer. To -follow up an article, type `\\[gnus-summary-followup]'. To mail a reply to the author -of an article, type `\\[gnus-summary-reply]'. +follow up an article, type \\[gnus-summary-followup]. To mail a reply to the author +of an article, type \\[gnus-summary-reply]. There are approximately one gazillion commands you can execute in this buffer; read the Info manual for more -information (`\\[gnus-info-find-node]'). +information (\\[gnus-info-find-node]). The following commands are available: diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index b5aa0b02d34..0b0a9bbfc1d 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -1113,8 +1113,7 @@ sure of changing the value of `foo'." (setq gnus-info-buffer (current-buffer)) (gnus-configure-windows 'info))) -(defun gnus-not-ignore (&rest _args) - t) +(defalias 'gnus-not-ignore #'always) (defvar gnus-directory-sep-char-regexp "/" "The regexp of directory separator character. diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index 99833e4eeca..dab66b60205 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -309,12 +309,31 @@ be set in `.emacs' instead." :group 'gnus-start :type 'boolean) +(defcustom gnus-mode-line-logo + '((:type svg :file "gnus-pointer.svg" :ascent center) + (:type xpm :file "gnus-pointer.xpm" :ascent center) + (:type xbm :file "gnus-pointer.xbm" :ascent center)) + "Image spec for the Gnus logo to be displayed in mode-line. + +If non-nil, it should be a list of image specifications to be passed +as the first argument to `find-image', which see. Then, if the display +is capable of showing images, the Gnus logo will be displayed as part of +the buffer-identification in the mode-line of Gnus-buffers. + +If nil, there will be no Gnus logo in the mode-line." + :group 'gnus-visual + :type '(choice + (repeat :tag "List of Gnus logo image specifications" (plist)) + (const :tag "Don't display Gnus logo" nil)) + :version "30.1") + (defun gnus-mode-line-buffer-identification (line) (let* ((str (car-safe line)) (str (if (stringp str) (car (propertized-buffer-identification str)) str))) - (if (or (not (fboundp 'find-image)) + (if (or (not gnus-mode-line-logo) + (not (fboundp 'find-image)) (not (display-graphic-p)) (not (stringp str)) (not (string-match "^Gnus:" str))) @@ -325,14 +344,7 @@ be set in `.emacs' instead." (add-text-properties 0 5 (list 'display - (find-image - '((:type svg :file "gnus-pointer.svg" - :ascent center) - (:type xpm :file "gnus-pointer.xpm" - :ascent center) - (:type xbm :file "gnus-pointer.xbm" - :ascent center)) - t) + (find-image gnus-mode-line-logo t) 'help-echo (if gnus-emacs-version (format "This is %s, %s." diff --git a/lisp/gnus/legacy-gnus-agent.el b/lisp/gnus/legacy-gnus-agent.el deleted file mode 100644 index d4f08c72de8..00000000000 --- a/lisp/gnus/legacy-gnus-agent.el +++ /dev/null @@ -1,260 +0,0 @@ -;;; legacy-gnus-agent.el --- Legacy unplugged support for Gnus -*- lexical-binding: t; -*- - -;; Copyright (C) 2004-2024 Free Software Foundation, Inc. - -;; Author: Kevin Greiner <kgreiner@xpediantsolutions.com> -;; Keywords: news - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Conversion functions for the Agent. - -;;; Code: -(require 'gnus-start) -(require 'gnus-util) -(require 'gnus-range) -(require 'gnus-agent) - -;; Oort Gnus v0.08 - This release updated agent to no longer use -;; history file and to support a compressed alist. - -(defvar gnus-agent-compressed-agentview-search-only nil) - -(defun gnus-agent-convert-to-compressed-agentview (converting-to) - "Iterates over all agentview files to ensure that they have been -converted to the compressed format." - - (let ((search-in (list gnus-agent-directory)) - here - members - member - converted-something) - (while (setq here (pop search-in)) - (setq members (directory-files here t)) - (while (setq member (pop members)) - (cond ((string-match "/\\.\\.?$" member) - nil) - ((file-directory-p member) - (push member search-in)) - ((equal (file-name-nondirectory member) ".agentview") - (setq converted-something - (or (gnus-agent-convert-agentview member) - converted-something)))))) - - (if converted-something - (gnus-message 4 "Successfully converted Gnus %s offline (agent) files to %s" gnus-newsrc-file-version converting-to)))) - -(defun gnus-agent-convert-to-compressed-agentview-prompt () - (catch 'found-file-to-convert - (let ((gnus-agent-compressed-agentview-search-only t)) - (gnus-agent-convert-to-compressed-agentview nil)))) - -(gnus-convert-mark-converter-prompt 'gnus-agent-convert-to-compressed-agentview 'gnus-agent-convert-to-compressed-agentview-prompt) - -(defun gnus-agent-convert-agentview (file) - "Load FILE and do a `read' there." - (with-temp-buffer - (nnheader-insert-file-contents file) - (goto-char (point-min)) - (let ((inhibit-quit t) - (alist (read (current-buffer))) - (version (condition-case nil (read (current-buffer)) - (end-of-file 0))) - changed-version - history-file) - - (cond - ((= version 0) - (let (entry - (gnus-command-method nil)) - (mm-disable-multibyte) ;; everything is binary - (erase-buffer) - (insert "\n") - (let ((file (concat (file-name-directory file) "/history"))) - (when (file-exists-p file) - (nnheader-insert-file-contents file) - (setq history-file file))) - - (goto-char (point-min)) - (while (not (eobp)) - (if (and (looking-at - "[^\t\n]+\t\\([0-9]+\\)\t\\([^ \n]+\\) \\([0-9]+\\)") - (string= (gnus-agent-article-name ".agentview" (match-string 2)) - file) - (setq entry (assoc (string-to-number (match-string 3)) alist))) - (setcdr entry (string-to-number (match-string 1)))) - (forward-line 1)) - (setq changed-version t))) - ((= version 1) - (setq changed-version t))) - - (when changed-version - (when gnus-agent-compressed-agentview-search-only - (throw 'found-file-to-convert t)) - - (erase-buffer) - (let (article-id day-of-download comp-list compressed) - (while alist - (setq article-id (caar alist) - day-of-download (cdar alist) - comp-list (assq day-of-download compressed) - alist (cdr alist)) - (if comp-list - (setcdr comp-list (cons article-id (cdr comp-list))) - (push (list day-of-download article-id) compressed))) - (setq alist compressed) - (while alist - (setq comp-list (pop alist)) - (setcdr comp-list - (gnus-compress-sequence (nreverse (cdr comp-list))))) - (princ compressed (current-buffer))) - (insert "\n2\n") - (write-file file) - (when history-file - (delete-file history-file)) - t)))) - -;; End of Oort Gnus v0.08 updates - -;; No Gnus v0.3 - This release provides a mechanism for upgrading gnus -;; from previous versions. Therefore, the previous -;; hacks to handle a gnus-agent-expire-days that -;; specifies a list of values can be removed. - -(defun gnus-agent-unlist-expire-days (converting-to) - (when (listp gnus-agent-expire-days) - (let (buffer) - (unwind-protect - (save-window-excursion - (setq buffer (gnus-get-buffer-create " *Gnus agent upgrade*")) - (set-buffer buffer) - (erase-buffer) - (insert "The definition of gnus-agent-expire-days has been changed.\nYou currently have it set to the list:\n ") - (gnus-pp gnus-agent-expire-days) - - (insert - (format-message - "\nIn order to use version `%s' of gnus, you will need to set\n" - converting-to)) - (insert "gnus-agent-expire-days to an integer. If you still wish to set different\n") - (insert "expiration days to individual groups, you must instead set the\n") - (insert (format-message - "`agent-days-until-old' group and/or topic parameter.\n")) - (insert "\n") - (insert "If you would like, gnus can iterate over every group comparing its name to the\n") - (insert "regular expressions that you currently have in gnus-agent-expire-days. When\n") - (insert (format-message - "gnus finds a match, it will update that group's `agent-days-until-old' group\n")) - (insert "parameter to the value associated with the regular expression.\n") - (insert "\n") - (insert "Whether gnus assigns group parameters, or not, gnus will terminate with an\n") - (insert "ERROR as soon as this function completes. The reason is that you must\n") - (insert "manually edit your configuration to either not set gnus-agent-expire-days or\n") - (insert "to set it to an integer before gnus can be used.\n") - (insert "\n") - (insert "Once you have successfully edited gnus-agent-expire-days, gnus will be able to\n") - (insert "execute past this function.\n") - (insert "\n") - (insert "Should gnus use gnus-agent-expire-days to assign\n") - (insert "agent-days-until-old parameters to individual groups? (Y/N)") - - (switch-to-buffer buffer) - (beep) - (beep) - - (let ((echo-keystrokes 0) - c) - (while (progn (setq c (read-char-exclusive)) - (cond ((or (eq c ?y) (eq c ?Y)) - (save-excursion - (let ((groups (gnus-group-listed-groups))) - (while groups - (let* ((group (pop groups)) - (days gnus-agent-expire-days) - (day (catch 'found - (while days - (when (eq 0 (string-match - (caar days) - group)) - (throw 'found (cadr (car days)))) - (setq days (cdr days))) - nil))) - (when day - (gnus-group-set-parameter group 'agent-days-until-old - day)))))) - nil - ) - ((or (eq c ?n) (eq c ?N)) - nil) - (t - t)))))) - (kill-buffer buffer)) - (error "Change gnus-agent-expire-days to an integer for gnus to start")))) - -;; The gnus-agent-unlist-expire-days has its own conversion prompt. -;; Therefore, hide the default prompt. -(gnus-convert-mark-converter-prompt 'gnus-agent-unlist-expire-days t) - -(defun gnus-agent-unhook-expire-days (_converting-to) - "Remove every lambda from `gnus-group-prepare-hook' that mention the -symbol `gnus-agent-do-once' in their definition. This should NOT be -necessary as gnus-agent.el no longer adds them. However, it is -possible that the hook was persistently saved." - (let ((h t)) ; Iterate from bgn of hook. - (while h - (let ((func (progn (when (eq h t) - ;; Init h to list of functions. - (setq h (cond ((listp gnus-group-prepare-hook) - gnus-group-prepare-hook) - ((boundp 'gnus-group-prepare-hook) - (list gnus-group-prepare-hook))))) - (pop h)))) - - (when (cond ((byte-code-function-p func) - ;; Search def. of compiled function for - ;; gnus-agent-do-once string. - (let* (definition - print-level - print-length - (standard-output - (lambda (char) - (setq definition (cons char definition))))) - (princ func) ; Populates definition with reversed list - ; of characters. - (let* ((i (length definition)) - (s (make-string i 0))) - (while definition - (aset s (setq i (1- i)) (pop definition))) - - (string-match "\\bgnus-agent-do-once\\b" s)))) - ((listp func) - (eq (cadr (nth 2 func)) 'gnus-agent-do-once) ; Handles eval'd lambda. - )) - - (remove-hook 'gnus-group-prepare-hook func) - ;; I don't what remove-hook is going to actually do to the - ;; hook list so start over from the beginning. - (setq h t)))))) - -;; gnus-agent-unhook-expire-days is safe in that it does not modify -;; the .newsrc.eld file. -(gnus-convert-mark-converter-prompt 'gnus-agent-unhook-expire-days t) - -(provide 'legacy-gnus-agent) - -;;; legacy-gnus-agent.el ends here diff --git a/lisp/gnus/mm-view.el b/lisp/gnus/mm-view.el index 3a7192092af..109b6c17c2c 100644 --- a/lisp/gnus/mm-view.el +++ b/lisp/gnus/mm-view.el @@ -502,6 +502,7 @@ If MODE is not set, try to find mode automatically." (setq coding-system (mm-find-buffer-file-coding-system))) (setq text (buffer-string)))) (with-temp-buffer + (setq untrusted-content t) (insert (cond ((eq charset 'gnus-decoded) (with-current-buffer (mm-handle-buffer handle) (buffer-string))) diff --git a/lisp/gnus/nnheader.el b/lisp/gnus/nnheader.el index 97821894b48..ea679759f3e 100644 --- a/lisp/gnus/nnheader.el +++ b/lisp/gnus/nnheader.el @@ -1016,7 +1016,7 @@ See `find-file-noselect' for the arguments." (nnheader-skeleton-replace from to t)) (defun nnheader-strip-cr () - "Strip all \r's from the current buffer." + "Strip all \\r's from the current buffer." (nnheader-skeleton-replace "\r")) (define-obsolete-function-alias 'nnheader-cancel-timer 'cancel-timer "27.1") diff --git a/lisp/help-fns.el b/lisp/help-fns.el index ca21408f6c3..a291893e9a2 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -741,18 +741,28 @@ the C sources, too." (defun help-fns--parent-mode (function) ;; If this is a derived mode, link to the parent. - (let ((parent-mode (and (symbolp function) - ;; FIXME: Should we mention other parent modes? - (get function - 'derived-mode-parent)))) + (when (symbolp function) + (let ((parent-mode (get function 'derived-mode-parent)) + (extra-parents (get function 'derived-mode-extra-parents))) (when parent-mode (insert (substitute-quotes " Parent mode: `")) (let ((beg (point))) - (insert (format "%s" parent-mode)) + (insert (format "%S" parent-mode)) (make-text-button beg (point) 'type 'help-function 'help-args (list parent-mode))) - (insert (substitute-quotes "'.\n"))))) + (insert (substitute-quotes "'.\n"))) + (when extra-parents + (insert (format " Extra parent mode%s:" (if (cdr extra-parents) "s" ""))) + (dolist (parent extra-parents) + (insert (substitute-quotes " `")) + (let ((beg (point))) + (insert (format "%S" parent)) + (make-text-button beg (point) + 'type 'help-function + 'help-args (list parent))) + (insert (substitute-quotes "'"))) + (insert ".\n"))))) (defun help-fns--obsolete (function) ;; Ignore lambda constructs, keyboard macros, etc. @@ -1051,10 +1061,10 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)." (concat "an autoloaded " (if (commandp def) "interactive ")) - (if (commandp def) "an interactive " "a ")))) - - ;; Print what kind of function-like object FUNCTION is. - (princ (cond ((or (stringp def) (vectorp def)) + (if (commandp def) "an interactive " "a "))) + ;; Print what kind of function-like object FUNCTION is. + (description + (cond ((or (stringp def) (vectorp def)) "a keyboard macro") ((and (symbolp function) (get function 'reader-construct)) @@ -1063,12 +1073,6 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)." ;; aliases before functions. (aliased (format-message "an alias for `%s'" real-def)) - ((subr-native-elisp-p def) - (concat beg "native-compiled Lisp function")) - ((subrp def) - (concat beg (if (eq 'unevalled (cdr (subr-arity def))) - "special form" - "built-in function"))) ((autoloadp def) (format "an autoloaded %s" (cond @@ -1082,12 +1086,13 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)." ;; need to check macros before functions. (macrop function)) (concat beg "Lisp macro")) - ((byte-code-function-p def) - (concat beg "byte-compiled Lisp function")) - ((module-function-p def) - (concat beg "module function")) - ((memq (car-safe def) '(lambda closure)) - (concat beg "Lisp function")) + ((atom def) + (let ((type (or (oclosure-type def) (cl-type-of def)))) + (concat beg (format "%s" + (make-text-button + (symbol-name type) nil + 'type 'help-type + 'help-args (list type)))))) ((keymapp def) (let ((is-full nil) (elts (cdr-safe def))) @@ -1097,7 +1102,9 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)." elts nil)) (setq elts (cdr-safe elts))) (concat beg (if is-full "keymap" "sparse keymap")))) - (t ""))) + (t "")))) + (with-current-buffer standard-output + (insert description)) (if (and aliased (not (fboundp real-def))) (princ ",\nwhich is not defined.") @@ -1789,9 +1796,8 @@ If FRAME is omitted or nil, use the selected frame." alias) "")))) (insert "\nDocumentation:\n" - (substitute-command-keys - (or (face-documentation face) - "Not documented as a face.")) + (or (face-documentation face) + "Not documented as a face.") "\n\n")) (with-current-buffer standard-output (save-excursion @@ -2124,6 +2130,12 @@ keymap value." (when used-gentemp (makunbound keymap)))) +(defcustom describe-mode-outline t + "Non-nil enables outlines in the output buffer of `describe-mode'." + :type 'boolean + :group 'help + :version "30.1") + ;;;###autoload (defun describe-mode (&optional buffer) "Display documentation of current major mode and minor modes. @@ -2136,7 +2148,10 @@ variable \(listed in `minor-mode-alist') must also be a function whose documentation describes the minor mode. If called from Lisp with a non-nil BUFFER argument, display -documentation for the major and minor modes of that buffer." +documentation for the major and minor modes of that buffer. + +When `describe-mode-outline' is non-nil, Outline minor mode +is enabled in the Help buffer." (interactive "@") (unless buffer (setq buffer (current-buffer))) @@ -2150,13 +2165,20 @@ documentation for the major and minor modes of that buffer." (with-current-buffer (help-buffer) ;; Add the local minor modes at the start. (when local-minors - (insert (format "Minor mode%s enabled in this buffer:" - (if (length> local-minors 1) - "s" ""))) + (unless describe-mode-outline + (insert (format "Minor mode%s enabled in this buffer:" + (if (length> local-minors 1) + "s" "")))) (describe-mode--minor-modes local-minors)) ;; Document the major mode. (let ((major (buffer-local-value 'major-mode buffer))) + (when describe-mode-outline + (goto-char (point-min)) + (put-text-property + (point) (progn (insert (format "Major mode %S" major)) (point)) + 'outline-level 1) + (insert "\n\n")) (insert "The major mode is " (buttonize (propertize (format-mode-line @@ -2180,36 +2202,56 @@ documentation for the major and minor modes of that buffer." ;; Insert the global minor modes after the major mode. (when global-minor-modes - (insert (format "Global minor mode%s enabled:" - (if (length> global-minor-modes 1) - "s" ""))) - (describe-mode--minor-modes global-minor-modes) - (when (re-search-forward "^\f") - (beginning-of-line) - (ensure-empty-lines 1))) + (unless describe-mode-outline + (insert (format "Global minor mode%s enabled:" + (if (length> global-minor-modes 1) + "s" "")))) + (describe-mode--minor-modes global-minor-modes t) + (unless describe-mode-outline + (when (re-search-forward "^\f") + (beginning-of-line) + (ensure-empty-lines 1)))) + + (when describe-mode-outline + (setq-local outline-search-function #'outline-search-level) + (setq-local outline-level (lambda () 1)) + (setq-local outline-minor-mode-cycle t + outline-minor-mode-highlight t + outline-minor-mode-use-buttons 'insert) + (outline-minor-mode 1)) + ;; For the sake of IELM and maybe others nil))))) -(defun describe-mode--minor-modes (modes) +(defun describe-mode--minor-modes (modes &optional global) (dolist (mode (seq-sort #'string< modes)) (let ((pretty-minor-mode (capitalize (replace-regexp-in-string "\\(\\(-minor\\)?-mode\\)?\\'" "" (symbol-name mode))))) - (insert - " " - (buttonize - pretty-minor-mode - (lambda (mode) - (goto-char (point-min)) - (text-property-search-forward - 'help-minor-mode mode t) - (beginning-of-line)) - mode)) + (if (not describe-mode-outline) + (insert + " " + (buttonize + pretty-minor-mode + (lambda (mode) + (goto-char (point-min)) + (text-property-search-forward + 'help-minor-mode mode t) + (beginning-of-line)) + mode)) + (goto-char (point-max)) + (put-text-property + (point) (progn (insert (if global "Global" "Local") + (format " minor mode %S" mode)) + (point)) + 'outline-level 1) + (insert "\n\n")) (save-excursion - (goto-char (point-max)) - (insert "\n\n\f\n") + (unless describe-mode-outline + (goto-char (point-max)) + (insert "\n\n\f\n")) ;; Document the minor modes fully. (insert (buttonize (propertize pretty-minor-mode 'help-minor-mode mode) @@ -2223,11 +2265,14 @@ documentation for the major and minor modes of that buffer." (format "indicator%s" indicator))))) (insert (or (help-split-fundoc (documentation mode) nil 'doc) - "No docstring"))))) - (forward-line -1) - (fill-paragraph nil) - (forward-paragraph 1) - (ensure-empty-lines 1)) + "No docstring")) + (when describe-mode-outline + (insert "\n\n"))))) + (unless describe-mode-outline + (forward-line -1) + (fill-paragraph nil) + (forward-paragraph 1) + (ensure-empty-lines 1))) (defun help-fns--list-local-commands () (let ((functions nil)) @@ -2400,6 +2445,81 @@ one of them returns non-nil." (setq buffer-undo-list nil) (texinfo-mode))) +(defconst help-fns--function-numbers + (make-hash-table :test 'equal :weakness 'value)) +(defconst help-fns--function-names (make-hash-table :weakness 'key)) + +(defun help-fns--display-function (function) + (cond + ((subr-primitive-p function) + (describe-function function)) + ((and (compiled-function-p function) + (not (and (fboundp 'kmacro-p) (kmacro-p function)))) + (disassemble function)) + (t + ;; FIXME: Use cl-print! + (pp-display-expression function "*Help Source*" (consp function))))) + +;;;###autoload +(defun help-fns-function-name (function) + "Return a short buttonized string representing FUNCTION. +The string is propertized with a button; clicking on that +provides further details about FUNCTION. +FUNCTION can be a function, a built-in, a keyboard macro, +or a compile function. +This function is intended to be used to display various +callable symbols in buffers in a way that allows the user +to find out more details about the symbols." + ;; FIXME: For kmacros, should we print the key-sequence? + (cond + ((symbolp function) + (let ((name (if (eq (intern-soft (symbol-name function)) function) + (symbol-name function) + (concat "#:" (symbol-name function))))) + (if (not (fboundp function)) + name + (make-text-button name nil + 'type 'help-function + 'help-args (list function))))) + ((gethash function help-fns--function-names)) + ((subrp function) + (let ((name (subr-name function))) + ;; FIXME: For native-elisp-functions, should we use `help-function' + ;; or `disassemble'? + (format "#<%s %s>" + (cl-type-of function) + (make-text-button name nil + 'type 'help-function + ;; Let's hope the subr hasn't been redefined! + 'help-args (list (intern name)))))) + (t + (let ((type (or (oclosure-type function) + (if (consp function) + (car function) (cl-type-of function)))) + (hash (sxhash-eq function)) + ;; Use 3 digits minimum. + (mask #xfff) + name) + (while + (let* ((hex (format (concat "%0" + (number-to-string (1+ (/ (logb mask) 4))) + "X") + (logand mask hash))) + ;; FIXME: For kmacros, we don't want to `disassemble'! + (button (buttonize + hex #'help-fns--display-function function + ;; FIXME: Shouldn't `buttonize' add + ;; the "mouse-2, RET:" prefix? + "mouse-2, RET: Display the function's body"))) + (setq name (format "#<%s %s>" type button)) + (and (< mask (abs hash)) ; We can add more digits. + (gethash name help-fns--function-numbers))) + ;; Add a digit. + (setq mask (+ (ash mask 4) #x0f))) + (puthash name function help-fns--function-numbers) + (puthash function name help-fns--function-names) + name)))) + (provide 'help-fns) ;;; help-fns.el ends here diff --git a/lisp/help-macro.el b/lisp/help-macro.el index cea8b379ec0..8a16e85a329 100644 --- a/lisp/help-macro.el +++ b/lisp/help-macro.el @@ -92,141 +92,146 @@ and then returns." `(defun ,fname () "Help command." (interactive) - (let ((line-prompt - (substitute-command-keys ,help-line)) - (help-buffer-under-preparation t)) - (when three-step-help - (message "%s" line-prompt)) - (let* ((help-screen ,help-text) - ;; We bind overriding-local-map for very small - ;; sections, *excluding* where we switch buffers - ;; and where we execute the chosen help command. - (local-map (make-sparse-keymap)) - (new-minor-mode-map-alist minor-mode-map-alist) - (prev-frame (selected-frame)) - config new-frame key char) - (when (string-match "%THIS-KEY%" help-screen) - (setq help-screen - (replace-match (help--key-description-fontified - (substring (this-command-keys) 0 -1)) - t t help-screen))) - (unwind-protect - (let ((minor-mode-map-alist nil)) - (setcdr local-map ,helped-map) - (define-key local-map [t] 'undefined) - ;; Make the scroll bar keep working normally. - (define-key local-map [vertical-scroll-bar] - (lookup-key global-map [vertical-scroll-bar])) - (if three-step-help - (progn - (setq key (let ((overriding-local-map local-map)) - (read-key-sequence nil))) - ;; Make the HELP key translate to C-h. - (if (lookup-key function-key-map key) - (setq key (lookup-key function-key-map key))) - (setq char (aref key 0))) - (setq char ??)) - (when (or (eq char ??) (eq char help-char) - (memq char help-event-list)) - (setq config (current-window-configuration)) - (pop-to-buffer (or ,buffer-name " *Metahelp*") nil t) - (and (fboundp 'make-frame) - (not (eq (window-frame) - prev-frame)) - (setq new-frame (window-frame) - config nil)) - (setq buffer-read-only nil) - (let ((inhibit-read-only t)) - (erase-buffer) - (insert (substitute-command-keys help-screen))) - (let ((minor-mode-map-alist new-minor-mode-map-alist)) - (help-mode) - (variable-pitch-mode) - (setq new-minor-mode-map-alist minor-mode-map-alist)) - (goto-char (point-min)) - (while (or (memq char (append help-event-list - (cons help-char '( ?? ?\C-v ?\s ?\177 ?\M-v ?\S-\s - deletechar backspace vertical-scroll-bar - home end next prior up down)))) - (eq (car-safe char) 'switch-frame) - (equal key "\M-v")) - (condition-case nil - (cond - ((eq (car-safe char) 'switch-frame) - (handle-switch-frame char)) - ((memq char '(?\C-v ?\s next end)) - (scroll-up)) - ((or (memq char '(?\177 ?\M-v ?\S-\s deletechar backspace prior home)) - (equal key "\M-v")) - (scroll-down)) - ((memq char '(down)) - (scroll-up 1)) - ((memq char '(up)) - (scroll-down 1))) - (error nil)) - (let ((cursor-in-echo-area t) - (overriding-local-map local-map)) - (frame-toggle-on-screen-keyboard (selected-frame) nil) - (setq key (read-key-sequence - (format "Type one of listed options%s: " - (if (pos-visible-in-window-p - (point-max)) - "" - (concat ", or " - (help--key-description-fontified (kbd "<PageDown>")) - "/" - (help--key-description-fontified (kbd "<PageUp>")) - "/" - (help--key-description-fontified (kbd "SPC")) - "/" - (help--key-description-fontified (kbd "DEL")) - " to scroll"))) - nil nil nil nil - ;; Disable ``text conversion''. OS - ;; input methods might otherwise chose - ;; to insert user input directly into - ;; a buffer. - t) - char (aref key 0))) - - ;; If this is a scroll bar command, just run it. - (when (eq char 'vertical-scroll-bar) - (command-execute (lookup-key local-map key) nil key)))) - ;; We don't need the prompt any more. - (message "") - ;; Mouse clicks are not part of the help feature, - ;; so reexecute them in the standard environment. - (if (listp char) - (setq unread-command-events - (cons char unread-command-events) - config nil) - (let ((defn (lookup-key local-map key))) - (if defn - (progn - (when config - (set-window-configuration config) - (setq config nil)) - ;; Temporarily rebind `minor-mode-map-alist' - ;; to `new-minor-mode-map-alist' (Bug#10454). - (let ((minor-mode-map-alist new-minor-mode-map-alist)) - ;; `defn' must make sure that its frame is - ;; selected, so we won't iconify it below. - (call-interactively defn)) - (when new-frame - ;; Do not iconify the selected frame. - (unless (eq new-frame (selected-frame)) - (iconify-frame new-frame)) - (setq new-frame nil))) - (unless (equal (key-description key) "C-g") - (message (substitute-command-keys - (format "No help command is bound to `\\`%s''" - (key-description key)))) - (ding)))))) - (when config - (set-window-configuration config)) - (when new-frame - (iconify-frame new-frame)) - (setq minor-mode-map-alist new-minor-mode-map-alist)))))) + (help--help-screen ,help-line ,help-text ,helped-map ,buffer-name))) + + +;;;###autoload +(defun help--help-screen (help-line help-text helped-map buffer-name) + (let ((line-prompt + (substitute-command-keys help-line)) + (help-buffer-under-preparation t)) + (when three-step-help + (message "%s" line-prompt)) + (let* ((help-screen help-text) + ;; We bind overriding-local-map for very small + ;; sections, *excluding* where we switch buffers + ;; and where we execute the chosen help command. + (local-map (make-sparse-keymap)) + (new-minor-mode-map-alist minor-mode-map-alist) + (prev-frame (selected-frame)) + config new-frame key char) + (when (string-match "%THIS-KEY%" help-screen) + (setq help-screen + (replace-match (help--key-description-fontified + (substring (this-command-keys) 0 -1)) + t t help-screen))) + (unwind-protect + (let ((minor-mode-map-alist nil)) + (setcdr local-map helped-map) + (define-key local-map [t] #'undefined) + ;; Make the scroll bar keep working normally. + (define-key local-map [vertical-scroll-bar] + (lookup-key global-map [vertical-scroll-bar])) + (if three-step-help + (progn + (setq key (let ((overriding-local-map local-map)) + (read-key-sequence nil))) + ;; Make the HELP key translate to C-h. + (if (lookup-key function-key-map key) + (setq key (lookup-key function-key-map key))) + (setq char (aref key 0))) + (setq char ??)) + (when (or (eq char ??) (eq char help-char) + (memq char help-event-list)) + (setq config (current-window-configuration)) + (pop-to-buffer (or buffer-name " *Metahelp*") nil t) + (and (fboundp 'make-frame) + (not (eq (window-frame) + prev-frame)) + (setq new-frame (window-frame) + config nil)) + (setq buffer-read-only nil) + (let ((inhibit-read-only t)) + (erase-buffer) + (insert (substitute-command-keys help-screen))) + (let ((minor-mode-map-alist new-minor-mode-map-alist)) + (help-mode) + (variable-pitch-mode) + (setq new-minor-mode-map-alist minor-mode-map-alist)) + (goto-char (point-min)) + (while (or (memq char (append help-event-list + (cons help-char '( ?? ?\C-v ?\s ?\177 ?\M-v ?\S-\s + deletechar backspace vertical-scroll-bar + home end next prior up down)))) + (eq (car-safe char) 'switch-frame) + (equal key "\M-v")) + (condition-case nil + (cond + ((eq (car-safe char) 'switch-frame) + (handle-switch-frame char)) + ((memq char '(?\C-v ?\s next end)) + (scroll-up)) + ((or (memq char '(?\177 ?\M-v ?\S-\s deletechar backspace prior home)) + (equal key "\M-v")) + (scroll-down)) + ((memq char '(down)) + (scroll-up 1)) + ((memq char '(up)) + (scroll-down 1))) + (error nil)) + (let ((cursor-in-echo-area t) + (overriding-local-map local-map)) + (frame-toggle-on-screen-keyboard (selected-frame) nil) + (setq key (read-key-sequence + (format "Type one of listed options%s: " + (if (pos-visible-in-window-p + (point-max)) + "" + (concat ", or " + (help--key-description-fontified (kbd "<PageDown>")) + "/" + (help--key-description-fontified (kbd "<PageUp>")) + "/" + (help--key-description-fontified (kbd "SPC")) + "/" + (help--key-description-fontified (kbd "DEL")) + " to scroll"))) + nil nil nil nil + ;; Disable ``text conversion''. OS + ;; input methods might otherwise chose + ;; to insert user input directly into + ;; a buffer. + t) + char (aref key 0))) + + ;; If this is a scroll bar command, just run it. + (when (eq char 'vertical-scroll-bar) + (command-execute (lookup-key local-map key) nil key)))) + ;; We don't need the prompt any more. + (message "") + ;; Mouse clicks are not part of the help feature, + ;; so reexecute them in the standard environment. + (if (listp char) + (setq unread-command-events + (cons char unread-command-events) + config nil) + (let ((defn (lookup-key local-map key))) + (if defn + (progn + (when config + (set-window-configuration config) + (setq config nil)) + ;; Temporarily rebind `minor-mode-map-alist' + ;; to `new-minor-mode-map-alist' (Bug#10454). + (let ((minor-mode-map-alist new-minor-mode-map-alist)) + ;; `defn' must make sure that its frame is + ;; selected, so we won't iconify it below. + (call-interactively defn)) + (when new-frame + ;; Do not iconify the selected frame. + (unless (eq new-frame (selected-frame)) + (iconify-frame new-frame)) + (setq new-frame nil))) + (unless (equal (key-description key) "C-g") + (message (substitute-command-keys + (format "No help command is bound to `\\`%s''" + (key-description key)))) + (ding)))))) + (when config + (set-window-configuration config)) + (when new-frame + (iconify-frame new-frame)) + (setq minor-mode-map-alist new-minor-mode-map-alist))))) (provide 'help-macro) diff --git a/lisp/help-mode.el b/lisp/help-mode.el index 9c405efeee5..48433d899ab 100644 --- a/lisp/help-mode.el +++ b/lisp/help-mode.el @@ -177,6 +177,11 @@ The format is (FUNCTION ARGS...).") 'help-function 'describe-variable 'help-echo (purecopy "mouse-2, RET: describe this variable")) +(define-button-type 'help-type + :supertype 'help-xref + 'help-function #'cl-describe-type + 'help-echo (purecopy "mouse-2, RET: describe this type")) + (define-button-type 'help-face :supertype 'help-xref 'help-function 'describe-face @@ -501,7 +506,17 @@ restore it properly when going back." ;; Disable `outline-minor-mode' in a reused Help buffer ;; created by `describe-bindings' that enables this mode. (when (bound-and-true-p outline-minor-mode) - (outline-minor-mode -1)) + (outline-minor-mode -1) + (mapc #'kill-local-variable + '(outline-search-function + outline-regexp + outline-heading-end-regexp + outline-level + outline-minor-mode-cycle + outline-minor-mode-highlight + outline-minor-mode-use-buttons + outline-default-state + outline-default-rules))) (when help-xref-stack-item (push (cons (point) help-xref-stack-item) help-xref-stack) (setq help-xref-forward-stack nil)) @@ -535,6 +550,9 @@ it does not already exist." (or (and (boundp symbol) (not (keywordp symbol))) (get symbol 'variable-documentation))) ,#'describe-variable) + ;; FIXME: We could go crazy and add another entry so describe-symbol can be + ;; used with the slot names of CL structs (and/or EIEIO objects). + ("type" ,#'cl-find-class ,#'cl-describe-type) ("face" ,#'facep ,(lambda (s _b _f) (describe-face s)))) "List of providers of information about symbols. Each element has the form (NAME TESTFUN DESCFUN) where: diff --git a/lisp/help.el b/lisp/help.el index a551dba5fe5..1ef46e394f3 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -151,7 +151,7 @@ buffer.") ("Mark & Kill" (set-mark-command . "mark") (kill-line . "kill line") - (kill-ring-save . "kill region") + (kill-region . "kill region") (yank . "yank") (exchange-point-and-mark . "swap")) ("Projects" @@ -165,13 +165,24 @@ buffer.") (isearch-forward . "search") (isearch-backward . "reverse search") (query-replace . "search & replace") - (fill-paragraph . "reformat")))) + (fill-paragraph . "reformat"))) + "Data structure for `help-quick'. +Value should be a list of elements, each element should of the form + + (GROUP-NAME (COMMAND . DESCRIPTION) (COMMAND . DESCRIPTION)...) + +where GROUP-NAME is the name of the group of the commands, +COMMAND is the symbol of a command and DESCRIPTION is its short +description, 10 to 15 char5acters at most.") (declare-function prop-match-value "text-property-search" (match)) ;; Inspired by a mg fork (https://github.com/troglobit/mg) (defun help-quick () - "Display a quick-help buffer." + "Display a quick-help buffer showing popular commands and their bindings. +The window showing quick-help can be toggled using \\[help-quick-toggle]. +You can click on a key binding shown in the quick-help buffer to display +the documentation of the command bound to that key sequence." (interactive) (with-current-buffer (get-buffer-create "*Quick Help*") (let ((inhibit-read-only t) (padding 2) blocks) @@ -246,10 +257,14 @@ buffer.") ;; ... and shrink it immediately. (fit-window-to-buffer)) (message - (substitute-command-keys "Toggle the quick help buffer using \\[help-quick-toggle].")))) + (substitute-command-keys "Toggle display of quick-help buffer using \\[help-quick-toggle].")))) (defun help-quick-toggle () - "Toggle the quick-help window." + "Toggle display of a window showing popular commands and their bindings. +This toggles on and off the display of the quick-help buffer, which shows +popular commands and their bindings as produced by `help-quick'. +You can click on a key binding shown in the quick-help buffer to display +the documentation of the command bound to that key sequence." (interactive) (if (and-let* ((window (get-buffer-window "*Quick Help*"))) (quit-window t window)) @@ -286,6 +301,8 @@ Do not call this in the scope of `with-help-window'." (let ((first-message (cond ((or pop-up-frames + ;; FIXME: `special-display-p' is obsolete since + ;; the vars on which it depends are obsolete! (special-display-p (buffer-name standard-output))) (setq help-return-method (cons (selected-window) t)) ;; If the help output buffer is a special display buffer, @@ -367,9 +384,9 @@ Do not call this in the scope of `with-help-window'." (propertize title 'face 'help-for-help-header) "\n\n" (help--for-help-make-commands commands)))) - sections "")) + sections)) -(defalias 'help 'help-for-help) +(defalias 'help #'help-for-help) (make-help-screen help-for-help (purecopy "Type a help option: [abcCdefFgiIkKlLmnprstvw.] C-[cdefmnoptw] or ?") (concat @@ -861,7 +878,7 @@ If INSERT (the prefix arg) is non-nil, insert the message in the buffer." (format "%s (translated from %s)" string otherstring)))))) (defun help--binding-undefined-p (defn) - (or (null defn) (integerp defn) (equal defn 'undefined))) + (or (null defn) (integerp defn) (equal defn #'undefined))) (defun help--analyze-key (key untranslated &optional buffer) "Get information about KEY its corresponding UNTRANSLATED events. @@ -909,7 +926,9 @@ in the selected window." (let ((key-desc (help-key-description key untranslated))) (if (help--binding-undefined-p defn) (format "%s%s is undefined" key-desc mouse-msg) - (format "%s%s runs the command %S" key-desc mouse-msg defn))) + (format "%s%s runs the command %s" key-desc mouse-msg + (if (symbolp defn) (prin1-to-string defn) + (help-fns-function-name defn))))) defn event mouse-msg))) (defun help--filter-info-list (info-list i) @@ -1206,7 +1225,7 @@ appeared on the mode-line." (defun describe-minor-mode-completion-table-for-symbol () ;; In order to list up all minor modes, minor-mode-list ;; is used here instead of minor-mode-alist. - (delq nil (mapcar 'symbol-name minor-mode-list))) + (delq nil (mapcar #'symbol-name minor-mode-list))) (defun describe-minor-mode-from-symbol (symbol) "Display documentation of a minor mode given as a symbol, SYMBOL." @@ -1629,34 +1648,14 @@ Return nil if the key sequence is too long." (t value)))) (defun help--describe-command (definition &optional translation) - (cond ((symbolp definition) - (if (and (fboundp definition) - help-buffer-under-preparation) - (insert-text-button (symbol-name definition) - 'type 'help-function - 'help-args (list definition)) - (insert (symbol-name definition))) - (insert "\n")) - ((or (stringp definition) (vectorp definition)) + (cond ((or (stringp definition) (vectorp definition)) (if translation (insert (key-description definition nil) "\n") + ;; These should be rare nowadays, replaced by `kmacro's. (insert "Keyboard Macro\n"))) ((keymapp definition) (insert "Prefix Command\n")) - ((byte-code-function-p definition) - (insert (format "[%s]\n" - (buttonize "byte-code" #'disassemble definition)))) - ((and (consp definition) - (memq (car definition) '(closure lambda))) - (insert (format "[%s]\n" - (buttonize - (symbol-name (car definition)) - (lambda (_) - (pp-display-expression - definition "*Help Source*" t)) - nil "View definition")))) - (t - (insert "??\n")))) + (t (insert (help-fns-function-name definition) "\n")))) (define-obsolete-function-alias 'help--describe-translation #'help--describe-command "29.1") @@ -1996,8 +1995,8 @@ and some others." (if temp-buffer-resize-mode ;; `help-make-xrefs' may add a `back' button and thus increase the ;; text size, so `resize-temp-buffer-window' must be run *after* it. - (add-hook 'temp-buffer-show-hook 'resize-temp-buffer-window 'append) - (remove-hook 'temp-buffer-show-hook 'resize-temp-buffer-window))) + (add-hook 'temp-buffer-show-hook #'resize-temp-buffer-window 'append) + (remove-hook 'temp-buffer-show-hook #'resize-temp-buffer-window))) (defvar resize-temp-buffer-window-inhibit nil "Non-nil means `resize-temp-buffer-window' should not resize.") @@ -2241,11 +2240,32 @@ The `temp-buffer-window-setup-hook' hook is called." ;; Don't print to *Help*; that would clobber Help history. (defun help-form-show () "Display the output of a non-nil `help-form'." - (let ((msg (eval help-form))) + (let ((msg (eval help-form t))) (if (stringp msg) (with-output-to-temp-buffer " *Char Help*" (princ msg))))) +(defun help--append-keystrokes-help (str) + (let* ((keys (this-single-command-keys)) + (bindings (delete nil + (mapcar (lambda (map) (lookup-key map keys t)) + (current-active-maps t))))) + (catch 'res + (dolist (val help-event-list) + (let ((key (vector (if (eql val 'help) + help-char + val)))) + (unless (seq-find (lambda (map) (and (keymapp map) (lookup-key map key))) + bindings) + (throw 'res + (concat + str + (substitute-command-keys + (format + " (\\`%s' for help)" + (key-description key)))))))) + str))) + (defun help--docstring-quote (string) "Return a doc string that represents STRING. @@ -2333,7 +2353,7 @@ the same names as used in the original source code, when possible." ((or (and (byte-code-function-p def) (integerp (aref def 0))) (subrp def) (module-function-p def)) (or (when preserve-names - (let* ((doc (condition-case nil (documentation def) (error nil))) + (let* ((doc (condition-case nil (documentation def 'raw) (error nil))) (docargs (if doc (car (help-split-fundoc doc nil)))) (arglist (if docargs (cdar (read-from-string (downcase docargs))))) @@ -2385,7 +2405,7 @@ the same names as used in the original source code, when possible." (t arg))) arglist))) -(define-obsolete-function-alias 'help-make-usage 'help--make-usage "25.1") +(define-obsolete-function-alias 'help-make-usage #'help--make-usage "25.1") (defun help--make-usage-docstring (fn arglist) (let ((print-escape-newlines t)) diff --git a/lisp/htmlfontify.el b/lisp/htmlfontify.el index 6b9c623f31f..89c2bee2204 100644 --- a/lisp/htmlfontify.el +++ b/lisp/htmlfontify.el @@ -586,6 +586,7 @@ If a window system is unavailable, calls `hfy-fallback-color-values'." (defvar hfy-cperl-mode-kludged-p nil) (defun hfy-kludge-cperl-mode () + ;; FIXME: Still? "CPerl mode does its damnedest not to do some of its fontification when not in a windowing system - try to trick it..." (declare (obsolete nil "28.1")) diff --git a/lisp/ibuffer.el b/lisp/ibuffer.el index 602f06338e2..c65213f5bde 100644 --- a/lisp/ibuffer.el +++ b/lisp/ibuffer.el @@ -2376,135 +2376,135 @@ particular subset of them, and sorting by various criteria. Operations on marked buffers: \\<ibuffer-mode-map> - `\\[ibuffer-do-save]' - Save the marked buffers. - `\\[ibuffer-do-view]' - View the marked buffers in the selected frame. - `\\[ibuffer-do-view-other-frame]' - View the marked buffers in another frame. - `\\[ibuffer-do-revert]' - Revert the marked buffers. - `\\[ibuffer-do-toggle-read-only]' - Toggle read-only state of marked buffers. - `\\[ibuffer-do-toggle-lock]' - Toggle lock state of marked buffers. - `\\[ibuffer-do-delete]' - Kill the marked buffers. - `\\[ibuffer-do-isearch]' - Do incremental search in the marked buffers. - `\\[ibuffer-do-isearch-regexp]' - Isearch for regexp in the marked buffers. - `\\[ibuffer-do-replace-regexp]' - Replace by regexp in each of the marked - buffers. - `\\[ibuffer-do-query-replace]' - Query replace in each of the marked buffers. - `\\[ibuffer-do-query-replace-regexp]' - As above, with a regular expression. - `\\[ibuffer-do-print]' - Print the marked buffers. - `\\[ibuffer-do-occur]' - List lines in all marked buffers which match - a given regexp (like the function `occur'). - `\\[ibuffer-do-shell-command-pipe]' - Pipe the contents of the marked - buffers to a shell command. - `\\[ibuffer-do-shell-command-pipe-replace]' - Replace the contents of the marked - buffers with the output of a shell command. - `\\[ibuffer-do-shell-command-file]' - Run a shell command with the - buffer's file as an argument. - `\\[ibuffer-do-eval]' - Evaluate a form in each of the marked buffers. This - is a very flexible command. For example, if you want to make all - of the marked buffers read-only, try using (read-only-mode 1) as - the input form. - `\\[ibuffer-do-view-and-eval]' - As above, but view each buffer while the form - is evaluated. - `\\[ibuffer-do-kill-lines]' - Remove the marked lines from the *Ibuffer* buffer, - but don't kill the associated buffer. - `\\[ibuffer-do-kill-on-deletion-marks]' - Kill all buffers marked for deletion. + \\[ibuffer-do-save] - Save the marked buffers. + \\[ibuffer-do-view] - View the marked buffers in the selected frame. + \\[ibuffer-do-view-other-frame] - View the marked buffers in another frame. + \\[ibuffer-do-revert] - Revert the marked buffers. + \\[ibuffer-do-toggle-read-only] - Toggle read-only state of marked buffers. + \\[ibuffer-do-toggle-lock] - Toggle lock state of marked buffers. + \\[ibuffer-do-delete] - Kill the marked buffers. + \\[ibuffer-do-isearch] - Do incremental search in the marked buffers. + \\[ibuffer-do-isearch-regexp] - Isearch for regexp in the marked buffers. + \\[ibuffer-do-replace-regexp] - Replace by regexp in each of the marked + buffers. + \\[ibuffer-do-query-replace] - Query replace in each of the marked buffers. + \\[ibuffer-do-query-replace-regexp] - As above, with a regular expression. + \\[ibuffer-do-print] - Print the marked buffers. + \\[ibuffer-do-occur] - List lines in all marked buffers which match + a given regexp (like the function `occur'). + \\[ibuffer-do-shell-command-pipe] - Pipe the contents of the marked + buffers to a shell command. + \\[ibuffer-do-shell-command-pipe-replace] - Replace the contents of the marked + buffers with the output of a shell command. + \\[ibuffer-do-shell-command-file] - Run a shell command with the + buffer's file as an argument. + \\[ibuffer-do-eval] - Evaluate a form in each of the marked buffers. This + is a very flexible command. For example, if you want to make all + of the marked buffers read-only, try using (read-only-mode 1) as + the input form. + \\[ibuffer-do-view-and-eval] - As above, but view each buffer while the form + is evaluated. + \\[ibuffer-do-kill-lines] - Remove the marked lines from the *Ibuffer* buffer, + but don't kill the associated buffer. + \\[ibuffer-do-kill-on-deletion-marks] - Kill all buffers marked for deletion. Marking commands: - `\\[ibuffer-mark-forward]' - Mark the buffer at point. - `\\[ibuffer-toggle-marks]' - Unmark all currently marked buffers, and mark - all unmarked buffers. - `\\[ibuffer-change-marks]' - Change the mark used on marked buffers. - `\\[ibuffer-unmark-forward]' - Unmark the buffer at point. - `\\[ibuffer-unmark-backward]' - Unmark the previous buffer. - `\\[ibuffer-unmark-all]' - Unmark buffers marked with MARK. - `\\[ibuffer-unmark-all-marks]' - Unmark all marked buffers. - `\\[ibuffer-mark-by-mode]' - Mark buffers by major mode. - `\\[ibuffer-mark-unsaved-buffers]' - Mark all \"unsaved\" buffers. - This means that the buffer is modified, and has an associated file. - `\\[ibuffer-mark-modified-buffers]' - Mark all modified buffers, - regardless of whether they have an associated file. - `\\[ibuffer-mark-special-buffers]' - Mark all buffers whose name begins and - ends with `*'. - `\\[ibuffer-mark-dissociated-buffers]' - Mark all buffers which have - an associated file, but that file doesn't currently exist. - `\\[ibuffer-mark-read-only-buffers]' - Mark all read-only buffers. - `\\[ibuffer-mark-dired-buffers]' - Mark buffers in `dired-mode'. - `\\[ibuffer-mark-help-buffers]' - Mark buffers in `help-mode', `apropos-mode', etc. - `\\[ibuffer-mark-old-buffers]' - Mark buffers older than `ibuffer-old-time'. - `\\[ibuffer-mark-for-delete]' - Mark the buffer at point for deletion. - `\\[ibuffer-mark-by-name-regexp]' - Mark buffers by their name, using a regexp. - `\\[ibuffer-mark-by-mode-regexp]' - Mark buffers by their major mode, using a regexp. - `\\[ibuffer-mark-by-file-name-regexp]' - Mark buffers by their filename, using a regexp. - `\\[ibuffer-mark-by-content-regexp]' - Mark buffers by their content, using a regexp. - `\\[ibuffer-mark-by-locked]' - Mark all locked buffers. + \\[ibuffer-mark-forward] - Mark the buffer at point. + \\[ibuffer-toggle-marks] - Unmark all currently marked buffers, and mark + all unmarked buffers. + \\[ibuffer-change-marks] - Change the mark used on marked buffers. + \\[ibuffer-unmark-forward] - Unmark the buffer at point. + \\[ibuffer-unmark-backward] - Unmark the previous buffer. + \\[ibuffer-unmark-all] - Unmark buffers marked with MARK. + \\[ibuffer-unmark-all-marks] - Unmark all marked buffers. + \\[ibuffer-mark-by-mode] - Mark buffers by major mode. + \\[ibuffer-mark-unsaved-buffers] - Mark all \"unsaved\" buffers. + This means that the buffer is modified, and has an associated file. + \\[ibuffer-mark-modified-buffers] - Mark all modified buffers, + regardless of whether they have an associated file. + \\[ibuffer-mark-special-buffers] - Mark all buffers whose name begins and + ends with `*'. + \\[ibuffer-mark-dissociated-buffers] - Mark all buffers which have + an associated file, but that file doesn't currently exist. + \\[ibuffer-mark-read-only-buffers] - Mark all read-only buffers. + \\[ibuffer-mark-dired-buffers] - Mark buffers in `dired-mode'. + \\[ibuffer-mark-help-buffers] - Mark buffers in `help-mode', `apropos-mode', etc. + \\[ibuffer-mark-old-buffers] - Mark buffers older than `ibuffer-old-time'. + \\[ibuffer-mark-for-delete] - Mark the buffer at point for deletion. + \\[ibuffer-mark-by-name-regexp] - Mark buffers by their name, using a regexp. + \\[ibuffer-mark-by-mode-regexp] - Mark buffers by their major mode, using a regexp. + \\[ibuffer-mark-by-file-name-regexp] - Mark buffers by their filename, using a regexp. + \\[ibuffer-mark-by-content-regexp] - Mark buffers by their content, using a regexp. + \\[ibuffer-mark-by-locked] - Mark all locked buffers. Filtering commands: - `\\[ibuffer-filter-chosen-by-completion]' - Select and apply filter chosen by completion. - `\\[ibuffer-filter-by-mode]' - Add a filter by any major mode. - `\\[ibuffer-filter-by-used-mode]' - Add a filter by a major mode now in use. - `\\[ibuffer-filter-by-derived-mode]' - Add a filter by derived mode. - `\\[ibuffer-filter-by-name]' - Add a filter by buffer name. - `\\[ibuffer-filter-by-content]' - Add a filter by buffer content. - `\\[ibuffer-filter-by-basename]' - Add a filter by basename. - `\\[ibuffer-filter-by-directory]' - Add a filter by directory name. - `\\[ibuffer-filter-by-filename]' - Add a filter by filename. - `\\[ibuffer-filter-by-file-extension]' - Add a filter by file extension. - `\\[ibuffer-filter-by-modified]' - Add a filter by modified buffers. - `\\[ibuffer-filter-by-predicate]' - Add a filter by an arbitrary Lisp predicate. - `\\[ibuffer-filter-by-size-gt]' - Add a filter by buffer size. - `\\[ibuffer-filter-by-size-lt]' - Add a filter by buffer size. - `\\[ibuffer-filter-by-starred-name]' - Add a filter by special buffers. - `\\[ibuffer-filter-by-visiting-file]' - Add a filter by buffers visiting files. - `\\[ibuffer-save-filters]' - Save the current filters with a name. - `\\[ibuffer-switch-to-saved-filters]' - Switch to previously saved filters. - `\\[ibuffer-add-saved-filters]' - Add saved filters to current filters. - `\\[ibuffer-and-filter]' - Replace the top two filters with their logical AND. - `\\[ibuffer-or-filter]' - Replace the top two filters with their logical OR. - `\\[ibuffer-pop-filter]' - Remove the top filter. - `\\[ibuffer-negate-filter]' - Invert the logical sense of the top filter. - `\\[ibuffer-decompose-filter]' - Break down the topmost filter. - `\\[ibuffer-filter-disable]' - Remove all filtering currently in effect. + \\[ibuffer-filter-chosen-by-completion] - Select and apply filter chosen by completion. + \\[ibuffer-filter-by-mode] - Add a filter by any major mode. + \\[ibuffer-filter-by-used-mode] - Add a filter by a major mode now in use. + \\[ibuffer-filter-by-derived-mode] - Add a filter by derived mode. + \\[ibuffer-filter-by-name] - Add a filter by buffer name. + \\[ibuffer-filter-by-content] - Add a filter by buffer content. + \\[ibuffer-filter-by-basename] - Add a filter by basename. + \\[ibuffer-filter-by-directory] - Add a filter by directory name. + \\[ibuffer-filter-by-filename] - Add a filter by filename. + \\[ibuffer-filter-by-file-extension] - Add a filter by file extension. + \\[ibuffer-filter-by-modified] - Add a filter by modified buffers. + \\[ibuffer-filter-by-predicate] - Add a filter by an arbitrary Lisp predicate. + \\[ibuffer-filter-by-size-gt] - Add a filter by buffer size. + \\[ibuffer-filter-by-size-lt] - Add a filter by buffer size. + \\[ibuffer-filter-by-starred-name] - Add a filter by special buffers. + \\[ibuffer-filter-by-visiting-file] - Add a filter by buffers visiting files. + \\[ibuffer-save-filters] - Save the current filters with a name. + \\[ibuffer-switch-to-saved-filters] - Switch to previously saved filters. + \\[ibuffer-add-saved-filters] - Add saved filters to current filters. + \\[ibuffer-and-filter] - Replace the top two filters with their logical AND. + \\[ibuffer-or-filter] - Replace the top two filters with their logical OR. + \\[ibuffer-pop-filter] - Remove the top filter. + \\[ibuffer-negate-filter] - Invert the logical sense of the top filter. + \\[ibuffer-decompose-filter] - Break down the topmost filter. + \\[ibuffer-filter-disable] - Remove all filtering currently in effect. Filter group commands: - `\\[ibuffer-filters-to-filter-group]' - Create filter group from filters. - `\\[ibuffer-pop-filter-group]' - Remove top filter group. - `\\[ibuffer-forward-filter-group]' - Move to the next filter group. - `\\[ibuffer-backward-filter-group]' - Move to the previous filter group. - `\\[ibuffer-clear-filter-groups]' - Remove all active filter groups. - `\\[ibuffer-save-filter-groups]' - Save the current groups with a name. - `\\[ibuffer-switch-to-saved-filter-groups]' - Restore previously saved groups. - `\\[ibuffer-delete-saved-filter-groups]' - Delete previously saved groups. + \\[ibuffer-filters-to-filter-group] - Create filter group from filters. + \\[ibuffer-pop-filter-group] - Remove top filter group. + \\[ibuffer-forward-filter-group] - Move to the next filter group. + \\[ibuffer-backward-filter-group] - Move to the previous filter group. + \\[ibuffer-clear-filter-groups] - Remove all active filter groups. + \\[ibuffer-save-filter-groups] - Save the current groups with a name. + \\[ibuffer-switch-to-saved-filter-groups] - Restore previously saved groups. + \\[ibuffer-delete-saved-filter-groups] - Delete previously saved groups. Sorting commands: - `\\[ibuffer-toggle-sorting-mode]' - Rotate between the various sorting modes. - `\\[ibuffer-invert-sorting]' - Reverse the current sorting order. - `\\[ibuffer-do-sort-by-alphabetic]' - Sort the buffers lexicographically. - `\\[ibuffer-do-sort-by-filename/process]' - Sort the buffers by the file name. - `\\[ibuffer-do-sort-by-recency]' - Sort the buffers by last viewing time. - `\\[ibuffer-do-sort-by-size]' - Sort the buffers by size. - `\\[ibuffer-do-sort-by-major-mode]' - Sort the buffers by major mode. + \\[ibuffer-toggle-sorting-mode] - Rotate between the various sorting modes. + \\[ibuffer-invert-sorting] - Reverse the current sorting order. + \\[ibuffer-do-sort-by-alphabetic] - Sort the buffers lexicographically. + \\[ibuffer-do-sort-by-filename/process] - Sort the buffers by the file name. + \\[ibuffer-do-sort-by-recency] - Sort the buffers by last viewing time. + \\[ibuffer-do-sort-by-size] - Sort the buffers by size. + \\[ibuffer-do-sort-by-major-mode] - Sort the buffers by major mode. Other commands: - `\\[ibuffer-update]' - Regenerate the list of all buffers. - Prefix arg means to toggle whether buffers that match - `ibuffer-maybe-show-predicates' should be displayed. - `\\[ibuffer-auto-mode]' - Toggle automatic updates. - - `\\[ibuffer-switch-format]' - Change the current display format. - `\\[forward-line]' - Move point to the next line. - `\\[previous-line]' - Move point to the previous line. - `\\[describe-mode]' - This help. - `\\[ibuffer-diff-with-file]' - View the differences between this buffer - and its associated file. - `\\[ibuffer-visit-buffer]' - View the buffer on this line. - `\\[ibuffer-visit-buffer-other-window]' - As above, but in another window. - `\\[ibuffer-visit-buffer-other-window-noselect]' - As both above, but don't select - the new window. - `\\[ibuffer-bury-buffer]' - Bury (not kill!) the buffer on this line. + \\[ibuffer-update] - Regenerate the list of all buffers. + Prefix arg means to toggle whether buffers that match + `ibuffer-maybe-show-predicates' should be displayed. + \\[ibuffer-auto-mode] - Toggle automatic updates. + + \\[ibuffer-switch-format] - Change the current display format. + \\[forward-line] - Move point to the next line. + \\[previous-line] - Move point to the previous line. + \\[describe-mode] - This help. + \\[ibuffer-diff-with-file] - View the differences between this buffer + and its associated file. + \\[ibuffer-visit-buffer] - View the buffer on this line. + \\[ibuffer-visit-buffer-other-window] - As above, but in another window. + \\[ibuffer-visit-buffer-other-window-noselect] - As both above, but don't select + the new window. + \\[ibuffer-bury-buffer] - Bury (not kill!) the buffer on this line. ** Information on Filtering: @@ -2525,7 +2525,7 @@ with \"gnus\". You can accomplish this via: \\[ibuffer-filter-by-name] ^gnus RET Additionally, you can OR the top two filters together with -`\\[ibuffer-or-filters]'. To see all buffers in either +\\[ibuffer-or-filters]. To see all buffers in either `emacs-lisp-mode' or `lisp-interaction-mode', type: \\[ibuffer-filter-by-mode] emacs-lisp-mode RET @@ -2535,9 +2535,9 @@ Additionally, you can OR the top two filters together with Filters can also be saved and restored using mnemonic names: see the functions `ibuffer-save-filters' and `ibuffer-switch-to-saved-filters'. -To remove the top filter on the stack, use `\\[ibuffer-pop-filter]', and +To remove the top filter on the stack, use \\[ibuffer-pop-filter], and to disable all filtering currently in effect, use -`\\[ibuffer-filter-disable]'. +\\[ibuffer-filter-disable]. ** Filter Groups: @@ -2545,7 +2545,7 @@ Once one has mastered filters, the next logical step up is \"filter groups\". A filter group is basically a named group of buffers which match a filter, which are displayed together in an Ibuffer buffer. To create a filter group, simply use the regular functions to create a -filter, and then type `\\[ibuffer-filters-to-filter-group]'. +filter, and then type \\[ibuffer-filters-to-filter-group]. A quick example will make things clearer. Suppose that one wants to group all of one's Emacs Lisp buffers together. To do this, type: @@ -2563,7 +2563,7 @@ multiple filter groups; instead, the first filter group is used. The filter groups are displayed in this order of precedence. You may rearrange filter groups by using the usual pair -`\\[ibuffer-kill-line]' and `\\[ibuffer-yank]'. Yanked groups +\\[ibuffer-kill-line] and \\[ibuffer-yank]. Yanked groups will be inserted before the group at point." ;; Include state info next to the mode name. (setq-local mode-line-process diff --git a/lisp/icomplete.el b/lisp/icomplete.el index d49714f3204..aa3c5680a7e 100644 --- a/lisp/icomplete.el +++ b/lisp/icomplete.el @@ -789,10 +789,8 @@ and SUFFIX, if non-nil, are obtained from `affixation-function' or `group-function'. Consecutive `equal' sections are avoided. COMP is the element in PROSPECTS or a transformation also given by `group-function''s second \"transformation\" protocol." - (let* ((aff-fun (or (completion-metadata-get md 'affixation-function) - (plist-get completion-extra-properties :affixation-function))) - (ann-fun (or (completion-metadata-get md 'annotation-function) - (plist-get completion-extra-properties :annotation-function))) + (let* ((aff-fun (completion-metadata-get md 'affixation-function)) + (ann-fun (completion-metadata-get md 'annotation-function)) (grp-fun (and completions-group (completion-metadata-get md 'group-function))) (annotated diff --git a/lisp/ielm.el b/lisp/ielm.el index 777aebb70cf..e583e0fe32c 100644 --- a/lisp/ielm.el +++ b/lisp/ielm.el @@ -110,6 +110,13 @@ This gives more frame width for large indented sexps, and allows functions such as `edebug-defun' to work with such inputs." :type 'boolean) +(defcustom ielm-history-file-name + (locate-user-emacs-file "ielm-history.eld") + "If non-nil, name of the file to read/write IELM input history." + :type '(choice (const :tag "Disable input history" nil) + file) + :version "30.1") + (defvaralias 'inferior-emacs-lisp-mode-hook 'ielm-mode-hook) (defcustom ielm-mode-hook nil "Hooks to be run when IELM (`inferior-emacs-lisp-mode') is started." @@ -503,6 +510,17 @@ behavior of the indirect buffer." (funcall pp-default-function beg end) end)) +;;; Input history + +(defvar ielm--exit nil + "Function to call when Emacs is killed.") + +(defun ielm--input-history-writer (buf) + "Return a function writing IELM input history to BUF." + (lambda () + (with-current-buffer buf + (comint-write-input-ring)))) + ;;; Major mode (define-derived-mode inferior-emacs-lisp-mode comint-mode "IELM" @@ -605,6 +623,17 @@ Customized bindings may be defined in `ielm-map', which currently contains: #'ielm-indirect-setup-hook 'append t) (setq comint-indirect-setup-function #'emacs-lisp-mode) + ;; Input history + (setq-local comint-input-ring-file-name ielm-history-file-name) + (setq-local ielm--exit (ielm--input-history-writer (current-buffer))) + (setq-local kill-buffer-hook + (lambda () + (funcall ielm--exit) + (remove-hook 'kill-emacs-hook ielm--exit))) + (unless noninteractive + (add-hook 'kill-emacs-hook ielm--exit)) + (comint-read-input-ring t) + ;; A dummy process to keep comint happy. It will never get any input (unless (comint-check-proc (current-buffer)) ;; Was cat, but on non-Unix platforms that might not exist, so diff --git a/lisp/iimage.el b/lisp/iimage.el index 205141577c9..0f2297465fe 100644 --- a/lisp/iimage.el +++ b/lisp/iimage.el @@ -134,6 +134,7 @@ Examples of image filename patterns to match: :max-width (- (nth 2 edges) (nth 0 edges)) :max-height (- (nth 3 edges) (nth 1 edges))) keymap ,image-map + context-menu-functions (image-context-menu) modification-hooks (iimage-modification-hook))) (remove-list-of-text-properties diff --git a/lisp/image-mode.el b/lisp/image-mode.el index 355685e70fd..fa64f1ac03e 100644 --- a/lisp/image-mode.el +++ b/lisp/image-mode.el @@ -654,8 +654,9 @@ Key bindings: (unless (display-images-p) (error "Display does not support images")) - (major-mode-suspend) - (setq major-mode 'image-mode) + (unless (eq major-mode 'image-mode) + (major-mode-suspend) + (setq major-mode 'image-mode)) (setq image-transform-resize image-auto-resize) ;; Bail out early if we have no image data. diff --git a/lisp/image.el b/lisp/image.el index 73801f88d1e..d7496485aca 100644 --- a/lisp/image.el +++ b/lisp/image.el @@ -193,6 +193,29 @@ or \"ffmpeg\") is installed." "h" #'image-flip-horizontally "v" #'image-flip-vertically)) +(defun image-context-menu (menu click) + "Populate MENU with image-related commands at CLICK." + (when (mouse-posn-property (event-start click) 'display) + (define-key menu [image-separator] menu-bar-separator) + (let ((easy-menu (make-sparse-keymap "Image"))) + (easy-menu-define nil easy-menu nil + '("Image" + ["Zoom In" image-increase-size + :help "Enlarge the image"] + ["Zoom Out" image-decrease-size + :help "Shrink the image"] + ["Rotate Clockwise" image-rotate + :help "Rotate the image"] + ["Flip horizontally" image-flip-horizontally + :help "Flip horizontally"] + ["Flip vertically" image-flip-vertically + :help "Flip vertically"])) + (dolist (item (reverse (lookup-key easy-menu [menu-bar image]))) + (when (consp item) + (define-key menu (vector (car item)) (cdr item)))))) + + menu) + (defun image-load-path-for-library (library image &optional path no-error) "Return a suitable search path for images used by LIBRARY. @@ -494,9 +517,13 @@ use its file extension as image type. Optional DATA-P non-nil means FILE-OR-DATA is a string containing image data. Optional PROPS are additional image attributes to assign to the image, -like, e.g. `:mask MASK'. If the property `:scale' is not given and the -display has a high resolution (more exactly, when the average width of a -character in the default font is more than 10 pixels), the image is +like, e.g. `:mask MASK'. See Info node `(elisp)Image Descriptors' for +the list of supported properties; see the nodes following that node +for properties specific to certain image types. + +If the property `:scale' is not given and the display has a high +resolution (more exactly, when the average width of a character +in the default font is more than 10 pixels), the image is automatically scaled up in proportion to the default font. Value is the image created, or nil if images of type TYPE are not supported. @@ -533,6 +560,16 @@ Images should not be larger than specified by `max-image-size'." ('t t) ('nil nil) (func (funcall func image))))))) + ;; Add original map from map. + (when (and (plist-get props :map) + (not (plist-get props :original-map))) + (setq image (nconc image (list :original-map + (image--compute-original-map image))))) + ;; Add map from original map. + (when (and (plist-get props :original-map) + (not (plist-get props :map))) + (setq image (nconc image (list :map + (image--compute-map image))))) image))) (defun image--default-smoothing (image) @@ -571,7 +608,11 @@ Internal use only." Properties can be set with (setf (image-property IMAGE PROPERTY) VALUE) -If VALUE is nil, PROPERTY is removed from IMAGE." +If VALUE is nil, PROPERTY is removed from IMAGE. + +See Info node `(elisp)Image Descriptors' for the list of +supported properties; see the nodes following that node for +properties specific to certain image types." (declare (gv-setter image--set-property)) (plist-get (cdr image) property)) @@ -620,6 +661,7 @@ means display it in the right marginal area." (overlay-put overlay 'put-image t) (overlay-put overlay 'before-string string) (overlay-put overlay 'keymap image-map) + (overlay-put overlay 'context-menu-functions '(image-context-menu)) overlay))) @@ -672,8 +714,9 @@ is non-nil, this is inhibited." inhibit-isearch ,inhibit-isearch keymap ,(if slice image-slice-map - image-map))))) - + image-map) + context-menu-functions + (image-context-menu))))) ;;;###autoload (defun insert-sliced-image (image &optional string area rows cols) @@ -709,7 +752,9 @@ The image is automatically split into ROWS x COLS slices." (add-text-properties start (point) `(display ,(list (list 'slice x y dx dy) image) rear-nonsticky (display keymap) - keymap ,image-slice-map)) + keymap ,image-slice-map + context-menu-functions + (image-context-menu))) (setq x (+ x dx)))) (setq x 0.0 y (+ y dy)) @@ -759,21 +804,25 @@ BUFFER nil or omitted means use the current buffer." ;;;###autoload (defun find-image (specs &optional cache) - "Find an image, choosing one of a list of image specifications. + "Find an image that satisfies one of a list of image specifications. SPECS is a list of image specifications. -Each image specification in SPECS is a property list. The contents of -a specification are image type dependent. All specifications must at -least contain either the property `:file FILE' or `:data DATA', -where FILE is the file to load the image from, and DATA is a string -containing the actual image data. If the property `:type TYPE' is -omitted or nil, try to determine the image type from its first few +Each image specification in SPECS is a property list. The +contents of a specification are image type dependent; see the +info node `(elisp)Image Descriptors' for details. All specifications +must at least contain either the property `:file FILE' or `:data DATA', +where FILE is the file from which to load the image, and DATA is a +string containing the actual image data. If the property `:type TYPE' +is omitted or nil, try to determine the image type from its first few bytes of image data. If that doesn't work, and the property `:file -FILE' provide a file name, use its file extension as image type. -If `:type TYPE' is provided, it must match the actual type -determined for FILE or DATA by `create-image'. Return nil if no -specification is satisfied. +FILE' provide a file name, use its file extension as idication of the +image type. If `:type TYPE' is provided, it must match the actual type +determined for FILE or DATA by `create-image'. + +The function returns the image specification for the first specification +in the list whose TYPE is supported and FILE, if specified, exists. It +returns nil if no specification in the list can be satisfied. If CACHE is non-nil, results are cached and returned on subsequent calls. @@ -1169,7 +1218,10 @@ has no effect." If N is 3, then the image size will be increased by 30%. More generally, the image size is multiplied by 1 plus N divided by 10. N defaults to 2, which increases the image size by 20%. -POSITION can be a buffer position or a marker, and defaults to point." +POSITION can be a buffer position or a marker, and defaults to point. + +When user option `image-recompute-map-p' is non-nil, the image's `:map' +is recomputed to fit the newly transformed image." (interactive "P") (image--delayed-change-size (if n (1+ (/ (prefix-numeric-value n) 10.0)) @@ -1181,7 +1233,7 @@ POSITION can be a buffer position or a marker, and defaults to point." (defun image--delayed-change-size (size position) ;; Wait for a bit of idle-time before actually performing the change, ;; so as to batch together sequences of closely consecutive size changes. - ;; `image--change-size' just changes one value in a plist. The actual + ;; `image--change-size' just changes two values in a plist. The actual ;; image resizing happens later during redisplay. So if those ;; consecutive calls happen without any redisplay between them, ;; the costly operation of image resizing should happen only once. @@ -1192,7 +1244,10 @@ POSITION can be a buffer position or a marker, and defaults to point." If N is 3, then the image size will be decreased by 30%. More generally, the image size is multiplied by 1 minus N divided by 10. N defaults to 2, which decreases the image size by 20%. -POSITION can be a buffer position or a marker, and defaults to point." +POSITION can be a buffer position or a marker, and defaults to point. + +When user option `image-recompute-map-p' is non-nil, the image's `:map' +is recomputed to fit the newly transformed image." (interactive "P") (image--delayed-change-size (if n (- 1 (/ (prefix-numeric-value n) 10.0)) @@ -1204,7 +1259,10 @@ POSITION can be a buffer position or a marker, and defaults to point." (defun image-mouse-increase-size (&optional event) "Increase the image size using the mouse-gesture EVENT. This increases the size of the image at the position specified by -EVENT, if any, by the default factor used by `image-increase-size'." +EVENT, if any, by the default factor used by `image-increase-size'. + +When user option `image-recompute-map-p' is non-nil, the image's `:map' +is recomputed to fit the newly transformed image." (interactive "e") (when (listp event) (save-window-excursion @@ -1214,7 +1272,10 @@ EVENT, if any, by the default factor used by `image-increase-size'." (defun image-mouse-decrease-size (&optional event) "Decrease the image size using the mouse-gesture EVENT. This decreases the size of the image at the position specified by -EVENT, if any, by the default factor used by `image-decrease-size'." +EVENT, if any, by the default factor used by `image-decrease-size'. + +When user option `image-recompute-map-p' is non-nil, the image's `:map' +is recomputed to fit the newly transformed image." (interactive "e") (when (listp event) (save-window-excursion @@ -1265,7 +1326,9 @@ POSITION can be a buffer position or a marker, and defaults to point." (new-image (image--image-without-parameters image)) (scale (image--current-scaling image new-image))) (setcdr image (cdr new-image)) - (plist-put (cdr image) :scale (* scale factor)))) + (plist-put (cdr image) :scale (* scale factor)) + (when (and (image-property image :original-map) image-recompute-map-p) + (setf (image-property image :map) (image--compute-map image))))) (defun image--image-without-parameters (image) (cons (pop image) @@ -1292,7 +1355,10 @@ POSITION can be a buffer position or a marker, and defaults to point." If nil, ANGLE defaults to 90. Interactively, rotate the image 90 degrees clockwise with no prefix argument, and counter-clockwise with a prefix argument. Note that most image types support -rotations by only multiples of 90 degrees." +rotations by only multiples of 90 degrees. + +When user option `image-recompute-map-p' is non-nil, the image's `:map' +is recomputed to fit the newly transformed image." (interactive (and current-prefix-arg '(-90))) (let ((image (image--get-imagemagick-and-warn))) (setf (image-property image :rotation) @@ -1300,7 +1366,9 @@ rotations by only multiples of 90 degrees." (or angle 90)) ;; We don't want to exceed 360 degrees rotation, ;; because it's not seen as valid in Exif data. - 360)))) + 360))) + (when (and (image-property image :original-map) image-recompute-map-p) + (setf (image-property image :map) (image--compute-map image)))) (set-transient-map image--repeat-map nil nil "Use %k for further adjustments")) @@ -1321,23 +1389,190 @@ changing the displayed image size does not affect the saved image." (read-file-name "Write image to file: "))))) (defun image-flip-horizontally () - "Horizontally flip the image under point." + "Horizontally flip the image under point. + +When user option `image-recompute-map-p' is non-nil, the image's `:map' +is recomputed to fit the newly transformed image." (interactive) (let ((image (image--get-image))) (image-flush image) (setf (image-property image :flip) - (not (image-property image :flip))))) + (not (image-property image :flip))) + (when (and (image-property image :original-map) image-recompute-map-p) + (setf (image-property image :map) (image--compute-map image))))) (defun image-flip-vertically () - "Vertically flip the image under point." + "Vertically flip the image under point. + +When user option `image-recompute-map-p' is non-nil, the image's `:map' +is recomputed to fit the newly transformed image." (interactive) (let ((image (image--get-image))) (image-rotate 180) (setf (image-property image :flip) - (not (image-property image :flip))))) + (not (image-property image :flip))) + (when (and (image-property image :original-map) image-recompute-map-p) + (setf (image-property image :map) (image--compute-map image))))) (define-obsolete-function-alias 'image-refresh #'image-flush "29.1") +;;; Map transformation + +(defcustom image-recompute-map-p t + "Recompute image map when scaling, rotating, or flipping an image." + :type 'boolean + :version "30.1") + +(defun image--compute-map (image) + "Compute map for IMAGE suitable to be used as its :map property. +Return a copy of :original-image transformed based on IMAGE's :scale, +:rotation, and :flip. When IMAGE's :original-map is nil, return nil. +When :rotation is not a multiple of 90, return copy of :original-map." + (pcase-let* ((original-map (image-property image :original-map)) + (map (copy-tree original-map t)) + (scale (or (image-property image :scale) 1)) + (rotation (or (image-property image :rotation) 0)) + (flip (image-property image :flip)) + ((and size `(,width . ,height)) (image-size image t))) + (when (and ; Handle only 90-degree rotations + (zerop (mod rotation 1)) + (zerop (% (truncate rotation) 90))) + ;; SIZE fits MAP after transformations. Scale MAP before + ;; flip and rotate operations, since both need MAP to fit SIZE. + (image--scale-map map scale) + ;; In rendered images, rotation is always applied before flip. + (image--rotate-map + map rotation (if (or (= 90 rotation) (= 270 rotation)) + ;; If rotated ±90°, swap width and height. + (cons height width) + size)) + ;; After rotation, there's no need to swap width and height. + (image--flip-map map flip size)) + map)) + +(defun image--compute-original-map (image) + "Return original map for IMAGE. +If IMAGE lacks :map property, return nil. +When :rotation is not a multiple of 90, return copy of :map." + (when (image-property image :map) + (let* ((original-map (copy-tree (image-property image :map) t)) + (scale (or (image-property image :scale) 1)) + (rotation (or (image-property image :rotation) 0)) + (flip (image-property image :flip)) + (size (image-size image t))) + (when (and ; Handle only 90-degree rotations + (zerop (mod rotation 1)) + (zerop (% (truncate rotation) 90))) + ;; In rendered images, rotation is always applied before flip. + ;; To undo the transformation, flip before rotating. SIZE fits + ;; ORIGINAL-MAP before transformations are applied. Therefore, + ;; scale ORIGINAL-MAP after flip and rotate operations, since + ;; both need ORIGINAL-MAP to fit SIZE. + (image--flip-map original-map flip size) + (image--rotate-map original-map (- rotation) size) + (image--scale-map original-map (/ 1.0 scale))) + original-map))) + +(defun image--scale-map (map scale) + "Scale MAP according to SCALE. +Destructively modifies and returns MAP." + (unless (= 1 scale) + (pcase-dolist (`(,`(,type . ,coords) ,_id ,_plist) map) + (pcase-exhaustive type + ('rect + (setf (caar coords) (round (* (caar coords) scale))) + (setf (cdar coords) (round (* (cdar coords) scale))) + (setf (cadr coords) (round (* (cadr coords) scale))) + (setf (cddr coords) (round (* (cddr coords) scale)))) + ('circle + (setf (caar coords) (round (* (caar coords) scale))) + (setf (cdar coords) (round (* (cdar coords) scale))) + (setcdr coords (round (* (cdr coords) scale)))) + ('poly + (dotimes (i (length coords)) + (aset coords i + (round (* (aref coords i) scale)))))))) + map) + +(defun image--rotate-map (map rotation size) + "Rotate MAP according to ROTATION and SIZE. +Destructively modifies and returns MAP." + (unless (zerop rotation) + (pcase-dolist (`(,`(,type . ,coords) ,_id ,_plist) map) + (pcase-exhaustive type + ('rect + (let ( x0 y0 ; New upper left corner + x1 y1) ; New bottom right corner + (pcase (truncate (mod rotation 360)) ; Set new corners to... + (90 ; ...old bottom left and upper right + (setq x0 (caar coords) y0 (cddr coords) + x1 (cadr coords) y1 (cdar coords))) + (180 ; ...old bottom right and upper left + (setq x0 (cadr coords) y0 (cddr coords) + x1 (caar coords) y1 (cdar coords))) + (270 ; ...old upper right and bottom left + (setq x0 (cadr coords) y0 (cdar coords) + x1 (caar coords) y1 (cddr coords)))) + (setcar coords (image--rotate-coord x0 y0 rotation size)) + (setcdr coords (image--rotate-coord x1 y1 rotation size)))) + ('circle + (setcar coords (image--rotate-coord + (caar coords) (cdar coords) rotation size))) + ('poly + (dotimes (i (length coords)) + (when (= 0 (% i 2)) + (pcase-let ((`(,x . ,y) + (image--rotate-coord + (aref coords i) (aref coords (1+ i)) rotation size))) + (aset coords i x) + (aset coords (1+ i) y)))))))) + map) + +(defun image--rotate-coord (x y angle size) + "Rotate coordinates X and Y by ANGLE in image of SIZE. +ANGLE must be a multiple of 90. Returns a cons cell of rounded +coordinates (X1 Y1)." + (pcase-let* ((radian (* (/ angle 180.0) float-pi)) + (`(,width . ,height) size) + ;; y is positive, but we are in the bottom-right quadrant + (y (- y)) + ;; Rotate clockwise + (x1 (+ (* (sin radian) y) (* (cos radian) x))) + (y1 (- (* (cos radian) y) (* (sin radian) x))) + ;; Translate image back into bottom-right quadrant + (`(,x1 . ,y1) + (pcase (truncate (mod angle 360)) + (90 ; Translate right by height + (cons (+ x1 height) y1)) + (180 ; Translate right by width and down by height + (cons (+ x1 width) (- y1 height))) + (270 ; Translate down by width + (cons x1 (- y1 width))))) + ;; Invert y1 to make both x1 and y1 positive + (y1 (- y1))) + (cons (round x1) (round y1)))) + +(defun image--flip-map (map flip size) + "Horizontally flip MAP according to FLIP and SIZE. +Destructively modifies and returns MAP." + (when flip + (pcase-dolist (`(,`(,type . ,coords) ,_id ,_plist) map) + (pcase-exhaustive type + ('rect + (let ((x0 (- (car size) (cadr coords))) + (y0 (cdar coords)) + (x1 (- (car size) (caar coords))) + (y1 (cddr coords))) + (setcar coords (cons x0 y0)) + (setcdr coords (cons x1 y1)))) + ('circle + (setf (caar coords) (- (car size) (caar coords)))) + ('poly + (dotimes (i (length coords)) + (when (= 0 (% i 2)) + (aset coords i (- (car size) (aref coords i))))))))) + map) + (provide 'image) ;;; image.el ends here diff --git a/lisp/image/image-dired-dired.el b/lisp/image/image-dired-dired.el index f4778d8e121..7219a106ca8 100644 --- a/lisp/image/image-dired-dired.el +++ b/lisp/image/image-dired-dired.el @@ -383,7 +383,7 @@ matching tag will be marked in the Dired buffer." (file-name-directory curr-file))) (setq curr-file (file-name-nondirectory curr-file)) (goto-char (point-min)) - (when (search-forward-regexp (format "\\s %s$" curr-file) nil t) + (when (search-forward-regexp (format "\\s %s[*@]?$" curr-file) nil t) (setq hits (+ hits 1)) (dired-mark 1)))) (message "%d files with matching tag marked" hits))) diff --git a/lisp/image/image-dired-tags.el b/lisp/image/image-dired-tags.el index 7b4ca35a15e..2b5248cb14b 100644 --- a/lisp/image/image-dired-tags.el +++ b/lisp/image/image-dired-tags.el @@ -51,6 +51,7 @@ Return the value of last form in BODY." "Check if `image-dired-tags-db-file' exists. If not, try to create it (including any parent directories). Signal error if there are problems creating it." + (require 'image-dired) ; for `image-dired-dir' (or (file-exists-p image-dired-tags-db-file) (let (dir buf) (unless (file-directory-p (setq dir (file-name-directory diff --git a/lisp/info-look.el b/lisp/info-look.el index da7beafe500..cd59fdf17d7 100644 --- a/lisp/info-look.el +++ b/lisp/info-look.el @@ -985,9 +985,8 @@ Return nil if there is nothing appropriate in the buffer near point." finally return "(python)Index"))))) (info-lookup-maybe-add-help - :mode 'cperl-mode - :regexp "[$@%][^a-zA-Z]\\|\\$\\^[A-Z]\\|[$@%]?[a-zA-Z][_a-zA-Z0-9]*" - :other-modes '(perl-mode)) + :mode 'perl-mode + :regexp "[$@%][^a-zA-Z]\\|\\$\\^[A-Z]\\|[$@%]?[a-zA-Z][_a-zA-Z0-9]*") (info-lookup-maybe-add-help :mode 'latex-mode diff --git a/lisp/info-xref.el b/lisp/info-xref.el index 7887909037b..95e9a1e55f7 100644 --- a/lisp/info-xref.el +++ b/lisp/info-xref.el @@ -79,9 +79,11 @@ If removing the last \"-<NUM>\" from the filename gives a file which exists, then consider FILENAME a subfile. This is an imperfect test, probably ought to open up the purported top file and see what subfiles it says." - (and (string-match "\\`\\(\\([^-]*-\\)*[^-]*\\)-[0-9]+\\(.*\\)\\'" filename) - (file-exists-p (concat (match-string 1 filename) - (match-string 3 filename))))) + (let ((nondir (file-name-nondirectory filename))) + (and (string-match "\\`\\(\\([^-]*-\\)*[^-]*\\)-[0-9]+\\(.*\\)\\'" nondir) + (file-exists-p (concat (file-name-directory filename) + (match-string 1 nondir) + (match-string 3 nondir)))))) (defmacro info-xref-with-file (filename &rest body) ;; checkdoc-params: (filename body) diff --git a/lisp/info.el b/lisp/info.el index 39ca88c358c..1e478cdbee9 100644 --- a/lisp/info.el +++ b/lisp/info.el @@ -213,6 +213,54 @@ a version of Emacs without installing it.") These directories are searched after those in `Info-directory-list'." :type '(repeat directory)) +(defcustom Info-url-alist + '((("auth" "autotype" "bovine" "calc" "ccmode" "cl" "dbus" "dired-x" + "ebrowse" "ede" "ediff" "edt" "efaq" "efaq-w32" "eglot" "eieio" + "eintr" "elisp" "emacs" "emacs-gnutls" "emacs-mime" "epa" "erc" + "ert" "eshell" "eudc" "eww" "flymake" "forms" "gnus" + "htmlfontify" "idlwave" "ido" "info" "mairix-el" "message" + "mh-e" "modus-themes" "newsticker" "nxml-mode" "octave-mode" + "org" "pcl-cvs" "pgg" "rcirc" "reftex" "remember" "sasl" "sc" + "semantic" "ses" "sieve" "smtpmail" "speedbar" "srecode" + "todo-mode" "tramp" "transient" "url" "use-package" "vhdl-mode" + "vip" "viper" "vtable" "widget" "wisent" "woman") . + "https://www.gnu.org/software/emacs/manual/html_node/%m/%e")) + "Alist telling `Info-mode' where manuals are accessible online. + +Each element of this list has the form (MANUALs . URL-SPEC). +MANUALs represents the name of one or more manuals. It can +either be a string or a list of strings. URL-SPEC can be a +string in which the substring \"%m\" will be expanded to the +manual-name and \"%n\" to the node-name. \"%e\" will expand to +the URL-encoded node-name, including the `.html' extension; in +case of the Top node, it will expand to the empty string. (The +URL-encoding of the node-name mimics GNU Texinfo, as documented +at Info node `(texinfo)HTML Xref Node Name Expansion'.) +Alternatively, URL-SPEC can be a function which is given +manual-name, node-name and URL-encoded node-name as arguments, +and is expected to return the corresponding URL as a string. + +This variable particularly affects the command +`Info-goto-node-web', which see. + +The default value of this variable refers to the official, +HTTPS-accessible HTML-representations of all manuals that Emacs +includes. These URLs refer to the most recently released version +of Emacs, disregarding the version of the running Emacs. In +other words, the content of your local Info node and the +associated online node may differ. The resource represented by +the generated URL may even be not found by the gnu.org server." + :version "30.1" + :type '(alist + :tag "Mapping from manual-name(s) to URL-specification" + :key-type (choice + (string :tag "A single manual-name") + (repeat :tag "List of manual-names" string)) + :value-type (choice + (string :tag "URL-specification string") + (function + :tag "URL-specification function")))) + (defcustom Info-scroll-prefer-subnodes nil "If non-nil, \\<Info-mode-map>\\[Info-scroll-up] in a menu visits subnodes. @@ -452,6 +500,7 @@ or `Info-virtual-nodes'." (".info.bz2" . ("bzip2" "-dc")) (".info.xz" . "unxz") (".info.zst" . ("zstd" "-dc")) + (".info.lz" . ("lzip" "-dc")) (".info" . nil) ("-info.Z" . "uncompress") ("-info.Y" . "unyabba") @@ -460,6 +509,7 @@ or `Info-virtual-nodes'." ("-info.z" . "gunzip") ("-info.xz" . "unxz") ("-info.zst" . ("zstd" "-dc")) + ("-info.lz" . ("lzip" "-dc")) ("-info" . nil) ("/index.Z" . "uncompress") ("/index.Y" . "unyabba") @@ -468,6 +518,7 @@ or `Info-virtual-nodes'." ("/index.bz2" . ("bzip2" "-dc")) ("/index.xz" . "unxz") ("/index.zst" . ("zstd" "-dc")) + ("/index.lz" . ("lzip" "-dc")) ("/index" . nil) (".Z" . "uncompress") (".Y" . "unyabba") @@ -476,6 +527,7 @@ or `Info-virtual-nodes'." (".bz2" . ("bzip2" "-dc")) (".xz" . "unxz") (".zst" . ("zstd" "-dc")) + (".lz" . ("lzip" "-dc")) ("" . nil))) "List of file name suffixes and associated decoding commands. Each entry should be (SUFFIX . STRING); the file is given to @@ -732,8 +784,53 @@ in `Info-file-supports-index-cookies-list'." (read-file-name "Info file name: " nil nil t)) (if (numberp current-prefix-arg) (format "*info*<%s>" current-prefix-arg)))) - (info-setup file-or-node - (switch-to-buffer-other-window (or buffer "*info*")))) + (info-pop-to-buffer file-or-node buffer t)) + +(defun info-pop-to-buffer (&optional file-or-node buffer-or-name other-window) + "Put Info node FILE-OR-NODE in specified buffer and display it. +Optional argument FILE-OR-NODE is as for `info'. + +If the optional argument BUFFER-OR-NAME is a buffer, use that +buffer. If it is a string, use that string as the name of the +buffer, creating it if it does not exist. Otherwise, use a +buffer with the name `*info*', creating it if it does not exist. + +Optional argument OTHER-WINDOW nil means to prefer the selected +window. OTHER-WINDOW non-nil means to prefer another window. +Select the window used, if it has been made." + (let ((buffer (cond + ((bufferp buffer-or-name) + buffer-or-name) + ((stringp buffer-or-name) + (get-buffer-create buffer-or-name)) + (t + (get-buffer-create "*info*"))))) + (with-current-buffer buffer + (unless (derived-mode-p 'Info-mode) + (Info-mode))) + + (let* ((window + (display-buffer buffer + (if other-window + '(nil (inhibit-same-window . t)) + '(display-buffer-same-window))))) + (with-current-buffer buffer + (if file-or-node + ;; If argument already contains parentheses, don't add another set + ;; since the argument will then be parsed improperly. This also + ;; has the added benefit of allowing node names to be included + ;; following the parenthesized filename. + (Info-goto-node + (if (and (stringp file-or-node) (string-match "(.*)" file-or-node)) + file-or-node + (concat "(" file-or-node ")"))) + (if (and (zerop (buffer-size)) + (null Info-history)) + ;; If we just created the Info buffer, go to the directory. + (Info-directory)))) + + (when window + (select-window window))))) ;;;###autoload (put 'info 'info-file (purecopy "emacs")) ;;;###autoload @@ -768,8 +865,8 @@ See a list of available Info commands in `Info-mode'." ;; of names that might have been wrapped (in emails, etc.). (setq file-or-node (string-replace "\n" " " file-or-node))) - (info-setup file-or-node - (pop-to-buffer-same-window (or buffer "*info*")))) + + (info-pop-to-buffer file-or-node buffer)) (defun info-setup (file-or-node buffer) "Display Info node FILE-OR-NODE in BUFFER." @@ -789,6 +886,8 @@ See a list of available Info commands in `Info-mode'." ;; If we just created the Info buffer, go to the directory. (Info-directory)))) +(make-obsolete 'info-setup "use `info-pop-to-buffer' instead" "30.1") + ;;;###autoload (defun info-emacs-manual () "Display the Emacs manual in Info mode." @@ -927,7 +1026,7 @@ If NOERROR, inhibit error messages when we can't find the node." (setq nodename (info--node-canonicalize-whitespace nodename)) (setq filename (Info-find-file filename noerror)) ;; Go into Info buffer. - (or (derived-mode-p 'Info-mode) (switch-to-buffer "*info*")) + (or (derived-mode-p 'Info-mode) (info-pop-to-buffer filename)) ;; Record the node we are leaving, if we were in one. (and (not no-going-back) Info-current-file @@ -957,7 +1056,7 @@ otherwise, that defaults to `Top'." "Go to an Info node FILENAME and NODENAME, re-reading disk contents. When *info* is already displaying FILENAME and NODENAME, the window position is preserved, if possible." - (or (derived-mode-p 'Info-mode) (switch-to-buffer "*info*")) + (or (derived-mode-p 'Info-mode) (info-pop-to-buffer filename)) (let ((old-filename Info-current-file) (old-nodename Info-current-node) (window-selected (eq (selected-window) (get-buffer-window))) @@ -1807,33 +1906,52 @@ By default, go to the current Info node." (Info-url-for-node (format "(%s)%s" filename node))))) (defun Info-url-for-node (node) - "Return a URL for NODE, a node in the GNU Emacs or Elisp manual. -NODE should be a string on the form \"(manual)Node\". Only emacs -and elisp manuals are supported." - (unless (string-match "\\`(\\(.+\\))\\(.+\\)\\'" node) - (error "Invalid node name %s" node)) - (let ((manual (match-string 1 node)) - (node (match-string 2 node))) - (unless (member manual '("emacs" "elisp")) - (error "Only emacs/elisp manuals are supported")) - ;; Encode a bunch of characters the way that makeinfo does. - (setq node - (mapconcat (lambda (ch) - (if (or (< ch 32) ; ^@^A-^Z^[^\^]^^^- - (<= 33 ch 47) ; !"#$%&'()*+,-./ - (<= 58 ch 64) ; :;<=>?@ - (<= 91 ch 96) ; [\]_` - (<= 123 ch 127)) ; {|}~ DEL - (format "_00%x" ch) - (char-to-string ch))) - node - "")) - (concat "https://www.gnu.org/software/emacs/manual/html_node/" - manual "/" - (and (not (equal node "Top")) + "Return the URL corresponding to NODE. + +NODE should be a string of the form \"(manual)Node\"." + ;; GNU Texinfo skips whitespaces and newlines between the closing + ;; parenthesis and the node-name, i.e. space, tab, line feed and + ;; carriage return. + (unless (string-match "\\`(\\(.+\\))[ \t\n\r]*\\(.+\\)\\'" node) + (error "Invalid node-name %s" node)) + ;; Use `if-let*' instead of `let*' so we check if an association was + ;; found. + (if-let* ((manual (match-string 1 node)) + (node (match-string 2 node)) + (association (seq-find + (lambda (pair) + (seq-contains-p (ensure-list (car pair)) + manual #'string-equal-ignore-case)) + Info-url-alist)) + (url-spec (cdr association)) + (encoded-node + ;; Reproduce GNU Texinfo's way of URL-encoding. + ;; (info "(texinfo) HTML Xref Node Name Expansion") + (if (equal node "Top") + "" (concat - (url-hexify-string (string-replace " " "-" node)) - ".html"))))) + (url-hexify-string + (string-replace " " "-" + (mapconcat + (lambda (ch) + (if (or (< ch 32) ; ^@^A-^Z^[^\^]^^^- + (<= 33 ch 47) ; !"#$%&'()*+,-./ + (<= 58 ch 64) ; :;<=>?@ + (<= 91 ch 96) ; [\]_` + (<= 123 ch 127)) ; {|}~ DEL + (format "_00%x" ch) + (char-to-string ch))) + node ""))) + ".html")))) + (cond + ((stringp url-spec) + (format-spec url-spec + `((?m . ,manual) (?n . ,node) (?e . ,encoded-node)))) + ((functionp url-spec) + (funcall url-spec manual node encoded-node)) + (t (error "URL-specification neither string nor function"))) + (error "No URL-specification associated with manual-name `%s'" + manual))) (defvar Info-read-node-completion-table) @@ -2056,7 +2174,7 @@ If DIRECTION is `backward', search in the reverse direction." (re-search-forward regexp nil t)) (signal 'user-search-failed (list regexp)))))) - (if (and bound (not found)) + (if (and (or bound (not Info-current-subfile)) (not found)) (signal 'user-search-failed (list regexp))) (unless (or found bound) @@ -2290,7 +2408,7 @@ This command doesn't descend into sub-nodes, like \\<Info-mode-map>\\[Info-forwa (interactive nil Info-mode) ;; In case another window is currently selected (save-window-excursion - (or (derived-mode-p 'Info-mode) (switch-to-buffer "*info*")) + (or (derived-mode-p 'Info-mode) (info-pop-to-buffer)) (Info-goto-node (Info-extract-pointer "next")))) (defun Info-prev () @@ -2299,7 +2417,7 @@ This command doesn't go up to the parent node, like \\<Info-mode-map>\\[Info-bac (interactive nil Info-mode) ;; In case another window is currently selected (save-window-excursion - (or (derived-mode-p 'Info-mode) (switch-to-buffer "*info*")) + (or (derived-mode-p 'Info-mode) (info-pop-to-buffer)) (Info-goto-node (Info-extract-pointer "prev[ious]*" "previous")))) (defun Info-up (&optional same-file) @@ -2308,7 +2426,7 @@ If SAME-FILE is non-nil, do not move to a different Info file." (interactive nil Info-mode) ;; In case another window is currently selected (save-window-excursion - (or (derived-mode-p 'Info-mode) (switch-to-buffer "*info*")) + (or (derived-mode-p 'Info-mode) (info-pop-to-buffer)) (let ((old-node Info-current-node) (old-file Info-current-file) (node (Info-extract-pointer "up")) p) @@ -4686,8 +4804,14 @@ the variable `Info-file-list-for-emacs'." (eq command 'execute-extended-command)) (Info-goto-emacs-command-node (read-command "Find documentation for command: "))) + ((symbolp command) + (Info-goto-emacs-command-node command)) (t - (Info-goto-emacs-command-node command))))) + (message + (substitute-command-keys + (format + "\\`%s' invokes an anonymous command defined with `lambda'" + (key-description key)))))))) (defvar Info-link-keymap (let ((keymap (make-sparse-keymap))) @@ -5485,7 +5609,7 @@ completion alternatives to currently visited manuals." (raise-frame (window-frame window)) (select-frame-set-input-focus (window-frame window)) (select-window window)) - (switch-to-buffer found))) + (info-pop-to-buffer nil found))) ;; The buffer doesn't exist; create it. (info-initialize) (info (Info-find-file manual) diff --git a/lisp/international/emoji.el b/lisp/international/emoji.el index 3a191c5ecd3..4f3aab5a6be 100644 --- a/lisp/international/emoji.el +++ b/lisp/international/emoji.el @@ -683,11 +683,12 @@ We prefer the earliest unique letter." strings)))) (complete-with-action action table string pred))) nil t))) - (when (cl-plusp (length name)) - (let ((glyph (if emoji-alternate-names - (cadr (split-string name "\t")) - (gethash name emoji--all-bases)))) - (cons glyph (gethash glyph emoji--derived)))))) + (if (cl-plusp (length name)) + (let ((glyph (if emoji-alternate-names + (cadr (split-string name "\t")) + (gethash name emoji--all-bases)))) + (cons glyph (gethash glyph emoji--derived))) + (user-error "You didn't specify an emoji")))) (defvar-keymap emoji-zoom-map "+" #'emoji-zoom-increase diff --git a/lisp/international/fontset.el b/lisp/international/fontset.el index 2c461a7f7ab..33e444507c4 100644 --- a/lisp/international/fontset.el +++ b/lisp/international/fontset.el @@ -645,8 +645,14 @@ (nil . "microsoft-cp1251") (nil . "koi8-r")) - (arabic ,(font-spec :registry "iso10646-1" - :otf '(arab nil (init medi fina liga))) + (arabic ,(if (featurep 'android) + ;; The Android font driver does not support the + ;; detection of OTF tags but all fonts installed on + ;; Android with Arabic characters provide shaping + ;; information required for displaying Arabic text. + (font-spec :registry "iso10646-1" :script 'arabic) + (font-spec :registry "iso10646-1" + :otf '(arab nil (init medi fina liga)))) (nil . "MuleArabic-0") (nil . "MuleArabic-1") (nil . "MuleArabic-2") @@ -657,7 +663,9 @@ (hebrew ,(font-spec :registry "iso10646-1" :script 'hebrew) (nil . "ISO8859-8")) - (khmer ,(font-spec :registry "iso10646-1" :otf '(khmr nil (pres)))) + (khmer ,(if (featurep 'android) + (font-spec :registry "iso10646-1" :script 'khmer) + (font-spec :registry "iso10646-1" :otf '(khmr nil (pres))))) (kana (nil . "JISX0208*") (nil . "GB2312.1980-0") diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el index 07f11a62594..e80c42f523a 100644 --- a/lisp/international/mule-cmds.el +++ b/lisp/international/mule-cmds.el @@ -350,9 +350,10 @@ This also sets the following values: if CODING-SYSTEM is ASCII-compatible" (check-coding-system coding-system) (setq-default buffer-file-coding-system coding-system) - - (if (eq system-type 'darwin) - ;; The file-name coding system on Darwin systems is always utf-8. + (if (or (eq system-type 'darwin) + (eq system-type 'android)) + ;; The file-name coding system on Darwin and Android systems is + ;; always UTF-8. (setq default-file-name-coding-system 'utf-8-unix) (if (and (or (not coding-system) (coding-system-get coding-system 'ascii-compatible-p))) @@ -2159,7 +2160,9 @@ See `set-language-info-alist' for use in programs." (interactive (list (read-language-name 'documentation - (format-prompt "Describe language environment" current-language-environment)))) + (format-prompt "Describe language environment" + current-language-environment) + current-language-environment))) (let ((help-buffer-under-preparation t)) (if (null language-name) (setq language-name current-language-environment)) diff --git a/lisp/international/ogonek.el b/lisp/international/ogonek.el index 13feaee405a..4fddd2701d5 100644 --- a/lisp/international/ogonek.el +++ b/lisp/international/ogonek.el @@ -75,7 +75,7 @@ The codes are given in the following order: Je/sli czytasz ten tekst, to albo przegl/adasz plik /xr/od/lowy biblioteki `ogonek.el', albo wywo/la/le/s polecenie `ogonek-jak'. W drugim przypadku mo/zesz usun/a/c tekst z ekranu, stosuj/ac -polecenie `\\[kill-buffer]'. +polecenie \\[kill-buffer]. Niniejsza biblioteka dostarcza funkcji do zmiany kodowania polskich znak/ow diakrytycznych. Funkcje te mo/zna pogrupowa/c nast/epuj/aco. @@ -174,7 +174,7 @@ znak/ow diakrytycznych. Funkcje te mo/zna pogrupowa/c nast/epuj/aco. If you read this text then you are either looking at the library's source text or you have called the `ogonek-how' command. In the -latter case you may remove this text using `\\[kill-buffer]'. +latter case you may remove this text using \\[kill-buffer]. The library provides functions for changing the encoding of Polish diacritic characters, the ones with an `ogonek' below or above them. diff --git a/lisp/international/quail.el b/lisp/international/quail.el index 56f049aedf5..48d2ccb8828 100644 --- a/lisp/international/quail.el +++ b/lisp/international/quail.el @@ -1324,9 +1324,11 @@ If STR has `advice' text property, append the following special event: ;; binding in `universal-argument-map' just return ;; (list KEY), otherwise act as if there was no ;; overriding map. - (or (not (eq (cadr overriding-terminal-local-map) - universal-argument-map)) - (lookup-key overriding-terminal-local-map (vector key)))) + ;; We used to do that only for `universal-argument-map', + ;; but according to bug#68338 this should also apply to + ;; other transient maps. Let's hope it's OK to apply it + ;; to all `overriding-terminal-local-map's. + (lookup-key overriding-terminal-local-map (vector key))) overriding-local-map) (list key) (quail-setup-overlays (quail-conversion-keymap)) diff --git a/lisp/international/titdic-cnv.el b/lisp/international/titdic-cnv.el index c4706e061e3..42584f6548c 100644 --- a/lisp/international/titdic-cnv.el +++ b/lisp/international/titdic-cnv.el @@ -31,12 +31,12 @@ ;; Convert cxterm dictionary (of TIT format) to quail-package. ;; ;; Usage (within Emacs): -;; M-x titdic-convert<CR>CXTERM-DICTIONARY-NAME<CR> +;; M-x tit-dic-convert<CR>CXTERM-DICTIONARY-NAME<CR> ;; Usage (from shell): -;; % emacs -batch -l titdic-cnv -f batch-titdic-convert\ +;; % emacs -batch -l titdic-cnv -f batch-tit-dic-convert\ ;; [-dir DIR] [DIR | FILE] ... ;; -;; When you run titdic-convert within Emacs, you have a chance to +;; When you run `tit-dic-convert' within Emacs, you have a chance to ;; modify arguments of `quail-define-package' before saving the ;; converted file. For instance, you are likely to modify TITLE, ;; DOCSTRING, and KEY-BINDINGS. @@ -90,7 +90,8 @@ ;; \<quail-translation-docstring> is replaced by a description about ;; how to select a translation from a list of candidates. -(defvar quail-cxterm-package-ext-info +(define-obsolete-variable-alias 'quail-cxterm-package-ext-info 'tit-quail-cxterm-package-ext-info "30.1") +(defvar tit-quail-cxterm-package-ext-info '(("chinese-4corner" "四角") ("chinese-array30" "３０") ("chinese-ccdospy" "缩拼" @@ -277,7 +278,7 @@ SPC, 6, 3, 4, or 7 specifying a tone (SPC:陰平, 6:陽平, 3:上聲, 4:去聲, (tit-moveleft ",<") (tit-keyprompt nil)) - (generate-lisp-file-heading filename 'titdic-convert :code nil) + (generate-lisp-file-heading filename 'tit-dic-convert :code nil) (princ ";; Quail package `") (princ package) (princ "\n") @@ -354,7 +355,7 @@ SPC, 6, 3, 4, or 7 specifying a tone (SPC:陰平, 6:陽平, 3:上聲, 4:去聲, (princ "(quail-define-package ") ;; Args NAME, LANGUAGE, TITLE - (let ((title (nth 1 (assoc package quail-cxterm-package-ext-info)))) + (let ((title (nth 1 (assoc package tit-quail-cxterm-package-ext-info)))) (princ "\"") (princ package) (princ "\" \"") @@ -383,7 +384,7 @@ SPC, 6, 3, 4, or 7 specifying a tone (SPC:陰平, 6:陽平, 3:上聲, 4:去聲, (let ((doc (concat tit-prompt "\n")) (comments (if tit-comments (mapconcat #'identity (nreverse tit-comments) "\n"))) - (doc-ext (nth 2 (assoc package quail-cxterm-package-ext-info)))) + (doc-ext (nth 2 (assoc package tit-quail-cxterm-package-ext-info)))) (if comments (setq doc (concat doc "\n" comments "\n"))) (if doc-ext @@ -476,6 +477,9 @@ SPC, 6, 3, 4, or 7 specifying a tone (SPC:陰平, 6:陽平, 3:上聲, 4:去聲, ;;;###autoload (defun titdic-convert (filename &optional dirname) + (declare (obsolete tit-dic-convert "30.1")) + (tit-dic-convert filename dirname)) +(defun tit-dic-convert (filename &optional dirname) "Convert a TIT dictionary of FILENAME into a Quail package. Optional argument DIRNAME if specified is the directory name under which the generated Quail package is saved." @@ -531,21 +535,24 @@ the generated Quail package is saved." ;;;###autoload (defun batch-titdic-convert (&optional force) - "Run `titdic-convert' on the files remaining on the command line. + (declare (obsolete batch-tit-dic-convert "30.1")) + (batch-tit-dic-convert force)) +(defun batch-tit-dic-convert (&optional force) + "Run `tit-dic-convert' on the files remaining on the command line. Use this from the command line, with `-batch'; it won't work in an interactive Emacs. -For example, invoke \"emacs -batch -f batch-titdic-convert XXX.tit\" to +For example, invoke \"emacs -batch -f batch-tit-dic-convert XXX.tit\" to generate Quail package file \"xxx.el\" from TIT dictionary file \"XXX.tit\". -To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." +To get complete usage, invoke \"emacs -batch -f batch-tit-dic-convert -h\"." (defvar command-line-args-left) ; Avoid compiler warning. (if (not noninteractive) - (error "`batch-titdic-convert' should be used only with -batch")) + (error "`batch-tit-dic-convert' should be used only with -batch")) (if (string= (car command-line-args-left) "-h") (progn (message "To convert XXX.tit and YYY.tit into xxx.el and yyy.el:") - (message " %% emacs -batch -l titdic-cnv -f batch-titdic-convert XXX.tit YYY.tit") + (message " %% emacs -batch -l titdic-cnv -f batch-tit-dic-convert XXX.tit YYY.tit") (message "To convert XXX.tit into DIR/xxx.el:") - (message " %% emacs -batch -l titdic-cnv -f batch-titdic-convert -dir DIR XXX.tit")) + (message " %% emacs -batch -l titdic-cnv -f batch-tit-dic-convert -dir DIR XXX.tit")) (let (targetdir filename files file) (if (string= (car command-line-args-left) "-dir") (progn @@ -564,7 +571,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." (when (or force (file-newer-than-file-p file (tit-make-quail-package-file-name file targetdir))) - (titdic-convert file targetdir)) + (tit-dic-convert file targetdir)) (setq files (cdr files))) (setq command-line-args-left (cdr command-line-args-left))))) (kill-emacs 0)) @@ -583,10 +590,11 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ;; COPYRIGHT-NOTICE ;; Copyright notice of the source dictionary. ;; ) -(defvar quail-misc-package-ext-info +(define-obsolete-variable-alias 'quail-misc-package-ext-info 'tit-quail-misc-package-ext-info "30.1") +(defvar tit-quail-misc-package-ext-info '(("chinese-b5-tsangchi" "倉B" "cangjie-table.b5" big5 "tsang-b5.el" - tsang-b5-converter + tit--tsang-b5-converter "\ ;; # Copyright 2001 Christian Wittern <wittern@iis.sinica.edu.tw> ;; # @@ -596,7 +604,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ("chinese-b5-quick" "簡B" "cangjie-table.b5" big5 "quick-b5.el" - quick-b5-converter + tit--quick-b5-converter "\ ;; # Copyright 2001 Christian Wittern <wittern@iis.sinica.edu.tw> ;; # @@ -606,7 +614,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ("chinese-cns-tsangchi" "倉C" "cangjie-table.cns" iso-2022-cn-ext "tsang-cns.el" - tsang-cns-converter + tit--tsang-cns-converter "\ ;; # Copyright 2001 Christian Wittern <wittern@iis.sinica.edu.tw> ;; # @@ -616,7 +624,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ("chinese-cns-quick" "簡C" "cangjie-table.cns" iso-2022-cn-ext "quick-cns.el" - quick-cns-converter + tit--quick-cns-converter "\ ;; # Copyright 2001 Christian Wittern <wittern@iis.sinica.edu.tw> ;; # @@ -626,7 +634,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ("chinese-py" "拼G" "pinyin.map" cn-gb-2312 "PY.el" - py-converter + tit--py-converter "\ ;; \"pinyin.map\" is included in a free package called CCE. It is ;; available at: [link needs updating -- SK 2021-09-27] @@ -654,7 +662,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ("chinese-ziranma" "自然" "ziranma.cin" cn-gb-2312 "ZIRANMA.el" - ziranma-converter + tit--ziranma-converter "\ ;; \"ziranma.cin\" is included in a free package called CCE. It is ;; available at: [link needs updating -- SK 2021-09-27] @@ -682,7 +690,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ("chinese-ctlau" "刘粤" "CTLau.html" cn-gb-2312 "CTLau.el" - ctlau-gb-converter + tit--ctlau-gb-converter "\ ;; \"CTLau.html\" is available at: ;; @@ -707,7 +715,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ("chinese-ctlaub" "劉粵" "CTLau-b5.html" big5 "CTLau-b5.el" - ctlau-b5-converter + tit--ctlau-b5-converter "\ ;; \"CTLau-b5.html\" is available at: ;; @@ -740,7 +748,8 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ;; input method is for inputting Big5 characters. Otherwise the input ;; method is for inputting CNS characters. -(defun tsang-quick-converter (dicbuf tsang-p big5-p) +(define-obsolete-function-alias 'tsang-quick-converter #'tit--tsang-quick-converter "30.1") +(defun tit--tsang-quick-converter (dicbuf tsang-p big5-p) (let ((fulltitle (if tsang-p "倉頡" "簡易")) dic) (goto-char (point-max)) @@ -822,23 +831,28 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." (if big5-p (nth 1 elt) (nth 2 elt)))))) (insert ")\n"))) -(defun tsang-b5-converter (dicbuf) - (tsang-quick-converter dicbuf t t)) +(define-obsolete-function-alias 'tsang-b5-converter #'tit--tsang-b5-converter "30.1") +(defun tit--tsang-b5-converter (dicbuf) + (tit--tsang-quick-converter dicbuf t t)) -(defun quick-b5-converter (dicbuf) - (tsang-quick-converter dicbuf nil t)) +(define-obsolete-function-alias 'quick-b5-converter #'tit--quick-b5-converter "30.1") +(defun tit--quick-b5-converter (dicbuf) + (tit--tsang-quick-converter dicbuf nil t)) -(defun tsang-cns-converter (dicbuf) - (tsang-quick-converter dicbuf t nil)) +(define-obsolete-function-alias 'tsang-cns-converter #'tit--tsang-cns-converter "30.1") +(defun tit--tsang-cns-converter (dicbuf) + (tit--tsang-quick-converter dicbuf t nil)) -(defun quick-cns-converter (dicbuf) - (tsang-quick-converter dicbuf nil nil)) +(define-obsolete-function-alias 'quick-cns-converter #'tit--quick-cns-converter "30.1") +(defun tit--quick-cns-converter (dicbuf) + (tit--tsang-quick-converter dicbuf nil nil)) ;; Generate a code of a Quail package in the current buffer from ;; Pinyin dictionary in the buffer DICBUF. The input method name of ;; the Quail package is NAME, and the title string is TITLE. -(defun py-converter (dicbuf) +(define-obsolete-function-alias 'py-converter #'tit--py-converter "30.1") +(defun tit--py-converter (dicbuf) (goto-char (point-max)) (insert (format "%S\n" "汉字输入∷拼音∷ @@ -913,7 +927,8 @@ method `chinese-tonepy' with which you must specify tones by digits ;; Ziranma dictionary in the buffer DICBUF. The input method name of ;; the Quail package is NAME, and the title string is TITLE. -(defun ziranma-converter (dicbuf) +(define-obsolete-function-alias 'ziranma-converter #'tit--ziranma-converter "30.1") +(defun tit--ziranma-converter (dicbuf) (let (dic) (with-current-buffer dicbuf (goto-char (point-min)) @@ -1022,7 +1037,8 @@ To input symbols and punctuation, type `/' followed by one of `a' to ;; method name of the Quail package is NAME, and the title string is ;; TITLE. DESCRIPTION is the string shown by describe-input-method. -(defun ctlau-converter (dicbuf description) +(define-obsolete-function-alias 'ctlau-converter #'tit--ctlau-converter "30.1") +(defun tit--ctlau-converter (dicbuf description) (goto-char (point-max)) (insert (format "%S\n" description)) (insert " '((\"\C-?\" . quail-delete-last-char) @@ -1071,8 +1087,9 @@ To input symbols and punctuation, type `/' followed by one of `a' to (forward-line 1))) (insert ")\n")) -(defun ctlau-gb-converter (dicbuf) - (ctlau-converter dicbuf +(define-obsolete-function-alias 'ctlau-gb-converter #'tit--ctlau-gb-converter "30.1") +(defun tit--ctlau-gb-converter (dicbuf) + (tit--ctlau-converter dicbuf "汉字输入∷刘锡祥式粤音∷ 刘锡祥式粤语注音方案 @@ -1085,8 +1102,9 @@ To input symbols and punctuation, type `/' followed by one of `a' to Some infrequent GB characters are accessed by typing \\, followed by the Cantonese romanization of the respective radical (部首).")) -(defun ctlau-b5-converter (dicbuf) - (ctlau-converter dicbuf +(define-obsolete-function-alias 'ctlau-b5-converter #'tit--ctlau-b5-converter "30.1") +(defun tit--ctlau-b5-converter (dicbuf) + (tit--ctlau-converter dicbuf "漢字輸入：劉錫祥式粵音： 劉錫祥式粵語注音方案 @@ -1101,14 +1119,15 @@ To input symbols and punctuation, type `/' followed by one of `a' to (declare-function dos-8+3-filename "dos-fns.el" (filename)) -(defun miscdic-convert (filename &optional dirname) +(define-obsolete-function-alias 'miscdic-convert #'tit-miscdic-convert "30.1") +(defun tit-miscdic-convert (filename &optional dirname) "Convert a dictionary file FILENAME into a Quail package. Optional argument DIRNAME if specified is the directory name under which the generated Quail package is saved." (interactive "FInput method dictionary file: ") (or (file-readable-p filename) (error "%s does not exist" filename)) - (let ((tail quail-misc-package-ext-info) + (let ((tail tit-quail-misc-package-ext-info) coding-system-for-write slot name title dicfile coding quailfile converter copyright) @@ -1137,7 +1156,7 @@ the generated Quail package is saved." ;; Explicitly set eol format to `unix'. (setq coding-system-for-write 'utf-8-unix) (with-temp-file (expand-file-name quailfile dirname) - (generate-lisp-file-heading quailfile 'miscdic-convert) + (generate-lisp-file-heading quailfile 'tit-miscdic-convert) (insert (format-message ";; Quail package `%s'\n" name)) (insert ";; Source dictionary file: " dicfile "\n") (insert ";; Copyright notice of the source file\n") @@ -1164,15 +1183,17 @@ the generated Quail package is saved." quailfile :inhibit-provide t :compile t :coding nil))) (setq tail (cdr tail))))) -(defun batch-miscdic-convert () - "Run `miscdic-convert' on the files remaining on the command line. +;; Used in `Makefile.in'. +(define-obsolete-function-alias 'batch-miscdic-convert #'batch-tit-miscdic-convert "30.1") +(defun batch-tit-miscdic-convert () + "Run `tit-miscdic-convert' on the files remaining on the command line. Use this from the command line, with `-batch'; it won't work in an interactive Emacs. If there's an argument \"-dir\", the next argument specifies a directory to store generated Quail packages." (defvar command-line-args-left) ; Avoid compiler warning. (if (not noninteractive) - (error "`batch-miscdic-convert' should be used only with -batch")) + (error "`batch-tit-miscdic-convert' should be used only with -batch")) (let ((dir default-directory) filename) (while command-line-args-left @@ -1186,11 +1207,13 @@ to store generated Quail packages." (if (file-directory-p filename) (dolist (file (directory-files filename t nil t)) (or (file-directory-p file) - (miscdic-convert file dir))) - (miscdic-convert filename dir)))) + (tit-miscdic-convert file dir))) + (tit-miscdic-convert filename dir)))) (kill-emacs 0)) -(defun pinyin-convert () +;; Used in `Makefile.in'. +(define-obsolete-function-alias 'pinyin-convert #'tit-pinyin-convert "30.1") +(defun tit-pinyin-convert () "Convert text file pinyin.map into an elisp library. The library is named pinyin.el, and contains the constant `pinyin-character-map'." diff --git a/lisp/isearch.el b/lisp/isearch.el index 6b39054b512..a139a6fb84e 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el @@ -282,13 +282,13 @@ Value is nil, t, or a function. If nil, default to literal searches (note that `case-fold-search' and `isearch-lax-whitespace' may still be applied).\\<isearch-mode-map> -If t, default to regexp searches (as if typing `\\[isearch-toggle-regexp]' during +If t, default to regexp searches (as if typing \\[isearch-toggle-regexp] during isearch). If a function, use that function as an `isearch-regexp-function'. Example functions (and the keys to toggle them during isearch) -are `word-search-regexp' \(`\\[isearch-toggle-word]'), `isearch-symbol-regexp' -\(`\\[isearch-toggle-symbol]'), and `char-fold-to-regexp' \(`\\[isearch-toggle-char-fold]')." +are `word-search-regexp' \(\\[isearch-toggle-word]), `isearch-symbol-regexp' +\(\\[isearch-toggle-symbol]), and `char-fold-to-regexp' \(\\[isearch-toggle-char-fold])." ;; :type is set below by `isearch-define-mode-toggle'. :type '(choice (const :tag "Literal search" nil) (const :tag "Regexp search" t) @@ -2875,7 +2875,8 @@ The command accepts Unicode names like \"smiling face\" or (isearch-search) (when (and (memq isearch-wrap-pause '(no no-ding)) (not isearch-success)) - (isearch-repeat (if isearch-forward 'forward 'backward))))) + (let ((isearch-cmds isearch-cmds)) + (isearch-repeat (if isearch-forward 'forward 'backward)))))) (isearch-push-state) (if isearch-op-fun (funcall isearch-op-fun)) (isearch-update)) diff --git a/lisp/jsonrpc.el b/lisp/jsonrpc.el index 3f33443f321..5037d8c5b2b 100644 --- a/lisp/jsonrpc.el +++ b/lisp/jsonrpc.el @@ -4,7 +4,7 @@ ;; Author: João Távora <joaotavora@gmail.com> ;; Keywords: processes, languages, extensions -;; Version: 1.0.23 +;; Version: 1.0.25 ;; Package-Requires: ((emacs "25.2")) ;; This is a GNU ELPA :core package. Avoid functionality that is not @@ -438,7 +438,7 @@ ignored." `(canceled ,cancel-on-input-retval)) (t (while t (accept-process-output nil 30))))) ;; In normal operation, continuations for error/success is - ;; handled by `jsonrpc-continue'. Timeouts also remove + ;; handled by `jsonrpc--continue'. Timeouts also remove ;; the continuation... (pcase-let* ((`(,id ,_) id-and-timer)) ;; ...but we still have to guard against exist explicit @@ -689,8 +689,22 @@ With optional CLEANUP, kill any associated buffers." (when-let (p (slot-value connection '-autoport-inferior)) (delete-process p)) (funcall (jsonrpc--on-shutdown connection) connection))))) +(defvar jsonrpc--in-process-filter nil + "Non-nil if inside `jsonrpc--process-filter'.") + (cl-defun jsonrpc--process-filter (proc string) "Called when new data STRING has arrived for PROC." + (when jsonrpc--in-process-filter + ;; Problematic recursive process filters may happen if + ;; `jsonrpc-connection-receive', called by us, eventually calls + ;; client code which calls `process-send-string' (which see) to, + ;; say send a follow-up message. If that happens to writes enough + ;; bytes for pending output to be received, we will lose JSONRPC + ;; messages. In that case, remove recursiveness by re-scheduling + ;; ourselves to run from within a timer as soon as possible + ;; (bug#60088) + (run-at-time 0 nil #'jsonrpc--process-filter proc string) + (cl-return-from jsonrpc--process-filter)) (when (buffer-live-p (process-buffer proc)) (with-current-buffer (process-buffer proc) (let* ((conn (process-get proc 'jsonrpc-connection)) @@ -746,10 +760,11 @@ With optional CLEANUP, kill any associated buffers." (setq message (plist-put message :jsonrpc-json (buffer-string))) - (process-put proc 'jsonrpc-mqueue - (nconc (process-get proc - 'jsonrpc-mqueue) - (list message))))) + ;; Put new messages at the front of the queue, + ;; this is correct as the order is reversed + ;; before putting the timers on `timer-list'. + (push message + (process-get proc 'jsonrpc-mqueue)))) (goto-char message-end) (let ((inhibit-read-only t)) (delete-region (point-min) (point))) @@ -768,11 +783,20 @@ With optional CLEANUP, kill any associated buffers." ;; non-locally (typically the reply to a request), so do ;; this all this processing in top-level loops timer. (cl-loop + ;; `timer-activate' orders timers by time, which is an + ;; very expensive operation when jsonrpc-mqueue is large, + ;; therefore the time object is reused for each timer + ;; created. + with time = (current-time) for msg = (pop (process-get proc 'jsonrpc-mqueue)) while msg - do (run-at-time 0 nil - (lambda (m) (with-temp-buffer - (jsonrpc-connection-receive conn m))) - msg))))))) + do (let ((timer (timer-create))) + (timer-set-time timer time) + (timer-set-function timer + (lambda (conn msg) + (with-temp-buffer + (jsonrpc-connection-receive conn msg))) + (list conn msg)) + (timer-activate timer)))))))) (defun jsonrpc--remove (conn id &optional deferred-spec) "Cancel CONN's continuations for ID, including its timer, if it exists. @@ -782,7 +806,7 @@ Return the full continuation (ID SUCCESS-FN ERROR-FN TIMER)" (if deferred-spec (remhash deferred-spec defs)) (when-let ((ass (assq id conts))) (cl-destructuring-bind (_ _ _ _ timer) ass - (cancel-timer timer)) + (when timer (cancel-timer timer))) (setf conts (delete ass conts)) ass))) @@ -1003,16 +1027,17 @@ of the API instead.") (or method "") (if id (format "[%s]" id) ""))))) (msg - (cond ((eq format 'full) - (format "%s%s\n" preamble (or json log-text))) - ((eq format 'short) - (format "%s%s\n" preamble (or log-text ""))) - (t - (format "%s%s" preamble - (or (and foreign-message - (concat "\n" (pp-to-string - foreign-message))) - (concat log-text "\n"))))))) + (pcase format + ('full (format "%s%s\n" preamble (or json log-text))) + ('short (format "%s%s\n" preamble (or log-text ""))) + (_ + (format "%s%s" preamble + (or (and foreign-message + (let ((lisp-indent-function ;bug#68072 + #'lisp-indent-function)) + (concat "\n" (pp-to-string + foreign-message)))) + (concat log-text "\n"))))))) (goto-char (point-max)) ;; XXX: could use `run-at-time' to delay server logs ;; slightly to play nice with verbose servers' stderr. diff --git a/lisp/keymap.el b/lisp/keymap.el index 065c59da74c..b2b475c7d71 100644 --- a/lisp/keymap.el +++ b/lisp/keymap.el @@ -260,7 +260,7 @@ returned by \\[describe-key] (`describe-key')." (setq word (concat (match-string 1 word) (match-string 3 word))) (not (string-match - "\\<\\(NUL\\|RET\\|LFD\\|ESC\\|SPC\\|DEL\\)$" + "\\<\\(NUL\\|RET\\|LFD\\|TAB\\|ESC\\|SPC\\|DEL\\)$" word)))) (setq key (list (intern word)))) ((or (equal word "REM") (string-match "^;;" word)) @@ -577,9 +577,15 @@ should be a MENU form as accepted by `easy-menu-define'. (let ((def (pop definitions))) (if (eq key :menu) (easy-menu-define nil keymap "" def) - (if (member key seen-keys) - (error "Duplicate definition for key: %S %s" key keymap) - (push key seen-keys)) + (when (member key seen-keys) + ;; Since the keys can be computed dynamically, it can + ;; very well happen that we get duplicate definitions + ;; due to some unfortunate configuration rather than + ;; due to an actual bug. While such duplicates are + ;; not desirable, they shouldn't prevent the users + ;; from getting their job done. + (message "Duplicate definition for key: %S %s" key keymap)) + (push key seen-keys) (keymap-set keymap key def))))) keymap))) diff --git a/lisp/language/japan-util.el b/lisp/language/japan-util.el index 93e8ab24971..b058eab7029 100644 --- a/lisp/language/japan-util.el +++ b/lisp/language/japan-util.el @@ -29,8 +29,8 @@ ;;;###autoload (defun setup-japanese-environment-internal () - (prefer-coding-system (if (memq system-type '(windows-nt ms-dos cygwin)) - 'japanese-shift-jis + (prefer-coding-system (if (memq system-type '(windows-nt ms-dos)) + 'japanese-cp932 'utf-8)) (use-cjk-char-width-table 'ja_JP)) diff --git a/lisp/language/japanese.el b/lisp/language/japanese.el index dd65409c839..8957d1a49af 100644 --- a/lisp/language/japanese.el +++ b/lisp/language/japanese.el @@ -79,7 +79,7 @@ (#x00A2 . #xFFE0) ; CENT SIGN FULLWIDTH CENT SIGN (#x00A3 . #xFFE1) ; POUND SIGN FULLWIDTH POUND SIGN (#x00AC . #xFFE2) ; NOT SIGN FULLWIDTH NOT SIGN - (#x00A6 . #xFFE4) ; BROKEN LINE FULLWIDTH BROKEN LINE + (#x00A6 . #xFFE4) ; BROKEN BAR FULLWIDTH BROKEN BAR ))) (define-translation-table 'japanese-ucs-jis-to-cp932-map map) (setq map (mapcar (lambda (x) (cons (cdr x) (car x))) map)) diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el index ef672d6c2e5..b434ee0e37f 100644 --- a/lisp/ldefs-boot.el +++ b/lisp/ldefs-boot.el @@ -729,19 +729,19 @@ CONCEALED: CLOSED: A TOPIC whose immediate OFFSPRING and body-text is CONCEALED. OPEN: A TOPIC that is not CLOSED, though its OFFSPRING or BODY may be. -This is a minor mode. If called interactively, toggle the -`Allout mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `Allout mode' +mode. If the prefix argument is positive, enable the mode, and if it is +zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `allout-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (define-obsolete-function-alias 'outlinify-sticky #'allout-outlinify-sticky "29.1") @@ -803,18 +803,18 @@ bindings for easy outline navigation and exposure control, extending outline hot-spot navigation (see `allout-mode'). This is a minor mode. If called interactively, toggle the -`Allout-Widgets mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Allout-Widgets mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `allout-widgets-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "allout-widgets" '("allout-")) @@ -1389,19 +1389,19 @@ Keymap summary \\{artist-mode-map} -This is a minor mode. If called interactively, toggle the -`Artist mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `Artist mode' +mode. If the prefix argument is positive, enable the mode, and if it is +zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `artist-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "artist" '("artist-")) @@ -1534,18 +1534,18 @@ When Auto-insert mode is enabled, when new files are created you can insert a template for the file depending on the mode of the buffer. This is a global minor mode. If called interactively, toggle the -`Auto-Insert mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Auto-Insert mode' mode. If the prefix argument is positive, enable the +mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='auto-insert-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "autoinsert" '("auto-insert")) @@ -1571,19 +1571,19 @@ Use `global-auto-revert-mode' to automatically revert all buffers. Use `auto-revert-tail-mode' if you know that the file will only grow without being changed in the part that is already in the buffer. -This is a minor mode. If called interactively, toggle the -`Auto-Revert mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `Auto-Revert +mode' mode. If the prefix argument is positive, enable the mode, and if +it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `auto-revert-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'turn-on-auto-revert-mode "autorevert" "\ @@ -1610,19 +1610,18 @@ suppressed by setting `auto-revert-verbose' to nil. Use `auto-revert-mode' for changes other than appends! This is a minor mode. If called interactively, toggle the -`Auto-Revert-Tail mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable -the mode. +`Auto-Revert-Tail mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `auto-revert-tail-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'turn-on-auto-revert-tail-mode "autorevert" "\ @@ -1659,19 +1658,18 @@ It displays the text that `global-auto-revert-mode-text' specifies in the mode line. This is a global minor mode. If called interactively, toggle the -`Global Auto-Revert mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable -the mode. +`Global Auto-Revert mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='global-auto-revert-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "autorevert" '("auto-revert-" "global-auto-revert-")) @@ -1774,18 +1772,18 @@ functions in `battery-update-functions', which can be used to trigger actions based on battery-related events. This is a global minor mode. If called interactively, toggle the -`Display-Battery mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Display-Battery mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='display-battery-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "battery" '("battery-")) @@ -1949,6 +1947,10 @@ Major mode for editing BibTeX style files. ;;; Generated autoloads from bind-key.el (push (purecopy '(bind-key 2 4 1)) package--builtin-versions) +(defvar personal-keybindings nil "\ +List of bindings performed by `bind-key'. + +Elements have the form ((KEY . [MAP]) CMD ORIGINAL-CMD)") (autoload 'bind-key "bind-key" "\ Bind KEY-NAME to COMMAND in KEYMAP (`global-map' if not passed). @@ -2022,7 +2024,7 @@ other modes. See `override-global-mode'. (fn &rest ARGS)" nil t) (autoload 'describe-personal-keybindings "bind-key" "\ Display all the personal keybindings defined by `bind-key'." t) -(register-definition-prefixes "bind-key" '("bind-key" "override-global-m" "personal-keybindings")) +(register-definition-prefixes "bind-key" '("bind-key" "override-global-m")) ;;; Generated autoloads from emacs-lisp/bindat.el @@ -2755,37 +2757,36 @@ columns on its right towards the left. Toggle hyperlinking bug references in the buffer (Bug Reference mode). This is a minor mode. If called interactively, toggle the -`Bug-Reference mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Bug-Reference mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `bug-reference-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'bug-reference-prog-mode "bug-reference" "\ Like `bug-reference-mode', but only buttonize in comments and strings. This is a minor mode. If called interactively, toggle the -`Bug-Reference-Prog mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable -the mode. +`Bug-Reference-Prog mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `bug-reference-prog-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "bug-reference" '("bug-reference-")) @@ -2939,12 +2940,6 @@ and corresponding effects. ;;; Generated autoloads from progmodes/c-ts-mode.el -(autoload 'c-ts-base-mode "c-ts-mode" "\ -Major mode for editing C, powered by tree-sitter. - -\\{c-ts-base-mode-map} - -(fn)" t) (autoload 'c-ts-mode "c-ts-mode" "\ Major mode for editing C, powered by tree-sitter. @@ -2994,6 +2989,7 @@ should be used. This function attempts to use file contents to determine whether the code is C or C++ and based on that chooses whether to enable `c-ts-mode' or `c++-ts-mode'." t) +(make-obsolete 'c-or-c++-ts-mode 'c-or-c++-mode "30.1") (register-definition-prefixes "c-ts-mode" '("c-ts-")) @@ -4380,19 +4376,19 @@ checking of documentation strings. \\{checkdoc-minor-mode-map} -This is a minor mode. If called interactively, toggle the -`Checkdoc minor mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `Checkdoc +minor mode' mode. If the prefix argument is positive, enable the mode, +and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `checkdoc-minor-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'checkdoc-package-keywords "checkdoc" "\ @@ -4478,19 +4474,18 @@ or call the function `cl-font-lock-built-in-mode'.") Highlight built-in functions, variables, and types in `lisp-mode'. This is a global minor mode. If called interactively, toggle the -`Cl-Font-Lock-Built-In mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable -the mode. +`Cl-Font-Lock-Built-In mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='cl-font-lock-built-in-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "cl-font-lock" '("cl-font-lock-")) @@ -4620,19 +4615,18 @@ macro-expansion of `cl-defstruct' that used vectors objects instead of record objects. This is a global minor mode. If called interactively, toggle the -`Cl-Old-Struct-Compat mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable -the mode. +`Cl-Old-Struct-Compat mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='cl-old-struct-compat-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "cl-lib" '("cl-")) @@ -5032,6 +5026,16 @@ on third call it again advances points to the next difference and so on. (register-definition-prefixes "compare-w" '("compare-")) +;;; Generated autoloads from emacs-lisp/compat.el + + (push (list 'compat + emacs-major-version + emacs-minor-version + 9999) + package--builtin-versions) +(register-definition-prefixes "compat" '("compat-")) + + ;;; Generated autoloads from image/compface.el (register-definition-prefixes "compface" '("uncompface")) @@ -5180,18 +5184,18 @@ See `compilation-mode'. This is a minor mode. If called interactively, toggle the `Compilation-Shell minor mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable -the mode. +positive, enable the mode, and if it is zero or negative, disable the +mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `compilation-shell-minor-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'compilation-minor-mode "compile" "\ @@ -5201,20 +5205,19 @@ When Compilation minor mode is enabled, all the error-parsing commands of Compilation major mode are available. See `compilation-mode'. -This is a minor mode. If called interactively, toggle the -`Compilation minor mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable -the mode. +This is a minor mode. If called interactively, toggle the `Compilation +minor mode' mode. If the prefix argument is positive, enable the mode, +and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `compilation-minor-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'compilation-next-error-function "compile" "\ @@ -5272,19 +5275,18 @@ this mode: `enable-completion', `save-completions-flag', and options can be found in the `completion' group. This is a global minor mode. If called interactively, toggle the -`Dynamic-Completion mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable -the mode. +`Dynamic-Completion mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='dynamic-completion-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "completion" '("*c-def-regexp*" "*lisp-def-regexp*" "accept-completion" "add-" "cdabbrev-" "check-completion-length" "clear-all-completions" "cmpl-" "complet" "current-completion-source" "delete-completion" "enable-completion" "find-" "inside-locate-completion-entry" "interactive-completion-string-reader" "kill-" "list-all-completions" "load-completions-from-file" "make-c" "next-cdabbrev" "num-cmpl-sources" "reset-cdabbrev" "save" "set-c" "symbol-" "use-completion-")) @@ -5304,19 +5306,18 @@ completion suggestion, and \\[completion-preview-prev-candidate] cycles backward. This is a minor mode. If called interactively, toggle the -`Completion-Preview mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable -the mode. +`Completion-Preview mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `completion-preview-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "completion-preview" '("completion-preview-")) @@ -5543,6 +5544,7 @@ If FIX is non-nil, run `copyright-fix-years' instead. ;;; Generated autoloads from progmodes/cperl-mode.el +(put 'cperl-file-style 'safe-local-variable 'stringp) (put 'cperl-indent-level 'safe-local-variable 'integerp) (put 'cperl-brace-offset 'safe-local-variable 'integerp) (put 'cperl-continued-brace-offset 'safe-local-variable 'integerp) @@ -5550,7 +5552,6 @@ If FIX is non-nil, run `copyright-fix-years' instead. (put 'cperl-continued-statement-offset 'safe-local-variable 'integerp) (put 'cperl-extra-newline-before-brace 'safe-local-variable 'booleanp) (put 'cperl-merge-trailing-else 'safe-local-variable 'booleanp) -(put 'cperl-file-style 'safe-local-variable 'stringp) (autoload 'cperl-mode "cperl-mode" "\ Major mode for editing Perl code. Expression and list commands understand all C brackets. @@ -5903,19 +5904,19 @@ You can customize `cua-enable-cua-keys' to completely disable the CUA bindings, or `cua-prefix-override-inhibit-delay' to change the prefix fallback behavior. -This is a global minor mode. If called interactively, toggle the -`Cua mode' mode. If the prefix argument is positive, enable the -mode, and if it is zero or negative, disable the mode. +This is a global minor mode. If called interactively, toggle the `Cua +mode' mode. If the prefix argument is positive, enable the mode, and if +it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='cua-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'cua-selection-mode "cua-base" "\ @@ -5938,19 +5939,18 @@ Toggle the region as rectangular. Activates the region if needed. Only lasts until the region is deactivated. This is a minor mode. If called interactively, toggle the -`Cua-Rectangle-Mark mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable -the mode. +`Cua-Rectangle-Mark mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `cua-rectangle-mark-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "cua-rect" '("cua-")) @@ -5966,19 +5966,18 @@ By convention, this is a list of symbols where each symbol stands for the Keep cursor outside of any `cursor-intangible' text property. This is a minor mode. If called interactively, toggle the -`Cursor-Intangible mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable -the mode. +`Cursor-Intangible mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `cursor-intangible-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'cursor-sensor-mode "cursor-sensor" "\ @@ -5991,18 +5990,18 @@ the cursor and DIR can be `entered' or `left' depending on whether the cursor is entering the area covered by the text-property property or leaving it. This is a minor mode. If called interactively, toggle the -`Cursor-Sensor mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Cursor-Sensor mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `cursor-sensor-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "cursor-sensor" '("cursor-sensor-")) @@ -6115,6 +6114,11 @@ Customize GROUP, which must be a customization group, in another window. Customize SYMBOL, which must be a user option. (fn SYMBOL)" t) +(autoload 'customize-toggle-option "cus-edit" "\ +Toggle the value of boolean option SYMBOL for this session. + +(fn SYMBOL)" t) +(defalias 'toggle-option #'customize-toggle-option) (defalias 'customize-variable-other-window 'customize-option-other-window) (autoload 'customize-option-other-window "cus-edit" "\ Customize SYMBOL, which must be a user option. @@ -6368,19 +6372,19 @@ Note, in addition to enabling this minor mode, the major mode must be included in the variable `cwarn-configuration'. By default C and C++ modes are included. -This is a minor mode. If called interactively, toggle the `Cwarn -mode' mode. If the prefix argument is positive, enable the mode, -and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `Cwarn mode' +mode. If the prefix argument is positive, enable the mode, and if it is +zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `cwarn-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (put 'global-cwarn-mode 'globalized-minor-mode t) @@ -6871,19 +6875,18 @@ See `delete-selection-helper' and `delete-selection-pre-hook' for information on adapting behavior of commands in Delete Selection mode. This is a global minor mode. If called interactively, toggle the -`Delete-Selection mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable -the mode. +`Delete-Selection mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='delete-selection-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'delete-active-region "delsel" "\ @@ -6964,13 +6967,6 @@ See Info node `(elisp)Derived Modes' for more details. (fn CHILD PARENT NAME [DOCSTRING] [KEYWORD-ARGS...] &rest BODY)" nil t) (function-put 'define-derived-mode 'doc-string-elt 4) (function-put 'define-derived-mode 'lisp-indent-function 'defun) -(autoload 'derived-mode-init-mode-variables "derived" "\ -Initialize variables for a new MODE. -Right now, if they don't already exist, set up a blank keymap, an -empty syntax table, and an empty abbrev table -- these will be merged -the first time the mode is used. - -(fn MODE)") (register-definition-prefixes "derived" '("derived-mode-")) @@ -7042,13 +7038,22 @@ or call the function `desktop-save-mode'.") (autoload 'desktop-save-mode "desktop" "\ Toggle desktop saving (Desktop Save mode). -When Desktop Save mode is enabled, the state of Emacs is saved from -one session to another. In particular, Emacs will save the desktop when -it exits (this may prompt you; see the option `desktop-save'). The next -time Emacs starts, if this mode is active it will restore the desktop. +When Desktop Save mode is enabled, the state of Emacs is saved from one +session to another. The saved Emacs \"desktop configuration\" includes the +buffers, their file names, major modes, buffer positions, window and frame +configuration, and some important global variables. + +To enable this feature for future sessions, customize `desktop-save-mode' +to t, or add this line in your init file: + + (desktop-save-mode 1) -To manually save the desktop at any time, use the command `\\[desktop-save]'. -To load it, use `\\[desktop-read]'. +When this mode is enabled, Emacs will save the desktop when it exits +(this may prompt you, see the option `desktop-save'). The next time +Emacs starts, if this mode is active it will restore the desktop. + +To manually save the desktop at any time, use the command \\[desktop-save]. +To load it, use \\[desktop-read]. Once a desktop file exists, Emacs will auto-save it according to the option `desktop-auto-save-timeout'. @@ -7058,18 +7063,18 @@ To see all the options you can set, browse the `desktop' customization group. For further details, see info node `(emacs)Saving Emacs Sessions'. This is a global minor mode. If called interactively, toggle the -`Desktop-Save mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Desktop-Save mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='desktop-save-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (defvar desktop-locals-to-save '(desktop-locals-to-save truncate-lines case-fold-search case-replace fill-column overwrite-mode change-log-default-name line-number-mode column-number-mode size-indication-mode buffer-file-coding-system buffer-display-time indent-tabs-mode tab-width indicate-buffer-boundaries indicate-empty-lines show-trailing-whitespace) "\ @@ -7503,19 +7508,19 @@ Toggle Diff minor mode. \\{diff-minor-mode-map} -This is a minor mode. If called interactively, toggle the `Diff -minor mode' mode. If the prefix argument is positive, enable the -mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `Diff minor +mode' mode. If the prefix argument is positive, enable the mode, and if +it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `diff-minor-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (defvar diff-add-log-use-relative-names nil "\ @@ -7719,19 +7724,19 @@ This is an alternative to `shell-dirtrack-mode', which works by tracking `cd' and similar commands which change the shell working directory. -This is a minor mode. If called interactively, toggle the -`Dirtrack mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `Dirtrack +mode' mode. If the prefix argument is positive, enable the mode, and if +it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `dirtrack-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'dirtrack "dirtrack" "\ @@ -7750,7 +7755,7 @@ from `default-directory'. (autoload 'disassemble "disass" "\ Print disassembled code for OBJECT in (optional) BUFFER. OBJECT can be a symbol defined as a function, or a function itself -(a lambda expression or a compiled-function object). +(a lambda expression or a byte-code-function object). If OBJECT is not already compiled, we compile it, but do not redefine OBJECT if it is a symbol. @@ -7905,19 +7910,19 @@ not appear aligned. See Info node `Displaying Boundaries' for details. This is a minor mode. If called interactively, toggle the -`Display-Fill-Column-Indicator mode' mode. If the prefix -argument is positive, enable the mode, and if it is zero or -negative, disable the mode. +`Display-Fill-Column-Indicator mode' mode. If the prefix argument is +positive, enable the mode, and if it is zero or negative, disable the +mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `display-fill-column-indicator-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (put 'global-display-fill-column-indicator-mode 'globalized-minor-mode t) @@ -7977,19 +7982,18 @@ customize `display-line-numbers-type'. To change the type while the mode is on, set `display-line-numbers' directly. This is a minor mode. If called interactively, toggle the -`Display-Line-Numbers mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable -the mode. +`Display-Line-Numbers mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `display-line-numbers-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (put 'global-display-line-numbers-mode 'globalized-minor-mode t) @@ -8066,19 +8070,18 @@ of `header-line-format', like this: See also `line-number-display-width'. This is a minor mode. If called interactively, toggle the -`Header-Line-Indent mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable -the mode. +`Header-Line-Indent mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `header-line-indent-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "display-line-numbers" '("display-line-numbers-" "header-line-indent--")) @@ -8179,19 +8182,19 @@ Toggle displaying buffer via Doc View (Doc View minor mode). See the command `doc-view-mode' for more information on this mode. -This is a minor mode. If called interactively, toggle the -`Doc-View minor mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `Doc-View +minor mode' mode. If the prefix argument is positive, enable the mode, +and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `doc-view-minor-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'doc-view-bookmark-jump "doc-view" "\ @@ -8250,19 +8253,19 @@ Toggle special insertion on double keypresses (Double mode). When Double mode is enabled, some keys will insert different strings when pressed twice. See `double-map' for details. -This is a minor mode. If called interactively, toggle the -`Double mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `Double mode' +mode. If the prefix argument is positive, enable the mode, and if it is +zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `double-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "double" '("double-")) @@ -8870,18 +8873,18 @@ This global minor mode enables `ede-minor-mode' in all buffers in an EDE controlled project. This is a global minor mode. If called interactively, toggle the -`Global Ede mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Global Ede mode' mode. If the prefix argument is positive, enable the +mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='global-ede-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "ede" '("ede" "global-ede-mode-map" "project-try-ede")) @@ -8919,7 +8922,7 @@ An extant spec symbol is a symbol that is not a function and has a `edebug-form-spec' property. (fn SPEC)") -(defalias 'edebug-defun 'edebug-eval-top-level-form) +(defalias 'edebug-defun #'edebug-eval-top-level-form) (autoload 'edebug-eval-top-level-form "edebug" "\ Evaluate the top level form point is in, stepping through with Edebug. This is like `eval-defun' except that it steps the code for Edebug @@ -9285,9 +9288,9 @@ To change the default, set the variable `ediff-use-toolbar-p', which see." t) (autoload 'edit-kbd-macro "edmacro" "\ Edit a keyboard macro. At the prompt, type any key sequence which is bound to a keyboard macro. -Or, type `\\[kmacro-end-and-call-macro]' or \\`RET' to edit the last -keyboard macro, `\\[view-lossage]' to edit the last 300 -keystrokes as a keyboard macro, or `\\[execute-extended-command]' +Or, type \\[kmacro-end-and-call-macro] or \\`RET' to edit the last +keyboard macro, \\[view-lossage] to edit the last 300 +keystrokes as a keyboard macro, or \\[execute-extended-command] to edit a macro by its command name. With a prefix argument, format the macro in a more concise way. @@ -9359,7 +9362,7 @@ Turn on EDT Emulation." t) ;;; Generated autoloads from progmodes/eglot.el -(push (purecopy '(eglot 1 16)) package--builtin-versions) +(push (purecopy '(eglot 1 17)) package--builtin-versions) (define-obsolete-function-alias 'eglot-update #'eglot-upgrade-eglot "29.1") (autoload 'eglot "eglot" "\ Start LSP server for PROJECT's buffers under MANAGED-MAJOR-MODES. @@ -9494,7 +9497,7 @@ SUPERCLASSES as children. It creates an autoload function for CNAME's constructor. (fn CNAME SUPERCLASSES FILENAME DOC)") -(register-definition-prefixes "eieio-core" '("class-" "eieio-" "inconsistent-class-hierarchy" "invalid-slot-" "unbound-slot")) +(register-definition-prefixes "eieio-core" '("cl--generic-struct-tag" "class-" "eieio-" "inconsistent-class-hierarchy" "invalid-slot-" "unbound-slot")) ;;; Generated autoloads from emacs-lisp/eieio-custom.el @@ -9571,37 +9574,36 @@ inserted around the region instead. To toggle the mode in a single buffer, use `electric-pair-local-mode'. This is a global minor mode. If called interactively, toggle the -`Electric-Pair mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Electric-Pair mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='electric-pair-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'electric-pair-local-mode "elec-pair" "\ Toggle `electric-pair-mode' only in this buffer. This is a minor mode. If called interactively, toggle the -`Electric-Pair-Local mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable -the mode. +`Electric-Pair-Local mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `electric-pair-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "elec-pair" '("electric-pair-")) @@ -9618,19 +9620,19 @@ to `elide-head-headers-to-hide'. This is suitable as an entry on `find-file-hook' or appropriate mode hooks. -This is a minor mode. If called interactively, toggle the -`Elide-Head mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `Elide-Head +mode' mode. If the prefix argument is positive, enable the mode, and if +it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `elide-head-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'elide-head "elide-head" "\ @@ -9998,19 +10000,19 @@ Commands: \\{enriched-mode-map} -This is a minor mode. If called interactively, toggle the -`Enriched mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `Enriched +mode' mode. If the prefix argument is positive, enable the mode, and if +it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `enriched-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'enriched-encode "enriched" "\ @@ -10231,19 +10233,19 @@ enough, since keyservers have strict timeout settings. (autoload 'epa-mail-mode "epa-mail" "\ A minor-mode for composing encrypted/clearsigned mails. -This is a minor mode. If called interactively, toggle the -`epa-mail mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `epa-mail +mode' mode. If the prefix argument is positive, enable the mode, and if +it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `epa-mail-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'epa-mail-decrypt "epa-mail" "\ @@ -10293,18 +10295,18 @@ or call the function `epa-global-mail-mode'.") Minor mode to hook EasyPG into Mail mode. This is a global minor mode. If called interactively, toggle the -`Epa-Global-Mail mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Epa-Global-Mail mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='epa-global-mail-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "epa-mail" '("epa-mail-")) @@ -10356,84 +10358,77 @@ Look at CONFIG and try to expand GROUP. ;;; Generated autoloads from erc/erc.el (push (purecopy '(erc 5 6 -4)) package--builtin-versions) +(dolist (symbol '( erc-sasl erc-spelling ; 29 + erc-imenu erc-nicks)) ; 30 + (custom-add-load symbol symbol)) +(custom-autoload 'erc-modules "erc") (autoload 'erc-select-read-args "erc" "\ -Prompt the user for values of nick, server, port, and password. -With prefix arg, also prompt for user and full name.") +Prompt for connection parameters and return them in a plist. +By default, collect `:server', `:port', `:nickname', and +`:password'. With a non-nil prefix argument, also prompt for +`:user' and `:full-name'. Also return various environmental +properties needed by entry-point commands, like `erc-tls'.") (autoload 'erc-server-select "erc" "\ Interactively connect to a server from `erc-server-alist'." t) (make-obsolete 'erc-server-select 'erc-tls "30.1") (autoload 'erc "erc" "\ -ERC is a powerful, modular, and extensible IRC client. -This function is the main entry point for ERC. - -It allows selecting connection parameters, and then starts ERC. - -Non-interactively, it takes the keyword arguments - (server (erc-compute-server)) - (port (erc-compute-port)) - (nick (erc-compute-nick)) - (user (erc-compute-user)) - password - (full-name (erc-compute-full-name)) - id - -That is, if called with +Connect to an Internet Relay Chat SERVER on a non-TLS PORT. +Use NICK and USER, when non-nil, to inform the IRC commands of +the same name, possibly factoring in a non-nil FULL-NAME as well. +When PASSWORD is non-nil, also send an opening server password +via the \"PASS\" command. Interactively, prompt for SERVER, +PORT, NICK, and PASSWORD, along with USER and FULL-NAME when +given a prefix argument. Non-interactively, expect the rarely +needed ID parameter, when non-nil, to be a symbol or a string for +naming the server buffer and identifying the connection +unequivocally. Once connected, return the server buffer. (See +Info node `(erc) Connecting' for details about all mentioned +parameters.) + +Together with `erc-tls', this command serves as the main entry +point for ERC, the powerful, modular, and extensible IRC client. +Non-interactively, both commands accept the following keyword +arguments, with their defaults supplied by the indicated +\"compute\" functions: + + :server `erc-compute-server' + :port `erc-compute-port' + :nick `erc-compute-nick' + :user `erc-compute-user' + :password N/A + :full-name `erc-compute-full-name' + :id' N/A + +For example, when called in the following manner (erc :server \"irc.libera.chat\" :full-name \"J. Random Hacker\") -then the server and full-name will be set to those values, -whereas `erc-compute-port' and `erc-compute-nick' will be invoked -for the values of the other parameters. - -See `erc-tls' for the meaning of ID. +ERC assigns SERVER and FULL-NAME the associated keyword values +and defers to `erc-compute-port', `erc-compute-user', and +`erc-compute-nick' for those respective parameters. (fn &key SERVER PORT NICK USER PASSWORD FULL-NAME ID)" '((let ((erc--display-context `((erc-interactive-display . erc) ,@erc--display-context))) (erc-select-read-args)))) (defalias 'erc-select #'erc) (autoload 'erc-tls "erc" "\ -ERC is a powerful, modular, and extensible IRC client. -This function is the main entry point for ERC over TLS. - -It allows selecting connection parameters, and then starts ERC -over TLS. - -Non-interactively, it takes the keyword arguments - (server (erc-compute-server)) - (port (erc-compute-port)) - (nick (erc-compute-nick)) - (user (erc-compute-user)) - password - (full-name (erc-compute-full-name)) - client-certificate - id - -That is, if called with - - (erc-tls :server \"irc.libera.chat\" :full-name \"J. Random Hacker\") - -then the server and full-name will be set to those values, -whereas `erc-compute-port' and `erc-compute-nick' will be invoked -for the values of their respective parameters. - -CLIENT-CERTIFICATE, if non-nil, should either be a list where the -first element is the certificate key file name, and the second -element is the certificate file name itself, or t, which means -that `auth-source' will be queried for the key and the -certificate. Authenticating using a TLS client certificate is -also referred to as \"CertFP\" (Certificate Fingerprint) -authentication by various IRC networks. +Connect to an IRC server over a TLS-encrypted connection. +Interactively, prompt for SERVER, PORT, NICK, and PASSWORD, along +with USER and FULL-NAME when given a prefix argument. +Non-interactively, also accept a CLIENT-CERTIFICATE, which should +be a list containing the file name of the certificate's key +followed by that of the certificate itself. Alternatively, +accept a value of t instead of a list, to tell ERC to query +`auth-source' for the certificate's details. -Example usage: +Example client certificate (CertFP) usage: (erc-tls :server \"irc.libera.chat\" :port 6697 :client-certificate \\='(\"/home/bandali/my-cert.key\" \"/home/bandali/my-cert.crt\")) -When present, ID should be a symbol or a string to use for naming -the server buffer and identifying the connection unequivocally. -See Info node `(erc) Network Identifier' for details. Like -CLIENT-CERTIFICATE, this parameter cannot be specified -interactively. +See the alternative entry-point command `erc' as well as Info +node `(erc) Connecting' for a fuller description of the various +parameters, like ID. (fn &key SERVER PORT NICK USER PASSWORD FULL-NAME CLIENT-CERTIFICATE ID)" '((let ((erc-default-port erc-default-port-tls) (erc--display-context `((erc-interactive-display . erc-tls) ,@erc--display-context))) (erc-select-read-args)))) (autoload 'erc-handle-irc-url "erc" "\ @@ -10702,6 +10697,46 @@ Display the documentation for TEST-OR-TEST-NAME (a symbol or ert-test). (register-definition-prefixes "ert" '("ert-")) +;;; Generated autoloads from emacs-lisp/ert-font-lock.el + +(autoload 'ert-font-lock-deftest "ert-font-lock" "\ +Define test NAME (a symbol) using assertions from TEST-STR. + +Other than MAJOR-MODE and TEST-STR parameters, this macro accepts +the same parameters and keywords as `ert-deftest' and is intended +to be used through `ert'. + +(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] [:tags \\='(TAG...)] MAJOR-MODE TEST-STR)" nil t) +(function-put 'ert-font-lock-deftest 'doc-string-elt 3) +(function-put 'ert-font-lock-deftest 'lisp-indent-function 2) +(autoload 'ert-font-lock-deftest-file "ert-font-lock" "\ +Define test NAME (a symbol) using assertions from FILE. + +FILE - path to a file with assertions in ERT resource director as +return by `ert-resource-directory'. + +Other than MAJOR-MODE and FILE parameters, this macro accepts the +same parameters and keywords as `ert-deftest' and is intended to +be used through `ert'. + +(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] [:tags \\='(TAG...)] MAJOR-MODE FILE)" nil t) +(function-put 'ert-font-lock-deftest-file 'doc-string-elt 3) +(function-put 'ert-font-lock-deftest-file 'lisp-indent-function 2) +(autoload 'ert-font-lock-test-string "ert-font-lock" "\ +Check font faces in TEST-STRING set by MODE. + +The function is meant to be run from within an ERT test. + +(fn TEST-STRING MODE)") +(autoload 'ert-font-lock-test-file "ert-font-lock" "\ +Check font faces in FILENAME set by MODE. + +The function is meant to be run from within an ERT test. + +(fn FILENAME MODE)") +(register-definition-prefixes "ert-font-lock" '("ert-font-lock--")) + + ;;; Generated autoloads from emacs-lisp/ert-x.el (autoload 'ert-kill-all-test-buffers "ert-x" "\ @@ -11087,6 +11122,49 @@ for \\[find-tag] (which see)." t) (register-definition-prefixes "etags" '("default-tags-table-function" "etags-" "file-of-tag" "find-tag-" "goto-tag-location-function" "initialize-new-tags-table" "last-tag" "list-tags-function" "select-tags-table-" "snarf-tag-function" "tag" "verify-tags-table-function")) +;;; Generated autoloads from progmodes/etags-regen.el + +(put 'etags-regen-regexp-alist 'safe-local-variable (lambda (value) (and (listp value) (seq-every-p (lambda (group) (and (consp group) (listp (car group)) (listp (cdr group)) (seq-every-p #'stringp (car group)) (seq-every-p #'stringp (cdr group)))) value)))) +(put 'etags-regen-file-extensions 'safe-local-variable (lambda (value) (and (listp value) (seq-every-p #'stringp value)))) +(put 'etags-regen-ignores 'safe-local-variable (lambda (value) (and (listp value) (seq-every-p #'stringp value)))) +(defvar etags-regen-mode nil "\ +Non-nil if Etags-Regen mode is enabled. +See the `etags-regen-mode' command +for a description of this minor mode. +Setting this variable directly does not take effect; +either customize it (see the info node `Easy Customization') +or call the function `etags-regen-mode'.") +(custom-autoload 'etags-regen-mode "etags-regen" nil) +(autoload 'etags-regen-mode "etags-regen" "\ +Minor mode to automatically generate and update tags tables. + +This minor mode generates the tags table automatically based on +the current project configuration, and later updates it as you +edit the files and save the changes. + +If you select a tags table manually (for example, using +\\[visit-tags-table]), then this mode will be effectively +disabled for the entire session. Use \\[tags-reset-tags-tables] +to countermand the effect of a previous \\[visit-tags-table]. + +This is a global minor mode. If called interactively, toggle the +`Etags-Regen mode' mode. If the prefix argument is positive, enable the +mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `(default-value \\='etags-regen-mode)'. + +The mode's hook is called both when the mode is enabled and when it is +disabled. + +(fn &optional ARG)" t) +(register-definition-prefixes "etags-regen" '("etags-regen-")) + + ;;; Generated autoloads from language/ethio-util.el (autoload 'setup-ethiopic-environment-internal "ethio-util") @@ -11892,19 +11970,19 @@ Minor mode for a buffer-specific default face. When enabled, the face specified by the variable `buffer-face-mode-face' is used to display the buffer text. -This is a minor mode. If called interactively, toggle the -`Buffer-Face mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `Buffer-Face +mode' mode. If the prefix argument is positive, enable the mode, and if +it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `buffer-face-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'buffer-face-set "face-remap" "\ @@ -12377,12 +12455,14 @@ earlier in the `setq-connection-local'. The return value of the (fn [VARIABLE VALUE]...)" nil t) (autoload 'connection-local-p "files-x" "\ Non-nil if VARIABLE has a connection-local binding in `default-directory'. +`default-directory' must be a remote file name. If APPLICATION is nil, the value of `connection-local-default-application' is used. (fn VARIABLE &optional APPLICATION)" nil t) (autoload 'connection-local-value "files-x" "\ Return connection-local VARIABLE for APPLICATION in `default-directory'. +`default-directory' must be a remote file name. If APPLICATION is nil, the value of `connection-local-default-application' is used. If VARIABLE does not have a connection-local binding, the return @@ -12900,19 +12980,19 @@ suitable for the current buffer. The commands `flymake-reporting-backends' summarize the situation, as does the special *Flymake log* buffer. -This is a minor mode. If called interactively, toggle the -`Flymake mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `Flymake +mode' mode. If the prefix argument is positive, enable the mode, and if +it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `flymake-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'flymake-mode-on "flymake" "\ @@ -12977,19 +13057,19 @@ in your init file. \\[flyspell-region] checks all words inside a region. \\[flyspell-buffer] checks the whole buffer. -This is a minor mode. If called interactively, toggle the -`Flyspell mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `Flyspell +mode' mode. If the prefix argument is positive, enable the mode, and if +it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `flyspell-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'turn-on-flyspell "flyspell" "\ @@ -13045,7 +13125,7 @@ being able to use 144 or 216 lines instead of the normal 72... (your mileage may vary). To split one large window into two side-by-side windows, the commands -`\\[split-window-right]' or `\\[follow-delete-other-windows-and-split]' can be used. +\\[split-window-right] or \\[follow-delete-other-windows-and-split] can be used. Only windows displayed in the same frame follow each other. @@ -13054,19 +13134,19 @@ This command runs the normal hook `follow-mode-hook'. Keys specific to Follow mode: \\{follow-mode-map} -This is a minor mode. If called interactively, toggle the -`Follow mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `Follow mode' +mode. If the prefix argument is positive, enable the mode, and if it is +zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `follow-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'follow-scroll-up-window "follow" "\ @@ -13152,19 +13232,19 @@ provides footnote support for `message-mode'. To get started, play around with the following keys: \\{footnote-minor-mode-map} -This is a minor mode. If called interactively, toggle the -`Footnote mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `Footnote +mode' mode. If the prefix argument is positive, enable the mode, and if +it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `footnote-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "footnote" '("footnote-")) @@ -13618,19 +13698,18 @@ being transferred. This list may grow up to a size of the list) is deleted every time a new one is added (at the front). This is a global minor mode. If called interactively, toggle the -`Gdb-Enable-Debug mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable -the mode. +`Gdb-Enable-Debug mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='gdb-enable-debug)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'gdb "gdb-mi" "\ @@ -13794,19 +13873,19 @@ Minor mode for making identifiers likeThis readable. When this mode is active, it tries to add virtual separators (like underscores) at places they belong to. -This is a minor mode. If called interactively, toggle the -`Glasses mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `Glasses +mode' mode. If the prefix argument is positive, enable the mode, and if +it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `glasses-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "glasses" '("glasses-")) @@ -13826,19 +13905,18 @@ If enabled, all glyphless characters will be displayed as boxes that display their acronyms. This is a minor mode. If called interactively, toggle the -`Glyphless-Display mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable -the mode. +`Glyphless-Display mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `glyphless-display-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "glyphless-mode" '("glyphless-mode-")) @@ -14319,19 +14397,18 @@ Minor mode for providing mailing-list commands. \\{gnus-mailing-list-mode-map} This is a minor mode. If called interactively, toggle the -`Gnus-Mailing-List mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable -the mode. +`Gnus-Mailing-List mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `gnus-mailing-list-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "gnus-ml" '("gnus-mailing-list-")) @@ -14718,19 +14795,19 @@ Also fontifies the buffer appropriately (see `goto-address-fontify-p' and (autoload 'goto-address-mode "goto-addr" "\ Minor mode to buttonize URLs and e-mail addresses in the current buffer. -This is a minor mode. If called interactively, toggle the -`Goto-Address mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `Goto-Address +mode' mode. If the prefix argument is positive, enable the mode, and if +it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `goto-address-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (put 'global-goto-address-mode 'globalized-minor-mode t) @@ -14761,19 +14838,18 @@ See `goto-address-mode' for more information on Goto-Address mode. Like `goto-address-mode', but only for comments and strings. This is a minor mode. If called interactively, toggle the -`Goto-Address-Prog mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable -the mode. +`Goto-Address-Prog mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `goto-address-prog-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "goto-addr" '("goto-addr")) @@ -15129,18 +15205,18 @@ or call the function `gud-tooltip-mode'.") Toggle the display of GUD tooltips. This is a global minor mode. If called interactively, toggle the -`Gud-Tooltip mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Gud-Tooltip mode' mode. If the prefix argument is positive, enable the +mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='gud-tooltip-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'lldb "gud" "\ @@ -15582,6 +15658,9 @@ whose documentation describes the minor mode. If called from Lisp with a non-nil BUFFER argument, display documentation for the major and minor modes of that buffer. +When `describe-mode-outline' is non-nil, Outline minor mode +is enabled in the Help buffer. + (fn &optional BUFFER)" t) (autoload 'describe-widget "help-fns" "\ Display a buffer with information about a widget. @@ -15907,19 +15986,19 @@ position (number of characters into buffer) Hi-lock: end is found. A mode is excluded if it's in the list `hi-lock-exclude-modes'. -This is a minor mode. If called interactively, toggle the -`Hi-Lock mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `Hi-Lock +mode' mode. If the prefix argument is positive, enable the mode, and if +it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `hi-lock-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (put 'global-hi-lock-mode 'globalized-minor-mode t) @@ -16083,22 +16162,22 @@ Several variables affect how the hiding is done: \\{hide-ifdef-mode-map} -This is a minor mode. If called interactively, toggle the -`Hide-Ifdef mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `Hide-Ifdef +mode' mode. If the prefix argument is positive, enable the mode, and if +it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `hide-ifdef-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) -(register-definition-prefixes "hideif" '("backward-ifdef" "down-ifdef" "forward-ifdef" "hide-ifdef" "hif-" "intern-safe" "next-ifdef" "previous-ifdef" "show-ifdef" "up-ifdef")) +(register-definition-prefixes "hideif" '("backward-ifdef" "down-ifdef" "forward-ifdef" "hide-ifdef" "hif-" "next-ifdef" "previous-ifdef" "show-ifdef" "up-ifdef")) ;;; Generated autoloads from progmodes/hideshow.el @@ -16160,19 +16239,19 @@ Lastly, the normal hook `hs-minor-mode-hook' is run using `run-hooks'. Key bindings: \\{hs-minor-mode-map} -This is a minor mode. If called interactively, toggle the `hs -minor mode' mode. If the prefix argument is positive, enable the -mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `hs minor +mode' mode. If the prefix argument is positive, enable the mode, and if +it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `hs-minor-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'turn-off-hideshow "hideshow" "\ @@ -16206,19 +16285,18 @@ buffer with the contents of a file \\[highlight-compare-buffers] highlights differences between two buffers. This is a minor mode. If called interactively, toggle the -`Highlight-Changes mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable -the mode. +`Highlight-Changes mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `highlight-changes-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'highlight-changes-visible-mode "hilit-chg" "\ @@ -16235,18 +16313,18 @@ This command does not itself set Highlight Changes mode. This is a minor mode. If called interactively, toggle the `Highlight-Changes-Visible mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable -the mode. +positive, enable the mode, and if it is zero or negative, disable the +mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `highlight-changes-visible-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'highlight-changes-remove-highlight "hilit-chg" "\ @@ -16372,19 +16450,19 @@ non-selected window. Hl-Line mode uses the function When `hl-line-sticky-flag' is nil, Hl-Line mode highlights the line about point in the selected window only. -This is a minor mode. If called interactively, toggle the -`Hl-Line mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `Hl-Line +mode' mode. If the prefix argument is positive, enable the mode, and if +it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `hl-line-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (defvar global-hl-line-mode nil "\ @@ -16406,18 +16484,18 @@ Global-Hl-Line mode uses the function `global-hl-line-highlight' on `post-command-hook'. This is a global minor mode. If called interactively, toggle the -`Global Hl-Line mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Global Hl-Line mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='global-hl-line-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "hl-line" '("global-hl-line-" "hl-line-")) @@ -16777,19 +16855,19 @@ An enhanced `icomplete-mode' that emulates `ido-mode'. This global minor mode makes minibuffer completion behave more like `ido-mode' than regular `icomplete-mode'. -This is a global minor mode. If called interactively, toggle the -`Fido mode' mode. If the prefix argument is positive, enable the -mode, and if it is zero or negative, disable the mode. +This is a global minor mode. If called interactively, toggle the `Fido +mode' mode. If the prefix argument is positive, enable the mode, and if +it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='fido-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (defvar icomplete-mode nil "\ @@ -16817,18 +16895,18 @@ completions: \\{icomplete-minibuffer-map} This is a global minor mode. If called interactively, toggle the -`Icomplete mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Icomplete mode' mode. If the prefix argument is positive, enable the +mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='icomplete-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (defvar icomplete-vertical-mode nil "\ @@ -16849,19 +16927,18 @@ the value of `max-mini-window-height', and the way the mini-window is resized depends on `resize-mini-windows'. This is a global minor mode. If called interactively, toggle the -`Icomplete-Vertical mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable -the mode. +`Icomplete-Vertical mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='icomplete-vertical-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (defvar fido-vertical-mode nil "\ @@ -16879,18 +16956,18 @@ When turning on, if non-vertical `fido-mode' is off, turn it on. If it's on, just add the vertical display. This is a global minor mode. If called interactively, toggle the -`Fido-Vertical mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Fido-Vertical mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='fido-vertical-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (when (locate-library "obsolete/iswitchb") @@ -17380,19 +17457,19 @@ See `inferior-emacs-lisp-mode' for details. (autoload 'iimage-mode "iimage" "\ Toggle Iimage mode on or off. -This is a minor mode. If called interactively, toggle the -`Iimage mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `Iimage mode' +mode. If the prefix argument is positive, enable the mode, and if it is +zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `iimage-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "iimage" '("iimage-" "turn-off-iimage-mode")) @@ -17464,9 +17541,13 @@ use its file extension as image type. Optional DATA-P non-nil means FILE-OR-DATA is a string containing image data. Optional PROPS are additional image attributes to assign to the image, -like, e.g. `:mask MASK'. If the property `:scale' is not given and the -display has a high resolution (more exactly, when the average width of a -character in the default font is more than 10 pixels), the image is +like, e.g. `:mask MASK'. See Info node `(elisp)Image Descriptors' for +the list of supported properties; see the nodes following that node +for properties specific to certain image types. + +If the property `:scale' is not given and the display has a high +resolution (more exactly, when the average width of a character +in the default font is more than 10 pixels), the image is automatically scaled up in proportion to the default font. Value is the image created, or nil if images of type TYPE are not supported. @@ -17531,21 +17612,25 @@ BUFFER nil or omitted means use the current buffer. (fn START END &optional BUFFER)") (autoload 'find-image "image" "\ -Find an image, choosing one of a list of image specifications. +Find an image that satisfies one of a list of image specifications. SPECS is a list of image specifications. -Each image specification in SPECS is a property list. The contents of -a specification are image type dependent. All specifications must at -least contain either the property `:file FILE' or `:data DATA', -where FILE is the file to load the image from, and DATA is a string -containing the actual image data. If the property `:type TYPE' is -omitted or nil, try to determine the image type from its first few +Each image specification in SPECS is a property list. The +contents of a specification are image type dependent; see the +info node `(elisp)Image Descriptors' for details. All specifications +must at least contain either the property `:file FILE' or `:data DATA', +where FILE is the file from which to load the image, and DATA is a +string containing the actual image data. If the property `:type TYPE' +is omitted or nil, try to determine the image type from its first few bytes of image data. If that doesn't work, and the property `:file -FILE' provide a file name, use its file extension as image type. -If `:type TYPE' is provided, it must match the actual type -determined for FILE or DATA by `create-image'. Return nil if no -specification is satisfied. +FILE' provide a file name, use its file extension as idication of the +image type. If `:type TYPE' is provided, it must match the actual type +determined for FILE or DATA by `create-image'. + +The function returns the image specification for the first specification +in the list whose TYPE is supported and FILE, if specified, exists. It +returns nil if no specification in the list can be satisfied. If CACHE is non-nil, results are cached and returned on subsequent calls. @@ -17762,20 +17847,19 @@ are always available in Dired: \\[image-dired-dired-toggle-marked-thumbs] Toggle thumbnails in front of file names. \\[image-dired-dired-edit-comment-and-tags] Edit comment and tags of marked images. -This is a minor mode. If called interactively, toggle the -`Image-Dired minor mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable -the mode. +This is a minor mode. If called interactively, toggle the `Image-Dired +minor mode' mode. If the prefix argument is positive, enable the mode, +and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `image-dired-minor-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'image-dired-display-thumbs-append "image-dired-dired" "\ @@ -17881,18 +17965,18 @@ An image file is one whose name has an extension in `image-file-name-regexps'. This is a global minor mode. If called interactively, toggle the -`Auto-Image-File mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Auto-Image-File mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='auto-image-file-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "image-file" '("image-file-")) @@ -17913,19 +17997,19 @@ Toggle Image minor mode in this buffer. Image minor mode provides the key \\<image-mode-map>\\[image-toggle-display], to switch back to `image-mode' and display an image file as the actual image. -This is a minor mode. If called interactively, toggle the `Image -minor mode' mode. If the prefix argument is positive, enable the -mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `Image minor +mode' mode. If the prefix argument is positive, enable the mode, and if +it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `image-minor-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'image-mode-to-text "image-mode" "\ @@ -18126,19 +18210,18 @@ indented towards the left by the column number at the start of that text. This is a global minor mode. If called interactively, toggle the -`Kill-Ring-Deindent mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable -the mode. +`Kill-Ring-Deindent mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='kill-ring-deindent-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "indent-aux" '("kill-ring-deindent-buffer-substring-function")) @@ -18831,19 +18914,19 @@ SPC. For spell-checking \"on the fly\", not just after typing SPC or RET, use `flyspell-mode'. -This is a minor mode. If called interactively, toggle the -`ISpell minor mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `ISpell minor +mode' mode. If the prefix argument is positive, enable the mode, and if +it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `ispell-minor-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'ispell-message "ispell" "\ @@ -19049,7 +19132,7 @@ Major mode for editing JSON, powered by tree-sitter. ;;; Generated autoloads from jsonrpc.el -(push (purecopy '(jsonrpc 1 0 23)) package--builtin-versions) +(push (purecopy '(jsonrpc 1 0 24)) package--builtin-versions) (register-definition-prefixes "jsonrpc" '("jsonrpc-")) @@ -19849,7 +19932,7 @@ For example, in Usenet articles, sections of text quoted from another author are indented, or have each line start with `>'. To quote a section of text, define a keyboard macro which inserts `>', put point and mark at opposite ends of the quoted section, and use -`\\[apply-macro-to-region-lines]' to mark the entire section. +\\[apply-macro-to-region-lines] to mark the entire section. Suppose you wanted to build a keyword table in C where each entry looked like this: @@ -19871,7 +19954,7 @@ and write a macro to massage a word into a table entry: \\C-x ) and then select the region of un-tablified names and use -`\\[apply-macro-to-region-lines]' to build the table from the names. +\\[apply-macro-to-region-lines] to build the table from the names. (fn TOP BOTTOM &optional MACRO)" t) (define-key ctl-x-map "q" 'kbd-macro-query) @@ -20033,18 +20116,18 @@ headers (those specified by `mail-abbrev-mode-regexp'), based on the entries in your `mail-personal-alias-file'. This is a global minor mode. If called interactively, toggle the -`Mail-Abbrevs mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Mail-Abbrevs mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='mail-abbrevs-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'mail-abbrevs-setup "mailabbrev" "\ @@ -20360,19 +20443,19 @@ The slave buffer is stored in the buffer-local variable `master-of'. You can set this variable using `master-set-slave'. You can show yourself the value of `master-of' by calling `master-show-slave'. -This is a minor mode. If called interactively, toggle the -`Master mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `Master mode' +mode. If the prefix argument is positive, enable the mode, and if it is +zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `master-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "master" '("master-")) @@ -20398,18 +20481,18 @@ recursion depth in the minibuffer prompt. This is only useful if This is a global minor mode. If called interactively, toggle the `Minibuffer-Depth-Indicate mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable -the mode. +positive, enable the mode, and if it is zero or negative, disable the +mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='minibuffer-depth-indicate-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "mb-depth" '("minibuffer-depth-")) @@ -20565,7 +20648,7 @@ Major mode for editing MetaPost sources. ;;; Generated autoloads from mh-e/mh-acros.el -(register-definition-prefixes "mh-acros" '("defmacro-mh" "defun-mh" "mh-" "with-mh-folder-updating")) +(register-definition-prefixes "mh-acros" '("mh-" "with-mh-folder-updating")) ;;; Generated autoloads from mh-e/mh-alias.el @@ -20855,18 +20938,18 @@ or call the function `midnight-mode'.") Non-nil means run `midnight-hook' at midnight. This is a global minor mode. If called interactively, toggle the -`Midnight mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +`Midnight mode' mode. If the prefix argument is positive, enable the +mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='midnight-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'clean-buffer-list "midnight" "\ @@ -20910,19 +20993,19 @@ such that hitting RET would enter a non-default value, the prompt is modified to remove the default indication. This is a global minor mode. If called interactively, toggle the -`Minibuffer-Electric-Default mode' mode. If the prefix argument -is positive, enable the mode, and if it is zero or negative, -disable the mode. +`Minibuffer-Electric-Default mode' mode. If the prefix argument is +positive, enable the mode, and if it is zero or negative, disable the +mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='minibuffer-electric-default-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "minibuf-eldef" '("minibuf")) @@ -21440,19 +21523,19 @@ Toggle Msb mode. This mode overrides the binding(s) of `mouse-buffer-menu' to provide a different buffer menu using the function `msb'. -This is a global minor mode. If called interactively, toggle the -`Msb mode' mode. If the prefix argument is positive, enable the -mode, and if it is zero or negative, disable the mode. +This is a global minor mode. If called interactively, toggle the `Msb +mode' mode. If the prefix argument is positive, enable the mode, and if +it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='msb-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "msb" '("mouse-select-buffer" "msb")) @@ -21741,18 +21824,18 @@ or call the function `mouse-wheel-mode'.") Toggle mouse wheel support (Mouse Wheel mode). This is a global minor mode. If called interactively, toggle the -`Mouse-Wheel mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Mouse-Wheel mode' mode. If the prefix argument is positive, enable the +mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='mouse-wheel-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "mwheel" '("mouse-wheel-" "mwheel-")) @@ -22763,7 +22846,7 @@ Coloring: ;;; Generated autoloads from org/org.el -(push (purecopy '(org 9 6 13)) package--builtin-versions) +(push (purecopy '(org 9 6 15)) package--builtin-versions) (autoload 'org-babel-do-load-languages "org" "\ Load the languages defined in `org-babel-load-languages'. @@ -23495,19 +23578,19 @@ Toggle Outline minor mode. See the command `outline-mode' for more information on this mode. -This is a minor mode. If called interactively, toggle the -`Outline minor mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `Outline +minor mode' mode. If the prefix argument is positive, enable the mode, +and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `outline-minor-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'outline-search-level "outline" "\ @@ -24118,6 +24201,8 @@ FUN in `pred' and `app' can take one of the forms: call it with one argument (F ARG1 .. ARGn) call F with ARG1..ARGn and EXPVAL as n+1'th argument + (F ARG1 .. _ .. ARGn) + call F, passing EXPVAL at the _ position. FUN, BOOLEXP, and subsequent PAT can refer to variables bound earlier in the pattern by a SYMBOL pattern. @@ -24156,8 +24241,8 @@ As with `pcase-let', BINDINGS are of the form (PATTERN EXP), but the EXP in each binding in BINDINGS can use the results of the destructuring bindings that precede it in BINDINGS' order. -Each EXP should match (i.e. be of compatible structure) to its -respective PATTERN; a mismatch may signal an error or may go +Each EXP should match its respective PATTERN (i.e. be of structure +compatible to PATTERN); a mismatch may signal an error or may go undetected, binding variables to arbitrary values, such as nil. (fn BINDINGS &rest BODY)" nil t) @@ -24170,8 +24255,8 @@ All EXPs are evaluated first, and then used to perform destructuring bindings by matching each EXP against its respective PATTERN. Then BODY is evaluated with those bindings in effect. -Each EXP should match (i.e. be of compatible structure) to its -respective PATTERN; a mismatch may signal an error or may go +Each EXP should match its respective PATTERN (i.e. be of structure +compatible to PATTERN); a mismatch may signal an error or may go undetected, binding variables to arbitrary values, such as nil. (fn BINDINGS &rest BODY)" nil t) @@ -24773,11 +24858,6 @@ they are not by default assigned to keys." t) (register-definition-prefixes "picture" '("picture-")) -;;; Generated autoloads from language/pinyin.el - -(register-definition-prefixes "pinyin" '("pinyin-character-map")) - - ;;; Generated autoloads from textmodes/pixel-fill.el (register-definition-prefixes "pixel-fill" '("pixel-fill-")) @@ -24797,18 +24877,18 @@ or call the function `pixel-scroll-mode'.") A minor mode to scroll text pixel-by-pixel. This is a global minor mode. If called interactively, toggle the -`Pixel-Scroll mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Pixel-Scroll mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='pixel-scroll-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'pixel-scroll-precision-scroll-down-page "pixel-scroll" "\ @@ -24838,19 +24918,18 @@ When enabled, this minor mode allows you to scroll the display precisely, according to the turning of the mouse wheel. This is a global minor mode. If called interactively, toggle the -`Pixel-Scroll-Precision mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable -the mode. +`Pixel-Scroll-Precision mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='pixel-scroll-precision-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "pixel-scroll" '("pixel-")) @@ -25614,8 +25693,6 @@ requires quoting, e.g. `\\[quoted-insert]<space>'. (fn REGEXP)" t) (autoload 'project-or-external-find-regexp "project" "\ Find all matches for REGEXP in the project roots or external roots. -With \\[universal-argument] prefix, you can specify the file name -pattern to search for. (fn REGEXP)" t) (autoload 'project-find-file "project" "\ @@ -25771,8 +25848,8 @@ Otherwise, `default-directory' is temporarily set to the current project's root. If OVERRIDING-MAP is non-nil, it will be used as -`overriding-local-map' to provide shorter bindings from that map -which will take priority over the global ones. +`overriding-terminal-local-map' to provide shorter bindings +from that map which will take priority over the global ones. (fn &optional OVERRIDING-MAP PROMPT-FORMAT)" t) (autoload 'project-prefix-or-any-command "project" "\ @@ -25822,7 +25899,7 @@ line and comments can also be enclosed in /* ... */. If an optional argument SYSTEM is non-nil, set up mode for the given system. To find out what version of Prolog mode you are running, enter -`\\[prolog-mode-version]'. +\\[prolog-mode-version]. Commands: \\{prolog-mode-map} @@ -26452,19 +26529,18 @@ or call the function `rcirc-track-minor-mode'.") Global minor mode for tracking activity in rcirc buffers. This is a global minor mode. If called interactively, toggle the -`Rcirc-Track minor mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable -the mode. +`Rcirc-Track minor mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='rcirc-track-minor-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "rcirc" '("rcirc-" "with-rcirc-")) @@ -26527,18 +26603,18 @@ buffers you switch to a lot, you can say something like the following: (add-hook \\='buffer-list-update-hook #\\='recentf-track-opened-file) This is a global minor mode. If called interactively, toggle the -`Recentf mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +`Recentf mode' mode. If the prefix argument is positive, enable the +mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='recentf-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "recentf" '("recentf-")) @@ -26669,18 +26745,18 @@ Activates the region if it's inactive and Transient Mark mode is on. Only lasts until the region is next deactivated. This is a minor mode. If called interactively, toggle the -`Rectangle-Mark mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Rectangle-Mark mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `rectangle-mark-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "rect" '("apply-on-rectangle" "clear-rectangle-line" "delete-" "extract-rectangle-" "killed-rectangle" "ope" "rectangle-" "spaces-string" "string-rectangle-")) @@ -26708,19 +26784,19 @@ auto-filling. For true \"word wrap\" behavior, use `visual-line-mode' instead. -This is a minor mode. If called interactively, toggle the -`Refill mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `Refill mode' +mode. If the prefix argument is positive, enable the mode, and if it is +zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `refill-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "refill" '("refill-")) @@ -26770,19 +26846,19 @@ on the menu bar. ------------------------------------------------------------------------------ -This is a minor mode. If called interactively, toggle the -`Reftex mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `Reftex mode' +mode. If the prefix argument is positive, enable the mode, and if it is +zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `reftex-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'reftex-reset-scanning-information "reftex" "\ @@ -27004,18 +27080,18 @@ keys for repeating. See `describe-repeat-maps' for a list of all repeatable commands. This is a global minor mode. If called interactively, toggle the -`Repeat mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +`Repeat mode' mode. If the prefix argument is positive, enable the +mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='repeat-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'repeat-exit "repeat" "\ @@ -27091,19 +27167,19 @@ reveals invisible text around point. Also see the `reveal-auto-hide' variable. -This is a minor mode. If called interactively, toggle the -`Reveal mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `Reveal mode' +mode. If the prefix argument is positive, enable the mode, and if it is +zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `reveal-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (defvar global-reveal-mode nil "\ @@ -27120,18 +27196,18 @@ Toggle Reveal mode in all buffers (Global Reveal mode). Reveal mode renders invisible text around point visible again. This is a global minor mode. If called interactively, toggle the -`Global Reveal mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Global Reveal mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='global-reveal-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "reveal" '("reveal-")) @@ -27674,19 +27750,19 @@ conventionally have a suffix of `.rnc'). The variable `rng-schema-locating-files' specifies files containing rules to use for finding the schema. -This is a minor mode. If called interactively, toggle the -`Rng-Validate mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `Rng-Validate +mode' mode. If the prefix argument is positive, enable the mode, and if +it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `rng-validate-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "rng-valid" '("rng-")) @@ -27800,19 +27876,19 @@ When ReST minor mode is enabled, the ReST mode keybindings are installed on top of the major mode bindings. Use this for modes derived from Text mode, like Mail mode. -This is a minor mode. If called interactively, toggle the `Rst -minor mode' mode. If the prefix argument is positive, enable the -mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `Rst minor +mode' mode. If the prefix argument is positive, enable the mode, and if +it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `rst-minor-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "rst" '("rst-")) @@ -27860,19 +27936,19 @@ Use the command `ruler-mode' to change this variable.") (autoload 'ruler-mode "ruler-mode" "\ Toggle display of ruler in header line (Ruler mode). -This is a minor mode. If called interactively, toggle the `Ruler -mode' mode. If the prefix argument is positive, enable the mode, -and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `Ruler mode' +mode. If the prefix argument is positive, enable the mode, and if it is +zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `ruler-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "ruler-mode" '("ruler-")) @@ -28070,7 +28146,8 @@ For more details, see Info node `(elisp) Extending Rx'. (fn NAME [(ARGS...)] RX)" nil t) (function-put 'rx-define 'lisp-indent-function 'defun) -(eval-and-compile (defun rx--pcase-macroexpander (&rest regexps) "A pattern that matches strings against `rx' REGEXPS in sexp form. +(autoload 'rx--pcase-macroexpander "rx" "\ +A pattern that matches strings against `rx' REGEXPS in sexp form. REGEXPS are interpreted as in `rx'. The pattern matches any string that is a match for REGEXPS, as if by `string-match'. @@ -28084,7 +28161,9 @@ following constructs: (backref REF) matches whatever the submatch REF matched. REF can be a number, as usual, or a name introduced by a previous (let REF ...) - construct." (rx--pcase-expand regexps))) + construct. + +(fn &rest REGEXPS)") (define-symbol-prop 'rx--pcase-macroexpander 'edebug-form-spec 'nil) (define-symbol-prop 'rx 'pcase-macroexpander #'rx--pcase-macroexpander) (autoload 'rx--pcase-expand "rx" "\ @@ -28164,18 +28243,18 @@ Calling it at any other time replaces your current minibuffer histories, which is probably undesirable. This is a global minor mode. If called interactively, toggle the -`Savehist mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +`Savehist mode' mode. If the prefix argument is positive, enable the +mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='savehist-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "savehist" '("savehist-")) @@ -28198,18 +28277,18 @@ This means when you visit a file, point goes to the last place where it was when you previously visited the same file. This is a global minor mode. If called interactively, toggle the -`Save-Place mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Save-Place mode' mode. If the prefix argument is positive, enable the +mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='save-place-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'save-place-local-mode "saveplace" "\ @@ -28225,19 +28304,18 @@ file: (save-place-mode 1) This is a minor mode. If called interactively, toggle the -`Save-Place-Local mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable -the mode. +`Save-Place-Local mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `save-place-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "saveplace" '("save-place")) @@ -28324,18 +28402,18 @@ When Scroll-All mode is enabled, scrolling commands invoked in one window apply to all visible windows in the same frame. This is a global minor mode. If called interactively, toggle the -`Scroll-All mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Scroll-All mode' mode. If the prefix argument is positive, enable the +mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='scroll-all-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "scroll-all" '("scroll-all-")) @@ -28359,19 +28437,19 @@ boundaries during scrolling. Note that the default key binding to `scroll' will not work on MS-Windows systems if `w32-scroll-lock-modifier' is non-nil. -This is a minor mode. If called interactively, toggle the -`Scroll-Lock mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `Scroll-Lock +mode' mode. If the prefix argument is positive, enable the mode, and if +it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `scroll-lock-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "scroll-lock" '("scroll-lock-")) @@ -28435,18 +28513,18 @@ Semantic mode. \\{semantic-mode-map} This is a global minor mode. If called interactively, toggle the -`Semantic mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +`Semantic mode' mode. If the prefix argument is positive, enable the +mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='semantic-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "semantic" '("bovinate" "semantic-")) @@ -28755,18 +28833,18 @@ Server mode runs a process that accepts commands from the `server-start' for details. This is a global minor mode. If called interactively, toggle the -`Server mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +`Server mode' mode. If the prefix argument is positive, enable the +mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='server-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'server-save-buffers-kill-terminal "server" "\ @@ -29107,6 +29185,10 @@ Make the shell buffer the current buffer, and return it. ;;; Generated autoloads from emacs-lisp/shortdoc.el +(autoload 'shortdoc--check "shortdoc" "\ + + +(fn GROUP FUNCTIONS)") (defvar shortdoc--groups nil) (defmacro define-short-documentation-group (group &rest functions) "\ Add GROUP to the list of defined documentation groups. @@ -29170,7 +29252,7 @@ execution of the documented form depends on some conditions. A FUNC form can have any number of `:no-eval' (or `:no-value'), `:no-eval*', `:result', `:result-string', `:eg-result' and -`:eg-result-string' properties." (declare (indent defun)) `(progn (setq shortdoc--groups (delq (assq ',group shortdoc--groups) shortdoc--groups)) (push (cons ',group ',functions) shortdoc--groups))) +`:eg-result-string' properties." (declare (indent defun)) (shortdoc--check group functions) `(progn (setq shortdoc--groups (delq (assq ',group shortdoc--groups) shortdoc--groups)) (push (cons ',group ',functions) shortdoc--groups))) (autoload 'shortdoc-display-group "shortdoc" "\ Pop to a buffer with short documentation summary for functions in GROUP. If FUNCTION is non-nil, place point on the entry for FUNCTION (if any). @@ -29435,19 +29517,19 @@ Minor mode to simplify editing output from the diff3 program. \\{smerge-mode-map} -This is a minor mode. If called interactively, toggle the -`SMerge mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `SMerge mode' +mode. If the prefix argument is positive, enable the mode, and if it is +zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `smerge-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'smerge-start-session "smerge-mode" "\ @@ -29550,19 +29632,19 @@ with `so-long-variable-overrides'. This minor mode is a standard `so-long-action' option. -This is a minor mode. If called interactively, toggle the -`So-Long minor mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `So-Long +minor mode' mode. If the prefix argument is positive, enable the mode, +and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `so-long-minor-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'so-long-mode "so-long" "\ @@ -29640,18 +29722,18 @@ Use \\[so-long-customize] to open the customization group `so-long' to configure the behavior. This is a global minor mode. If called interactively, toggle the -`Global So-Long mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Global So-Long mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='global-so-long-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "so-long" '("so-long-" "turn-o")) @@ -29888,6 +29970,24 @@ For example: to sort lines in the region by the first word on each line RECORD-REGEXP would be \"^.*$\" and KEY would be \"\\\\=\\<f\\\\w*\\\\>\" (fn REVERSE RECORD-REGEXP KEY-REGEXP BEG END)" t) +(autoload 'sort-on "sort" "\ +Sort SEQUENCE by calling PREDICATE on sort keys produced by ACCESSOR. +SEQUENCE should be the input sequence to sort. +Elements of SEQUENCE are sorted by keys which are obtained by +calling ACCESSOR on each element. ACCESSOR should be a function of +one argument, an element of SEQUENCE, and should return the key +value to be compared by PREDICATE for sorting the element. +PREDICATE is the function for comparing keys; it is called with two +arguments, the keys to compare, and should return non-nil if the +first key should sort before the second key. +The return value is always a new list. +This function has the performance advantage of evaluating +ACCESSOR only once for each element in the input SEQUENCE, and is +therefore appropriate when computing the key by ACCESSOR is an +expensive operation. This is known as the \"decorate-sort-undecorate\" +paradigm, or the Schwartzian transform. + +(fn SEQUENCE PREDICATE ACCESSOR)") (autoload 'sort-columns "sort" "\ Sort lines in region alphabetically by a certain range of columns. For the purpose of this command, the region BEG...END includes @@ -30667,18 +30767,18 @@ Encode/decode your strokes with \\[strokes-encode-buffer], \\{strokes-mode-map} This is a global minor mode. If called interactively, toggle the -`Strokes mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +`Strokes mode' mode. If the prefix argument is positive, enable the +mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='strokes-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'strokes-decode-buffer "strokes" "\ @@ -30798,19 +30898,19 @@ called a `subword'. Here are some examples: This mode changes the definition of a word so that word commands treat nomenclature boundaries as word boundaries. -This is a minor mode. If called interactively, toggle the -`Subword mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `Subword +mode' mode. If the prefix argument is positive, enable the mode, and if +it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `subword-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (put 'global-subword-mode 'globalized-minor-mode t) @@ -30847,19 +30947,19 @@ syntax are treated as parts of words: e.g., in `superword-mode', \\{superword-mode-map} -This is a minor mode. If called interactively, toggle the -`Superword mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `Superword +mode' mode. If the prefix argument is positive, enable the mode, and if +it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `superword-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (put 'global-superword-mode 'globalized-minor-mode t) @@ -30951,18 +31051,18 @@ mouse to transfer text between Emacs and other programs which use GPM. This is due to limitations in GPM and the Linux kernel. This is a global minor mode. If called interactively, toggle the -`Gpm-Mouse mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Gpm-Mouse mode' mode. If the prefix argument is positive, enable the +mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='gpm-mouse-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "t-mouse" '("gpm-mouse-")) @@ -30973,19 +31073,19 @@ it is disabled. (autoload 'tab-line-mode "tab-line" "\ Toggle display of tab line in the windows displaying the current buffer. -This is a minor mode. If called interactively, toggle the -`Tab-Line mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `Tab-Line +mode' mode. If the prefix argument is positive, enable the mode, and if +it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `tab-line-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (defvar-local tab-line-exclude nil) @@ -31057,19 +31157,18 @@ variable's value can be toggled by \\[table-fixed-width-mode] at run-time. This is a minor mode. If called interactively, toggle the -`Table-Fixed-Width mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable -the mode. +`Table-Fixed-Width mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `table-fixed-width-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'table-insert "table" "\ @@ -31926,6 +32025,9 @@ such as if there are no commands in the file, the value of `tex-default-mode' says which mode to use. (fn)" t) + (add-to-list 'major-mode-remap-defaults '(TeX-mode . tex-mode)) + (add-to-list 'major-mode-remap-defaults '(plain-TeX-mode . plain-tex-mode)) + (add-to-list 'major-mode-remap-defaults '(LaTeX-mode . latex-mode)) (defalias 'TeX-mode #'tex-mode) (defalias 'plain-TeX-mode #'plain-tex-mode) (defalias 'LaTeX-mode #'latex-mode) @@ -32475,19 +32577,19 @@ When `tildify-mode' is enabled, if `tildify-string-alist' specifies a hard space representation for current major mode, the `tildify-space-string' buffer-local variable will be set to the representation. -This is a minor mode. If called interactively, toggle the -`Tildify mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `Tildify +mode' mode. If the prefix argument is positive, enable the mode, and if +it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `tildify-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "tildify" '("tildify-")) @@ -32523,25 +32625,25 @@ non-nil, the current day and date are displayed as well. This runs the normal hook `display-time-hook' after each update. This is a global minor mode. If called interactively, toggle the -`Display-Time mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Display-Time mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='display-time-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (define-obsolete-function-alias 'display-time-world #'world-clock "28.1") (autoload 'world-clock "time" "\ Display a world clock buffer with times in various time zones. The variable `world-clock-list' specifies which time zones to use. -To turn off the world time display, go to the window and type `\\[quit-window]'." t) +To turn off the world time display, go to the window and type \\[quit-window]." t) (autoload 'emacs-uptime "time" "\ Return a string giving the uptime of this instance of Emacs. FORMAT is a string to format the result, using `format-seconds'. @@ -32822,21 +32924,16 @@ List all timers in a buffer. ;;; Generated autoloads from international/titdic-cnv.el (autoload 'titdic-convert "titdic-cnv" "\ -Convert a TIT dictionary of FILENAME into a Quail package. -Optional argument DIRNAME if specified is the directory name under which -the generated Quail package is saved. -(fn FILENAME &optional DIRNAME)" t) + +(fn FILENAME &optional DIRNAME)") +(make-obsolete 'titdic-convert 'tit-dic-convert "30.1") (autoload 'batch-titdic-convert "titdic-cnv" "\ -Run `titdic-convert' on the files remaining on the command line. -Use this from the command line, with `-batch'; -it won't work in an interactive Emacs. -For example, invoke \"emacs -batch -f batch-titdic-convert XXX.tit\" to - generate Quail package file \"xxx.el\" from TIT dictionary file \"XXX.tit\". -To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\". + (fn &optional FORCE)") -(register-definition-prefixes "titdic-cnv" '("batch-miscdic-convert" "ctlau-" "miscdic-convert" "pinyin-convert" "py-converter" "quail-" "quick-" "tit-" "tsang-" "ziranma-converter")) +(make-obsolete 'batch-titdic-convert 'batch-tit-dic-convert "30.1") +(register-definition-prefixes "titdic-cnv" '("batch-tit-" "tit-")) ;;; Generated autoloads from tmm.el @@ -32914,7 +33011,7 @@ current (i.e., last displayed) category. In Todo mode just the category's unfinished todo items are shown by default. The done items are hidden, but typing -`\\[todo-toggle-view-done-items]' displays them below the todo +\\[todo-toggle-view-done-items] displays them below the todo items. With non-nil user option `todo-show-with-done' both todo and done items are always shown on visiting a category. @@ -33013,6 +33110,61 @@ holds a keymap. (register-definition-prefixes "tooltip" '("tooltip-")) +;;; Generated autoloads from touch-screen.el + +(autoload 'touch-screen-hold "touch-screen" "\ +Handle a long press EVENT. +Ding and select the window at EVENT, then activate the mark. If +`touch-screen-word-select' is enabled, try to select the whole +word around EVENT; otherwise, set point to the location of EVENT. + +(fn EVENT)" t) +(autoload 'touch-screen-track-tap "touch-screen" "\ +Track a single tap starting from EVENT. +EVENT should be a `touchscreen-begin' event. + +Read touch screen events until a `touchscreen-end' event is +received with the same ID as in EVENT. If UPDATE is non-nil and +a `touchscreen-update' event is received in the mean time and +contains a touch point with the same ID as in EVENT, call UPDATE +with that event and DATA. + +If THRESHOLD is non-nil, enforce a threshold of movement that is +either itself or 10 pixels when it is not a number. If the +aforementioned touch point moves beyond that threshold on any +axis, return nil immediately, and further resume mouse event +translation for the touch point at hand. + +Return nil immediately if any other kind of event is received; +otherwise, return t once the `touchscreen-end' event arrives. + +(fn EVENT &optional UPDATE DATA THRESHOLD)") +(autoload 'touch-screen-track-drag "touch-screen" "\ +Track a single drag starting from EVENT. +EVENT should be a `touchscreen-begin' event. + +Read touch screen events until a `touchscreen-end' event is +received with the same ID as in EVENT. For each +`touchscreen-update' event received in the mean time containing a +touch point with the same ID as in EVENT, call UPDATE with the +touch point in event and DATA, once the touch point has moved +significantly by at least 5 pixels from where it was in EVENT. + +Return nil immediately if any other kind of event is received; +otherwise, return either t or `no-drag' once the +`touchscreen-end' event arrives; return `no-drag' returned if the +touch point in EVENT did not move significantly, and t otherwise. + +(fn EVENT UPDATE &optional DATA)") +(autoload 'touch-screen-inhibit-drag "touch-screen" "\ +Inhibit subsequent `touchscreen-drag' events from being sent. +Prevent `touchscreen-drag' and translated mouse events from being +sent until the touch sequence currently being translated ends. +Must be called from a command bound to a `touchscreen-hold' or +`touchscreen-drag' event.") +(register-definition-prefixes "touch-screen" '("touch-screen-")) + + ;;; Generated autoloads from emacs-lisp/tq.el (autoload 'tq-create "tq" "\ @@ -33224,55 +33376,13 @@ Add archive file name handler to `file-name-handler-alist'." (when (and tramp-ar ;;; Generated autoloads from net/trampver.el -(push (purecopy '(tramp 2 7 0 -1)) package--builtin-versions) +(push (purecopy '(tramp 2 7 1 -1)) package--builtin-versions) (register-definition-prefixes "trampver" '("tramp-")) ;;; Generated autoloads from transient.el (push (purecopy '(transient 0 5 2)) package--builtin-versions) -(autoload 'transient-define-prefix "transient" "\ -Define NAME as a transient prefix command. - -ARGLIST are the arguments that command takes. -DOCSTRING is the documentation string and is optional. - -These arguments can optionally be followed by key-value pairs. -Each key has to be a keyword symbol, either `:class' or a keyword -argument supported by the constructor of that class. The -`transient-prefix' class is used if the class is not specified -explicitly. - -GROUPs add key bindings for infix and suffix commands and specify -how these bindings are presented in the popup buffer. At least -one GROUP has to be specified. See info node `(transient)Binding -Suffix and Infix Commands'. - -The BODY is optional. If it is omitted, then ARGLIST is also -ignored and the function definition becomes: - - (lambda () - (interactive) - (transient-setup \\='NAME)) - -If BODY is specified, then it must begin with an `interactive' -form that matches ARGLIST, and it must call `transient-setup'. -It may however call that function only when some condition is -satisfied; that is one of the reason why you might want to use -an explicit BODY. - -All transients have a (possibly nil) value, which is exported -when suffix commands are called, so that they can consume that -value. For some transients it might be necessary to have a sort -of secondary value, called a scope. Such a scope would usually -be set in the commands `interactive' form and has to be passed -to the setup function: - - (transient-setup \\='NAME nil nil :scope SCOPE) - -(fn NAME ARGLIST [DOCSTRING] [KEYWORD VALUE]... GROUP... [BODY...])" nil t) -(function-put 'transient-define-prefix 'lisp-indent-function 'defun) -(function-put 'transient-define-prefix 'doc-string-elt 3) (autoload 'transient-insert-suffix "transient" "\ Insert a SUFFIX into PREFIX before LOC. PREFIX is a prefix command, a symbol. @@ -33517,18 +33627,18 @@ sessions and after a crash. Manual changes to the file may result in problems. This is a global minor mode. If called interactively, toggle the -`Type-Break mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Type-Break mode' mode. If the prefix argument is positive, enable the +mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='type-break-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'type-break "type-break" "\ @@ -33914,18 +34024,18 @@ and `C-x C-f https://www.gnu.org/ RET' will give you the HTML at that URL in a buffer. This is a global minor mode. If called interactively, toggle the -`Url-Handler mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Url-Handler mode' mode. If the prefix argument is positive, enable the +mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='url-handler-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'url-file-handler "url-handlers" "\ @@ -34012,10 +34122,7 @@ URL can be a URL string, or a URL record of the type returned by ;;; Generated autoloads from url/url-mailto.el -(autoload 'url-mail "url-mailto" "\ - - -(fn &rest ARGS)" t) +(defalias 'url-mail #'message-mail) (autoload 'url-mailto "url-mailto" "\ Handle the mailto: URL syntax. @@ -34478,7 +34585,6 @@ Normalize arguments to delight. ;;; Generated autoloads from use-package/use-package-ensure-system-package.el -(push (purecopy '(use-package-ensure-system-package 0 2)) package--builtin-versions) (autoload 'use-package-normalize/:ensure-system-package "use-package-ensure-system-package" "\ Turn ARGS into a list of conses of the form (PACKAGE-NAME . INSTALL-COMMAND). @@ -35192,6 +35298,25 @@ case, and the process object in the asynchronous case. (progn (load "vc-git" nil t) (vc-git-registered file)))) +(autoload 'vc-git-grep "vc-git" "\ +Run git grep, searching for REGEXP in FILES in directory DIR. +The search is limited to file names matching shell pattern FILES. +FILES may use abbreviations defined in `grep-files-aliases', e.g. +entering `ch' is equivalent to `*.[ch]'. As whitespace triggers +completion when entering a pattern, including it requires +quoting, e.g. `\\[quoted-insert]<space>'. + +With \\[universal-argument] prefix, you can edit the constructed shell command line +before it is executed. +With two \\[universal-argument] prefixes, directly edit and run `grep-command'. + +Collect output in a buffer. While git grep runs asynchronously, you +can use \\[next-error] (`next-error'), or \\<grep-mode-map>\\[compile-goto-error] in the grep output buffer, +to go to the lines where grep found matches. + +This command shares argument histories with \\[rgrep] and \\[grep]. + +(fn REGEXP &optional FILES DIR)" t) (register-definition-prefixes "vc-git" '("vc-")) @@ -35317,7 +35442,7 @@ Key bindings: ;;; Generated autoloads from progmodes/verilog-mode.el -(push (purecopy '(verilog-mode 2023 6 6 141322628)) package--builtin-versions) +(push (purecopy '(verilog-mode 2024 3 1 121933719)) package--builtin-versions) (autoload 'verilog-mode "verilog-mode" "\ Major mode for editing Verilog code. \\<verilog-mode-map> @@ -35592,7 +35717,7 @@ Usage: according to option `vhdl-argument-list-indent'. If option `vhdl-indent-tabs-mode' is nil, spaces are used instead of - tabs. `\\[tabify]' and `\\[untabify]' allow the conversion of spaces to + tabs. \\[tabify] and \\[untabify] allow the conversion of spaces to tabs and vice versa. Syntax-based indentation can be very slow in large files. Option @@ -35903,7 +36028,7 @@ Usage: `vhdl-highlight-translate-off' is non-nil. For documentation and customization of the used colors see - customization group `vhdl-highlight-faces' (`\\[customize-group]'). For + customization group `vhdl-highlight-faces' (\\[customize-group]). For highlighting of matching parenthesis, see customization group `paren-showing'. Automatic buffer highlighting is turned on/off by option `global-font-lock-mode' (`font-lock-auto-fontify' in XEmacs). @@ -35963,14 +36088,14 @@ Usage: sessions using the \"Save Options\" menu entry. Options and their detailed descriptions can also be accessed by using - the \"Customize\" menu entry or the command `\\[customize-option]' - (`\\[customize-group]' for groups). Some customizations only take effect + the \"Customize\" menu entry or the command \\[customize-option] + (\\[customize-group] for groups). Some customizations only take effect after some action (read the NOTE in the option documentation). Customization can also be done globally (i.e. site-wide, read the INSTALL file). Not all options are described in this documentation, so go and see - what other useful user options there are (`\\[vhdl-customize]' or menu)! + what other useful user options there are (\\[vhdl-customize] or menu)! FILE EXTENSIONS: @@ -35999,7 +36124,7 @@ Usage: Maintenance: ------------ -To submit a bug report, enter `\\[vhdl-submit-bug-report]' within VHDL Mode. +To submit a bug report, enter \\[vhdl-submit-bug-report] within VHDL Mode. Add a description of the problem and include a reproducible test case. Questions and enhancement requests can be sent to <reto@gnu.org>. @@ -36264,19 +36389,19 @@ then \\[View-leave], \\[View-quit] and \\[View-kill-and-leave] will return to th Entry to view-mode runs the normal hook `view-mode-hook'. -This is a minor mode. If called interactively, toggle the `View -mode' mode. If the prefix argument is positive, enable the mode, -and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `View mode' +mode. If the prefix argument is positive, enable the mode, and if it is +zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `view-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'view-mode-enter "view" "\ @@ -36351,6 +36476,57 @@ Turn on Viper emulation of Vi in Emacs. See Info node `(viper)Top'." t) (register-definition-prefixes "quail/viqr" '("viet-quail-define-rules")) +;;; Generated autoloads from visual-wrap.el + +(autoload 'visual-wrap-prefix-mode "visual-wrap" "\ +Display continuation lines with prefixes from surrounding context. + +To enable this minor mode across all buffers, enable +`global-visual-wrap-prefix-mode'. + +This is a minor mode. If called interactively, toggle the +`Visual-Wrap-Prefix mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `visual-wrap-prefix-mode'. + +The mode's hook is called both when the mode is enabled and when it is +disabled. + +(fn &optional ARG)" t) +(put 'global-visual-wrap-prefix-mode 'globalized-minor-mode t) +(defvar global-visual-wrap-prefix-mode nil "\ +Non-nil if Global Visual-Wrap-Prefix mode is enabled. +See the `global-visual-wrap-prefix-mode' command +for a description of this minor mode. +Setting this variable directly does not take effect; +either customize it (see the info node `Easy Customization') +or call the function `global-visual-wrap-prefix-mode'.") +(custom-autoload 'global-visual-wrap-prefix-mode "visual-wrap" nil) +(autoload 'global-visual-wrap-prefix-mode "visual-wrap" "\ +Toggle Visual-Wrap-Prefix mode in all buffers. +With prefix ARG, enable Global Visual-Wrap-Prefix mode if ARG is +positive; otherwise, disable it. + +If called from Lisp, toggle the mode if ARG is `toggle'. +Enable the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +Visual-Wrap-Prefix mode is enabled in all buffers where +`visual-wrap-prefix-mode' would do it. + +See `visual-wrap-prefix-mode' for more information on +Visual-Wrap-Prefix mode. + +(fn &optional ARG)" t) +(register-definition-prefixes "visual-wrap" '("visual-wrap-")) + + ;;; Generated autoloads from emacs-lisp/vtable.el (register-definition-prefixes "vtable" '("vtable")) @@ -36532,18 +36708,18 @@ current function name is continuously displayed in the mode line, in certain major modes. This is a global minor mode. If called interactively, toggle the -`Which-Function mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Which-Function mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='which-function-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "which-func" '("which-func")) @@ -36561,19 +36737,19 @@ See also `whitespace-style', `whitespace-newline' and This mode uses a number of faces to visualize the whitespace; see the customization group `whitespace' for details. -This is a minor mode. If called interactively, toggle the -`Whitespace mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `Whitespace +mode' mode. If the prefix argument is positive, enable the mode, and if +it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `whitespace-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'whitespace-newline-mode "whitespace" "\ @@ -36587,19 +36763,18 @@ use `whitespace-mode'. See also `whitespace-newline' and `whitespace-display-mappings'. This is a minor mode. If called interactively, toggle the -`Whitespace-Newline mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable -the mode. +`Whitespace-Newline mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `whitespace-newline-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (put 'global-whitespace-mode 'globalized-minor-mode t) @@ -36646,18 +36821,18 @@ See also `whitespace-newline' and `whitespace-display-mappings'. This is a global minor mode. If called interactively, toggle the `Global Whitespace-Newline mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable -the mode. +positive, enable the mode, and if it is zero or negative, disable the +mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='global-whitespace-newline-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'whitespace-toggle-options "whitespace" "\ @@ -36961,19 +37136,19 @@ Show widget browser for WIDGET in other window. (autoload 'widget-minor-mode "wid-browse" "\ Minor mode for traversing widgets. -This is a minor mode. If called interactively, toggle the -`Widget minor mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the `Widget minor +mode' mode. If the prefix argument is positive, enable the mode, and if +it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `widget-minor-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "wid-browse" '("widget-")) @@ -37068,18 +37243,18 @@ for a description of this minor mode.") Global minor mode for default windmove commands. This is a global minor mode. If called interactively, toggle the -`Windmove mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +`Windmove mode' mode. If the prefix argument is positive, enable the +mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='windmove-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (autoload 'windmove-default-keybindings "windmove" "\ @@ -37215,18 +37390,18 @@ sequence \\`C-c <left>'. If you change your mind (while undoing), you can press \\`C-c <right>' (calling `winner-redo'). This is a global minor mode. If called interactively, toggle the -`Winner mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +`Winner mode' mode. If the prefix argument is positive, enable the +mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='winner-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "winner" '("winner-")) @@ -37294,19 +37469,18 @@ Allow `word-wrap' to fold on all breaking whitespace characters. The characters to break on are defined by `word-wrap-whitespace-characters'. This is a minor mode. If called interactively, toggle the -`Word-Wrap-Whitespace mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable -the mode. +`Word-Wrap-Whitespace mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `word-wrap-whitespace-mode'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (put 'global-word-wrap-whitespace-mode 'globalized-minor-mode t) @@ -37557,18 +37731,18 @@ mouse functionality for such clicks is still available by holding down the SHIFT key while pressing the mouse button. This is a global minor mode. If called interactively, toggle the -`Xterm-Mouse mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Xterm-Mouse mode' mode. If the prefix argument is positive, enable the +mode, and if it is zero or negative, disable the mode. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. To check whether the minor mode is enabled in the current buffer, evaluate `(default-value \\='xterm-mouse-mode)'. -The mode's hook is called both when the mode is enabled and when -it is disabled. +The mode's hook is called both when the mode is enabled and when it is +disabled. (fn &optional ARG)" t) (register-definition-prefixes "xt-mouse" '("turn-o" "xt-mouse-epoch" "xterm-mouse-")) @@ -37652,99 +37826,9 @@ run a specific program. The program must be a member of (register-definition-prefixes "zone" '("zone-")) -;;; Generated autoloads from emacs-lisp/ert-font-lock.el - -(autoload 'ert-font-lock-deftest "ert-font-lock" "\ -Define test NAME (a symbol) using assertions from TEST-STR. - -Other than MAJOR-MODE and TEST-STR parameters, this macro accepts -the same parameters and keywords as `ert-deftest' and is intended -to be used through `ert'. - -(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] [:tags \\='(TAG...)] MAJOR-MODE TEST-STR)" nil t) -(function-put 'ert-font-lock-deftest 'doc-string-elt 3) -(function-put 'ert-font-lock-deftest 'lisp-indent-function 2) -(autoload 'ert-font-lock-deftest-file "ert-font-lock" "\ -Define test NAME (a symbol) using assertions from FILE. - -FILE - path to a file with assertions in ERT resource director as -return by `ert-resource-directory'. - -Other than MAJOR-MODE and FILE parameters, this macro accepts the -same parameters and keywords as `ert-deftest' and is intended to -be used through `ert'. - -(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] [:tags \\='(TAG...)] MAJOR-MODE FILE)" nil t) -(function-put 'ert-font-lock-deftest-file 'doc-string-elt 3) -(function-put 'ert-font-lock-deftest-file 'lisp-indent-function 2) -(autoload 'ert-font-lock-test-string "ert-font-lock" "\ -Check font faces in TEST-STRING set by MODE. - -The function is meant to be run from within an ERT test. - -(fn TEST-STRING MODE)") -(autoload 'ert-font-lock-test-file "ert-font-lock" "\ -Check font faces in FILENAME set by MODE. - -The function is meant to be run from within an ERT test. - -(fn FILENAME MODE)") -(register-definition-prefixes "ert-font-lock" '("ert-font-lock--")) - - -;;; Generated autoloads from touch-screen.el - -(autoload 'touch-screen-hold "touch-screen" "\ -Handle a long press EVENT. -Ding and select the window at EVENT, then activate the mark. If -`touch-screen-word-select' is enabled, try to select the whole -word around EVENT; otherwise, set point to the location of EVENT. - -(fn EVENT)" t) -(autoload 'touch-screen-track-tap "touch-screen" "\ -Track a single tap starting from EVENT. -EVENT should be a `touchscreen-begin' event. - -Read touch screen events until a `touchscreen-end' event is -received with the same ID as in EVENT. If UPDATE is non-nil and -a `touchscreen-update' event is received in the mean time and -contains a touch point with the same ID as in EVENT, call UPDATE -with that event and DATA. - -If THRESHOLD is non-nil, enforce a threshold of movement that is -either itself or 10 pixels when it is not a number. If the -aforementioned touch point moves beyond that threshold on any -axis, return nil immediately, and further resume mouse event -translation for the touch point at hand. - -Return nil immediately if any other kind of event is received; -otherwise, return t once the `touchscreen-end' event arrives. - -(fn EVENT &optional UPDATE DATA THRESHOLD)") -(autoload 'touch-screen-track-drag "touch-screen" "\ -Track a single drag starting from EVENT. -EVENT should be a `touchscreen-begin' event. - -Read touch screen events until a `touchscreen-end' event is -received with the same ID as in EVENT. For each -`touchscreen-update' event received in the mean time containing a -touch point with the same ID as in EVENT, call UPDATE with the -touch point in event and DATA, once the touch point has moved -significantly by at least 5 pixels from where it was in EVENT. +;;; Generated autoloads from net/tramp-androidsu.el -Return nil immediately if any other kind of event is received; -otherwise, return either t or `no-drag' once the -`touchscreen-end' event arrives; return `no-drag' returned if the -touch point in EVENT did not move significantly, and t otherwise. - -(fn EVENT UPDATE &optional DATA)") -(autoload 'touch-screen-inhibit-drag "touch-screen" "\ -Inhibit subsequent `touchscreen-drag' events from being sent. -Prevent `touchscreen-drag' and translated mouse events from being -sent until the touch sequence currently being translated ends. -Must be called from a command bound to a `touchscreen-hold' or -`touchscreen-drag' event.") -(register-definition-prefixes "touch-screen" '("touch-screen-")) +(register-definition-prefixes "tramp-androidsu" '("tramp-androidsu-")) ;;; End of scraped data @@ -37754,8 +37838,8 @@ Must be called from a command bound to a `touchscreen-hold' or ;; Local Variables: ;; version-control: never ;; no-update-autoloads: t -;; no-byte-compile: t ;; no-native-compile: t +;; no-byte-compile: t ;; coding: utf-8-emacs-unix ;; End: diff --git a/lisp/leim/quail/cyrillic.el b/lisp/leim/quail/cyrillic.el index 577898f82bd..60c88221a65 100644 --- a/lisp/leim/quail/cyrillic.el +++ b/lisp/leim/quail/cyrillic.el @@ -1101,9 +1101,9 @@ as follows. ;; Ognyan Kulev <ogi@fmi.uni-sofia.bg> wrote: ;; I would suggest future `cyrillic-translit' to be with the -;; modification of `cyrillic-translit-bulgarian' applied and the +;; modification of `cyrillic-translit-bulgarian' (now deleted) applied and the ;; latter to disappear. It could be used by people who write -;; bulgarian e-mails with latin letters for kick start (phonetic input +;; Bulgarian e-mails with latin letters for kick start (phonetic input ;; method is not so obvious as translit input method but each letter ;; is one keypress and a *lot* of people know it). diff --git a/lisp/leim/quail/indian.el b/lisp/leim/quail/indian.el index c1348081d58..9ea23ec087c 100644 --- a/lisp/leim/quail/indian.el +++ b/lisp/leim/quail/indian.el @@ -476,7 +476,7 @@ Full key sequences are listed below:" (defgroup tamil-input nil "Translation rules for the Tamil input method." :prefix "tamil-" - :group 'leim) + :group 'quail) (defcustom tamil-translation-rules ;; Vowels. diff --git a/lisp/leim/quail/latin-post.el b/lisp/leim/quail/latin-post.el index 0d2c1888426..25e7c4a64a8 100644 --- a/lisp/leim/quail/latin-post.el +++ b/lisp/leim/quail/latin-post.el @@ -1616,6 +1616,7 @@ Doubling the postfix separates the letter and postfix: e.g. a^^ -> a^ ;; Italian (itln) ;; Spanish (spnsh) ;; Dvorak (dvorak) +;; Colemak (colemak) ;; ;;; 92.12.15 created for Mule Ver.0.9.6 by Takahashi N. <ntakahas@etl.go.jp> ;;; 92.12.29 modified by Takahashi N. <ntakahas@etl.go.jp> @@ -2224,6 +2225,55 @@ Dead accent is right to æ." nil t t t t nil nil nil nil nil t) ("?" ?Z) ) +;; +(quail-define-package + "english-colemak" "English" "CM@" t + "English (ASCII) input method simulating Colemak keyboard" + nil t t t t nil nil nil nil nil t) + +;; 1! 2@ 3# 4$ 5% 6^ 7& 8* 9( 0) -_ =+ `~ +;; qQ wW fF pP gG jJ lL uU yY ;: [{ ]} +;; aA rR sS tT dD hH nN eE iI oO '" \| +;; zZ xX cC vV bB kK mM ,< .> /? + +(quail-define-rules + ("e" ?f) + ("r" ?p) + ("t" ?g) + ("y" ?j) + ("u" ?l) + ("i" ?u) + ("o" ?y) + ("p" ?\;) + ("s" ?r) + ("d" ?s) + ("f" ?t) + ("g" ?d) + ("j" ?n) + ("k" ?e) + ("l" ?i) + (";" ?o) + ("n" ?k) + + ("E" ?F) + ("R" ?P) + ("T" ?G) + ("Y" ?J) + ("U" ?L) + ("I" ?U) + ("O" ?Y) + ("P" ?\:) + ("S" ?R) + ("D" ?S) + ("F" ?T) + ("G" ?D) + ("J" ?N) + ("K" ?E) + ("L" ?I) + (":" ?O) + ("N" ?K) + ) + (quail-define-package "latin-postfix" "Latin" "L<" t "Latin character input method with postfix modifiers. diff --git a/lisp/leim/quail/persian.el b/lisp/leim/quail/persian.el index de61481d7f1..676b3ab5c2e 100644 --- a/lisp/leim/quail/persian.el +++ b/lisp/leim/quail/persian.el @@ -500,7 +500,7 @@ ;; RIGHT-TO-LEFT EMBEDDING (sets base dir to RTL but allows embedded text) ("&rle;" ?\u202B) ;; (ucs-insert #x202B) named: زیرمتنِ راستبهچپ ;; POP DIRECTIONAL FORMATTING (used for RLE or LRE and RLO or LRO) - ;; EMACS ANOMOLY --- Why does &pdf not show up in (describe-input-method 'farsi-transliterate-banan) + ;; EMACS ANOMALY --- Why does &pdf not show up in (describe-input-method 'farsi-transliterate-banan) ("&pdf;" ?\u202C) ;; (ucs-insert #x202C) named: پایانِ زیرمتن ("P" ?\u202C) ;; LEFT-TO-RIGHT OVERRIDE (overrides the bidirectional algorithm, display LTR) diff --git a/lisp/leim/quail/vnvni.el b/lisp/leim/quail/vnvni.el index 59d1a82eb21..ae5941cbfc7 100644 --- a/lisp/leim/quail/vnvni.el +++ b/lisp/leim/quail/vnvni.el @@ -125,8 +125,8 @@ and postfix: E66 -> E6, a55 -> a5, etc. ("A61" ?Ấ) ; LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND ACUTE ("a62" ?ầ) ; LATIN SMALL LETTER A WITH CIRCUMFLEX AND GRAVE ("A62" ?Ầ) ; LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND GRAVE - ("a63" ?ẩ) ; LATIN SMALL LETTER A WITH CIRCUMFLEX AND HO6K ABOVE - ("A63" ?Ẩ) ; LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND HO6K ABOVE + ("a63" ?ẩ) ; LATIN SMALL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE + ("A63" ?Ẩ) ; LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE ("a64" ?ẫ) ; LATIN SMALL LETTER A WITH CIRCUMFLEX AND TILDE ("A64" ?Ẫ) ; LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND TILDE ("a65" ?ậ) ; LATIN SMALL LETTER A WITH CIRCUMFLEX AND DOT BELOW @@ -135,42 +135,42 @@ and postfix: E66 -> E6, a55 -> a5, etc. ("A81" ?Ắ) ; LATIN CAPITAL LETTER A WITH BREVE AND ACUTE ("a82" ?ằ) ; LATIN SMALL LETTER A WITH BREVE AND GRAVE ("A82" ?Ằ) ; LATIN CAPITAL LETTER A WITH BREVE AND GRAVE - ("a83" ?ẳ) ; LATIN SMALL LETTER A WITH BREVE AND HO6K ABOVE - ("A83" ?Ẳ) ; LATIN CAPITAL LETTER A WITH BREVE AND HO6K ABOVE + ("a83" ?ẳ) ; LATIN SMALL LETTER A WITH BREVE AND HOOK ABOVE + ("A83" ?Ẳ) ; LATIN CAPITAL LETTER A WITH BREVE AND HOOK ABOVE ("a84" ?ẵ) ; LATIN SMALL LETTER A WITH BREVE AND TILDE ("A84" ?Ẵ) ; LATIN CAPITAL LETTER A WITH BREVE AND TILDE ("a85" ?ặ) ; LATIN SMALL LETTER A WITH BREVE AND DOT BELOW ("A85" ?Ặ) ; LATIN CAPITAL LETTER A WITH BREVE AND DOT BELOW ("e5" ?ẹ) ; LATIN SMALL LETTER E WITH DOT BELOW ("E5" ?Ẹ) ; LATIN CAPITAL LETTER E WITH DOT BELOW - ("e3" ?ẻ) ; LATIN SMALL LETTER E WITH HO6K ABOVE - ("E3" ?Ẻ) ; LATIN CAPITAL LETTER E WITH HO6K ABOVE + ("e3" ?ẻ) ; LATIN SMALL LETTER E WITH HOOK ABOVE + ("E3" ?Ẻ) ; LATIN CAPITAL LETTER E WITH HOOK ABOVE ("e4" ?ẽ) ; LATIN SMALL LETTER E WITH TILDE ("E4" ?Ẽ) ; LATIN CAPITAL LETTER E WITH TILDE ("e61" ?ế) ; LATIN SMALL LETTER E WITH CIRCUMFLEX AND ACUTE ("E61" ?Ế) ; LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND ACUTE ("e62" ?ề) ; LATIN SMALL LETTER E WITH CIRCUMFLEX AND GRAVE ("E62" ?Ề) ; LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND GRAVE - ("e63" ?ể) ; LATIN SMALL LETTER E WITH CIRCUMFLEX AND HO6K ABOVE - ("E63" ?Ể) ; LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND HO6K ABOVE + ("e63" ?ể) ; LATIN SMALL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE + ("E63" ?Ể) ; LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE ("e64" ?ễ) ; LATIN SMALL LETTER E WITH CIRCUMFLEX AND TILDE ("E64" ?Ễ) ; LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND TILDE ("e65" ?ệ) ; LATIN SMALL LETTER E WITH CIRCUMFLEX AND DOT BELOW ("E65" ?Ệ) ; LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND DOT BELOW - ("i3" ?ỉ) ; LATIN SMALL LETTER I WITH HO6K ABOVE - ("I3" ?Ỉ) ; LATIN CAPITAL LETTER I WITH HO6K ABOVE + ("i3" ?ỉ) ; LATIN SMALL LETTER I WITH HOOK ABOVE + ("I3" ?Ỉ) ; LATIN CAPITAL LETTER I WITH HOOK ABOVE ("i5" ?ị) ; LATIN SMALL LETTER I WITH DOT BELOW ("I5" ?Ị) ; LATIN CAPITAL LETTER I WITH DOT BELOW ("o5" ?ọ) ; LATIN SMALL LETTER O WITH DOT BELOW ("O5" ?Ọ) ; LATIN CAPITAL LETTER O WITH DOT BELOW - ("o3" ?ỏ) ; LATIN SMALL LETTER O WITH HO6K ABOVE - ("O3" ?Ỏ) ; LATIN CAPITAL LETTER O WITH HO6K ABOVE + ("o3" ?ỏ) ; LATIN SMALL LETTER O WITH HOOK ABOVE + ("O3" ?Ỏ) ; LATIN CAPITAL LETTER O WITH HOOK ABOVE ("o61" ?ố) ; LATIN SMALL LETTER O WITH CIRCUMFLEX AND ACUTE ("O61" ?Ố) ; LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND ACUTE ("o62" ?ồ) ; LATIN SMALL LETTER O WITH CIRCUMFLEX AND GRAVE ("O62" ?Ồ) ; LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND GRAVE - ("o63" ?ổ) ; LATIN SMALL LETTER O WITH CIRCUMFLEX AND HO6K ABOVE - ("O63" ?Ổ) ; LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND HO6K ABOVE + ("o63" ?ổ) ; LATIN SMALL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE + ("O63" ?Ổ) ; LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE ("o64" ?ỗ) ; LATIN SMALL LETTER O WITH CIRCUMFLEX AND TILDE ("O64" ?Ỗ) ; LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND TILDE ("o65" ?ộ) ; LATIN SMALL LETTER O WITH CIRCUMFLEX AND DOT BELO7 @@ -179,22 +179,22 @@ and postfix: E66 -> E6, a55 -> a5, etc. ("O71" ?Ớ) ; LATIN CAPITAL LETTER O WITH HORN AND ACUTE ("o72" ?ờ) ; LATIN SMALL LETTER O WITH HORN AND GRAVE ("O72" ?Ờ) ; LATIN CAPITAL LETTER O WITH HORN AND GRAVE - ("o73" ?ở) ; LATIN SMALL LETTER O WITH HORN AND HO6K ABOVE - ("O73" ?Ở) ; LATIN CAPITAL LETTER O WITH HORN AND HO6K ABOVE + ("o73" ?ở) ; LATIN SMALL LETTER O WITH HORN AND HOOK ABOVE + ("O73" ?Ở) ; LATIN CAPITAL LETTER O WITH HORN AND HOOK ABOVE ("o74" ?ỡ) ; LATIN SMALL LETTER O WITH HORN AND TILDE ("O74" ?Ỡ) ; LATIN CAPITAL LETTER O WITH HORN AND TILDE ("o75" ?ợ) ; LATIN SMALL LETTER O WITH HORN AND DOT BELO7 ("O75" ?Ợ) ; LATIN CAPITAL LETTER O WITH HORN AND DOT BELO7 ("u5" ?ụ) ; LATIN SMALL LETTER U WITH DOT BELO7 ("U5" ?Ụ) ; LATIN CAPITAL LETTER U WITH DOT BELO7 - ("u3" ?ủ) ; LATIN SMALL LETTER U WITH HO6K ABOVE - ("U3" ?Ủ) ; LATIN CAPITAL LETTER U WITH HO6K ABOVE + ("u3" ?ủ) ; LATIN SMALL LETTER U WITH HOOK ABOVE + ("U3" ?Ủ) ; LATIN CAPITAL LETTER U WITH HOOK ABOVE ("u71" ?ứ) ; LATIN SMALL LETTER U WITH HORN AND ACUTE ("U71" ?Ứ) ; LATIN CAPITAL LETTER U WITH HORN AND ACUTE ("u72" ?ừ) ; LATIN SMALL LETTER U WITH HORN AND GRAVE ("U72" ?Ừ) ; LATIN CAPITAL LETTER U WITH HORN AND GRAVE - ("u73" ?ử) ; LATIN SMALL LETTER U WITH HORN AND HO6K ABOVE - ("U73" ?Ử) ; LATIN CAPITAL LETTER U WITH HORN AND HO6K ABOVE + ("u73" ?ử) ; LATIN SMALL LETTER U WITH HORN AND HOOK ABOVE + ("U73" ?Ử) ; LATIN CAPITAL LETTER U WITH HORN AND HOOK ABOVE ("u74" ?ữ) ; LATIN SMALL LETTER U WITH HORN AND TILDE ("U74" ?Ữ) ; LATIN CAPITAL LETTER U WITH HORN AND TILDE ("u75" ?ự) ; LATIN SMALL LETTER U WITH HORN AND DOT BELO7 @@ -203,20 +203,20 @@ and postfix: E66 -> E6, a55 -> a5, etc. ("Y2" ?Ỳ) ; LATIN CAPITAL LETTER Y WITH GRAVE ("y5" ?ỵ) ; LATIN SMALL LETTER Y WITH DOT BELO7 ("Y5" ?Ỵ) ; LATIN CAPITAL LETTER Y WITH DOT BELO7 - ("y3" ?ỷ) ; LATIN SMALL LETTER Y WITH HO6K ABOVE - ("Y3" ?Ỷ) ; LATIN CAPITAL LETTER Y WITH HO6K ABOVE + ("y3" ?ỷ) ; LATIN SMALL LETTER Y WITH HOOK ABOVE + ("Y3" ?Ỷ) ; LATIN CAPITAL LETTER Y WITH HOOK ABOVE ("y4" ?ỹ) ; LATIN SMALL LETTER Y WITH TILDE ("Y4" ?Ỹ) ; LATIN CAPITAL LETTER Y WITH TILDE ("d9" ?đ) ; LATIN SMALL LETTER D WITH STROKE ("D9" ?Đ) ; LATIN CAPITAL LETTER D WITH STROKE ;("$$" ?₫) ; U+20AB DONG SIGN (#### check) - ("a22" ["a22"]) + ("a22" ["a2"]) ("A22" ["A2"]) ("a11" ["a1"]) ("A11" ["A1"]) - ("a66"' ["a6"]) - ("A66"' ["A6"]) + ("a66" ["a6"]) + ("A66" ["A6"]) ("a44" ["a4"]) ("A44" ["A4"]) ("e22" ["e2"]) @@ -248,7 +248,7 @@ and postfix: E66 -> E6, a55 -> a5, etc. ("i44" ["i4"]) ("I44" ["I4"]) ("u44" ["u4"]) - ("U44" ["u4"]) + ("U44" ["U4"]) ("o77" ["o7"]) ("O77" ["O7"]) ("u77" ["u7"]) @@ -283,7 +283,7 @@ and postfix: E66 -> E6, a55 -> a5, etc. ("Y33" ["Y3"]) ("y44" ["y4"]) ("Y44" ["Y4"]) - ("d9" ["d9"]) + ("d99" ["d9"]) ("D99" ["D9"]) ;("$$$" ["$$"]) diff --git a/lisp/loadup.el b/lisp/loadup.el index c498c0e53af..c6a8dcbb909 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -635,6 +635,8 @@ directory got moved. This is set to be a pair in the form of: (unwind-protect (let ((tmp-dump-mode dump-mode) (dump-mode nil) + ;; Set `lexical-binding' to nil by default + ;; in the dumped Emacs. (lexical-binding nil)) (if (member tmp-dump-mode '("pdump" "pbootstrap")) (dump-emacs-portable (expand-file-name output invocation-directory)) diff --git a/lisp/locate.el b/lisp/locate.el index d86e7fa678f..70328d5184e 100644 --- a/lisp/locate.el +++ b/lisp/locate.el @@ -559,7 +559,7 @@ do not work in subdirectories. (defun locate-tags () "Visit a tags table in `*Locate*' mode." - (interactive) + (interactive nil locate-mode) (if (locate-main-listing-line-p) (let ((tags-table (locate-get-filename))) (and (y-or-n-p (format "Visit tags table %s? " tags-table)) @@ -589,7 +589,7 @@ locate database using the shell command in `locate-update-command'." (defun locate-find-directory () "Visit the directory of the file mentioned on this line." - (interactive) + (interactive nil locate-mode) (if (locate-main-listing-line-p) (let ((directory-name (locate-get-dirname))) (if (file-directory-p directory-name) @@ -601,7 +601,7 @@ locate database using the shell command in `locate-update-command'." (defun locate-find-directory-other-window () "Visit the directory of the file named on this line in other window." - (interactive) + (interactive nil locate-mode) (if (locate-main-listing-line-p) (find-file-other-window (locate-get-dirname)) (message "This command only works inside main listing."))) diff --git a/lisp/macros.el b/lisp/macros.el index 0a04bad762a..7108a027ca6 100644 --- a/lisp/macros.el +++ b/lisp/macros.el @@ -197,7 +197,7 @@ For example, in Usenet articles, sections of text quoted from another author are indented, or have each line start with `>'. To quote a section of text, define a keyboard macro which inserts `>', put point and mark at opposite ends of the quoted section, and use -`\\[apply-macro-to-region-lines]' to mark the entire section. +\\[apply-macro-to-region-lines] to mark the entire section. Suppose you wanted to build a keyword table in C where each entry looked like this: @@ -219,7 +219,7 @@ and write a macro to massage a word into a table entry: \\C-x ) and then select the region of un-tablified names and use -`\\[apply-macro-to-region-lines]' to build the table from the names." +\\[apply-macro-to-region-lines] to build the table from the names." (interactive "r") (or macro (progn diff --git a/lisp/mail/mail-extr.el b/lisp/mail/mail-extr.el index 668cae05521..cfdbc1b2509 100644 --- a/lisp/mail/mail-extr.el +++ b/lisp/mail/mail-extr.el @@ -1845,7 +1845,7 @@ place. It affects how `mail-extract-address-components' works." ;; https://en.wikipedia.org/wiki/List_of_Internet_top-level_domains (defconst mail-extr-all-top-level-domains - (let ((ob (make-vector 739 0))) + (let ((ob (obarray-make 739))) (mapc (lambda (x) (put (intern (downcase (car x)) ob) diff --git a/lisp/mail/mailabbrev.el b/lisp/mail/mailabbrev.el index 68d325ea261..c8006294a7d 100644 --- a/lisp/mail/mailabbrev.el +++ b/lisp/mail/mailabbrev.el @@ -171,7 +171,7 @@ no aliases, which is represented by this being a table with no entries.)") ;;;###autoload (defun mail-abbrevs-setup () "Initialize use of the `mailabbrev' package." - (if (and (not (vectorp mail-abbrevs)) + (if (and (not (obarrayp mail-abbrevs)) (file-exists-p mail-personal-alias-file)) (progn (setq mail-abbrev-modtime @@ -196,7 +196,7 @@ no aliases, which is represented by this being a table with no entries.)") "Read mail aliases from personal mail alias file and set `mail-abbrevs'. By default this is the file specified by `mail-personal-alias-file'." (setq file (expand-file-name (or file mail-personal-alias-file))) - (if (vectorp mail-abbrevs) + (if (obarrayp mail-abbrevs) nil (setq mail-abbrevs nil) (define-abbrev-table 'mail-abbrevs '())) @@ -278,7 +278,7 @@ double-quotes." ;; true, and we do some evil space->comma hacking like /bin/mail does. (interactive "sDefine mail alias: \nsDefine %s as mail alias for: ") ;; Read the defaults first, if we have not done so. - (unless (vectorp mail-abbrevs) (build-mail-abbrevs)) + (unless (obarrayp mail-abbrevs) (build-mail-abbrevs)) ;; strip garbage from front and end (if (string-match "\\`[ \t\n,]+" definition) (setq definition (substring definition (match-end 0)))) @@ -355,7 +355,7 @@ double-quotes." (if mail-abbrev-aliases-need-to-be-resolved (progn ;; (message "Resolving mail aliases...") - (if (vectorp mail-abbrevs) + (if (obarrayp mail-abbrevs) (mapatoms (function mail-resolve-all-aliases-1) mail-abbrevs)) (setq mail-abbrev-aliases-need-to-be-resolved nil) ;; (message "Resolving mail aliases... done.") @@ -555,9 +555,9 @@ of a mail alias. The value is set up, buffer-local, when first needed.") (defun mail-abbrev-insert-alias (&optional alias) "Prompt for and insert a mail alias." (interactive (progn - (if (not (vectorp mail-abbrevs)) (mail-abbrevs-setup)) + (if (not (obarrayp mail-abbrevs)) (mail-abbrevs-setup)) (list (completing-read "Expand alias: " mail-abbrevs nil t)))) - (if (not (vectorp mail-abbrevs)) (mail-abbrevs-setup)) + (if (not (obarrayp mail-abbrevs)) (mail-abbrevs-setup)) (insert (or (and alias (symbol-value (intern-soft alias mail-abbrevs))) "")) (mail-abbrev-expand-hook)) diff --git a/lisp/mail/rmail.el b/lisp/mail/rmail.el index 74cf297c2fc..d422383acdf 100644 --- a/lisp/mail/rmail.el +++ b/lisp/mail/rmail.el @@ -805,8 +805,8 @@ that knows the exact ordering of the \\( \\) subexpressions.") "\\(" cite-chars "[ \t]*\\)\\)+\\)" "\\(.*\\)") (beginning-of-line) (end-of-line) - (1 font-lock-comment-delimiter-face nil t) - (5 font-lock-comment-face nil t))) + (1 'font-lock-comment-delimiter-face nil t) + (5 'font-lock-comment-face nil t))) '("^\\(X-[a-z0-9-]+\\|In-Reply-To\\|Date\\):.*\\(\n[ \t]+.*\\)*$" . 'rmail-header-name)))) "Additional expressions to highlight in Rmail mode.") @@ -815,7 +815,7 @@ that knows the exact ordering of the \\( \\) subexpressions.") (defun rmail-pop-to-buffer (&rest args) "Like `pop-to-buffer', but with `split-width-threshold' set to nil." (let (split-width-threshold) - (apply 'pop-to-buffer args))) + (apply #'pop-to-buffer args))) ;; Perform BODY in the summary buffer ;; in such a way that its cursor is properly updated in its own window. @@ -1008,66 +1008,66 @@ The buffer is expected to be narrowed to just the header of the message." (defvar rmail-mode-map (let ((map (make-keymap))) (suppress-keymap map) - (define-key map "a" 'rmail-add-label) - (define-key map "b" 'rmail-bury) - (define-key map "c" 'rmail-continue) - (define-key map "d" 'rmail-delete-forward) - (define-key map "\C-d" 'rmail-delete-backward) - (define-key map "e" 'rmail-edit-current-message) + (define-key map "a" #'rmail-add-label) + (define-key map "b" #'rmail-bury) + (define-key map "c" #'rmail-continue) + (define-key map "d" #'rmail-delete-forward) + (define-key map "\C-d" #'rmail-delete-backward) + (define-key map "e" #'rmail-edit-current-message) ;; If you change this, change the rmail-resend menu-item's :keys. - (define-key map "f" 'rmail-forward) - (define-key map "g" 'rmail-get-new-mail) - (define-key map "h" 'rmail-summary) - (define-key map "i" 'rmail-input) - (define-key map "j" 'rmail-show-message) - (define-key map "k" 'rmail-kill-label) - (define-key map "l" 'rmail-summary-by-labels) - (define-key map "\e\C-h" 'rmail-summary) - (define-key map "\e\C-l" 'rmail-summary-by-labels) - (define-key map "\e\C-r" 'rmail-summary-by-recipients) - (define-key map "\e\C-s" 'rmail-summary-by-regexp) - (define-key map "\e\C-f" 'rmail-summary-by-senders) - (define-key map "\e\C-t" 'rmail-summary-by-topic) - (define-key map "m" 'rmail-mail) - (define-key map "\em" 'rmail-retry-failure) - (define-key map "n" 'rmail-next-undeleted-message) - (define-key map "\en" 'rmail-next-message) - (define-key map "\e\C-n" 'rmail-next-labeled-message) - (define-key map "o" 'rmail-output) - (define-key map "\C-o" 'rmail-output-as-seen) - (define-key map "p" 'rmail-previous-undeleted-message) - (define-key map "\ep" 'rmail-previous-message) - (define-key map "\e\C-p" 'rmail-previous-labeled-message) - (define-key map "q" 'rmail-quit) - (define-key map "r" 'rmail-reply) + (define-key map "f" #'rmail-forward) + (define-key map "g" #'rmail-get-new-mail) + (define-key map "h" #'rmail-summary) + (define-key map "i" #'rmail-input) + (define-key map "j" #'rmail-show-message) + (define-key map "k" #'rmail-kill-label) + (define-key map "l" #'rmail-summary-by-labels) + (define-key map "\e\C-h" #'rmail-summary) + (define-key map "\e\C-l" #'rmail-summary-by-labels) + (define-key map "\e\C-r" #'rmail-summary-by-recipients) + (define-key map "\e\C-s" #'rmail-summary-by-regexp) + (define-key map "\e\C-f" #'rmail-summary-by-senders) + (define-key map "\e\C-t" #'rmail-summary-by-topic) + (define-key map "m" #'rmail-mail) + (define-key map "\em" #'rmail-retry-failure) + (define-key map "n" #'rmail-next-undeleted-message) + (define-key map "\en" #'rmail-next-message) + (define-key map "\e\C-n" #'rmail-next-labeled-message) + (define-key map "o" #'rmail-output) + (define-key map "\C-o" #'rmail-output-as-seen) + (define-key map "p" #'rmail-previous-undeleted-message) + (define-key map "\ep" #'rmail-previous-message) + (define-key map "\e\C-p" #'rmail-previous-labeled-message) + (define-key map "q" #'rmail-quit) + (define-key map "r" #'rmail-reply) ;; I find I can't live without the default M-r command -- rms. - ;; (define-key rmail-mode-map "\er" 'rmail-search-backwards) - (define-key map "s" 'rmail-expunge-and-save) - (define-key map "\es" 'rmail-search) - (define-key map "t" 'rmail-toggle-header) - (define-key map "u" 'rmail-undelete-previous-message) - (define-key map "v" 'rmail-mime) - (define-key map "w" 'rmail-output-body-to-file) - (define-key map "\C-c\C-w" 'rmail-widen) - (define-key map "x" 'rmail-expunge) - (define-key map "." 'rmail-beginning-of-message) - (define-key map "/" 'rmail-end-of-message) - (define-key map "<" 'rmail-first-message) - (define-key map ">" 'rmail-last-message) - (define-key map " " 'scroll-up-command) - (define-key map [?\S-\ ] 'scroll-down-command) - (define-key map "\177" 'scroll-down-command) - (define-key map "?" 'describe-mode) - (define-key map "\C-c\C-d" 'rmail-epa-decrypt) - (define-key map "\C-c\C-s\C-d" 'rmail-sort-by-date) - (define-key map "\C-c\C-s\C-s" 'rmail-sort-by-subject) - (define-key map "\C-c\C-s\C-a" 'rmail-sort-by-author) - (define-key map "\C-c\C-s\C-r" 'rmail-sort-by-recipient) - (define-key map "\C-c\C-s\C-c" 'rmail-sort-by-correspondent) - (define-key map "\C-c\C-s\C-l" 'rmail-sort-by-lines) - (define-key map "\C-c\C-s\C-k" 'rmail-sort-by-labels) - (define-key map "\C-c\C-n" 'rmail-next-same-subject) - (define-key map "\C-c\C-p" 'rmail-previous-same-subject) + ;; (define-key rmail-mode-map "\er" #'rmail-search-backwards) + (define-key map "s" #'rmail-expunge-and-save) + (define-key map "\es" #'rmail-search) + (define-key map "t" #'rmail-toggle-header) + (define-key map "u" #'rmail-undelete-previous-message) + (define-key map "v" #'rmail-mime) + (define-key map "w" #'rmail-output-body-to-file) + (define-key map "\C-c\C-w" #'rmail-widen) + (define-key map "x" #'rmail-expunge) + (define-key map "." #'rmail-beginning-of-message) + (define-key map "/" #'rmail-end-of-message) + (define-key map "<" #'rmail-first-message) + (define-key map ">" #'rmail-last-message) + (define-key map " " #'scroll-up-command) + (define-key map [?\S-\ ] #'scroll-down-command) + (define-key map "\177" #'scroll-down-command) + (define-key map "?" #'describe-mode) + (define-key map "\C-c\C-d" #'rmail-epa-decrypt) + (define-key map "\C-c\C-s\C-d" #'rmail-sort-by-date) + (define-key map "\C-c\C-s\C-s" #'rmail-sort-by-subject) + (define-key map "\C-c\C-s\C-a" #'rmail-sort-by-author) + (define-key map "\C-c\C-s\C-r" #'rmail-sort-by-recipient) + (define-key map "\C-c\C-s\C-c" #'rmail-sort-by-correspondent) + (define-key map "\C-c\C-s\C-l" #'rmail-sort-by-lines) + (define-key map "\C-c\C-s\C-k" #'rmail-sort-by-labels) + (define-key map "\C-c\C-n" #'rmail-next-same-subject) + (define-key map "\C-c\C-p" #'rmail-previous-same-subject) (define-key map [menu-bar] (make-sparse-keymap)) @@ -1344,9 +1344,9 @@ Instead, these commands are available: (setq local-abbrev-table text-mode-abbrev-table) ;; Functions to support buffer swapping: (add-hook 'write-region-annotate-functions - 'rmail-write-region-annotate nil t) - (add-hook 'kill-buffer-hook 'rmail-mode-kill-buffer-hook nil t) - (add-hook 'change-major-mode-hook 'rmail-change-major-mode-hook nil t)) + #'rmail-write-region-annotate nil t) + (add-hook 'kill-buffer-hook #'rmail-mode-kill-buffer-hook nil t) + (add-hook 'change-major-mode-hook #'rmail-change-major-mode-hook nil t)) (defun rmail-generate-viewer-buffer () "Return a reusable buffer suitable for viewing messages. @@ -1363,7 +1363,7 @@ Create the buffer if necessary." (file-name-nondirectory (or buffer-file-name (buffer-name))))))) (with-current-buffer newbuf - (add-hook 'kill-buffer-hook 'rmail-view-buffer-kill-buffer-hook nil t)) + (add-hook 'kill-buffer-hook #'rmail-view-buffer-kill-buffer-hook nil t)) newbuf))) (defun rmail-swap-buffers () @@ -1479,7 +1479,7 @@ If so restore the actual mbox message collection." ;; Don't turn off auto-saving based on the size of the buffer ;; because that code does not understand buffer-swapping. (setq-local auto-save-include-big-deletions t) - (setq-local revert-buffer-function 'rmail-revert) + (setq-local revert-buffer-function #'rmail-revert) (setq-local font-lock-defaults '(rmail-font-lock-keywords t t nil nil @@ -1490,7 +1490,7 @@ If so restore the actual mbox message collection." (setq-local file-precious-flag t) (setq-local desktop-save-buffer t) (setq-local save-buffer-coding-system 'no-conversion) - (setq next-error-move-function 'rmail-next-error-move)) + (setq next-error-move-function #'rmail-next-error-move)) ;; Handle M-x revert-buffer done in an rmail-mode buffer. (defun rmail-revert (arg noconfirm) @@ -1606,7 +1606,7 @@ The duplicate copy goes into the Rmail file just after the original." (files (directory-files start t rmail-secondary-file-regexp))) ;; Sort here instead of in directory-files ;; because this list is usually much shorter. - (sort files 'string<)))) + (sort files #'string<)))) (defun rmail-list-to-menu (menu-name l action &optional full-name) (let ((menu (make-sparse-keymap menu-name)) @@ -2026,7 +2026,7 @@ Value is the size of the newly read mail after conversion." rmail-movemail-flags) (list file tofile) (if password (list password) nil)))) - (apply 'call-process args)) + (apply #'call-process args)) (if (not (buffer-modified-p errors)) ;; No output => movemail won nil @@ -2518,7 +2518,7 @@ Output a helpful message unless NOMSG is non-nil." ;; which will never be used. (push nil messages-head) (push ?0 deleted-head) - (setq rmail-message-vector (apply 'vector messages-head) + (setq rmail-message-vector (apply #'vector messages-head) rmail-deleted-vector (concat deleted-head)) (setq rmail-summary-vector (make-vector rmail-total-messages nil) @@ -2712,7 +2712,9 @@ N defaults to the current message." (and (string-match text-regexp content-type-header) t))))) (defcustom rmail-show-message-verbose-min 200000 - "Message size at which to show progress messages for displaying it." + "Message size at which to show progress messages for displaying it. +Messages longer than this (in characters) will produce echo-area +messages when Rmail processes such a message for display." :type 'integer :group 'rmail :version "23.1") @@ -3603,10 +3605,10 @@ If `rmail-confirm-expunge' is non-nil, ask user to confirm." (cons (aref messages number) nil))) (setq rmail-current-message new-message-number rmail-total-messages counter - rmail-message-vector (apply 'vector messages-head) + rmail-message-vector (apply #'vector messages-head) rmail-deleted-vector (make-string (1+ counter) ?\s) rmail-summary-vector (vconcat (nreverse new-summary)) - rmail-msgref-vector (apply 'vector (nreverse new-msgref)) + rmail-msgref-vector (apply #'vector (nreverse new-msgref)) win t))) (message "Expunging deleted messages...done") (if (not win) @@ -3889,7 +3891,7 @@ use \\[mail-yank-original] to yank the original message into it." (if (or references message-id) (list (cons "References" (if references (concat - (mapconcat 'identity references " ") + (mapconcat #'identity references " ") " " message-id) message-id))))))) @@ -4087,26 +4089,24 @@ typically for purposes of moderating a list." (insert "Resent-Bcc: " (user-login-name) "\n")) (insert "Resent-To: " (if (stringp address) address - (mapconcat 'identity address ",\n\t")) + (mapconcat #'identity address ",\n\t")) "\n") ;; Expand abbrevs in the recipients. (save-excursion (if (featurep 'mailabbrev) (let ((end (point-marker)) - (local-abbrev-table mail-abbrevs) - (old-syntax-table (syntax-table))) - (if (and (not (vectorp mail-abbrevs)) + (local-abbrev-table mail-abbrevs)) + (if (and (not (obarrayp mail-abbrevs)) (file-exists-p mail-personal-alias-file)) (build-mail-abbrevs)) (unless mail-abbrev-syntax-table (mail-abbrev-make-syntax-table)) - (set-syntax-table mail-abbrev-syntax-table) - (goto-char before) - (while (and (< (point) end) - (progn (forward-word-strictly 1) - (<= (point) end))) - (expand-abbrev)) - (set-syntax-table old-syntax-table)) + (with-syntax-table mail-abbrev-syntax-table + (goto-char before) + (while (and (< (point) end) + (progn (forward-word-strictly 1) + (<= (point) end))) + (expand-abbrev)))) (expand-mail-aliases before (point))))) ;;>> Set up comment, if any. (if (and (sequencep comment) (not (zerop (length comment)))) @@ -4333,7 +4333,7 @@ This has an effect only if a summary buffer exists." (defun rmail-fontify-buffer-function () ;; This function's symbol is bound to font-lock-fontify-buffer-function. - (add-hook 'rmail-show-message-hook 'rmail-fontify-message nil t) + (add-hook 'rmail-show-message-hook #'rmail-fontify-message nil t) ;; If we're already showing a message, fontify it now. (if rmail-current-message (rmail-fontify-message)) ;; Prevent Font Lock mode from kicking in. @@ -4344,7 +4344,7 @@ This has an effect only if a summary buffer exists." (with-silent-modifications (save-restriction (widen) - (remove-hook 'rmail-show-message-hook 'rmail-fontify-message t) + (remove-hook 'rmail-show-message-hook #'rmail-fontify-message t) (remove-text-properties (point-min) (point-max) '(rmail-fontified nil)) (font-lock-default-unfontify-buffer)))) @@ -4379,11 +4379,12 @@ browsing, and moving of messages." "Install those variables used by speedbar to enhance rmail." (unless rmail-speedbar-key-map (setq rmail-speedbar-key-map (speedbar-make-specialized-keymap)) - (define-key rmail-speedbar-key-map "e" 'speedbar-edit-line) - (define-key rmail-speedbar-key-map "r" 'speedbar-edit-line) - (define-key rmail-speedbar-key-map "\C-m" 'speedbar-edit-line) + (declare-function speedbar-edit-line "speedbar") + (define-key rmail-speedbar-key-map "e" #'speedbar-edit-line) + (define-key rmail-speedbar-key-map "r" #'speedbar-edit-line) + (define-key rmail-speedbar-key-map "\C-m" #'speedbar-edit-line) (define-key rmail-speedbar-key-map "M" - 'rmail-speedbar-move-message-to-folder-on-line))) + #'rmail-speedbar-move-message-to-folder-on-line))) ;; Mouse-3. (defvar rmail-speedbar-menu-items @@ -4690,7 +4691,7 @@ Argument MIME is non-nil if this is a mime message." (while (search-forward "\r\n" nil t) (delete-region (- (point) 2) (- (point) 1)))))) ))) - ;; User wants to decrypt the message perenently. + ;; User wants to decrypt the message permanently. (when (eq major-mode 'rmail-mode) (rmail-add-label "decrypt")) (setq decrypts (nreverse decrypts)) @@ -4827,7 +4828,8 @@ Content-Transfer-Encoding: base64\n") (with-current-buffer (if (rmail-buffers-swapped-p) rmail-buffer rmail-view-buffer) (setq buffer-file-coding-system rmail-message-encoding)))) -(add-hook 'after-save-hook 'rmail-after-save-hook) +;; FIXME: Don't do it globally!! +(add-hook 'after-save-hook #'rmail-after-save-hook) ;;; Mailing list support diff --git a/lisp/mail/rmailkwd.el b/lisp/mail/rmailkwd.el index d9c4cb8cfee..a13c42edb5c 100644 --- a/lisp/mail/rmailkwd.el +++ b/lisp/mail/rmailkwd.el @@ -31,7 +31,7 @@ ;; Global to all RMAIL buffers. It exists for the sake of completion. ;; It is better to use strings with the label functions and let them ;; worry about making the label. -(defvar rmail-label-obarray (make-vector 47 0) +(defvar rmail-label-obarray (obarray-make 47) "Obarray of labels used by Rmail. `rmail-read-label' uses this to offer completion.") diff --git a/lisp/mail/rmailsum.el b/lisp/mail/rmailsum.el index 18a36e5f0e9..48c5cb70b33 100644 --- a/lisp/mail/rmailsum.el +++ b/lisp/mail/rmailsum.el @@ -436,19 +436,19 @@ headers of the messages." (unless (and rmail-summary-message-parents-vector (= (length rmail-summary-message-parents-vector) (1+ rmail-total-messages))) - (rmail-summary-fill-message-parents-and-descs-vectors)) - (let ((enc-msgs (make-bool-vector (1+ rmail-total-messages) nil))) - (rmail-summary--walk-thread-message-recursively msgnum enc-msgs) - (rmail-new-summary (format "thread containing message %d" msgnum) - (list 'rmail-summary-by-thread msgnum) - (if (and rmail-summary-progressively-narrow - (rmail-summary--exists-1)) - (lambda (msg _msgnum) - (and (aref rmail-summary-currently-displayed-msgs msg) - (aref enc-msgs msg))) + (rmail-summary-fill-message-parents-and-descs-vectors))) + (let ((enc-msgs (make-bool-vector (1+ rmail-total-messages) nil))) + (rmail-summary--walk-thread-message-recursively msgnum enc-msgs) + (rmail-new-summary (format "thread containing message %d" msgnum) + (list 'rmail-summary-by-thread msgnum) + (if (and rmail-summary-progressively-narrow + (rmail-summary--exists-1)) (lambda (msg _msgnum) - (aref enc-msgs msg))) - msgnum)))) + (and (aref rmail-summary-currently-displayed-msgs msg) + (aref enc-msgs msg))) + (lambda (msg _msgnum) + (aref enc-msgs msg))) + msgnum))) ;;;###autoload (defun rmail-summary-by-labels (labels) diff --git a/lisp/mail/supercite.el b/lisp/mail/supercite.el index c3fa738150e..9104feb6219 100644 --- a/lisp/mail/supercite.el +++ b/lisp/mail/supercite.el @@ -817,7 +817,7 @@ If there was no mail header with FIELD as its key, return the value of (defun sc-mail-field-query (arg) "View the value of a mail field. -With `\\[universal-argument]', prompts for action on mail field. +With \\[universal-argument], prompts for action on mail field. Action can be one of: View, Modify, Add, or Delete." (interactive "P") (let* ((alist '(("view" . ?v) ("modify" . ?m) ("add" . ?a) ("delete" . ?d))) @@ -1710,7 +1710,7 @@ Numeric ARG indicates which header style from `sc-rewrite-header-list' to use when rewriting the header. No supplied ARG indicates use of `sc-preferred-header-style'. -With just `\\[universal-argument]', electric reference insert mode is +With just \\[universal-argument], electric reference insert mode is entered, regardless of the value of `sc-electric-references-p'. See `sc-electric-mode' for more information." (interactive "P") @@ -1930,7 +1930,7 @@ With numeric ARG, inserts that many new lines." (defun sc-insert-citation (arg) "Insert citation string at beginning of current line if not already cited. -With `\\[universal-argument]' insert citation even if line is already +With \\[universal-argument] insert citation even if line is already cited." (interactive "P") (save-excursion diff --git a/lisp/man.el b/lisp/man.el index 55cb9383bec..d96396483d3 100644 --- a/lisp/man.el +++ b/lisp/man.el @@ -761,7 +761,11 @@ and the `Man-section-translations-alist' variables)." (setq name (match-string 2 ref) section (match-string 1 ref)))) (if (string= name "") - ref ; Return the reference as is + ;; see Bug#66390 + (mapconcat 'identity + (mapcar #'shell-quote-argument + (split-string ref "\\s-+")) + " ") ; Return the reference as is (if Man-downcase-section-letters-flag (setq section (downcase section))) (while slist diff --git a/lisp/menu-bar.el b/lisp/menu-bar.el index 477e3036b47..320fabb54cf 100644 --- a/lisp/menu-bar.el +++ b/lisp/menu-bar.el @@ -1353,6 +1353,15 @@ mail status in mode line")) (frame-visible-p (symbol-value 'speedbar-frame)))))) + (bindings--define-key menu [showhide-outline-minor-mode] + '(menu-item "Outlines" outline-minor-mode + :help "Turn outline-minor-mode on/off" + :visible (seq-some #'local-variable-p + '(outline-search-function + outline-regexp outline-level)) + :button (:toggle . (and (boundp 'outline-minor-mode) + outline-minor-mode)))) + (bindings--define-key menu [showhide-tab-line-mode] '(menu-item "Window Tab Line" global-tab-line-mode :help "Turn window-local tab-lines on/off" @@ -1438,6 +1447,14 @@ mail status in mode line")) (defvar menu-bar-line-wrapping-menu (let ((menu (make-sparse-keymap "Line Wrapping"))) + (bindings--define-key menu [visual-wrap] + '(menu-item "Visual Wrap Prefix mode" visual-wrap-prefix-mode + :help "Display continuation lines with visual context-dependent prefix" + :visible (menu-bar-menu-frame-live-and-visible-p) + :button (:toggle + . (bound-and-true-p visual-wrap-prefix-mode)) + :enable t)) + (bindings--define-key menu [word-wrap] '(menu-item "Word Wrap (Visual Line mode)" menu-bar--visual-line-mode-enable @@ -1821,6 +1838,9 @@ mail status in mode line")) (bindings--define-key menu [project-open-file] '(menu-item "Open File..." project-find-file :help "Open an existing file that belongs to current project")) menu)) +(defvar menu-bar-project-item + `(menu-item "Project" ,menu-bar-project-menu)) + (defun menu-bar-read-mail () "Read mail using `read-mail-command'." (interactive) @@ -1908,7 +1928,7 @@ mail status in mode line")) :help "Start language server suitable for this buffer's major-mode")) (bindings--define-key menu [project] - `(menu-item "Project" ,menu-bar-project-menu)) + menu-bar-project-item) (bindings--define-key menu [ede] '(menu-item "Project Support (EDE)" diff --git a/lisp/mh-e/mh-funcs.el b/lisp/mh-e/mh-funcs.el index 2684722eb26..bb3e67467d5 100644 --- a/lisp/mh-e/mh-funcs.el +++ b/lisp/mh-e/mh-funcs.el @@ -108,7 +108,7 @@ folder. This is useful for folders that are easily regenerated." (window-config mh-previous-window-config)) (mh-set-folder-modified-p t) ; lock folder to kill it (mh-exec-cmd-daemon "rmf" 'mh-rmf-daemon folder) - (when (boundp 'mh-speed-folder-map) + (when (and (boundp 'speedbar-buffer) speedbar-buffer) (mh-speed-invalidate-map folder)) (mh-remove-from-sub-folders-cache folder) (mh-set-folder-modified-p nil) ; so kill-buffer doesn't complain diff --git a/lisp/mh-e/mh-search.el b/lisp/mh-e/mh-search.el index f475973631c..59dad161c11 100644 --- a/lisp/mh-e/mh-search.el +++ b/lisp/mh-e/mh-search.el @@ -1569,7 +1569,7 @@ If the folder returned doesn't exist then it is created." (save-excursion (mh-exec-cmd-quiet nil "rmf" chosen-name)) (mh-exec-cmd-quiet nil "folder" "-create" "-fast" chosen-name) (mh-remove-from-sub-folders-cache chosen-name) - (when (boundp 'mh-speed-folder-map) + (when (and (boundp 'speedbar-buffer) speedbar-buffer) (mh-speed-add-folder chosen-name)) chosen-name)) diff --git a/lisp/mh-e/mh-utils.el b/lisp/mh-e/mh-utils.el index 7943879d887..9d5711105ba 100644 --- a/lisp/mh-e/mh-utils.el +++ b/lisp/mh-e/mh-utils.el @@ -795,7 +795,7 @@ used in searching." (message "Creating %s" folder-name) (mh-exec-cmd-error nil "folder" folder-name) (mh-remove-from-sub-folders-cache folder-name) - (when (boundp 'mh-speed-folder-map) + (when (and (boundp 'speedbar-buffer) speedbar-buffer) (mh-speed-add-folder folder-name)) (message "Creating %s...done" folder-name)) (new-file-flag diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index fa2dcb4f698..0a844c538b4 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -150,8 +150,29 @@ The metadata of a completion table should be constant between two boundaries." minibuffer-completion-table minibuffer-completion-predicate)) +(defun completion--metadata-get-1 (metadata prop) + (or (alist-get prop metadata) + (plist-get completion-extra-properties + ;; Cache the keyword + (or (get prop 'completion-extra-properties--keyword) + (put prop 'completion-extra-properties--keyword + (intern (concat ":" (symbol-name prop)))))))) + (defun completion-metadata-get (metadata prop) - (cdr (assq prop metadata))) + "Get property PROP from completion METADATA. +If the metadata specifies a completion category, the variables +`completion-category-overrides' and +`completion-category-defaults' take precedence for +category-specific overrides. If the completion metadata does not +specify the property, the `completion-extra-properties' plist is +consulted. Note that the keys of the +`completion-extra-properties' plist are keyword symbols, not +plain symbols." + (if-let (((not (eq prop 'category))) + (cat (completion--metadata-get-1 metadata 'category)) + (over (completion--category-override cat prop))) + (cdr over) + (completion--metadata-get-1 metadata prop))) (defun complete-with-action (action collection string predicate) "Perform completion according to ACTION. @@ -300,7 +321,7 @@ the form (concat S2 S)." ;; Predicates are called differently depending on the nature of ;; the completion table :-( (cond - ((vectorp table) ;Obarray. + ((obarrayp table) (lambda (sym) (funcall pred (concat prefix (symbol-name sym))))) ((hash-table-p table) (lambda (s _v) (funcall pred (concat prefix s)))) @@ -1135,23 +1156,42 @@ styles for specific categories, such as files, buffers, etc." (project-file (styles . (substring))) (xref-location (styles . (substring))) (info-menu (styles . (basic substring))) - (symbol-help (styles . (basic shorthand substring)))) + (symbol-help (styles . (basic shorthand substring))) + (calendar-month (display-sort-function . identity))) "Default settings for specific completion categories. + Each entry has the shape (CATEGORY . ALIST) where ALIST is an association list that can specify properties such as: - `styles': the list of `completion-styles' to use for that category. - `cycle': the `completion-cycle-threshold' to use for that category. +- `cycle-sort-function': function to sort entries when cycling. +- `display-sort-function': function to sort entries in *Completions*. +- `group-function': function for grouping the completion candidates. +- `annotation-function': function to add annotations in *Completions*. +- `affixation-function': function to prepend/append a prefix/suffix. + Categories are symbols such as `buffer' and `file', used when completing buffer and file names, respectively. Also see `completion-category-overrides'.") (defcustom completion-category-overrides nil - "List of category-specific user overrides for completion styles. + "List of category-specific user overrides for completion metadata. + Each override has the shape (CATEGORY . ALIST) where ALIST is an association list that can specify properties such as: - `styles': the list of `completion-styles' to use for that category. - `cycle': the `completion-cycle-threshold' to use for that category. +- `cycle-sort-function': function to sort entries when cycling. +- `display-sort-function': nil means to use either the sorting +function from metadata, or if that is nil, fall back to `completions-sort'; +`identity' disables sorting and keeps the original order; and other +possible values are the same as in `completions-sort'. +- `group-function': function for grouping the completion candidates. +- `annotation-function': function to add annotations in *Completions*. +- `affixation-function': function to prepend/append a prefix/suffix. +See more description of metadata in `completion-metadata'. + Categories are symbols such as `buffer' and `file', used when completing buffer and file names, respectively. @@ -1171,7 +1211,33 @@ overrides the default specified in `completion-category-defaults'." ,completion--styles-type) (cons :tag "Completion Cycling" (const :tag "Select one value from the menu." cycle) - ,completion--cycling-threshold-type)))) + ,completion--cycling-threshold-type) + (cons :tag "Cycle Sorting" + (const :tag "Select one value from the menu." + cycle-sort-function) + (choice (function :tag "Custom function"))) + (cons :tag "Completion Sorting" + (const :tag "Select one value from the menu." + display-sort-function) + (choice (const :tag "Use default" nil) + (const :tag "No sorting" identity) + (const :tag "Alphabetical sorting" + minibuffer-sort-alphabetically) + (const :tag "Historical sorting" + minibuffer-sort-by-history) + (function :tag "Custom function"))) + (cons :tag "Completion Groups" + (const :tag "Select one value from the menu." + group-function) + (choice (function :tag "Custom function"))) + (cons :tag "Completion Annotation" + (const :tag "Select one value from the menu." + annotation-function) + (choice (function :tag "Custom function"))) + (cons :tag "Completion Affixation" + (const :tag "Select one value from the menu." + affixation-function) + (choice (function :tag "Custom function")))))) (defun completion--category-override (category tag) (or (assq tag (cdr (assq category completion-category-overrides))) @@ -1904,10 +1970,13 @@ appear to be a match." ;; Allow user to specify null string ((= beg end) (funcall exit-function)) ;; The CONFIRM argument is a predicate. - ((and (functionp minibuffer-completion-confirm) - (funcall minibuffer-completion-confirm - (buffer-substring beg end))) - (funcall exit-function)) + ((functionp minibuffer-completion-confirm) + (if (funcall minibuffer-completion-confirm + (buffer-substring beg end)) + (funcall exit-function) + (unless completion-fail-discreetly + (ding) + (completion--message "No match")))) ;; See if we have a completion from the table. ((test-completion (buffer-substring beg end) minibuffer-completion-table @@ -2379,6 +2448,9 @@ candidates." "Property list of extra properties of the current completion job. These include: +`:category': the kind of objects returned by `all-completions'. + Used by `completion-category-overrides'. + `:annotation-function': Function to annotate the completions buffer. The function must accept one argument, a completion string, and return either nil or a string which is to be displayed @@ -2394,6 +2466,15 @@ These include: `:annotation-function' when both are provided, so only this function is used. +`:group-function': Function for grouping the completion candidates. + +`:display-sort-function': Function to sort entries in *Completions*. + +`:cycle-sort-function': Function to sort entries when cycling. + +See more information about these functions above +in `completion-metadata'. + `:exit-function': Function to run after completion is performed. The function must accept two arguments, STRING and STATUS. @@ -2516,12 +2597,8 @@ The candidate will still be chosen by `choose-completion' unless base-size md minibuffer-completion-table minibuffer-completion-predicate)) - (ann-fun (or (completion-metadata-get all-md 'annotation-function) - (plist-get completion-extra-properties - :annotation-function))) - (aff-fun (or (completion-metadata-get all-md 'affixation-function) - (plist-get completion-extra-properties - :affixation-function))) + (ann-fun (completion-metadata-get all-md 'annotation-function)) + (aff-fun (completion-metadata-get all-md 'affixation-function)) (sort-fun (completion-metadata-get all-md 'display-sort-function)) (group-fun (completion-metadata-get all-md 'group-function)) (mainbuf (current-buffer)) @@ -3075,30 +3152,41 @@ the mode hook of this mode." (setq-local minibuffer-completion-auto-choose nil))) (defcustom minibuffer-visible-completions nil - "When non-nil, visible completions can be navigated from the minibuffer. -This means that when the *Completions* buffer is visible in a window, -then you can use the arrow keys in the minibuffer to move the cursor -in the *Completions* buffer. Then you can type `RET', -and the candidate highlighted in the *Completions* buffer -will be accepted. -But when the *Completions* buffer is not displayed on the screen, -then the arrow keys move point in the minibuffer as usual, and -`RET' accepts the input typed in the minibuffer." + "Whether candidates shown in *Completions* can be navigated from minibuffer. +When non-nil, if the *Completions* buffer is displayed in a window, +you can use the arrow keys in the minibuffer to move the cursor in +the window showing the *Completions* buffer. Typing `RET' selects +the highlighted completion candidate. +If the *Completions* buffer is not displayed on the screen, or this +variable is nil, the arrow keys move point in the minibuffer as usual, +and `RET' accepts the input typed into the minibuffer." :type 'boolean :version "30.1") +(defvar minibuffer-visible-completions--always-bind nil + "If non-nil, force the `minibuffer-visible-completions' bindings on.") + +(defun minibuffer-visible-completions--filter (cmd) + "Return CMD if `minibuffer-visible-completions' bindings should be active." + (if minibuffer-visible-completions--always-bind + cmd + (when-let ((window (get-buffer-window "*Completions*" 0))) + (when (and (eq (buffer-local-value 'completion-reference-buffer + (window-buffer window)) + (window-buffer (active-minibuffer-window))) + (if (eq cmd #'minibuffer-choose-completion-or-exit) + (with-current-buffer (window-buffer window) + (get-text-property (point) 'completion--string)) + t)) + cmd)))) + (defun minibuffer-visible-completions-bind (binding) "Use BINDING when completions are visible. Return an item that is enabled only when a window displaying the *Completions* buffer exists." `(menu-item "" ,binding - :filter ,(lambda (cmd) - (when-let ((window (get-buffer-window "*Completions*" 0))) - (when (eq (buffer-local-value 'completion-reference-buffer - (window-buffer window)) - (window-buffer (active-minibuffer-window))) - cmd))))) + :filter ,#'minibuffer-visible-completions--filter)) (defvar-keymap minibuffer-visible-completions-map :doc "Local keymap for minibuffer input with visible completions." @@ -3409,9 +3497,10 @@ Fourth arg MUSTMATCH can take the following values: input, but she needs to confirm her choice if she called `minibuffer-complete' right before `minibuffer-complete-and-exit' and the input is not an existing file. -- a function, which will be called with the input as the - argument. If the function returns a non-nil value, the - minibuffer is exited with that argument as the value. +- a function, which will be called with a single argument, the + input unquoted by `substitute-in-file-name', which see. If the + function returns a non-nil value, the minibuffer is exited with + that argument as the value. - anything else behaves like t except that typing RET does not exit if it does non-null completion. @@ -3500,7 +3589,13 @@ See `read-file-name' for the meaning of the arguments." (let ((ignore-case read-file-name-completion-ignore-case) (minibuffer-completing-file-name t) (pred (or predicate 'file-exists-p)) - (add-to-history nil)) + (add-to-history nil) + (require-match (if (functionp mustmatch) + (lambda (input) + (funcall mustmatch + ;; User-supplied MUSTMATCH expects an unquoted filename + (substitute-in-file-name input))) + mustmatch))) (let* ((val (if (or (not (next-read-file-uses-dialog-p)) @@ -3536,7 +3631,7 @@ See `read-file-name' for the meaning of the arguments." (read-file-name--defaults dir initial)))) (set-syntax-table minibuffer-local-filename-syntax)) (completing-read prompt 'read-file-name-internal - pred mustmatch insdef + pred require-match insdef 'file-name-history default-filename))) ;; If DEFAULT-FILENAME not supplied and DIR contains ;; a file name, split it. diff --git a/lisp/mouse.el b/lisp/mouse.el index d1b06c2040d..cef88dede8a 100644 --- a/lisp/mouse.el +++ b/lisp/mouse.el @@ -393,6 +393,7 @@ and should return the same menu with changes such as added new menu items." (function-item context-menu-local) (function-item context-menu-minor) (function-item context-menu-buffers) + (function-item context-menu-project) (function-item context-menu-vc) (function-item context-menu-ffap) (function-item hi-lock-context-menu) @@ -414,13 +415,17 @@ Each function receives the menu and the mouse click event and returns the same menu after adding own menu items to the composite menu. When there is a text property `context-menu-function' at CLICK, it overrides all functions from `context-menu-functions'. +Whereas the property `context-menu-functions' doesn't override +the variable `context-menu-functions', but adds menus from the +list in the property after adding menus from the variable. At the end, it's possible to modify the final menu by specifying the function `context-menu-filter-function'." (let* ((menu (make-sparse-keymap (propertize "Context Menu" 'hide t))) (click (or click last-input-event)) - (window (posn-window (event-start click))) - (fun (mouse-posn-property (event-start click) - 'context-menu-function))) + (start (event-start click)) + (window (posn-window start)) + (fun (mouse-posn-property start 'context-menu-function)) + (funs (mouse-posn-property start 'context-menu-functions))) (unless (eq (selected-window) window) (select-window window)) @@ -430,7 +435,9 @@ the function `context-menu-filter-function'." (run-hook-wrapped 'context-menu-functions (lambda (fun) (setq menu (funcall fun menu click)) - nil))) + nil)) + (dolist (fun funs) + (setq menu (funcall fun menu click)))) ;; Remove duplicate separators as well as ones at the beginning or ;; end of the menu. @@ -527,6 +534,12 @@ Some context functions add menu items below the separator." (mouse-buffer-menu-keymap)) menu) +(defun context-menu-project (menu _click) + "Populate MENU with project commands." + (define-key-after menu [separator-project] menu-bar-separator) + (define-key-after menu [project-menu] menu-bar-project-item) + menu) + (defun context-menu-vc (menu _click) "Populate MENU with Version Control commands." (define-key-after menu [separator-vc] menu-bar-separator) diff --git a/lisp/mpc.el b/lisp/mpc.el index 9577e0f2f42..768c70c2e3a 100644 --- a/lisp/mpc.el +++ b/lisp/mpc.el @@ -1867,11 +1867,14 @@ A value of t means the main playlist.") (defvar mpc-volume nil) (put 'mpc-volume 'risky-local-variable t) (defun mpc-volume-refresh () - ;; Maintain the volume. - (setq mpc-volume - (mpc-volume-widget - (string-to-number (cdr (assq 'volume mpc-status))))) - (let ((status-buf (mpc-proc-buffer (mpc-proc) 'status))) + "Maintain the volume." + (let ((status-buf (mpc-proc-buffer (mpc-proc) 'status)) + (status-vol (cdr (assq 'volume mpc-status)))) + ;; If MPD is paused or stopped the volume is nil. + (when status-vol + (setq mpc-volume + (mpc-volume-widget + (string-to-number status-vol)))) (when (buffer-live-p status-buf) (with-current-buffer status-buf (force-mode-line-update))))) diff --git a/lisp/mwheel.el b/lisp/mwheel.el index b75b6f27d53..66a1fa1a706 100644 --- a/lisp/mwheel.el +++ b/lisp/mwheel.el @@ -34,8 +34,8 @@ ;; Implementation note: ;; ;; I for one would prefer some way of converting the mouse-4/mouse-5 -;; events into different event types, like 'mwheel-up' or -;; 'mwheel-down', but I cannot find a way to do this very easily (or +;; events into different event types, like 'wheel-up' or +;; 'wheel-down', but I cannot find a way to do this very easily (or ;; portably), so for now I just live with it. (require 'timer) @@ -56,49 +56,24 @@ (bound-and-true-p mouse-wheel-mode)) (mouse-wheel-mode 1))) +(defvar mouse-wheel-obey-old-style-wheel-buttons t + "If non-nil, treat mouse-4/5/6/7 events as mouse wheel events. +These are the event names used historically in X11 before XInput2. +They are sometimes generated by things like text-terminals as well.") + (defcustom mouse-wheel-down-event - (if (or (featurep 'w32-win) (featurep 'ns-win) - (featurep 'haiku-win) (featurep 'pgtk-win) - (featurep 'android-win)) - 'wheel-up - 'mouse-4) - "Event used for scrolling down." - :group 'mouse - :type 'symbol - :set 'mouse-wheel-change-button) - -(defcustom mouse-wheel-down-alternate-event - (if (featurep 'xinput2) - 'wheel-up - (unless (featurep 'x) - 'mouse-4)) - "Alternative wheel down event to consider." + (if mouse-wheel-obey-old-style-wheel-buttons 'mouse-4) + "Event used for scrolling down, beside `wheel-up', if any." :group 'mouse :type 'symbol - :version "29.1" - :set 'mouse-wheel-change-button) + :set #'mouse-wheel-change-button) (defcustom mouse-wheel-up-event - (if (or (featurep 'w32-win) (featurep 'ns-win) - (featurep 'haiku-win) (featurep 'pgtk-win) - (featurep 'android-win)) - 'wheel-down - 'mouse-5) - "Event used for scrolling up." + (if mouse-wheel-obey-old-style-wheel-buttons 'mouse-5) + "Event used for scrolling up, beside `wheel-down', if any." :group 'mouse :type 'symbol - :set 'mouse-wheel-change-button) - -(defcustom mouse-wheel-up-alternate-event - (if (featurep 'xinput2) - 'wheel-down - (unless (featurep 'x) - 'mouse-5)) - "Alternative wheel up event to consider." - :group 'mouse - :type 'symbol - :version "29.1" - :set 'mouse-wheel-change-button) + :set #'mouse-wheel-change-button) (defcustom mouse-wheel-click-event 'mouse-2 "Event that should be temporarily inhibited after mouse scrolling. @@ -108,7 +83,7 @@ scrolling with the mouse wheel. To prevent that, this variable can be set to the event sent when clicking on the mouse wheel button." :group 'mouse :type 'symbol - :set 'mouse-wheel-change-button) + :set #'mouse-wheel-change-button) (defcustom mouse-wheel-inhibit-click-time 0.35 "Time in seconds to inhibit clicking on mouse wheel button after scroll." @@ -165,7 +140,7 @@ information, see `text-scale-adjust' and `global-text-scale-adjust'." (const :tag "Scroll horizontally" :value hscroll) (const :tag "Change buffer face size" :value text-scale) (const :tag "Change global face size" :value global-text-scale))))) - :set 'mouse-wheel-change-button + :set #'mouse-wheel-change-button :version "28.1") (defcustom mouse-wheel-progressive-speed t @@ -216,15 +191,9 @@ Also see `mouse-wheel-tilt-scroll'." :type 'boolean :version "26.1") -(defun mwheel-event-button (event) - (let ((x (event-basic-type event))) - ;; Map mouse-wheel events to appropriate buttons - (if (eq 'mouse-wheel x) - (let ((amount (car (cdr (cdr (cdr event)))))) - (if (< amount 0) - mouse-wheel-up-event - mouse-wheel-down-event)) - x))) +;; This function used to handle the `mouse-wheel` event which was +;; removed in 2003 by commit 9eb28007fb27, thus making it obsolete. +(define-obsolete-function-alias 'mwheel-event-button #'event-basic-type "30.1") (defun mwheel-event-window (event) (posn-window (event-start event))) @@ -255,34 +224,12 @@ Also see `mouse-wheel-tilt-scroll'." "Function that does the job of scrolling right.") (defvar mouse-wheel-left-event - (if (or (featurep 'w32-win) (featurep 'ns-win) - (featurep 'haiku-win) (featurep 'pgtk-win) - (featurep 'android-win)) - 'wheel-left - 'mouse-6) - "Event used for scrolling left.") - -(defvar mouse-wheel-left-alternate-event - (if (featurep 'xinput2) - 'wheel-left - (unless (featurep 'x) - 'mouse-6)) - "Alternative wheel left event to consider.") + (if mouse-wheel-obey-old-style-wheel-buttons 'mouse-6) + "Event used for scrolling left, beside `wheel-left', if any.") (defvar mouse-wheel-right-event - (if (or (featurep 'w32-win) (featurep 'ns-win) - (featurep 'haiku-win) (featurep 'pgtk-win) - (featurep 'android-win)) - 'wheel-right - 'mouse-7) - "Event used for scrolling right.") - -(defvar mouse-wheel-right-alternate-event - (if (featurep 'xinput2) - 'wheel-right - (unless (featurep 'x) - 'mouse-7)) - "Alternative wheel right event to consider.") + (if mouse-wheel-obey-old-style-wheel-buttons 'mouse-7) + "Event used for scrolling right, beside `wheel-right', if any.") (defun mouse-wheel--get-scroll-window (event) "Return window for mouse wheel event EVENT. @@ -311,6 +258,23 @@ active window." frame nil t))))) (mwheel-event-window event))) +(defmacro mwheel--is-dir-p (dir button) + (declare (debug (sexp form))) + (let ((custom-var (intern (format "mouse-wheel-%s-event" dir))) + ;; N.B. that the direction `down' in a wheel event refers to + ;; the movement of the section of the buffer the window is + ;; displaying, that is to say, the direction `scroll-up' moves + ;; it in. + (event (intern (format "wheel-%s" (cond ((eq dir 'up) + 'down) + ((eq dir 'down) + 'up) + (t dir)))))) + (macroexp-let2 nil butsym button + `(or (eq ,butsym ',event) + ;; We presume here `button' is never nil. + (eq ,butsym ,custom-var))))) + (defun mwheel-scroll (event &optional arg) "Scroll up or down according to the EVENT. This should be bound only to mouse buttons 4, 5, 6, and 7 on @@ -347,18 +311,17 @@ value of ARG, and the command uses it in subsequent scrolls." (when (numberp amt) (setq amt (* amt (event-line-count event)))) (condition-case nil (unwind-protect - (let ((button (mwheel-event-button event))) - (cond ((and (eq amt 'hscroll) (memq button (list mouse-wheel-down-event - mouse-wheel-down-alternate-event))) + (let ((button (event-basic-type event))) + (cond ((and (eq amt 'hscroll) (mwheel--is-dir-p down button)) (when (and (natnump arg) (> arg 0)) (setq mouse-wheel-scroll-amount-horizontal arg)) (funcall (if mouse-wheel-flip-direction mwheel-scroll-left-function mwheel-scroll-right-function) mouse-wheel-scroll-amount-horizontal)) - ((memq button (list mouse-wheel-down-event - mouse-wheel-down-alternate-event)) - (condition-case nil (funcall mwheel-scroll-down-function amt) + ((mwheel--is-dir-p down button) + (condition-case nil + (funcall mwheel-scroll-down-function amt) ;; Make sure we do indeed scroll to the beginning of ;; the buffer. (beginning-of-buffer @@ -372,31 +335,30 @@ value of ARG, and the command uses it in subsequent scrolls." ;; for a reason that escapes me. This problem seems ;; to only affect scroll-down. --Stef (set-window-start (selected-window) (point-min)))))) - ((and (eq amt 'hscroll) (memq button (list mouse-wheel-up-event - mouse-wheel-up-alternate-event))) + ((and (eq amt 'hscroll) (mwheel--is-dir-p up button)) (when (and (natnump arg) (> arg 0)) (setq mouse-wheel-scroll-amount-horizontal arg)) (funcall (if mouse-wheel-flip-direction mwheel-scroll-right-function mwheel-scroll-left-function) mouse-wheel-scroll-amount-horizontal)) - ((memq button (list mouse-wheel-up-event - mouse-wheel-up-alternate-event)) + ((mwheel--is-dir-p up button) (condition-case nil (funcall mwheel-scroll-up-function amt) ;; Make sure we do indeed scroll to the end of the buffer. - (end-of-buffer (while t (funcall mwheel-scroll-up-function))))) - ((memq button (list mouse-wheel-left-event - mouse-wheel-left-alternate-event)) ; for tilt scroll + (end-of-buffer + (while t (funcall mwheel-scroll-up-function))))) + ((mwheel--is-dir-p left button) ; for tilt scroll (when mouse-wheel-tilt-scroll (funcall (if mouse-wheel-flip-direction mwheel-scroll-right-function - mwheel-scroll-left-function) amt))) - ((memq button (list mouse-wheel-right-event - mouse-wheel-right-alternate-event)) ; for tilt scroll + mwheel-scroll-left-function) + amt))) + ((mwheel--is-dir-p right button) ; for tilt scroll (when mouse-wheel-tilt-scroll (funcall (if mouse-wheel-flip-direction mwheel-scroll-left-function - mwheel-scroll-right-function) amt))) + mwheel-scroll-right-function) + amt))) (t (error "Bad binding in mwheel-scroll")))) (if (eq scroll-window selected-window) ;; If there is a temporarily active region, deactivate it if @@ -434,14 +396,12 @@ See also `text-scale-adjust'." (interactive (list last-input-event)) (let ((selected-window (selected-window)) (scroll-window (mouse-wheel--get-scroll-window event)) - (button (mwheel-event-button event))) + (button (event-basic-type event))) (select-window scroll-window 'mark-for-redisplay) (unwind-protect - (cond ((memq button (list mouse-wheel-down-event - mouse-wheel-down-alternate-event)) + (cond ((mwheel--is-dir-p down button) (text-scale-increase 1)) - ((memq button (list mouse-wheel-up-event - mouse-wheel-up-alternate-event)) + ((mwheel--is-dir-p up button) (text-scale-decrease 1))) (select-window selected-window)))) @@ -450,12 +410,10 @@ See also `text-scale-adjust'." "Increase or decrease the global font size according to the EVENT. This invokes `global-text-scale-adjust', which see." (interactive (list last-input-event)) - (let ((button (mwheel-event-button event))) - (cond ((memq button (list mouse-wheel-down-event - mouse-wheel-down-alternate-event)) + (let ((button (event-basic-type event))) + (cond ((mwheel--is-dir-p down button) (global-text-scale-adjust 1)) - ((memq button (list mouse-wheel-up-event - mouse-wheel-up-alternate-event)) + ((mwheel--is-dir-p up button) (global-text-scale-adjust -1))))) (defun mouse-wheel--add-binding (key fun) @@ -507,15 +465,13 @@ an event used for scrolling, such as `mouse-wheel-down-event'." ;; Bindings for changing font size. ((and (consp binding) (eq (cdr binding) 'text-scale)) (dolist (event (list mouse-wheel-down-event mouse-wheel-up-event - mouse-wheel-down-alternate-event - mouse-wheel-up-alternate-event)) + 'wheel-down 'wheel-up)) (when event (mouse-wheel--add-binding `[,(append (car binding) (list event))] 'mouse-wheel-text-scale)))) ((and (consp binding) (eq (cdr binding) 'global-text-scale)) (dolist (event (list mouse-wheel-down-event mouse-wheel-up-event - mouse-wheel-down-alternate-event - mouse-wheel-up-alternate-event)) + 'wheel-down 'wheel-up)) (when event (mouse-wheel--add-binding `[,(append (car binding) (list event))] 'mouse-wheel-global-text-scale)))) @@ -523,10 +479,7 @@ an event used for scrolling, such as `mouse-wheel-down-event'." (t (dolist (event (list mouse-wheel-down-event mouse-wheel-up-event mouse-wheel-left-event mouse-wheel-right-event - mouse-wheel-down-alternate-event - mouse-wheel-up-alternate-event - mouse-wheel-left-alternate-event - mouse-wheel-right-alternate-event)) + 'wheel-down 'wheel-up 'wheel-left 'wheel-right)) (when event (dolist (key (mouse-wheel--create-scroll-keys binding event)) (mouse-wheel--add-binding key 'mwheel-scroll)))))))) diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index 359453ca433..f22aa19f5e3 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -688,8 +688,10 @@ websites are increasingly rare, but they do still exist." (defun browse-url-url-at-point () (or (thing-at-point 'url t) ;; assume that the user is pointing at something like gnu.org/gnu - (let ((f (thing-at-point 'filename t))) - (and f (concat browse-url-default-scheme "://" f))))) + (when-let ((f (thing-at-point 'filename t))) + (if (string-match-p browse-url-button-regexp f) + f + (concat browse-url-default-scheme "://" f))))) ;; Having this as a separate function called by the browser-specific ;; functions allows them to be stand-alone commands, making it easier @@ -702,8 +704,10 @@ it defaults to the current region, else to the URL at or before point. If invoked with a mouse button, it moves point to the position clicked before acting. -This function returns a list (URL NEW-WINDOW-FLAG) -for use in `interactive'." +This function returns a list (URL NEW-WINDOW-FLAG) for use in +`interactive'. NEW-WINDOW-FLAG is the prefix arg; if +`browse-url-new-window-flag' is non-nil, invert the prefix arg +instead." (let ((event (elt (this-command-keys) 0))) (mouse-set-point event)) (list (read-string prompt (or (and transient-mark-mode mark-active @@ -713,8 +717,7 @@ for use in `interactive'." (buffer-substring-no-properties (region-beginning) (region-end)))) (browse-url-url-at-point))) - (not (eq (null browse-url-new-window-flag) - (null current-prefix-arg))))) + (xor browse-url-new-window-flag current-prefix-arg))) ;; called-interactive-p needs to be called at a function's top-level, hence ;; this macro. We use that rather than interactive-p because @@ -877,8 +880,8 @@ The variables `browse-url-browser-function', `browse-url-handlers', and `browse-url-default-handlers' determine which browser function to use. -This command prompts for a URL, defaulting to the URL at or -before point. +Interactively, this command prompts for a URL, defaulting to the +URL at or before point. The additional ARGS are passed to the browser function. See the doc strings of the actual functions, starting with @@ -886,7 +889,9 @@ doc strings of the actual functions, starting with significance of ARGS (most of the functions ignore it). If ARGS are omitted, the default is to pass -`browse-url-new-window-flag' as ARGS." +`browse-url-new-window-flag' as ARGS. Interactively, pass the +prefix arg as ARGS; if `browse-url-new-window-flag' is non-nil, +invert the prefix arg instead." (interactive (browse-url-interactive-arg "URL: ")) (unless (called-interactively-p 'interactive) (setq args (or args (list browse-url-new-window-flag)))) @@ -1322,7 +1327,7 @@ and instant messengers instead of opening it in a web browser." :type 'boolean :version "30.1") -(declare-function android-browse-url "androidselect.c") +(declare-function android-browse-url "../term/android-win") ;;;###autoload (defun browse-url-default-android-browser (url &optional _new-window) diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el index 77b334e704e..46f85daba24 100644 --- a/lisp/net/dbus.el +++ b/lisp/net/dbus.el @@ -371,11 +371,7 @@ object is returned instead of a list containing this single Lisp object. (apply #'dbus-message-internal dbus-message-type-method-call bus service path interface method #'dbus-call-method-handler args)) - (result (unless executing-kbd-macro (cons :pending nil)))) - - ;; While executing a keyboard macro, we run into an infinite loop, - ;; receiving the event -1. So we don't try to get the result. - ;; (Bug#62018) + (result (cons :pending nil))) ;; Wait until `dbus-call-method-handler' has put the result into ;; `dbus-return-values-table'. If no timeout is given, use the diff --git a/lisp/net/dictionary.el b/lisp/net/dictionary.el index 1981b757017..d4dfa33716c 100644 --- a/lisp/net/dictionary.el +++ b/lisp/net/dictionary.el @@ -787,7 +787,7 @@ FUNCTION is the callback which is called for each search result." Optional argument NOMATCHING controls whether to suppress the display of matching words." - (message "Searching for %s in %s" word dictionary) + (insert (format-message "Searching for `%s' in `%s'\n" word dictionary)) (dictionary-send-command (concat "define " (dictionary-encode-charset dictionary "") " \"" @@ -799,13 +799,13 @@ of matching words." (if (dictionary-check-reply reply 552) (progn (unless nomatching - (insert "Word not found") + (insert (format-message "Word `%s' not found\n" word)) (dictionary-do-matching word dictionary "." (lambda (reply) - (insert ", maybe you are looking for one of these words\n\n") + (insert "Maybe you are looking for one of these words\n") (dictionary-display-only-match-result reply))) (dictionary-post-buffer))) (if (dictionary-check-reply reply 550) @@ -1116,20 +1116,26 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." (defun dictionary-new-matching (word) "Run a new matching search on WORD." - (dictionary-ensure-buffer) (dictionary-store-positions) - (dictionary-do-matching word dictionary-default-dictionary - dictionary-default-strategy - 'dictionary-display-match-result) - (dictionary-store-state 'dictionary-do-matching + (dictionary-ensure-buffer) + (dictionary-new-matching-internal word dictionary-default-dictionary + dictionary-default-strategy + 'dictionary-display-match-result) + (dictionary-store-state 'dictionary-new-matching-internal (list word dictionary-default-dictionary dictionary-default-strategy 'dictionary-display-match-result))) +(defun dictionary-new-matching-internal (word dictionary strategy function) + "Start a new matching for WORD in DICTIONARY after preparing the buffer. +FUNCTION is the callback which is called for each search result." + (dictionary-pre-buffer) + (dictionary-do-matching word dictionary strategy function)) + (defun dictionary-do-matching (word dictionary strategy function) "Search for WORD with STRATEGY in DICTIONARY and display them with FUNCTION." - (message "Lookup matching words for %s in %s using %s" - word dictionary strategy) + (insert (format-message "Lookup matching words for `%s' in `%s' using `%s'\n" + word dictionary strategy)) (dictionary-send-command (concat "match " (dictionary-encode-charset dictionary "") " " (dictionary-encode-charset strategy "") " \"" @@ -1141,10 +1147,13 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." (if (dictionary-check-reply reply 551) (error "Strategy \"%s\" is invalid" strategy)) (if (dictionary-check-reply reply 552) - (error (concat - "No match for \"%s\" with strategy \"%s\" in " - "dictionary \"%s\".") - word strategy dictionary)) + (let ((errmsg (format-message + (concat + "No match for `%s' with strategy `%s' in " + "dictionary `%s'.") + word strategy dictionary))) + (insert errmsg "\n") + (user-error errmsg))) (unless (dictionary-check-reply reply 152) (error "Unknown server answer: %s" (dictionary-reply reply))) (funcall function reply))) @@ -1172,8 +1181,6 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." (defun dictionary-display-match-result (reply) "Display the results in REPLY from a match operation." - (dictionary-pre-buffer) - (let ((number (nth 1 (dictionary-reply-list reply))) (list (dictionary-simple-split-string (dictionary-read-answer) "\n+"))) (insert number " matching word" (if (equal number "1") "" "s") @@ -1271,7 +1278,7 @@ prompt for DICTIONARY." (interactive) (let ((word (current-word))) (unless word - (error "No word at point")) + (user-error "No word at point")) (dictionary-new-search (cons word dictionary-default-dictionary)))) (defun dictionary-previous () @@ -1311,7 +1318,8 @@ prompt for DICTIONARY." (defun dictionary-popup-matching-words (&optional word) "Display entries matching WORD or the current word if not given." (interactive) - (dictionary-do-matching (or word (current-word) (error "Nothing to search for")) + (dictionary-do-matching (or word (current-word) + (user-error "Nothing to search for")) dictionary-default-dictionary dictionary-default-popup-strategy 'dictionary-process-popup-replies)) diff --git a/lisp/net/dns.el b/lisp/net/dns.el index 23ea88ef4ad..54f4d227a49 100644 --- a/lisp/net/dns.el +++ b/lisp/net/dns.el @@ -359,7 +359,7 @@ Parses \"/etc/resolv.conf\" or calls \"nslookup\"." result)) ;;; Interface functions. -(defvar dns-cache (make-vector 4096 0)) +(defvar dns-cache (obarray-make 4096)) (defun dns-query-cached (name &optional type fullp reversep) (let* ((key (format "%s:%s:%s:%s" name type fullp reversep)) diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 22f07cbc5b4..39ea964d47a 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -182,6 +182,33 @@ the tab bar is enabled." (const :tag "Open new tab when tab bar is enabled" tab-bar) (const :tag "Never open URL in new tab" nil))) +(defcustom eww-before-browse-history-function #'eww-delete-future-history + "A function to call to update history before browsing to a new page. +EWW provides the following values for this option: + +* `eww-delete-future-history': Delete any history entries after the + currently-shown one. This is the default behavior, and works the same + as in most other web browsers. + +* `eww-clone-previous-history': Clone and prepend any history entries up + to the currently-shown one. This is like `eww-delete-future-history', + except that it preserves the previous contents of the history list at + the end. + +* `ignore': Preserve the current history unchanged. This will result in + the new page simply being prepended to the existing history list. + +You can also set this to any other function you wish." + :version "30.1" + :group 'eww + :type '(choice (function-item :tag "Delete future history" + eww-delete-future-history) + (function-item :tag "Clone previous history" + eww-clone-previous-history) + (function-item :tag "Preserve history" + ignore) + (function :tag "Custom function"))) + (defcustom eww-after-render-hook nil "A hook called after eww has finished rendering the buffer." :version "25.1" @@ -248,6 +275,27 @@ parameter, and should return the (possibly) transformed URL." :type '(repeat function) :version "29.1") +(defcustom eww-readable-urls nil + "A list of regexps matching URLs to display in readable mode by default. +EWW will display matching URLs using `eww-readable' (which see). + +Each element can be one of the following forms: a regular expression in +string form or a cons cell of the form (REGEXP . READABILITY). If +READABILITY is non-nil, this behaves the same as the string form; +otherwise, URLs matching REGEXP will never be displayed in readable mode +by default." + :type '(repeat (choice (string :tag "Readable URL") + (cons :tag "URL and Readability" + (string :tag "URL") + (radio (const :tag "Readable" t) + (const :tag "Non-readable" nil))))) + :version "30.1") + +(defcustom eww-readable-adds-to-history t + "If non-nil, calling `eww-readable' adds a new entry to the history." + :type 'boolean + :version "30.1") + (defface eww-form-submit '((((type x w32 ns haiku pgtk android) (class color)) ; Like default mode line :box (:line-width 2 :style released-button) @@ -312,7 +360,10 @@ parameter, and should return the (possibly) transformed URL." (defvar eww-data nil) (defvar eww-history nil) -(defvar eww-history-position 0) +(defvar eww-history-position 0 + "The 1-indexed position in `eww-history'. +If zero, EWW is at the newest page, which isn't yet present in +`eww-history'.") (defvar eww-prompt-history nil) (defvar eww-local-regex "localhost" @@ -340,7 +391,7 @@ parameter, and should return the (possibly) transformed URL." (defun eww-suggested-uris nil "Return the list of URIs to suggest at the `eww' prompt. This list can be customized via `eww-suggest-uris'." - (let ((obseen (make-vector 42 0)) + (let ((obseen (obarray-make 42)) (uris nil)) (dolist (fun eww-suggest-uris) (let ((ret (funcall fun))) @@ -402,6 +453,7 @@ For more information, see Info node `(eww) Top'." (t (get-buffer-create "*eww*")))) (eww-setup-buffer) + (eww--before-browse) ;; Check whether the domain only uses "Highly Restricted" Unicode ;; IDNA characters. If not, transform to punycode to indicate that ;; there may be funny business going on. @@ -433,11 +485,11 @@ For more information, see Info node `(eww) Top'." (defun eww-retrieve (url callback cbargs) (cond ((null eww-retrieve-command) - (url-retrieve url #'eww-render cbargs)) + (url-retrieve url callback cbargs)) ((eq eww-retrieve-command 'sync) (let ((data-buffer (url-retrieve-synchronously url))) (with-current-buffer data-buffer - (apply #'eww-render nil url cbargs)))) + (apply callback nil cbargs)))) (t (let ((buffer (generate-new-buffer " *eww retrieve*")) (error-buffer (generate-new-buffer " *eww error*"))) @@ -642,9 +694,9 @@ The renaming scheme is performed in accordance with (insert (format "<a href=%S>Direct link to the document</a>" url)) (goto-char (point-min)) - (eww-display-html charset url nil point buffer encode)) + (eww-display-html (or encode charset) url nil point buffer)) ((eww-html-p (car content-type)) - (eww-display-html charset url nil point buffer encode)) + (eww-display-html (or encode charset) url nil point buffer)) ((equal (car content-type) "application/pdf") (eww-display-pdf)) ((string-match-p "\\`image/" (car content-type)) @@ -654,7 +706,6 @@ The renaming scheme is performed in accordance with (with-current-buffer buffer (plist-put eww-data :url url) (eww--after-page-change) - (setq eww-history-position 0) (and last-coding-system-used (set-buffer-file-coding-system last-coding-system-used)) (unless shr-fill-text @@ -696,34 +747,40 @@ The renaming scheme is performed in accordance with (declare-function libxml-parse-html-region "xml.c" (start end &optional base-url discard-comments)) -(defun eww-display-html (charset url &optional document point buffer encode) +(defun eww--parse-html-region (start end &optional coding-system) + "Parse the HTML between START and END, returning the DOM as an S-expression. +Use CODING-SYSTEM to decode the region; if nil, decode as UTF-8. + +This replaces the region with the preprocessed HTML." + (setq coding-system (or coding-system 'utf-8)) + (with-restriction start end + (condition-case nil + (decode-coding-region (point-min) (point-max) coding-system) + (coding-system-error nil)) + ;; Remove CRLF and replace NUL with � before parsing. + (while (re-search-forward "\\(\r$\\)\\|\0" nil t) + (replace-match (if (match-beginning 1) "" "�") t t)) + (eww--preprocess-html (point-min) (point-max)) + (libxml-parse-html-region (point-min) (point-max)))) + +(defsubst eww-document-base (url dom) + `(base ((href . ,url)) ,dom)) + +(defun eww-display-document (document &optional point buffer) (unless (fboundp 'libxml-parse-html-region) (error "This function requires Emacs to be compiled with libxml2")) + (setq buffer (or buffer (current-buffer))) (unless (buffer-live-p buffer) (error "Buffer %s doesn't exist" buffer)) ;; There should be a better way to abort loading images ;; asynchronously. (setq url-queue nil) - (let ((document - (or document - (list - 'base (list (cons 'href url)) - (progn - (setq encode (or encode charset 'utf-8)) - (condition-case nil - (decode-coding-region (point) (point-max) encode) - (coding-system-error nil)) - (save-excursion - ;; Remove CRLF and replace NUL with � before parsing. - (while (re-search-forward "\\(\r$\\)\\|\0" nil t) - (replace-match (if (match-beginning 1) "" "�") t t))) - (eww--preprocess-html (point) (point-max)) - (libxml-parse-html-region (point) (point-max)))))) - (source (and (null document) - (buffer-substring (point) (point-max))))) + (let ((url (when (eq (car document) 'base) + (alist-get 'href (cadr document))))) + (unless url + (error "Document is missing base URL")) (with-current-buffer buffer (setq bidi-paragraph-direction nil) - (plist-put eww-data :source source) (plist-put eww-data :dom document) (let ((inhibit-read-only t) (inhibit-modification-hooks t) @@ -764,6 +821,20 @@ The renaming scheme is performed in accordance with (forward-line 1))))) (eww-size-text-inputs)))) +(defun eww-display-html (charset url &optional document point buffer) + (let ((source (buffer-substring (point) (point-max)))) + (with-current-buffer buffer + (plist-put eww-data :source source))) + (unless document + (let ((dom (eww--parse-html-region (point) (point-max) charset))) + (when (eww-default-readable-p url) + (eww-score-readability dom) + (setq dom (eww-highest-readability dom)) + (with-current-buffer buffer + (plist-put eww-data :readable t))) + (setq document (eww-document-base url dom)))) + (eww-display-document document point buffer)) + (defun eww-handle-link (dom) (let* ((rel (dom-attr dom 'rel)) (href (dom-attr dom 'href)) @@ -905,6 +976,11 @@ The renaming scheme is performed in accordance with `((?u . ,(or url "")) (?t . ,title)))))))) +(defun eww--before-browse () + (funcall eww-before-browse-history-function) + (setq eww-history-position 0 + eww-data (list :title ""))) + (defun eww--after-page-change () (eww-update-header-line-format) (eww--rename-buffer)) @@ -1020,29 +1096,47 @@ The renaming scheme is performed in accordance with "automatic" bidi-paragraph-direction))) -(defun eww-readable () - "View the main \"readable\" parts of the current web page. +(defun eww-readable (&optional arg) + "Toggle display of only the main \"readable\" parts of the current web page. This command uses heuristics to find the parts of the web page that -contains the main textual portion, leaving out navigation menus and -the like." - (interactive nil eww-mode) +contain the main textual portion, leaving out navigation menus and the +like. + +If called interactively, toggle the display of the readable parts. If +the prefix argument is positive, display the readable parts, and if it +is zero or negative, display the full page. + +If called from Lisp, toggle the display of the readable parts if ARG is +`toggle'. Display the readable parts if ARG is nil, omitted, or is a +positive number. Display the full page if ARG is a negative number. + +When `eww-readable-adds-to-history' is non-nil, calling this function +adds a new entry to `eww-history'." + (interactive (list (if current-prefix-arg + (prefix-numeric-value current-prefix-arg) + 'toggle)) + eww-mode) (let* ((old-data eww-data) - (dom (with-temp-buffer + (make-readable (cond + ((eq arg 'toggle) + (not (plist-get old-data :readable))) + ((and (numberp arg) (< arg 1)) + nil) + (t t))) + (dom (with-temp-buffer (insert (plist-get old-data :source)) - (condition-case nil - (decode-coding-region (point-min) (point-max) 'utf-8) - (coding-system-error nil)) - (eww--preprocess-html (point-min) (point-max)) - (libxml-parse-html-region (point-min) (point-max)))) + (eww--parse-html-region (point-min) (point-max)))) (base (plist-get eww-data :url))) - (eww-score-readability dom) - (eww-save-history) - (eww-display-html nil nil - (list 'base (list (cons 'href base)) - (eww-highest-readability dom)) - nil (current-buffer)) - (dolist (elem '(:source :url :title :next :previous :up :peer)) - (plist-put eww-data elem (plist-get old-data elem))) + (when make-readable + (eww-score-readability dom) + (setq dom (eww-highest-readability dom))) + (when eww-readable-adds-to-history + (eww-save-history) + (eww--before-browse) + (dolist (elem '(:source :url :title :next :previous :up :peer)) + (plist-put eww-data elem (plist-get old-data elem)))) + (eww-display-document (eww-document-base base dom)) + (plist-put eww-data :readable make-readable) (eww--after-page-change))) (defun eww-score-readability (node) @@ -1085,6 +1179,19 @@ the like." (setq result highest)))) result)) +(defun eww-default-readable-p (url) + "Return non-nil if URL should be displayed in readable mode by default. +This consults the entries in `eww-readable-urls' (which see)." + (catch 'found + (let (result) + (dolist (regexp eww-readable-urls) + (if (consp regexp) + (setq result (cdr regexp) + regexp (car regexp)) + (setq result t)) + (when (string-match regexp url) + (throw 'found result)))))) + (defvar-keymap eww-mode-map "g" #'eww-reload ;FIXME: revert-buffer-function instead! "G" #'eww @@ -1129,9 +1236,9 @@ the like." ["Reload" eww-reload t] ["Follow URL in new buffer" eww-open-in-new-buffer] ["Back to previous page" eww-back-url - :active (not (zerop (length eww-history)))] + :active (< eww-history-position (length eww-history))] ["Forward to next page" eww-forward-url - :active (not (zerop eww-history-position))] + :active (> eww-history-position 1)] ["Browse with external browser" eww-browse-with-external-browser t] ["Download" eww-download t] ["View page source" eww-view-source] @@ -1155,9 +1262,9 @@ the like." (easy-menu-define nil easy-menu nil '("Eww" ["Back to previous page" eww-back-url - :visible (not (zerop (length eww-history)))] + :active (< eww-history-position (length eww-history))] ["Forward to next page" eww-forward-url - :visible (not (zerop eww-history-position))] + :active (> eww-history-position 1)] ["Reload" eww-reload t])) (dolist (item (reverse (lookup-key easy-menu [menu-bar eww]))) (when (consp item) @@ -1280,16 +1387,20 @@ instead of `browse-url-new-window-flag'." (interactive nil eww-mode) (when (>= eww-history-position (length eww-history)) (user-error "No previous page")) - (eww-save-history) - (setq eww-history-position (+ eww-history-position 2)) + (if (eww-save-history) + ;; We were at the latest page (which was just added to the + ;; history), so go back two entries. + (setq eww-history-position 2) + (setq eww-history-position (1+ eww-history-position))) (eww-restore-history (elt eww-history (1- eww-history-position)))) (defun eww-forward-url () "Go to the next displayed page." (interactive nil eww-mode) - (when (zerop eww-history-position) + (when (<= eww-history-position 1) (user-error "No next page")) (eww-save-history) + (setq eww-history-position (1- eww-history-position)) (eww-restore-history (elt eww-history (1- eww-history-position)))) (defun eww-restore-history (elem) @@ -1358,8 +1469,7 @@ just re-display the HTML already fetched." (if local (if (null (plist-get eww-data :dom)) (error "No current HTML data") - (eww-display-html 'utf-8 url (plist-get eww-data :dom) - (point) (current-buffer))) + (eww-display-document (plist-get eww-data :dom) (point))) (let ((parsed (url-generic-parse-url url))) (if (equal (url-type parsed) "file") ;; Use Tramp instead of url.el for files (since url.el @@ -1959,6 +2069,7 @@ If EXTERNAL is double prefix, browse in new buffer." (eww-same-page-p url (plist-get eww-data :url))) (let ((point (point))) (eww-save-history) + (eww--before-browse) (plist-put eww-data :url url) (goto-char (point-min)) (if-let ((match (text-property-search-forward 'shr-target-id target #'member))) @@ -2064,9 +2175,10 @@ If CHARSET is nil then use UTF-8." "Prompt for an EWW buffer to display in the selected window." (interactive nil eww-mode) (let ((completion-extra-properties - '(:annotation-function (lambda (buf) - (with-current-buffer buf - (format " %s" (eww-current-url)))))) + `(:annotation-function + ,(lambda (buf) + (with-current-buffer buf + (format " %s" (eww-current-url)))))) (curbuf (current-buffer))) (pop-to-buffer-same-window (read-buffer "Switch to EWW buffer: " @@ -2225,7 +2337,7 @@ If ERROR-OUT, signal user-error if there are no bookmarks." (setq first t) (eww-read-bookmarks t) (eww-bookmark-prepare)) - (with-current-buffer (get-buffer "*eww bookmarks*") + (with-current-buffer "*eww bookmarks*" (when (and (not first) (not (eobp))) (forward-line 1)) @@ -2244,7 +2356,7 @@ If ERROR-OUT, signal user-error if there are no bookmarks." (setq first t) (eww-read-bookmarks t) (eww-bookmark-prepare)) - (with-current-buffer (get-buffer "*eww bookmarks*") + (with-current-buffer "*eww bookmarks*" (if first (goto-char (point-max)) (beginning-of-line)) @@ -2288,11 +2400,69 @@ If ERROR-OUT, signal user-error if there are no bookmarks." ;;; History code (defun eww-save-history () + "Save the current page's data to the history. +If the current page is a historial one loaded from +`eww-history' (e.g. by calling `eww-back-url'), this will update the +page's entry in `eww-history' and return nil. Otherwise, add a new +entry to `eww-history' and return t." (plist-put eww-data :point (point)) (plist-put eww-data :text (buffer-string)) - (let ((history-delete-duplicates nil)) - (add-to-history 'eww-history eww-data eww-history-limit t)) - (setq eww-data (list :title ""))) + (if (zerop eww-history-position) + (let ((history-delete-duplicates nil)) + (add-to-history 'eww-history eww-data eww-history-limit t) + (setq eww-history-position 1) + t) + (setf (elt eww-history (1- eww-history-position)) eww-data) + nil)) + +(defun eww-delete-future-history () + "Remove any entries in `eww-history' after the currently-shown one. +This is useful for `eww-before-browse-history-function' to make EWW's +navigation to a new page from a historical one work like other web +browsers: it will delete any \"future\" history elements before adding +the new page to the end of the history. + +For example, if `eww-history' looks like this (going from newest to +oldest, with \"*\" marking the current page): + + E D C* B A + +then calling this function updates `eww-history' to: + + C* B A" + (when (> eww-history-position 1) + (setq eww-history (nthcdr (1- eww-history-position) eww-history) + ;; We don't really need to set this since `eww--before-browse' + ;; sets it too, but this ensures that other callers can use + ;; this function and get the expected results. + eww-history-position 1))) + +(defun eww-clone-previous-history () + "Clone and prepend entries in `eww-history' up to the currently-shown one. +These cloned entries get added to the beginning of `eww-history' so that +it's possible to navigate back to the very first page for this EWW +without deleting any history entries. + +For example, if `eww-history' looks like this (going from newest to +oldest, with \"*\" marking the current page): + + E D C* B A + +then calling this function updates `eww-history' to: + + C* B A E D C B A + +This is useful for setting `eww-before-browse-history-function' (which +see)." + (when (> eww-history-position 1) + (setq eww-history (take eww-history-limit + (append (nthcdr (1- eww-history-position) + eww-history) + eww-history)) + ;; As with `eww-delete-future-history', we don't really need + ;; to set this since `eww--before-browse' sets it too, but + ;; let's be thorough. + eww-history-position 1))) (defvar eww-current-buffer) diff --git a/lisp/net/imap.el b/lisp/net/imap.el index f10b5b8fc12..a06740528e9 100644 --- a/lisp/net/imap.el +++ b/lisp/net/imap.el @@ -1057,7 +1057,7 @@ necessary. If nil, the buffer name is generated." (setq imap-capability nil) (setq streams nil)))))) (when (imap-opened buffer) - (setq imap-mailbox-data (make-vector imap-mailbox-prime 0))) + (setq imap-mailbox-data (obarray-make imap-mailbox-prime))) ;; (debug "opened+state+auth+buffer" (imap-opened buffer) imap-state imap-auth buffer) (when imap-stream buffer)))) @@ -1280,7 +1280,7 @@ If EXAMINE is non-nil, do a read-only select." (concat (if examine "EXAMINE" "SELECT") " \"" mailbox "\""))) (progn - (setq imap-message-data (make-vector imap-message-prime 0) + (setq imap-message-data (obarray-make imap-message-prime) imap-state (if examine 'examine 'selected)) imap-current-mailbox) ;; Failed SELECT/EXAMINE unselects current mailbox @@ -1722,7 +1722,7 @@ See `imap-enable-exchange-bug-workaround'." (string-to-number (nth 2 (imap-mailbox-get-1 'copyuid mailbox)))) (let ((old-mailbox imap-current-mailbox) (state imap-state) - (imap-message-data (make-vector 2 0))) + (imap-message-data (obarray-make 2))) (when (imap-mailbox-examine-1 mailbox) (prog1 (and (imap-fetch-safe '("*" . "*:*") "UID") @@ -1768,7 +1768,7 @@ first element. The rest of list contains the saved articles' UIDs." (imap-mailbox-get-1 'appenduid mailbox) (let ((old-mailbox imap-current-mailbox) (state imap-state) - (imap-message-data (make-vector 2 0))) + (imap-message-data (obarray-make 2))) (when (imap-mailbox-examine-1 mailbox) (prog1 (and (imap-fetch-safe '("*" . "*:*") "UID") diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 17fdffd619d..09df5f5a9bb 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -784,8 +784,9 @@ size, and full-buffer size." (or shr-current-font 'shr-text))))))))) (defun shr-fill-lines (start end) - (if (or (not shr-fill-text) (<= shr-internal-width 0)) - nil + "Indent and fill text from START to END. +When `shr-fill-text' is nil, only indent." + (unless (<= shr-internal-width 0) (save-restriction (narrow-to-region start end) (goto-char start) @@ -807,6 +808,8 @@ size, and full-buffer size." (forward-char 1)))) (defun shr-fill-line () + "Indent and fill the current line. +When `shr-fill-text' is nil, only indent." (let ((shr-indentation (or (get-text-property (point) 'shr-indentation) shr-indentation)) (continuation (get-text-property @@ -821,9 +824,11 @@ size, and full-buffer size." `,(shr-face-background face)))) (setq start (point)) (setq shr-indentation (or continuation shr-indentation)) - ;; If we have an indentation that's wider than the width we're - ;; trying to fill to, then just give up and don't do any filling. - (when (< shr-indentation shr-internal-width) + ;; Fill the current line, unless `shr-fill-text' is unset, or we + ;; have an indentation that's wider than the width we're trying to + ;; fill to. + (when (and shr-fill-text + (< shr-indentation shr-internal-width)) (shr-vertical-motion shr-internal-width) (when (looking-at " $") (delete-region (point) (line-end-position))) @@ -1437,13 +1442,85 @@ ones, in case fg and bg are nil." (shr-dom-print elem))))) (insert (format "</%s>" (dom-tag dom)))) +(defconst shr-correct-attribute-case + '((attributename . attributeName) + (attributetype . attributeType) + (basefrequency . baseFrequency) + (baseprofile . baseProfile) + (calcmode . calcMode) + (clippathunits . clipPathUnits) + (diffuseconstant . diffuseConstant) + (edgemode . edgeMode) + (filterunits . filterUnits) + (glyphref . glyphRef) + (gradienttransform . gradientTransform) + (gradientunits . gradientUnits) + (kernelmatrix . kernelMatrix) + (kernelunitlength . kernelUnitLength) + (keypoints . keyPoints) + (keysplines . keySplines) + (keytimes . keyTimes) + (lengthadjust . lengthAdjust) + (limitingconeangle . limitingConeAngle) + (markerheight . markerHeight) + (markerunits . markerUnits) + (markerwidth . markerWidth) + (maskcontentunits . maskContentUnits) + (maskunits . maskUnits) + (numoctaves . numOctaves) + (pathlength . pathLength) + (patterncontentunits . patternContentUnits) + (patterntransform . patternTransform) + (patternunits . patternUnits) + (pointsatx . pointsAtX) + (pointsaty . pointsAtY) + (pointsatz . pointsAtZ) + (preservealpha . preserveAlpha) + (preserveaspectratio . preserveAspectRatio) + (primitiveunits . primitiveUnits) + (refx . refX) + (refy . refY) + (repeatcount . repeatCount) + (repeatdur . repeatDur) + (requiredextensions . requiredExtensions) + (requiredfeatures . requiredFeatures) + (specularconstant . specularConstant) + (specularexponent . specularExponent) + (spreadmethod . spreadMethod) + (startoffset . startOffset) + (stddeviation . stdDeviation) + (stitchtiles . stitchTiles) + (surfacescale . surfaceScale) + (systemlanguage . systemLanguage) + (tablevalues . tableValues) + (targetx . targetX) + (targety . targetY) + (textlength . textLength) + (viewbox . viewBox) + (viewtarget . viewTarget) + (xchannelselector . xChannelSelector) + (ychannelselector . yChannelSelector) + (zoomandpan . zoomAndPan)) + "Attributes for correcting the case in SVG and MathML. +Based on https://html.spec.whatwg.org/multipage/parsing.html#parsing-main-inforeign .") + +(defun shr-correct-dom-case (dom) + "Correct the case for SVG segments." + (dolist (attr (dom-attributes dom)) + (when-let ((rep (assoc-default (car attr) shr-correct-attribute-case))) + (setcar attr rep))) + (dolist (child (dom-children dom)) + (shr-correct-dom-case child)) + dom) + (defun shr-tag-svg (dom) (when (and (image-type-available-p 'svg) (not shr-inhibit-images) (dom-attr dom 'width) (dom-attr dom 'height)) - (funcall shr-put-image-function (list (shr-dom-to-xml dom 'utf-8) - 'image/svg+xml) + (funcall shr-put-image-function + (list (shr-dom-to-xml (shr-correct-dom-case dom) 'utf-8) + 'image/svg+xml) "SVG Image"))) (defun shr-tag-sup (dom) diff --git a/lisp/net/sieve.el b/lisp/net/sieve.el index fddc6e21bcc..a6ba556e7ae 100644 --- a/lisp/net/sieve.el +++ b/lisp/net/sieve.el @@ -354,7 +354,7 @@ Used to bracket operations which move point in the sieve-buffer." (let ((script (buffer-string)) (script-name (file-name-sans-extension (buffer-name))) err) - (with-current-buffer (get-buffer sieve-buffer) + (with-current-buffer sieve-buffer (setq err (sieve-manage-putscript (or name sieve-buffer-script-name script-name) script sieve-manage-buffer)) diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 2e4ad1cc412..da23d062c2e 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -263,9 +263,10 @@ arguments to pass to the OPERATION." (tramp-convert-file-attributes v localname id-format (and (tramp-adb-send-command-and-check - v (format "%s -d -l %s | cat" + v (format "(%s -d -l %s; echo tramp_exit_status $?) | cat" (tramp-adb-get-ls-command v) - (tramp-shell-quote-argument localname))) + (tramp-shell-quote-argument localname)) + nil t) (with-current-buffer (tramp-get-buffer v) (tramp-adb-sh-fix-ls-output) (cdar (tramp-do-parse-file-attributes-with-ls v))))))) @@ -316,9 +317,10 @@ arguments to pass to the OPERATION." directory full match nosort id-format count (with-current-buffer (tramp-get-buffer v) (when (tramp-adb-send-command-and-check - v (format "%s -a -l %s | cat" + v (format "(%s -a -l %s; echo tramp_exit_status $?) | cat" (tramp-adb-get-ls-command v) - (tramp-shell-quote-argument localname))) + (tramp-shell-quote-argument localname)) + nil t) ;; We insert also filename/. and filename/.., because "ls" ;; doesn't on some file systems, like "sdcard". (unless (search-backward-regexp (rx "." eol) nil t) @@ -440,10 +442,12 @@ Emacs dired can't find files." filename (with-parsed-tramp-file-name (expand-file-name directory) nil (with-tramp-file-property v localname "file-name-all-completions" - (tramp-adb-send-command - v (format "%s -a %s | cat" - (tramp-adb-get-ls-command v) - (tramp-shell-quote-argument localname))) + (unless (tramp-adb-send-command-and-check + v (format "(%s -a %s; echo tramp_exit_status $?) | cat" + (tramp-adb-get-ls-command v) + (tramp-shell-quote-argument localname)) + nil t) + (erase-buffer)) (mapcar (lambda (f) (if (file-directory-p (expand-file-name f directory)) @@ -504,12 +508,11 @@ Emacs dired can't find files." (with-parsed-tramp-file-name (expand-file-name filename) nil (with-tramp-file-property v localname "file-writable-p" (if (file-exists-p filename) - ;; Examine `file-attributes' cache to see if request can be - ;; satisfied without remote operation. - (if (tramp-file-property-p v localname "file-attributes") - (tramp-check-cached-permissions v ?w) - (tramp-adb-send-command-and-check - v (format "test -w %s" (tramp-shell-quote-argument localname)))) + ;; The file-attributes cache is unreliable since its + ;; information does not take partition writability into + ;; account, so a call to test must never be skipped. + (tramp-adb-send-command-and-check + v (format "test -w %s" (tramp-shell-quote-argument localname))) ;; If file doesn't exist, check if directory is writable. (and (file-directory-p (file-name-directory filename)) @@ -1142,17 +1145,23 @@ error and non-nil on success." (while (search-forward-regexp (rx (+ "\r") eol) nil t) (replace-match "" nil nil))))))) -(defun tramp-adb-send-command-and-check (vec command &optional exit-status) +(defun tramp-adb-send-command-and-check + (vec command &optional exit-status command-augmented-p) "Run COMMAND and check its exit status. Sends `echo $?' along with the COMMAND for checking the exit status. If COMMAND is nil, just sends `echo $?'. Returns nil if the exit status is not equal 0, and t otherwise. +If COMMAND-AUGMENTED-P, COMMAND is already configured to print exit +status upon completion and need not be modified. + Optional argument EXIT-STATUS, if non-nil, triggers the return of the exit status." (tramp-adb-send-command vec (if command - (format "%s; echo tramp_exit_status $?" command) + (if command-augmented-p + command + (format "%s; echo tramp_exit_status $?" command)) "echo tramp_exit_status $?")) (with-current-buffer (tramp-get-connection-buffer vec) (unless (tramp-search-regexp (rx "tramp_exit_status " (+ digit))) @@ -1230,7 +1239,7 @@ connection if a previous connection has died for some reason." (let* ((coding-system-for-read 'utf-8-dos) ; Is this correct? (process-connection-type tramp-process-connection-type) (args (tramp-expand-args - vec 'tramp-login-args ?d (or device ""))) + vec 'tramp-login-args nil ?d (or device ""))) (p (let ((default-directory tramp-compat-temporary-file-directory)) (apply @@ -1257,7 +1266,7 @@ connection if a previous connection has died for some reason." (tramp-set-connection-property p "prompt" (rx "///" (literal prompt) "#$")) (tramp-adb-send-command - vec (format "PS1=\"///\"\"%s\"\"#$\"" prompt)) + vec (format "PS1=\"///\"\"%s\"\"#$\" PS2=''" prompt)) ;; Disable line editing. (tramp-adb-send-command diff --git a/lisp/net/tramp-androidsu.el b/lisp/net/tramp-androidsu.el new file mode 100644 index 00000000000..09bee323f5e --- /dev/null +++ b/lisp/net/tramp-androidsu.el @@ -0,0 +1,561 @@ +;;; tramp-androidsu.el --- Tramp method for Android superuser shells -*- lexical-binding:t -*- + +;; Copyright (C) 2024 Free Software Foundation, Inc. + +;; Author: Po Lu +;; Keywords: comm, processes +;; Package: tramp + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; `su' method implementation for Android. +;; +;; The `su' method struggles (as do other shell-based methods) with the +;; crippled versions of many Unix utilities installed on Android, +;; workarounds for which are implemented in the `adb' method. This +;; method defines a shell-based method that is identical in function to +;; and replaces if connecting to a local Android machine `su', but +;; reuses such code from the `adb' method where applicable and also +;; provides for certain mannerisms of popular Android `su' +;; implementations. + +;;; Code: + +(require 'tramp) +(require 'tramp-adb) +(require 'tramp-sh) + +;;;###tramp-autoload +(defconst tramp-androidsu-method "androidsu" + "When this method name is used, forward all calls to su.") + +;;;###tramp-autoload +(defcustom tramp-androidsu-mount-global-namespace t + "When non-nil, browse files from within the global mount namespace. +On systems that assign each application a unique view of the +filesystem by executing them within individual mount namespaces +and thus conceal each application's data directories from +others, invoke `su' with the option `-mm' in order for the shell +launched to run within the global mount namespace, so that Tramp +may edit files belonging to any and all applications." + :group 'tramp + :version "30.1" + :type 'boolean) + +;;;###tramp-autoload +(defcustom tramp-androidsu-remote-path '("/system/bin" + "/system/xbin") + "Directories in which to search for transfer programs and the like." + :group 'tramp + :version "30.1" + :type '(list string)) + +(defvar tramp-androidsu-su-mm-supported 'unknown + "Whether `su -mm' is supported on this system.") + +;;;###tramp-autoload +(defconst tramp-androidsu-local-shell-name "/system/bin/sh" + "Name of the local shell on Android.") + +;;;###tramp-autoload +(defconst tramp-androidsu-local-tmp-directory "/data/local/tmp" + "Name of the local temporary directory on Android.") + +;;;###tramp-autoload +(tramp--with-startup + (add-to-list 'tramp-methods + `(,tramp-androidsu-method + (tramp-login-program "su") + (tramp-login-args (("-") ("%u"))) + (tramp-remote-shell ,tramp-androidsu-local-shell-name) + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")) + (tramp-tmpdir ,tramp-androidsu-local-tmp-directory) + (tramp-connection-timeout 10) + (tramp-shell-name ,tramp-androidsu-local-shell-name))) + (add-to-list 'tramp-default-user-alist + `(,tramp-androidsu-method nil ,tramp-root-id-string))) + +(defvar android-use-exec-loader) ; androidfns.c. + +(defun tramp-androidsu-maybe-open-connection (vec) + "Open a connection VEC if not already open. +Mostly identical to `tramp-adb-maybe-open-connection', but also disables +multibyte mode and waits for the shell prompt to appear." + ;; During completion, don't reopen a new connection. + (unless (tramp-connectable-p vec) + (throw 'non-essential 'non-essential)) + + (with-tramp-debug-message vec "Opening connection" + (let ((p (tramp-get-connection-process vec)) + (process-name (tramp-get-connection-property vec "process-name")) + (process-environment (copy-sequence process-environment))) + ;; Open a new connection. + (condition-case err + (unless (process-live-p p) + (with-tramp-progress-reporter + vec 3 + (if (tramp-string-empty-or-nil-p (tramp-file-name-user vec)) + (format "Opening connection %s for %s using %s" + process-name + (tramp-file-name-host vec) + (tramp-file-name-method vec)) + (format "Opening connection %s for %s@%s using %s" + process-name + (tramp-file-name-user vec) + (tramp-file-name-host vec) + (tramp-file-name-method vec))) + (let* ((coding-system-for-read 'utf-8-unix) + (process-connection-type tramp-process-connection-type) + ;; The executable loader cannot execute setuid + ;; binaries, such as su. + (android-use-exec-loader nil) + (p (start-process (tramp-get-connection-name vec) + (tramp-get-connection-buffer vec) + ;; Disregard + ;; `tramp-encoding-shell', as + ;; there's no guarantee that it's + ;; possible to execute it with + ;; `android-use-exec-loader' off. + tramp-androidsu-local-shell-name "-i")) + (user (tramp-file-name-user vec)) + command) + ;; Set sentinel. Initialize variables. + (set-process-sentinel p #'tramp-process-sentinel) + (tramp-post-process-creation p vec) + ;; Replace `login-args' place holders. + (setq command (format "exec su - %s || exit" user)) + ;; Attempt to execute the shell inside the global mount + ;; namespace if requested. + (when tramp-androidsu-mount-global-namespace + (progn + (when (eq tramp-androidsu-su-mm-supported 'unknown) + ;; Change the prompt in advance so that + ;; `tramp-adb-send-command-and-check' can call + ;; `tramp-search-regexp'. + (tramp-adb-send-command + vec (format "PS1=%s PS2=''" + (tramp-shell-quote-argument + tramp-end-of-output))) + (setq tramp-androidsu-su-mm-supported + ;; Detect support for `su -mm'. + (tramp-adb-send-command-and-check + vec "su -mm -c 'exit 24'" 24))) + (when tramp-androidsu-su-mm-supported + (tramp-set-connection-property + vec "remote-namespace" t) + (setq command (format "exec su -mm - %s || exit" + user))))) + ;; Send the command. + (tramp-message vec 3 "Sending command `%s'" command) + (tramp-adb-send-command vec command t t) + ;; Android su binaries contact a background service to + ;; obtain authentication; during this process, input + ;; received is discarded, so input cannot be + ;; guaranteed to reach the root shell until its prompt + ;; is displayed. + (with-current-buffer (process-buffer p) + (tramp-wait-for-regexp p tramp-connection-timeout + "#[[:space:]]*$")) + ;; Set connection-local variables. + (tramp-set-connection-local-variables vec) + ;; Change prompt. + (tramp-adb-send-command + vec (format "PS1=%s PS2=''" + (tramp-shell-quote-argument tramp-end-of-output))) + ;; Disable line editing. + (tramp-adb-send-command + vec "set +o vi +o vi-esccomplete +o vi-tabcomplete +o emacs") + ;; Disable Unicode, for otherwise Unicode filenames will + ;; not be decoded correctly. + (tramp-adb-send-command vec "set +U") + ;; Dump option settings in the traces. + (when (>= tramp-verbose 9) + (tramp-adb-send-command vec "set -o")) + ;; Disable echo expansion. + (tramp-adb-send-command + vec "stty -inlcr -onlcr -echo kill '^U' erase '^H'" t) + ;; Check whether the echo has really been disabled. + ;; Some implementations, like busybox, don't support + ;; disabling. + (tramp-adb-send-command vec "echo foo" t) + (with-current-buffer (process-buffer p) + (goto-char (point-min)) + (when (looking-at-p "echo foo") + (tramp-set-connection-property p "remote-echo" t) + (tramp-message vec 5 "Remote echo still on. Ok.") + ;; Make sure backspaces and their echo are enabled + ;; and no line width magic interferes with them. + (tramp-adb-send-command + vec "stty icanon erase ^H cols 32767" t))) + ;; Mark it as connected. + (tramp-set-connection-property p "connected" t)))) + ;; Cleanup, and propagate the signal. + ((error quit) + (tramp-cleanup-connection vec t) + (signal (car err) (cdr err))))))) + +(defun tramp-androidsu-generate-wrapper (function) + "Return connection wrapper function for FUNCTION. +Return a function which temporarily substitutes local replacements for +the `adb' method's connection management functions around a call to +FUNCTION." + (lambda (&rest args) + (let ((tramp-adb-wait-for-output + (symbol-function #'tramp-adb-wait-for-output)) + (tramp-adb-maybe-open-connection + (symbol-function #'tramp-adb-maybe-open-connection))) + (unwind-protect + (progn + ;; `tramp-adb-wait-for-output' addresses problems introduced + ;; by the adb utility itself, not Android utilities, so + ;; replace it with the regular Tramp function. + (fset 'tramp-adb-wait-for-output #'tramp-wait-for-output) + ;; Likewise, except some special treatment is necessary on + ;; account of flaws in Android's su implementation. + (fset 'tramp-adb-maybe-open-connection + #'tramp-androidsu-maybe-open-connection) + (apply function args)) + ;; Restore the original definitions of the functions overridden + ;; above. + (fset 'tramp-adb-wait-for-output tramp-adb-wait-for-output) + (fset 'tramp-adb-maybe-open-connection + tramp-adb-maybe-open-connection))))) + +(defalias 'tramp-androidsu-handle-copy-file #'tramp-sh-handle-copy-file) + +(defalias 'tramp-androidsu-handle-delete-directory + (tramp-androidsu-generate-wrapper #'tramp-adb-handle-delete-directory)) + +(defalias 'tramp-androidsu-handle-delete-file + (tramp-androidsu-generate-wrapper #'tramp-adb-handle-delete-file)) + +(defalias 'tramp-androidsu-handle-directory-files-and-attributes + (tramp-androidsu-generate-wrapper + #'tramp-adb-handle-directory-files-and-attributes)) + +(defalias 'tramp-androidsu-handle-exec-path + (tramp-androidsu-generate-wrapper #'tramp-adb-handle-exec-path)) + +(defalias 'tramp-androidsu-handle-file-attributes + (tramp-androidsu-generate-wrapper #'tramp-adb-handle-file-attributes)) + +(defalias 'tramp-androidsu-handle-file-executable-p + (tramp-androidsu-generate-wrapper #'tramp-adb-handle-file-executable-p)) + +(defalias 'tramp-androidsu-handle-file-exists-p + (tramp-androidsu-generate-wrapper #'tramp-adb-handle-file-exists-p)) + +(defalias 'tramp-androidsu-handle-file-local-copy + #'tramp-sh-handle-file-local-copy) + +(defalias 'tramp-androidsu-handle-file-name-all-completions + (tramp-androidsu-generate-wrapper + #'tramp-adb-handle-file-name-all-completions)) + +(defalias 'tramp-androidsu-handle-file-readable-p + (tramp-androidsu-generate-wrapper #'tramp-adb-handle-file-readable-p)) + +(defalias 'tramp-androidsu-handle-file-system-info + (tramp-androidsu-generate-wrapper #'tramp-adb-handle-file-system-info)) + +(defalias 'tramp-androidsu-handle-file-writable-p + (tramp-androidsu-generate-wrapper #'tramp-adb-handle-file-writable-p)) + +(defalias 'tramp-androidsu-handle-make-directory + (tramp-androidsu-generate-wrapper #'tramp-adb-handle-make-directory)) + +(defun tramp-androidsu-handle-make-process (&rest args) + "Like `tramp-handle-make-process', but modified for Android." + (when args + (with-parsed-tramp-file-name (expand-file-name default-directory) nil + (let ((default-directory tramp-compat-temporary-file-directory) + (name (plist-get args :name)) + (buffer (plist-get args :buffer)) + (command (plist-get args :command)) + (coding (plist-get args :coding)) + (noquery (plist-get args :noquery)) + (connection-type + (or (plist-get args :connection-type) process-connection-type)) + (filter (plist-get args :filter)) + (sentinel (plist-get args :sentinel)) + (stderr (plist-get args :stderr))) + (unless (stringp name) + (signal 'wrong-type-argument (list #'stringp name))) + (unless (or (bufferp buffer) (string-or-null-p buffer)) + (signal 'wrong-type-argument (list #'bufferp buffer))) + (unless (consp command) + (signal 'wrong-type-argument (list #'consp command))) + (unless (or (null coding) + (and (symbolp coding) (memq coding coding-system-list)) + (and (consp coding) + (memq (car coding) coding-system-list) + (memq (cdr coding) coding-system-list))) + (signal 'wrong-type-argument (list #'symbolp coding))) + (when (eq connection-type t) + (setq connection-type 'pty)) + (unless (or (and (consp connection-type) + (memq (car connection-type) '(nil pipe pty)) + (memq (cdr connection-type) '(nil pipe pty))) + (memq connection-type '(nil pipe pty))) + (signal 'wrong-type-argument (list #'symbolp connection-type))) + (unless (or (null filter) (eq filter t) (functionp filter)) + (signal 'wrong-type-argument (list #'functionp filter))) + (unless (or (null sentinel) (functionp sentinel)) + (signal 'wrong-type-argument (list #'functionp sentinel))) + (unless (or (null stderr) (bufferp stderr)) + (signal 'wrong-type-argument (list #'bufferp stderr))) + (let* ((buffer + (if buffer + (get-buffer-create buffer) + ;; BUFFER can be nil. We use a temporary buffer. + (generate-new-buffer tramp-temp-buffer-name))) + (orig-command command) + (env (mapcar + (lambda (elt) + (when (tramp-compat-string-search "=" elt) elt)) + tramp-remote-process-environment)) + ;; We use as environment the difference to toplevel + ;; `process-environment'. + (env (dolist (elt process-environment env) + (when + (and + (tramp-compat-string-search "=" elt) + (not + (member + elt (default-toplevel-value 'process-environment)))) + (setq env (cons elt env))))) + ;; Add remote path if exists. + (env (let ((remote-path + (string-join (tramp-get-remote-path v) ":"))) + (setenv-internal env "PATH" remote-path 'keep))) + (env (setenv-internal + env "INSIDE_EMACS" (tramp-inside-emacs) 'keep)) + (env (mapcar #'tramp-shell-quote-argument (delq nil env))) + ;; Quote command. + (command (mapconcat #'tramp-shell-quote-argument command " ")) + ;; Set cwd and environment variables. + (command + (append + `("cd" ,(tramp-shell-quote-argument localname) "&&" "(" "env") + env `(,command ")"))) + ;; Add remote shell if needed. + (command + (if (consp (tramp-get-method-parameter v 'tramp-direct-async)) + (append + (tramp-get-method-parameter v 'tramp-direct-async) + `(,(string-join command " "))) + command)) + p) + ;; Generate a command to start the process using `su' with + ;; suitable options for specifying the mount namespace and + ;; suchlike. + (setq + p (make-process + :name name :buffer buffer + :command (if (tramp-get-connection-property v "remote-namespace") + (append (list "su" "-mm" "-" user "-c") command) + (append (list "su" "-" user "-c") command)) + :coding coding :noquery noquery :connection-type connection-type + :sentinel sentinel :stderr stderr)) + ;; Set filter. Prior Emacs 29.1, it doesn't work reliably + ;; to provide it as `make-process' argument when filter is + ;; t. See Bug#51177. + (when filter + (set-process-filter p filter)) + (tramp-post-process-creation p v) + ;; Query flag is overwritten in `tramp-post-process-creation', + ;; so we reset it. + (set-process-query-on-exit-flag p (null noquery)) + ;; This is needed for ssh or PuTTY based processes, and + ;; only if the respective options are set. Perhaps, the + ;; setting could be more fine-grained. + ;; (process-put p 'tramp-shared-socket t) + (process-put p 'remote-command orig-command) + (tramp-set-connection-property p "remote-command" orig-command) + (when (bufferp stderr) + (tramp-taint-remote-process-buffer stderr)) + p))))) + +(defalias 'tramp-androidsu-handle-make-symbolic-link + #'tramp-sh-handle-make-symbolic-link) + +(defalias 'tramp-androidsu-handle-process-file + (tramp-androidsu-generate-wrapper #'tramp-adb-handle-process-file)) + +(defalias 'tramp-androidsu-handle-rename-file #'tramp-sh-handle-rename-file) + +(defalias 'tramp-androidsu-handle-set-file-modes + (tramp-androidsu-generate-wrapper #'tramp-adb-handle-set-file-modes)) + +(defalias 'tramp-androidsu-handle-set-file-times + (tramp-androidsu-generate-wrapper #'tramp-adb-handle-set-file-times)) + +(defalias 'tramp-androidsu-handle-get-remote-gid + (tramp-androidsu-generate-wrapper #'tramp-adb-handle-get-remote-gid)) + +(defalias 'tramp-androidsu-handle-get-remote-groups + (tramp-androidsu-generate-wrapper #'tramp-adb-handle-get-remote-groups)) + +(defalias 'tramp-androidsu-handle-get-remote-uid + (tramp-androidsu-generate-wrapper #'tramp-adb-handle-get-remote-uid)) + +(defalias 'tramp-androidsu-handle-write-region #'tramp-sh-handle-write-region) + +;;;###tramp-autoload +(defconst tramp-androidsu-file-name-handler-alist + '(;; `abbreviate-file-name' performed by default handler. + (access-file . tramp-handle-access-file) + (add-name-to-file . tramp-handle-add-name-to-file) + ;; `byte-compiler-base-file-name' performed by default handler. + (copy-directory . tramp-handle-copy-directory) + (copy-file . tramp-androidsu-handle-copy-file) + (delete-directory . tramp-androidsu-handle-delete-directory) + (delete-file . tramp-androidsu-handle-delete-file) + ;; `diff-latest-backup-file' performed by default handler. + (directory-file-name . tramp-handle-directory-file-name) + (directory-files . tramp-handle-directory-files) + (directory-files-and-attributes + . tramp-androidsu-handle-directory-files-and-attributes) + (dired-compress-file . ignore) + (dired-uncache . tramp-handle-dired-uncache) + (exec-path . tramp-androidsu-handle-exec-path) + (expand-file-name . tramp-handle-expand-file-name) + (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) + (file-acl . ignore) + (file-attributes . tramp-androidsu-handle-file-attributes) + (file-directory-p . tramp-handle-file-directory-p) + (file-equal-p . tramp-handle-file-equal-p) + (file-executable-p . tramp-androidsu-handle-file-executable-p) + (file-exists-p . tramp-androidsu-handle-file-exists-p) + (file-group-gid . tramp-handle-file-group-gid) + (file-in-directory-p . tramp-handle-file-in-directory-p) + (file-local-copy . tramp-androidsu-handle-file-local-copy) + (file-locked-p . tramp-handle-file-locked-p) + (file-modes . tramp-handle-file-modes) + (file-name-all-completions + . tramp-androidsu-handle-file-name-all-completions) + (file-name-as-directory . tramp-handle-file-name-as-directory) + (file-name-case-insensitive-p . tramp-handle-file-name-case-insensitive-p) + (file-name-completion . tramp-handle-file-name-completion) + (file-name-directory . tramp-handle-file-name-directory) + (file-name-nondirectory . tramp-handle-file-name-nondirectory) + ;; `file-name-sans-versions' performed by default handler. + (file-newer-than-file-p . tramp-handle-file-newer-than-file-p) + (file-notify-add-watch . tramp-handle-file-notify-add-watch) + (file-notify-rm-watch . tramp-handle-file-notify-rm-watch) + (file-notify-valid-p . tramp-handle-file-notify-valid-p) + (file-ownership-preserved-p . ignore) + (file-readable-p . tramp-androidsu-handle-file-readable-p) + (file-regular-p . tramp-handle-file-regular-p) + (file-remote-p . tramp-handle-file-remote-p) + (file-selinux-context . tramp-handle-file-selinux-context) + (file-symlink-p . tramp-handle-file-symlink-p) + (file-system-info . tramp-androidsu-handle-file-system-info) + (file-truename . tramp-handle-file-truename) + (file-user-uid . tramp-handle-file-user-uid) + (file-writable-p . tramp-androidsu-handle-file-writable-p) + (find-backup-file-name . tramp-handle-find-backup-file-name) + ;; `get-file-buffer' performed by default handler. + (insert-directory . tramp-handle-insert-directory) + (insert-file-contents . tramp-handle-insert-file-contents) + (list-system-processes . tramp-handle-list-system-processes) + (load . tramp-handle-load) + (lock-file . tramp-handle-lock-file) + (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) + (make-directory . tramp-androidsu-handle-make-directory) + (make-directory-internal . ignore) + (make-lock-file-name . tramp-handle-make-lock-file-name) + (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) + (make-process . tramp-androidsu-handle-make-process) + (make-symbolic-link . tramp-androidsu-handle-make-symbolic-link) + (memory-info . tramp-handle-memory-info) + (process-attributes . tramp-handle-process-attributes) + (process-file . tramp-androidsu-handle-process-file) + (rename-file . tramp-androidsu-handle-rename-file) + (set-file-acl . ignore) + (set-file-modes . tramp-androidsu-handle-set-file-modes) + (set-file-selinux-context . ignore) + (set-file-times . tramp-androidsu-handle-set-file-times) + (set-visited-file-modtime . tramp-handle-set-visited-file-modtime) + (shell-command . tramp-handle-shell-command) + (start-file-process . tramp-handle-start-file-process) + (substitute-in-file-name . tramp-handle-substitute-in-file-name) + (temporary-file-directory . tramp-handle-temporary-file-directory) + (tramp-get-home-directory . ignore) + (tramp-get-remote-gid . tramp-androidsu-handle-get-remote-gid) + (tramp-get-remote-groups . tramp-androidsu-handle-get-remote-groups) + (tramp-get-remote-uid . tramp-androidsu-handle-get-remote-uid) + (tramp-set-file-uid-gid . ignore) + (unhandled-file-name-directory . ignore) + (unlock-file . tramp-handle-unlock-file) + (vc-registered . ignore) + (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) + (write-region . tramp-androidsu-handle-write-region)) + "Alist of Tramp handler functions for superuser sessions on Android.") + +;; It must be a `defsubst' in order to push the whole code into +;; tramp-loaddefs.el. Otherwise, there would be recursive autoloading. +;;;###tramp-autoload +(defsubst tramp-androidsu-file-name-p (vec-or-filename) + "Check whether VEC-OR-FILENAME is for the `androidsu' method." + (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) + (equal (tramp-file-name-method vec) tramp-androidsu-method))) + +;;;###tramp-autoload +(defun tramp-androidsu-file-name-handler (operation &rest args) + "Invoke the `androidsu' handler for OPERATION. +First arg specifies the OPERATION, second arg is a list of +arguments to pass to the OPERATION." + (if-let ((fn (assoc operation tramp-androidsu-file-name-handler-alist))) + (prog1 (save-match-data (apply (cdr fn) args)) + (setq tramp-debug-message-fnh-function (cdr fn))) + (prog1 (tramp-run-real-handler operation args) + (setq tramp-debug-message-fnh-function operation)))) + +;;;###tramp-autoload +(tramp--with-startup + (tramp-register-foreign-file-name-handler + #'tramp-androidsu-file-name-p #'tramp-androidsu-file-name-handler)) + +;;; Default connection-local variables for Tramp. + +(defconst tramp-androidsu-connection-local-default-variables + `((tramp-remote-path . ,tramp-androidsu-remote-path)) + "Default connection-local variables for remote androidsu connections.") + +(connection-local-set-profile-variables + 'tramp-androidsu-connection-local-default-profile + tramp-androidsu-connection-local-default-variables) + +(connection-local-set-profiles + `(:application tramp :protocol ,tramp-androidsu-method) + 'tramp-androidsu-connection-local-default-profile) + +(with-eval-after-load 'shell + (connection-local-set-profiles + `(:application tramp :protocol ,tramp-androidsu-method) + 'tramp-adb-connection-local-default-shell-profile + 'tramp-adb-connection-local-default-ps-profile)) + +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-androidsu 'force))) + +(provide 'tramp-androidsu) +;;; tramp-androidsu.el ends here diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index 298cacdb0e0..59c4223794c 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -387,6 +387,8 @@ arguments to pass to the OPERATION." ;;;###autoload (progn (defun tramp-register-archive-autoload-file-name-handler () "Add archive file name handler to `file-name-handler-alist'." + ;; Do not use read syntax #' for `tramp-archive-file-name-handler', it + ;; isn't autoloaded. (when (and tramp-archive-enabled (not (rassq 'tramp-archive-file-name-handler file-name-handler-alist))) @@ -443,7 +445,7 @@ arguments to pass to the OPERATION." (and (tramp-archive-file-name-p name) (match-string 2 name))) -(defvar tramp-archive-hash (make-hash-table :test 'equal) +(defvar tramp-archive-hash (make-hash-table :test #'equal) "Hash table for archive local copies. The hash key is the archive name. The value is a cons of the used `tramp-file-name' structure for tramp-gvfs, and the file diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index 25123a6e282..225a26ad1cd 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -144,7 +144,6 @@ If KEY is `tramp-cache-undefined', don't create anything, and return nil." (defun tramp-get-file-property (key file property &optional default) "Get the PROPERTY of FILE from the cache context of KEY. Return DEFAULT if not set." - ;; Unify localname. Remove hop from `tramp-file-name' structure. (setq key (tramp-file-name-unify key file)) (if (eq key tramp-cache-undefined) default (let* ((hash (tramp-get-hash-table key)) @@ -191,7 +190,6 @@ Return DEFAULT if not set." (defun tramp-set-file-property (key file property value) "Set the PROPERTY of FILE to VALUE, in the cache context of KEY. Return VALUE." - ;; Unify localname. Remove hop from `tramp-file-name' structure. (setq key (tramp-file-name-unify key file)) (if (eq key tramp-cache-undefined) value (let ((hash (tramp-get-hash-table key))) @@ -224,7 +222,6 @@ Return VALUE." ;;;###tramp-autoload (defun tramp-flush-file-property (key file property) "Remove PROPERTY of FILE in the cache context of KEY." - ;; Unify localname. Remove hop from `tramp-file-name' structure. (setq key (tramp-file-name-unify key file)) (unless (eq key tramp-cache-undefined) (remhash property (tramp-get-hash-table key)) @@ -239,7 +236,6 @@ Return VALUE." ;; `file-name-directory' can return nil, for example for "~". (when-let ((file (file-name-directory file)) (file (directory-file-name file))) - ;; Unify localname. Remove hop from `tramp-file-name' structure. (setq key (tramp-file-name-unify key file)) (unless (eq key tramp-cache-undefined) (dolist (property (hash-table-keys (tramp-get-hash-table key))) @@ -254,7 +250,6 @@ Return VALUE." (defun tramp-flush-file-properties (key file) "Remove all properties of FILE in the cache context of KEY." (let ((truename (tramp-get-file-property key file "file-truename"))) - ;; Unify localname. Remove hop from `tramp-file-name' structure. (setq key (tramp-file-name-unify key file)) (unless (eq key tramp-cache-undefined) (tramp-message key 8 "%s" (tramp-file-name-localname key)) @@ -338,17 +333,15 @@ FILE must be a local file name on a connection identified via KEY." "Save PROPERTY, run BODY, reset PROPERTY. Preserve timestamps." (declare (indent 3) (debug t)) - `(progn - ;; Unify localname. Remove hop from `tramp-file-name' structure. - (setf ,key (tramp-file-name-unify ,key ,file)) - (let* ((hash (tramp-get-hash-table ,key)) - (cached (and (hash-table-p hash) (gethash ,property hash)))) - (unwind-protect (progn ,@body) - ;; Reset PROPERTY. Recompute hash, it could have been flushed. - (setq hash (tramp-get-hash-table ,key)) - (if (consp cached) - (puthash ,property cached hash) - (remhash ,property hash)))))) + `(let* ((key (tramp-file-name-unify ,key ,file)) + (hash (tramp-get-hash-table key)) + (cached (and (hash-table-p hash) (gethash ,property hash)))) + (unwind-protect (progn ,@body) + ;; Reset PROPERTY. Recompute hash, it could have been flushed. + (setq hash (tramp-get-hash-table key)) + (if (consp cached) + (puthash ,property cached hash) + (remhash ,property hash))))) ;;;###tramp-autoload (defmacro with-tramp-saved-file-properties (key file properties &rest body) @@ -356,22 +349,20 @@ Preserve timestamps." PROPERTIES is a list of file properties (strings). Preserve timestamps." (declare (indent 3) (debug t)) - `(progn - ;; Unify localname. Remove hop from `tramp-file-name' structure. - (setf ,key (tramp-file-name-unify ,key ,file)) - (let* ((hash (tramp-get-hash-table ,key)) - (values - (and (hash-table-p hash) - (mapcar - (lambda (property) (cons property (gethash property hash))) - ,properties)))) - (unwind-protect (progn ,@body) - ;; Reset PROPERTIES. Recompute hash, it could have been flushed. - (setq hash (tramp-get-hash-table ,key)) - (dolist (value values) - (if (consp (cdr value)) - (puthash (car value) (cdr value) hash) - (remhash (car value) hash))))))) + `(let* ((key (tramp-file-name-unify ,key ,file)) + (hash (tramp-get-hash-table key)) + (values + (and (hash-table-p hash) + (mapcar + (lambda (property) (cons property (gethash property hash))) + ,properties)))) + (unwind-protect (progn ,@body) + ;; Reset PROPERTIES. Recompute hash, it could have been flushed. + (setq hash (tramp-get-hash-table key)) + (dolist (value values) + (if (consp (cdr value)) + (puthash (car value) (cdr value) hash) + (remhash (car value) hash)))))) ;;; -- Properties -- @@ -473,38 +464,36 @@ used to cache connection properties of the local machine." (defmacro with-tramp-saved-connection-property (key property &rest body) "Save PROPERTY, run BODY, reset PROPERTY." (declare (indent 2) (debug t)) - `(progn - (setf ,key (tramp-file-name-unify ,key)) - (let* ((hash (tramp-get-hash-table ,key)) - (cached (and (hash-table-p hash) - (gethash ,property hash tramp-cache-undefined)))) - (unwind-protect (progn ,@body) - ;; Reset PROPERTY. Recompute hash, it could have been flushed. - (setq hash (tramp-get-hash-table ,key)) - (if (not (eq cached tramp-cache-undefined)) - (puthash ,property cached hash) - (remhash ,property hash)))))) + `(let* ((key (tramp-file-name-unify ,key)) + (hash (tramp-get-hash-table key)) + (cached (and (hash-table-p hash) + (gethash ,property hash tramp-cache-undefined)))) + (unwind-protect (progn ,@body) + ;; Reset PROPERTY. Recompute hash, it could have been flushed. + (setq hash (tramp-get-hash-table key)) + (if (not (eq cached tramp-cache-undefined)) + (puthash ,property cached hash) + (remhash ,property hash))))) ;;;###tramp-autoload (defmacro with-tramp-saved-connection-properties (key properties &rest body) "Save PROPERTIES, run BODY, reset PROPERTIES. PROPERTIES is a list of file properties (strings)." (declare (indent 2) (debug t)) - `(progn - (setf ,key (tramp-file-name-unify ,key)) - (let* ((hash (tramp-get-hash-table ,key)) - (values - (mapcar - (lambda (property) - (cons property (gethash property hash tramp-cache-undefined))) - ,properties))) - (unwind-protect (progn ,@body) - ;; Reset PROPERTIES. Recompute hash, it could have been flushed. - (setq hash (tramp-get-hash-table ,key)) - (dolist (value values) - (if (not (eq (cdr value) tramp-cache-undefined)) - (puthash (car value) (cdr value) hash) - (remhash (car value) hash))))))) + `(let* ((key (tramp-file-name-unify ,key)) + (hash (tramp-get-hash-table key)) + (values + (mapcar + (lambda (property) + (cons property (gethash property hash tramp-cache-undefined))) + ,properties))) + (unwind-protect (progn ,@body) + ;; Reset PROPERTIES. Recompute hash, it could have been flushed. + (setq hash (tramp-get-hash-table key)) + (dolist (value values) + (if (not (eq (cdr value) tramp-cache-undefined)) + (puthash (car value) (cdr value) hash) + (remhash (car value) hash)))))) ;;;###tramp-autoload (defun tramp-cache-print (table) diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el index a545a8e7273..d3af7a009ec 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -281,7 +281,7 @@ non-nil." ;; Remove all buffers with a remote default-directory which fit the hook. (dolist (name (tramp-list-remote-buffers)) (and (buffer-live-p (get-buffer name)) - (with-current-buffer (get-buffer name) + (with-current-buffer name (run-hook-with-args-until-success 'tramp-cleanup-some-buffers-hook)) (kill-buffer name)))) diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index 8065ba01734..98de0dba7ff 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -309,7 +309,7 @@ Also see `ignore'." ;; Macro `connection-local-p' is new in Emacs 30.1. (if (macrop 'connection-local-p) - (defalias 'tramp-compat-connection-local-p #'connection-local-p) + (defalias 'tramp-compat-connection-local-p 'connection-local-p) (defmacro tramp-compat-connection-local-p (variable) "Non-nil if VARIABLE has a connection-local binding in `default-directory'." `(let (connection-local-variables-alist file-local-variables-alist) @@ -330,6 +330,18 @@ Also see `ignore'." ;;; TODO: ;; ;; * Starting with Emacs 27.1, there's no need to escape open -;; parentheses with a backslash in docstrings anymore. +;; parentheses with a backslash in docstrings anymore. However, +;; `outline-minor-mode' has still problems with this. Since there +;; are developers using `outline-minor-mode' in Lisp files, we still +;; keep this quoting. +;; +;; * Starting with Emacs 29.1, use `buffer-match-p'. +;; +;; * Starting with Emacs 29.1, use `string-split'. +;; +;; * Starting with Emacs 30.1, there is `handler-bind'. Use it +;; instead of `condition-case' when the origin of an error shall be +;; kept, for example when the HANDLER propagates the error with +;; `(signal (car err) (cdr err)'. ;;; tramp-compat.el ends here diff --git a/lisp/net/tramp-container.el b/lisp/net/tramp-container.el index 1f578949e4d..30639cbeb85 100644 --- a/lisp/net/tramp-container.el +++ b/lisp/net/tramp-container.el @@ -31,15 +31,20 @@ ;; Open a file on a running Docker container: ;; ;; C-x C-f /docker:USER@CONTAINER:/path/to/file +;; C-x C-f /dockercp:USER@CONTAINER:/path/to/file ;; ;; or Podman: ;; ;; C-x C-f /podman:USER@CONTAINER:/path/to/file +;; C-x C-f /podmancp:USER@CONTAINER:/path/to/file ;; ;; Where: ;; USER is the user on the container to connect as (optional). ;; CONTAINER is the container to connect to. ;; +;; "docker" and "podman" are inline methods, "dockercp" and "podmancp" +;; are out-of-band methods. +;; ;; ;; ;; Open file in a Kubernetes container: @@ -142,10 +147,20 @@ If it is nil, the default context will be used." "Tramp method name to use to connect to Docker containers.") ;;;###tramp-autoload +(defconst tramp-dockercp-method "dockercp" + "Tramp method name to use to connect to Docker containers. +This is for out-of-band connections.") + +;;;###tramp-autoload (defconst tramp-podman-method "podman" "Tramp method name to use to connect to Podman containers.") ;;;###tramp-autoload +(defconst tramp-podmancp-method "podmancp" + "Tramp method name to use to connect to Podman containers. +This is for out-of-band connections.") + +;;;###tramp-autoload (defconst tramp-kubernetes-method "kubernetes" "Tramp method name to use to connect to Kubernetes containers.") @@ -183,7 +198,8 @@ BODY is the backend specific code." (defun tramp-container--completion-function (method) "List running containers available for connection. METHOD is the Tramp method to be used for \"ps\", either -`tramp-docker-method' or `tramp-podman-method'. +`tramp-docker-method', `tramp-dockercp-method', `tramp-podman-method', +or `tramp-podmancp-method'. This function is used by `tramp-set-completion-function', please see its function help for a description of the format." @@ -376,6 +392,23 @@ see its function help for a description of the format." (tramp-remote-shell-args ("-i" "-c")))) (add-to-list 'tramp-methods + `(,tramp-dockercp-method + (tramp-login-program ,tramp-docker-program) + (tramp-login-args (("exec") + ("-it") + ("-u" "%u") + ("%h") + ("%l"))) + (tramp-direct-async (,tramp-default-remote-shell "-c")) + (tramp-remote-shell ,tramp-default-remote-shell) + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-i" "-c")) + (tramp-copy-program ,tramp-docker-program) + (tramp-copy-args (("cp"))) + (tramp-copy-file-name (("%h" ":") ("%f"))) + (tramp-copy-recursive t))) + + (add-to-list 'tramp-methods `(,tramp-podman-method (tramp-login-program ,tramp-podman-program) (tramp-login-args (("exec") @@ -389,6 +422,23 @@ see its function help for a description of the format." (tramp-remote-shell-args ("-i" "-c")))) (add-to-list 'tramp-methods + `(,tramp-podmancp-method + (tramp-login-program ,tramp-podman-program) + (tramp-login-args (("exec") + ("-it") + ("-u" "%u") + ("%h") + ("%l"))) + (tramp-direct-async (,tramp-default-remote-shell "-c")) + (tramp-remote-shell ,tramp-default-remote-shell) + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-i" "-c")) + (tramp-copy-program ,tramp-podman-program) + (tramp-copy-args (("cp"))) + (tramp-copy-file-name (("%h" ":") ("%f"))) + (tramp-copy-recursive t))) + + (add-to-list 'tramp-methods `(,tramp-kubernetes-method (tramp-login-program ,tramp-kubernetes-program) (tramp-login-args (("%x") ; context and namespace. @@ -432,10 +482,18 @@ see its function help for a description of the format." `((tramp-container--completion-function ,tramp-docker-method))) (tramp-set-completion-function + tramp-dockercp-method + `((tramp-container--completion-function ,tramp-dockercp-method))) + + (tramp-set-completion-function tramp-podman-method `((tramp-container--completion-function ,tramp-podman-method))) (tramp-set-completion-function + tramp-podmancp-method + `((tramp-container--completion-function ,tramp-podmancp-method))) + + (tramp-set-completion-function tramp-kubernetes-method `((tramp-kubernetes--completion-function ,tramp-kubernetes-method))) diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 72589e7ce4a..93071ed7350 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -888,7 +888,8 @@ Operations not mentioned here will be handled by the default Emacs primitives.") "Invoke the GVFS related OPERATION and ARGS. First arg specifies the OPERATION, second arg is a list of arguments to pass to the OPERATION." - (unless tramp-gvfs-enabled + ;; `file-remote-p' must not return an error. (Bug#68976) + (unless (or tramp-gvfs-enabled (eq operation 'file-remote-p)) (tramp-user-error nil "Package `tramp-gvfs' not supported")) (if-let ((filename (apply #'tramp-file-name-for-operation operation args)) (tramp-gvfs-dbus-event-vector @@ -2293,8 +2294,8 @@ connection if a previous connection has died for some reason." ;; indicated by the "mounted" signal, i.e. the ;; "fuse-mountpoint" file property. (with-timeout - ((or (tramp-get-method-parameter vec 'tramp-connection-timeout) - tramp-connection-timeout) + ((tramp-get-method-parameter + vec 'tramp-connection-timeout tramp-connection-timeout) (if (tramp-string-empty-or-nil-p (tramp-file-name-user vec)) (tramp-error vec 'file-error diff --git a/lisp/net/tramp-integration.el b/lisp/net/tramp-integration.el index c0b60f57e40..e1f0b2a3495 100644 --- a/lisp/net/tramp-integration.el +++ b/lisp/net/tramp-integration.el @@ -69,7 +69,7 @@ special handling of `substitute-in-file-name'." (when minibuffer-completing-file-name (setq tramp-rfn-eshadow-overlay (make-overlay (minibuffer-prompt-end) (minibuffer-prompt-end))) - ;; Copy rfn-eshadow-overlay properties. + ;; Copy `rfn-eshadow-overlay' properties. (let ((props (overlay-properties rfn-eshadow-overlay))) (while props ;; The `field' property prevents correct minibuffer diff --git a/lisp/net/tramp-message.el b/lisp/net/tramp-message.el index 96071e626a5..97e94a51e7a 100644 --- a/lisp/net/tramp-message.el +++ b/lisp/net/tramp-message.el @@ -353,6 +353,7 @@ applicable)." If VEC-OR-PROC is nil, the buffer *debug tramp* is used. FORCE forces the backtrace even if `tramp-verbose' is less than 10. This function is meant for debugging purposes." + (declare (tramp-suppress-trace t)) (let ((tramp-verbose (if force 10 tramp-verbose))) (when (>= tramp-verbose 10) (tramp-message @@ -364,6 +365,7 @@ VEC-OR-PROC identifies the connection to use, SIGNAL is the signal identifier to be raised, remaining arguments passed to `tramp-message'. Finally, signal SIGNAL is raised with FMT-STRING and ARGUMENTS." + (declare (tramp-suppress-trace t)) (let (signal-hook-function) (tramp-backtrace vec-or-proc) (unless arguments @@ -391,6 +393,7 @@ tramp-tests.el.") "Emit an error, and show BUF. If BUF is nil, show the connection buf. Wait for 30\", or until an input event arrives. The other arguments are passed to `tramp-error'." + (declare (tramp-suppress-trace t)) (save-window-excursion (let* ((buf (or (and (bufferp buf) buf) (and (processp vec-or-proc) (process-buffer vec-or-proc)) @@ -424,6 +427,7 @@ an input event arrives. The other arguments are passed to `tramp-error'." (defsubst tramp-user-error (vec-or-proc fmt-string &rest arguments) "Signal a user error (or \"pilot error\")." + (declare (tramp-suppress-trace t)) (unwind-protect (apply #'tramp-error vec-or-proc 'user-error fmt-string arguments) ;; Save exit. diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 6489f473634..66e648624b2 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -38,7 +38,6 @@ (declare-function dired-compress-file "dired-aux") (declare-function dired-remove-file "dired-aux") (defvar dired-compress-file-suffixes) -(defvar ls-lisp-use-insert-directory-program) ;; Added in Emacs 28.1. (defvar process-file-return-signal-string) (defvar vc-handled-backends) @@ -283,6 +282,7 @@ The string is used in `tramp-methods'.") (tramp-copy-program "nc") ;; We use "-v" for better error tracking. (tramp-copy-args (("-w" "1") ("-v") ("%h") ("%r"))) + (tramp-copy-file-name (("%f"))) (tramp-remote-copy-program "nc") ;; We use "-p" as required for newer busyboxes. For older ;; busybox/nc versions, the value must be (("-l") ("%r")). This @@ -429,6 +429,9 @@ The string is used in `tramp-methods'.") eos) nil ,(user-login-name)))) +(defconst tramp-default-copy-file-name '(("%u" "@") ("%h" ":") ("%f")) + "Default `tramp-copy-file-name' entry for out-of-band methods.") + ;;;###tramp-autoload (defconst tramp-completion-function-alist-rsh '((tramp-parse-rhosts "/etc/hosts.equiv") @@ -548,6 +551,7 @@ shell from reading its init file." (tramp-terminal-prompt-regexp tramp-action-terminal) (tramp-antispoof-regexp tramp-action-confirm-message) (tramp-security-key-confirm-regexp tramp-action-show-and-confirm-message) + (tramp-security-key-pin-regexp tramp-action-otp-password) (tramp-process-alive-regexp tramp-action-process-alive)) "List of pattern/action pairs. Whenever a pattern matches, the corresponding action is performed. @@ -567,6 +571,7 @@ corresponding PATTERN matches, the ACTION function is called.") (tramp-wrong-passwd-regexp tramp-action-permission-denied) (tramp-copy-failed-regexp tramp-action-permission-denied) (tramp-security-key-confirm-regexp tramp-action-show-and-confirm-message) + (tramp-security-key-pin-regexp tramp-action-otp-password) (tramp-process-alive-regexp tramp-action-out-of-band)) "List of pattern/action pairs. This list is used for copying/renaming with out-of-band methods. @@ -2010,7 +2015,7 @@ ID-FORMAT valid values are `string' and `integer'." #'copy-directory (list dirname newname keep-date parents copy-contents)))) - ;; When newname did exist, we have wrong cached values. + ;; NEWNAME has wrong cached values. (when t2 (with-parsed-tramp-file-name (expand-file-name newname) nil (tramp-flush-file-properties v localname))))))) @@ -2149,24 +2154,24 @@ file names." ;; One of them must be a Tramp file. (error "Tramp implementation says this cannot happen"))) - ;; Handle `preserve-extended-attributes'. We ignore - ;; possible errors, because ACL strings could be - ;; incompatible. - (when-let ((attributes (and preserve-extended-attributes - (file-extended-attributes filename)))) - (ignore-errors - (set-file-extended-attributes newname attributes))) - ;; In case of `rename', we must flush the cache of the source file. (when (and t1 (eq op 'rename)) (with-parsed-tramp-file-name filename v1 (tramp-flush-file-properties v1 v1-localname))) - ;; When newname did exist, we have wrong cached values. + ;; NEWNAME has wrong cached values. (when t2 (with-parsed-tramp-file-name newname v2 (tramp-flush-file-properties v2 v2-localname))) + ;; Handle `preserve-extended-attributes'. We ignore + ;; possible errors, because ACL strings could be + ;; incompatible. + (when-let ((attributes (and preserve-extended-attributes + (file-extended-attributes filename)))) + (ignore-errors + (set-file-extended-attributes newname attributes))) + ;; KEEP-DATE handling. (when (and keep-date (not copy-keep-date)) (tramp-compat-set-file-times @@ -2398,10 +2403,10 @@ The method used must be an out-of-band method." #'file-name-as-directory #'identity) (if v1 - (tramp-make-copy-program-file-name v1) + (tramp-make-copy-file-name v1) (file-name-unquote filename))) target (if v2 - (tramp-make-copy-program-file-name v2) + (tramp-make-copy-file-name v2) (file-name-unquote newname))) ;; Check for listener port. @@ -2438,9 +2443,9 @@ The method used must be an out-of-band method." copy-program (tramp-get-method-parameter v 'tramp-copy-program) copy-args ;; " " has either been a replacement of "%k" (when - ;; keep-date argument is non-nil), or a replacement for + ;; KEEP-DATE argument is non-nil), or a replacement for ;; the whole keep-date sublist. - (delete " " (apply #'tramp-expand-args v 'tramp-copy-args spec)) + (delete " " (apply #'tramp-expand-args v 'tramp-copy-args nil spec)) ;; `tramp-ssh-controlmaster-options' is a string instead ;; of a list. Unflatten it. copy-args @@ -2449,11 +2454,11 @@ The method used must be an out-of-band method." (lambda (x) (if (tramp-compat-string-search " " x) (split-string x) x)) copy-args)) - copy-env (apply #'tramp-expand-args v 'tramp-copy-env spec) + copy-env (apply #'tramp-expand-args v 'tramp-copy-env nil spec) remote-copy-program (tramp-get-method-parameter v 'tramp-remote-copy-program) remote-copy-args - (apply #'tramp-expand-args v 'tramp-remote-copy-args spec)) + (apply #'tramp-expand-args v 'tramp-remote-copy-args nil spec)) ;; Check for local copy program. (unless (executable-find copy-program) @@ -2636,7 +2641,7 @@ The method used must be an out-of-band method." (defun tramp-sh-handle-insert-directory (filename switches &optional wildcard full-directory-p) "Like `insert-directory' for Tramp files." - (if (and (featurep 'ls-lisp) + (if (and (boundp 'ls-lisp-use-insert-directory-program) (not ls-lisp-use-insert-directory-program)) (tramp-handle-insert-directory filename switches wildcard full-directory-p) @@ -3652,20 +3657,20 @@ filled are described in `tramp-bundle-read-file-names'." (dolist (elt - (ignore-errors + (with-current-buffer (tramp-get-connection-buffer vec) ;; We cannot use `tramp-send-command-and-read', because ;; this does not cooperate well with heredoc documents. - (tramp-send-command - vec - (format - "tramp_bundle_read_file_names <<'%s'\n%s\n%s\n" - tramp-end-of-heredoc - (mapconcat #'tramp-shell-quote-argument files "\n") - tramp-end-of-heredoc)) - (with-current-buffer (tramp-get-connection-buffer vec) - ;; Read the expression. - (goto-char (point-min)) - (read (current-buffer))))) + (unless (tramp-send-command-and-check + vec + (format + "tramp_bundle_read_file_names <<'%s'\n%s\n%s\n" + tramp-end-of-heredoc + (mapconcat #'tramp-shell-quote-argument files "\n") + tramp-end-of-heredoc)) + (tramp-error vec 'file-error "%s" (tramp-get-buffer-string))) + ;; Read the expression. + (goto-char (point-min)) + (read (current-buffer)))) (tramp-set-file-property vec (car elt) "file-exists-p" (nth 1 elt)) (tramp-set-file-property vec (car elt) "file-readable-p" (nth 2 elt)) @@ -4112,7 +4117,7 @@ Only send the definition if it has not already been done." (unless (member name scripts) (with-tramp-progress-reporter vec 5 (format-message "Sending script `%s'" name) - ;; In bash, leading TABs like in `tramp-vc-registered-read-file-names' + ;; In bash, leading TABs like in `tramp-bundle-read-file-names' ;; could result in unwanted command expansion. Avoid this. (setq script (tramp-compat-string-replace (make-string 1 ?\t) (make-string 8 ? ) script)) @@ -5289,7 +5294,8 @@ connection if a previous connection has died for some reason." (tramp-get-method-parameter hop 'tramp-async-args))) (connection-timeout (tramp-get-method-parameter - hop 'tramp-connection-timeout)) + hop 'tramp-connection-timeout + tramp-connection-timeout)) (command (tramp-get-method-parameter hop 'tramp-login-program)) @@ -5347,14 +5353,14 @@ connection if a previous connection has died for some reason." ;; Add arguments for asynchronous processes. (when process-name async-args) (tramp-expand-args - hop 'tramp-login-args + hop 'tramp-login-args nil ?h (or l-host "") ?u (or l-user "") ?p (or l-port "") ?c (format-spec options (format-spec-make ?t tmpfile)) ?n (concat "2>" (tramp-get-remote-null-device previous-hop)) ?l (concat remote-shell " " extra-args " -i")) ;; A restricted shell does not allow "exec". - (when r-shell '("&&" "exit" "||" "exit"))) + (when r-shell '("&&" "exit")) '("||" "exit")) " ")) ;; Send the command. @@ -5364,8 +5370,7 @@ connection if a previous connection has died for some reason." p vec (min pos (with-current-buffer (process-buffer p) (point-max))) - tramp-actions-before-shell - (or connection-timeout tramp-connection-timeout)) + tramp-actions-before-shell connection-timeout) (tramp-message vec 3 "Found remote shell prompt on `%s'" l-host) @@ -5558,8 +5563,8 @@ raises an error." string "")) -(defun tramp-make-copy-program-file-name (vec) - "Create a file name suitable for `scp', `pscp', or `nc' and workalikes." +(defun tramp-make-copy-file-name (vec) + "Create a file name suitable for out-of-band methods." (let ((method (tramp-file-name-method vec)) (user (tramp-file-name-user vec)) (host (tramp-file-name-host vec)) @@ -5570,13 +5575,13 @@ raises an error." ;; This does not work for MS Windows scp, if there are characters ;; to be quoted. OpenSSH 8 supports disabling of strict file name ;; checking in scp, we use it when available. - (unless (string-match-p (rx "ftp" eos) method) + (unless (string-match-p (rx (| "dockercp" "podmancp" "ftp") eos) method) (setq localname (tramp-unquote-shell-quote-argument localname))) - (cond - ((tramp-get-method-parameter vec 'tramp-remote-copy-program) - localname) - ((tramp-string-empty-or-nil-p user) (format "%s:%s" host localname)) - (t (format "%s@%s:%s" user host localname))))) + (string-join + (apply #'tramp-expand-args vec + 'tramp-copy-file-name tramp-default-copy-file-name + (list ?h (or host "") ?u (or user "") ?f localname)) + ""))) (defun tramp-method-out-of-band-p (vec size) "Return t if this is an out-of-band method, nil otherwise." diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el index 8dad599c7e7..d0d56b8967e 100644 --- a/lisp/net/tramp-sshfs.el +++ b/lisp/net/tramp-sshfs.el @@ -322,7 +322,7 @@ arguments to pass to the OPERATION." v (tramp-get-method-parameter v 'tramp-login-program) nil outbuf display (tramp-expand-args - v 'tramp-login-args + v 'tramp-login-args nil ?h (or (tramp-file-name-host v) "") ?u (or (tramp-file-name-user v) "") ?p (or (tramp-file-name-port v) "") @@ -424,7 +424,7 @@ connection if a previous connection has died for some reason." (tramp-fuse-mount-spec vec) (tramp-fuse-mount-point vec) (tramp-expand-args - vec 'tramp-mount-args + vec 'tramp-mount-args nil ?p (or (tramp-file-name-port vec) "")))))) (tramp-error vec 'file-error "Error mounting %s" (tramp-fuse-mount-spec vec))) diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index 0c717c4a5aa..7bbfec62753 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -771,7 +771,7 @@ in case of error, t otherwise." (tramp-get-connection-name vec) (current-buffer) (append (tramp-expand-args - vec 'tramp-sudo-login + vec 'tramp-sudo-login nil ?h (or (tramp-file-name-host vec) "") ?u (or (tramp-file-name-user vec) "")) (flatten-tree args)))) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 2f6b526039f..5b101000926 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -67,11 +67,6 @@ (declare-function file-notify-rm-watch "filenotify") (declare-function netrc-parse "netrc") (defvar auto-save-file-name-transforms) -(defvar ls-lisp-dirs-first) -(defvar ls-lisp-emulation) -(defvar ls-lisp-ignore-case) -(defvar ls-lisp-use-insert-directory-program) -(defvar ls-lisp-verbosity) (defvar tramp-prefix-format) (defvar tramp-prefix-regexp) (defvar tramp-method-regexp) @@ -219,7 +214,7 @@ pair of the form (KEY VALUE). The following KEYs are defined: set this to any value other than \"/bin/sh\": Tramp wants to use a shell which groks tilde expansion, but it can search for it. Also note that \"/bin/sh\" exists on all Unixen - except Andtoid, this might not be true for the value that you + except Android, this might not be true for the value that you decide to use. You Have Been Warned. * `tramp-remote-shell-login' @@ -306,6 +301,15 @@ pair of the form (KEY VALUE). The following KEYs are defined: This specifies the list of parameters to pass to the above mentioned program, the hints for `tramp-login-args' also apply here. + * `tramp-copy-file-name' + The remote source or destination file name for out-of-band methods. + You can use \"%u\" and \"%h\" like in `tramp-login-args'. + Additionally, \"%f\" denotes the local file name part. This list + will be expanded to a string without spaces between the elements of + the list. + + The default value is `tramp-default-copy-file-name'. + * `tramp-copy-env' A list of environment variables and their values, which will be set when calling `tramp-copy-program'. @@ -320,8 +324,8 @@ pair of the form (KEY VALUE). The following KEYs are defined: chosen port for the remote listener. * `tramp-copy-keep-date' - This specifies whether the copying program when the preserves the - timestamp of the original file. + This specifies whether the copying program preserves the timestamp + of the original file. * `tramp-copy-keep-tmpfile' This specifies whether a temporary local file shall be kept @@ -562,7 +566,7 @@ host runs a restricted shell, it shall be added to this list, too." eos) "Host names which are regarded as local host. If the local host runs a chrooted environment, set this to nil." - :version "30.1" + :version "29.3" :type '(choice (const :tag "Chrooted environment" nil) (regexp :tag "Host regexp"))) @@ -750,9 +754,8 @@ The regexp should match at end of buffer." ;; A security key requires the user physically to touch the device ;; with their finger. We must tell it to the user. -;; Added in OpenSSH 8.2. I've tested it with yubikey. Nitrokey and -;; Titankey, which have also passed the tests, do not show such a -;; message. +;; Added in OpenSSH 8.2. I've tested it with Nitrokey, Titankey, and +;; Yubikey. (defcustom tramp-security-key-confirm-regexp (rx bol (* "\r") "Confirm user presence for key " (* nonl) (* (any "\r\n"))) "Regular expression matching security key confirmation message. @@ -775,6 +778,14 @@ The regexp should match at end of buffer." :version "28.1" :type 'regexp) +;; Needed only for FIDO2 (residential) keys. Tested with Nitrokey and Yubikey. +(defcustom tramp-security-key-pin-regexp + (rx bol (* "\r") (group "Enter PIN for " (* nonl)) (* (any "\r\n"))) + "Regular expression matching security key PIN prompt. +The regexp should match at end of buffer." + :version "29.3" + :type 'regexp) + (defcustom tramp-operation-not-permitted-regexp (rx (| (: "preserving times" (* nonl)) "set mode") ":" (* blank) "Operation not permitted") @@ -1085,10 +1096,10 @@ Derived from `tramp-postfix-host-format'.") (defconst tramp-localname-regexp (rx (* (not (any "\r\n"))) eos) "Regexp matching localnames.") -(defconst tramp-unknown-id-string "UNKNOWN" +(defvar tramp-unknown-id-string "UNKNOWN" "String used to denote an unknown user or group.") -(defconst tramp-unknown-id-integer -1 +(defvar tramp-unknown-id-integer -1 "Integer used to denote an unknown user or group.") ;;;###tramp-autoload @@ -1205,14 +1216,7 @@ The `ftp' syntax does not support methods.") ;; FIXME: This shouldn't be necessary. (rx bos "/" (? "[" (* (not "]"))) eos) (rx - bos - ;; `file-name-completion' uses absolute paths for matching. - ;; This means that on W32 systems, something like - ;; "/ssh:host:~/path" becomes "c:/ssh:host:~/path". See also - ;; `tramp-drop-volume-letter'. - (? (regexp tramp-volume-letter-regexp)) - ;; We cannot use `tramp-prefix-regexp', because it starts with `bol'. - (literal tramp-prefix-format) + (regexp tramp-prefix-regexp) ;; Optional multi-hops. (* (regexp tramp-remote-file-name-spec-regexp) @@ -1550,21 +1554,23 @@ LOCALNAME and HOP do not count." (equal (tramp-file-name-unify vec1) (tramp-file-name-unify vec2)))) -(defun tramp-get-method-parameter (vec param) +(defun tramp-get-method-parameter (vec param &optional default) "Return the method parameter PARAM. If VEC is a vector, check first in connection properties. Afterwards, check in `tramp-methods'. If the `tramp-methods' -entry does not exist, return nil." +entry does not exist, return DEFAULT." (let ((hash-entry (replace-regexp-in-string (rx bos "tramp-") "" (symbol-name param)))) (if (tramp-connection-property-p vec hash-entry) ;; We use the cached property. (tramp-get-connection-property vec hash-entry) ;; Use the static value from `tramp-methods'. - (when-let ((methods-entry + (if-let ((methods-entry (assoc param (assoc (tramp-file-name-method vec) tramp-methods)))) - (cadr methods-entry))))) + (cadr methods-entry) + ;; Return the default value. + default)))) ;; The localname can be quoted with "/:". Extract this. (defun tramp-file-name-unquote-localname (vec) @@ -2081,7 +2087,7 @@ without a visible progress reporter." (defmacro with-tramp-timeout (list &rest body) "Like `with-timeout', but allow SECONDS to be nil. -(fn (SECONDS TIMEOUT-FORMS...) BODY)" +\(fn (SECONDS TIMEOUT-FORMS...) BODY)" (declare (indent 1) (debug ((form body) body))) (let ((seconds (car list)) (timeout-forms (cdr list))) @@ -2666,7 +2672,7 @@ not in completion mode." (string-match-p (rx (regexp tramp-postfix-host-regexp) eos) dir)) (concat dir filename)) ((string-match-p - (rx bos (regexp tramp-prefix-regexp) + (rx (regexp tramp-prefix-regexp) (* (regexp tramp-remote-file-name-spec-regexp) (regexp tramp-postfix-hop-regexp)) (? (regexp tramp-method-regexp) (regexp tramp-postfix-method-regexp) @@ -3198,7 +3204,7 @@ Host is always \"localhost\"." (when (zerop (tramp-call-process nil "getent" nil t nil "passwd")) (goto-char (point-min)) (cl-loop while (not (eobp)) collect - (tramp-parse-etc-group-group)))) + (tramp-parse-passwd-group)))) (tramp-parse-file filename #'tramp-parse-passwd-group)))) (defun tramp-parse-passwd-group () @@ -3948,6 +3954,9 @@ Let-bind it when necessary.") (tramp-get-method-parameter v 'tramp-case-insensitive) ;; There isn't. So we must check, in case there's a connection already. + ;; Note: We cannot use it as DEFAULT value of + ;; `tramp-get-method-parameter', because it would be evalled + ;; during the call. (and (let ((non-essential t)) (tramp-connectable-p v)) (with-tramp-connection-property v "case-insensitive" (ignore-errors @@ -4196,6 +4205,11 @@ Let-bind it when necessary.") (filename switches &optional wildcard full-directory-p) "Like `insert-directory' for Tramp files." (require 'ls-lisp) + (defvar ls-lisp-dirs-first) + (defvar ls-lisp-emulation) + (defvar ls-lisp-ignore-case) + (defvar ls-lisp-use-insert-directory-program) + (defvar ls-lisp-verbosity) (unless switches (setq switches "")) ;; Mark trailing "/". (when (and (directory-name-p filename) @@ -4752,15 +4766,15 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.") (defvar tramp-extra-expand-args nil "Method specific arguments.") -(defun tramp-expand-args (vec parameter &rest spec-list) +(defun tramp-expand-args (vec parameter default &rest spec-list) "Expand login arguments as given by PARAMETER in `tramp-methods'. PARAMETER is a symbol like `tramp-login-args', denoting a list of list of strings from `tramp-methods', containing %-sequences for -substitution. +substitution. DEFAULT is used when PARAMETER is not specified. SPEC-LIST is a list of char/value pairs used for `format-spec-make'. It is appended by `tramp-extra-expand-args', a connection-local variable." - (let ((args (tramp-get-method-parameter vec parameter)) + (let ((args (tramp-get-method-parameter vec parameter default)) (extra-spec-list (mapcar #'eval @@ -4939,7 +4953,7 @@ a connection-local variable." (mapcar (lambda (x) (split-string x " ")) (tramp-expand-args - v 'tramp-login-args + v 'tramp-login-args nil ?h (or host "") ?u (or user "") ?p (or port "") ?c (format-spec (or options "") (format-spec-make ?t tmpfile)) ?d (or device "") ?a (or pta "") ?l "")))) @@ -5442,7 +5456,7 @@ of." prompt) (goto-char (point-min)) (tramp-check-for-regexp proc tramp-process-action-regexp) - (setq prompt (concat (match-string 1) " ")) + (setq prompt (concat (string-trim (match-string 1)) " ")) (tramp-message vec 3 "Sending %s" (match-string 1)) ;; We don't call `tramp-send-string' in order to hide the ;; password from the debug buffer and the traces. @@ -5518,14 +5532,16 @@ Wait, until the connection buffer changes." (ignore set-message-function clear-message-function) (tramp-message vec 6 "\n%s" (buffer-string)) (tramp-check-for-regexp proc tramp-process-action-regexp) - (with-temp-message - (replace-regexp-in-string (rx (any "\r\n")) "" (match-string 0)) + (with-temp-message (concat (string-trim (match-string 0)) " ") ;; Hide message in buffer. (narrow-to-region (point-max) (point-max)) ;; Wait for new output. (while (not (ignore-error file-error (tramp-wait-for-regexp - proc 0.1 tramp-security-key-confirmed-regexp))) + proc 0.1 + (rx (| (regexp tramp-security-key-confirmed-regexp) + (regexp tramp-security-key-pin-regexp) + (regexp tramp-security-key-timeout-regexp)))))) (when (tramp-check-for-regexp proc tramp-security-key-timeout-regexp) (throw 'tramp-action 'timeout)) (redisplay 'force)))))) @@ -6324,9 +6340,8 @@ This handles also chrooted environments, which are not regarded as local." (defun tramp-get-remote-tmpdir (vec) "Return directory for temporary files on the remote host identified by VEC." (with-tramp-connection-property (tramp-get-process vec) "remote-tmpdir" - (let ((dir - (tramp-make-tramp-file-name - vec (or (tramp-get-method-parameter vec 'tramp-tmpdir) "/tmp")))) + (let ((dir (tramp-make-tramp-file-name + vec (tramp-get-method-parameter vec 'tramp-tmpdir "/tmp")))) (or (and (file-directory-p dir) (file-writable-p dir) (tramp-file-local-name dir)) (tramp-error vec 'file-error "Directory %s not accessible" dir)) @@ -6571,12 +6586,13 @@ Consults the auth-source package." (tramp-get-connection-property key "login-as"))) (host (tramp-file-name-host-port vec)) (pw-prompt - (or prompt - (with-current-buffer (process-buffer proc) - (tramp-check-for-regexp proc tramp-password-prompt-regexp) - (if (string-match-p "passphrase" (match-string 1)) - (match-string 0) - (format "%s for %s " (capitalize (match-string 1)) key))))) + (string-trim-left + (or prompt + (with-current-buffer (process-buffer proc) + (tramp-check-for-regexp proc tramp-password-prompt-regexp) + (if (string-match-p "passphrase" (match-string 1)) + (match-string 0) + (format "%s for %s " (capitalize (match-string 1)) key)))))) (auth-source-creation-prompts `((secret . ,pw-prompt))) ;; Use connection-local value. (auth-sources (buffer-local-value 'auth-sources (process-buffer proc))) diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el index bfabbbeaf34..c131d39c110 100644 --- a/lisp/net/trampver.el +++ b/lisp/net/trampver.el @@ -7,7 +7,7 @@ ;; Maintainer: Michael Albinus <michael.albinus@gmx.de> ;; Keywords: comm, processes ;; Package: tramp -;; Version: 2.7.0-pre +;; Version: 2.7.1-pre ;; Package-Requires: ((emacs "27.1")) ;; Package-Type: multi ;; URL: https://www.gnu.org/software/tramp/ @@ -40,7 +40,7 @@ ;; ./configure" to change them. ;;;###tramp-autoload -(defconst tramp-version "2.7.0-pre" +(defconst tramp-version "2.7.1-pre" "This version of Tramp.") ;;;###tramp-autoload @@ -78,7 +78,7 @@ ;; Check for Emacs version. (let ((x (if (not (string-version-lessp emacs-version "27.1")) "ok" - (format "Tramp 2.7.0-pre is not fit for %s" + (format "Tramp 2.7.1-pre is not fit for %s" (replace-regexp-in-string "\n" "" (emacs-version)))))) (unless (string-equal "ok" x) (error "%s" x))) diff --git a/lisp/notifications.el b/lisp/notifications.el index 6abc6e163ed..2692df9d7fa 100644 --- a/lisp/notifications.el +++ b/lisp/notifications.el @@ -23,7 +23,7 @@ ;;; Commentary: ;; This package provides an implementation of the Desktop Notifications -;; <https://developer.gnome.org/notification-spec/>. +;; <https://specifications.freedesktop.org/notification-spec/latest/>. ;; In order to activate this package, you must add the following code ;; into your .emacs: diff --git a/lisp/obarray.el b/lisp/obarray.el index a26992df8e2..5e646db9ab7 100644 --- a/lisp/obarray.el +++ b/lisp/obarray.el @@ -27,24 +27,13 @@ ;;; Code: -(defconst obarray-default-size 59 - "The value 59 is an arbitrary prime number that gives a good hash.") +(defconst obarray-default-size 4) +(make-obsolete-variable 'obarray-default-size + "obarrays now grow automatically." "30.1") -(defun obarray-make (&optional size) - "Return a new obarray of size SIZE or `obarray-default-size'." - (let ((size (or size obarray-default-size))) - (if (< 0 size) - (make-vector size 0) - (signal 'wrong-type-argument '(size 0))))) - -(defun obarray-size (ob) - "Return the number of slots of obarray OB." - (length ob)) - -(defun obarrayp (object) - "Return t if OBJECT is an obarray." - (and (vectorp object) - (< 0 (length object)))) +(defun obarray-size (_ob) + (declare (obsolete "obarrays now grow automatically." "30.1")) + obarray-default-size) ;; Don’t use obarray as a variable name to avoid shadowing. (defun obarray-get (ob name) @@ -54,7 +43,7 @@ Return nil otherwise." (defun obarray-put (ob name) "Return symbol named NAME from obarray OB. -Creates and adds the symbol if doesn't exist." +Creates and adds the symbol if it doesn't exist." (intern name ob)) (defun obarray-remove (ob name) diff --git a/lisp/obsolete/eieio-compat.el b/lisp/obsolete/eieio-compat.el index 26648a4d7bb..8fdcebbd1c4 100644 --- a/lisp/obsolete/eieio-compat.el +++ b/lisp/obsolete/eieio-compat.el @@ -150,10 +150,9 @@ Summary: (lambda (tag &rest _) (and (symbolp tag) (setq tag (cl--find-class tag)) (eieio--class-p tag) - (let ((superclasses (eieio--class-precedence-list tag)) + (let ((superclasses (cl--class-allparents tag)) (specializers ())) (dolist (superclass superclasses) - (setq superclass (eieio--class-name superclass)) (push superclass specializers) (push `(eieio--static ,superclass) specializers)) (nreverse specializers))))) @@ -240,7 +239,7 @@ Summary: (declare (obsolete cl-no-applicable-method "25.1")) (apply #'cl-no-applicable-method method object args)) -(define-obsolete-function-alias 'call-next-method 'cl-call-next-method "25.1") +(define-obsolete-function-alias 'call-next-method #'cl-call-next-method "25.1") (defun next-method-p () (declare (obsolete cl-next-method-p "25.1")) ;; EIEIO's `next-method-p' just returned nil when called in an diff --git a/lisp/obsolete/iswitchb.el b/lisp/obsolete/iswitchb.el index 3f05b7fe7ac..e1ea9141f0d 100644 --- a/lisp/obsolete/iswitchb.el +++ b/lisp/obsolete/iswitchb.el @@ -370,7 +370,7 @@ See documentation of `walk-windows' for useful values." This hook is run during minibuffer setup if `iswitchb' is active. For instance: \(add-hook \\='iswitchb-minibuffer-setup-hook - \\='\(lambda () (set (make-local-variable \\='max-mini-window-height) 3))) + \\='\(lambda () (setq-local max-mini-window-height 3))) will constrain the minibuffer to a maximum height of 3 lines when iswitchb is running." :type 'hook) @@ -1262,7 +1262,7 @@ Modified from `icomplete-completions'." "Set up minibuffer for `iswitchb-buffer'. Copied from `icomplete-minibuffer-setup-hook'." (when (iswitchb-entryfn-p) - (set (make-local-variable 'iswitchb-use-mycompletion) t) + (setq-local iswitchb-use-mycompletion t) (add-hook 'pre-command-hook #'iswitchb-pre-command nil t) (add-hook 'post-command-hook #'iswitchb-post-command nil t) (run-hooks 'iswitchb-minibuffer-setup-hook))) diff --git a/lisp/obsolete/longlines.el b/lisp/obsolete/longlines.el index 6aa388805f2..f065bcaff26 100644 --- a/lisp/obsolete/longlines.el +++ b/lisp/obsolete/longlines.el @@ -116,17 +116,14 @@ newlines are indicated with a symbol." ;; Turn on longlines mode (progn (use-hard-newlines 1 'never) - (set (make-local-variable 'require-final-newline) nil) + (setq-local require-final-newline nil) (add-to-list 'buffer-file-format 'longlines) (add-hook 'change-major-mode-hook #'longlines-mode-off nil t) (add-hook 'before-revert-hook #'longlines-before-revert-hook nil t) (make-local-variable 'longlines-auto-wrap) - (set (make-local-variable 'isearch-search-fun-function) - #'longlines-search-function) - (set (make-local-variable 'replace-search-function) - #'longlines-search-forward) - (set (make-local-variable 'replace-re-search-function) - #'longlines-re-search-forward) + (setq-local isearch-search-fun-function #'longlines-search-function) + (setq-local replace-search-function #'longlines-search-forward) + (setq-local replace-re-search-function #'longlines-re-search-forward) (add-function :filter-return (local 'filter-buffer-substring-function) #'longlines-encode-string) (when longlines-wrap-follows-window-size @@ -136,8 +133,7 @@ newlines are indicated with a symbol." (window-width))) longlines-wrap-follows-window-size 2))) - (set (make-local-variable 'fill-column) - (- (window-width) dw))) + (setq-local fill-column (- (window-width) dw))) (add-hook 'window-configuration-change-hook #'longlines-window-change-function nil t)) (let ((buffer-undo-list t) diff --git a/lisp/obsolete/pgg.el b/lisp/obsolete/pgg.el index 6c00ad201f1..4c7b653155e 100644 --- a/lisp/obsolete/pgg.el +++ b/lisp/obsolete/pgg.el @@ -85,9 +85,9 @@ is true, or else the output buffer is displayed." (set-buffer standard-output) (insert-buffer-substring pgg-errors-buffer)))) -(defvar pgg-passphrase-cache (make-vector 7 0)) +(defvar pgg-passphrase-cache (obarray-make 7)) -(defvar pgg-pending-timers (make-vector 7 0) +(defvar pgg-pending-timers (obarray-make 7) "Hash table for managing scheduled pgg cache management timers. We associate key and timer, so the timer can be canceled if a new diff --git a/lisp/obsolete/quickurl.el b/lisp/obsolete/quickurl.el index 7393bebdce1..7da51a8a4a8 100644 --- a/lisp/obsolete/quickurl.el +++ b/lisp/obsolete/quickurl.el @@ -447,7 +447,7 @@ The key bindings for `quickurl-list-mode' are: (defun quickurl-list-populate-buffer () "Populate the `quickurl-list' buffer." - (with-current-buffer (get-buffer quickurl-list-buffer-name) + (with-current-buffer quickurl-list-buffer-name (let* ((sizes (or (cl-loop for url in quickurl-urls collect (length (quickurl-url-description url))) (list 20))) diff --git a/lisp/obsolete/rcompile.el b/lisp/obsolete/rcompile.el index e0826475e32..258b2b519d9 100644 --- a/lisp/obsolete/rcompile.el +++ b/lisp/obsolete/rcompile.el @@ -169,12 +169,12 @@ See \\[compile]." ;; compilation-parse-errors will find referenced files by Tramp. (with-current-buffer next-error-last-buffer (when (fboundp 'tramp-make-tramp-file-name) - (set (make-local-variable 'comint-file-name-prefix) - (funcall - #'tramp-make-tramp-file-name - nil ;; method. - remote-compile-user - remote-compile-host - "")))))) + (setq-local comint-file-name-prefix + (funcall + #'tramp-make-tramp-file-name + nil ;; method. + remote-compile-user + remote-compile-host + "")))))) ;;; rcompile.el ends here diff --git a/lisp/org/ob-calc.el b/lisp/org/ob-calc.el index d335aab7499..f834f05cb6d 100644 --- a/lisp/org/ob-calc.el +++ b/lisp/org/ob-calc.el @@ -93,7 +93,7 @@ (mapcar #'org-trim (split-string (org-babel-expand-body:calc body params) "[\n\r]")))) (save-excursion - (with-current-buffer (get-buffer "*Calculator*") + (with-current-buffer "*Calculator*" (prog1 (calc-eval (calc-top 1)) (calc-pop 1))))) diff --git a/lisp/org/org-agenda.el b/lisp/org/org-agenda.el index f8195a053bc..06249ed48fa 100644 --- a/lisp/org/org-agenda.el +++ b/lisp/org/org-agenda.el @@ -3883,7 +3883,7 @@ generating a new one." ;; buffer found (get-buffer org-agenda-buffer-name) ;; C-u parameter is same as last call - (with-current-buffer (get-buffer org-agenda-buffer-name) + (with-current-buffer org-agenda-buffer-name (and (equal current-prefix-arg org-agenda-last-prefix-arg) diff --git a/lisp/org/org-element.el b/lisp/org/org-element.el index 6e87e870996..ef96dc024d1 100644 --- a/lisp/org/org-element.el +++ b/lisp/org/org-element.el @@ -6556,7 +6556,7 @@ the expected result." (error "org-element: Parsing aborted by user. Cache has been cleared. If you observe Emacs hangs frequently, please report this to Org mode mailing list (M-x org-submit-bug-report).")) (message (substitute-command-keys - "`org-element--parse-buffer': Suppressed `\\[keyboard-quit]'. Press `\\[keyboard-quit]' %d more times to force interruption.") + "`org-element--parse-to': Suppressed `\\[keyboard-quit]'. Press `\\[keyboard-quit]' %d more times to force interruption.") (- org-element--cache-interrupt-C-g-max-count org-element--cache-interrupt-C-g-count))) (unless element diff --git a/lisp/org/org-fold-core.el b/lisp/org/org-fold-core.el index 73b3c9bbf8c..be90ca398a1 100644 --- a/lisp/org/org-fold-core.el +++ b/lisp/org/org-fold-core.el @@ -433,7 +433,7 @@ Return nil when there is no matching folding spec." (org-fold-core-get-folding-spec-from-alias spec-or-alias)) (defsubst org-fold-core--check-spec (spec-or-alias) - "Throw an error if SPEC-OR-ALIAS is not in `org-fold-core--spec-priority-list'." + "Throw an error if SPEC-OR-ALIAS is not in `org-fold-core-folding-spec-list'." (unless (org-fold-core-folding-spec-p spec-or-alias) (error "%s is not a valid folding spec" spec-or-alias))) diff --git a/lisp/org/org-macro.el b/lisp/org/org-macro.el index 737eab5d2bb..fe3bbc658ff 100644 --- a/lisp/org/org-macro.el +++ b/lisp/org/org-macro.el @@ -109,6 +109,13 @@ previous one, unless VALUE is nil. Return the updated list." (let ((new-templates nil)) (pcase-dolist (`(,name . ,value) templates) (let ((old-definition (assoc name new-templates))) + ;; This code can be evaluated unconditionally, as a part of + ;; loading Org mode. We *must not* evaluate any code present + ;; inside the Org buffer while loading. Org buffers may come + ;; from various sources, like received email messages from + ;; potentially malicious senders. Org mode might be used to + ;; preview such messages and no code evaluation from inside the + ;; received Org text should ever happen without user consent. (when (and (stringp value) (string-match-p "\\`(eval\\>" value)) ;; Pre-process the evaluation form for faster macro expansion. (let* ((args (org-macro--makeargs value)) @@ -121,7 +128,7 @@ previous one, unless VALUE is nil. Return the updated list." (cadr (read value)) (error (user-error "Invalid definition for macro %S" name))))) - (setq value (eval (macroexpand-all `(lambda ,args ,body)) t)))) + (setq value `(lambda ,args ,body)))) (cond ((and value old-definition) (setcdr old-definition value)) (old-definition) (t (push (cons name (or value "")) new-templates))))) diff --git a/lisp/org/org-macs.el b/lisp/org/org-macs.el index 5df6062e464..aafbdf0e0aa 100644 --- a/lisp/org/org-macs.el +++ b/lisp/org/org-macs.el @@ -982,7 +982,7 @@ Otherwise, return nil." "Splits STRING into substrings at SEPARATORS. SEPARATORS is a regular expression. When nil, it defaults to -\"[ \f\t\n\r\v]+\". +\"[ \\f\\t\\n\\r\\v]+\". Unlike `split-string', matching SEPARATORS at the beginning and end of string are ignored." @@ -1072,7 +1072,7 @@ Return width in pixels when PIXELS is non-nil." ;; FIXME: Fallback to old limited version, because ;; `window-pixel-width' is buggy in older Emacs. (org--string-width-1 string) - ;; Wrap/line prefix will make `window-text-pizel-size' return too + ;; Wrap/line prefix will make `window-text-pixel-size' return too ;; large value including the prefix. (remove-text-properties 0 (length string) '(wrap-prefix t line-prefix t) diff --git a/lisp/org/org.el b/lisp/org/org.el index 2c5de69a36c..678936f3417 100644 --- a/lisp/org/org.el +++ b/lisp/org/org.el @@ -1140,6 +1140,24 @@ the following lines anywhere in the buffer: :package-version '(Org . "8.0") :type 'boolean) +(defvar untrusted-content) ; defined in files.el +(defvar org--latex-preview-when-risky nil + "If non-nil, enable LaTeX preview in Org buffers from unsafe source. + +Some specially designed LaTeX code may generate huge pdf or log files +that may exhaust disk space. + +This variable controls how to handle LaTeX preview when rendering LaTeX +fragments that originate from incoming email messages. It has no effect +when Org mode is unable to determine the origin of the Org buffer. + +An Org buffer is considered to be from unsafe source when the +variable `untrusted-content' has a non-nil value in the buffer. + +If this variable is non-nil, LaTeX previews are rendered unconditionally. + +This variable may be renamed or changed in the future.") + (defcustom org-insert-mode-line-in-empty-file nil "Non-nil means insert the first line setting Org mode in empty files. When the function `org-mode' is called interactively in an empty file, this @@ -4558,12 +4576,16 @@ from file or URL, and return nil. If NOCACHE is non-nil, do a fresh fetch of FILE even if cached version is available. This option applies only if FILE is a URL." (let* ((is-url (org-url-p file)) + (is-remote (condition-case nil + (file-remote-p file) + ;; In case of error, be safe. + (t t))) (cache (and is-url (not nocache) (gethash file org--file-cache)))) (cond (cache) - (is-url + ((or is-url is-remote) (if (org--should-fetch-remote-resource-p file) (condition-case error (with-current-buffer (url-retrieve-synchronously file) @@ -4649,9 +4671,9 @@ returns non-nil if any of them match." (propertize domain 'face '(:inherit org-link :weight normal)) ") as safe.\n ") "") - (propertize "f" 'face 'success) (if current-file (concat + (propertize "f" 'face 'success) " to download this resource, and permanently mark all resources in " (propertize current-file 'face 'underline) " as safe.\n ") @@ -4685,7 +4707,7 @@ returns non-nil if any of them match." (if (and (= char ?f) current-file) (concat "file://" current-file) uri)) "\\'"))))) - (prog1 (memq char '(?y ?n ?! ?d ?\s ?f)) + (prog1 (memq char '(?y ?! ?d ?\s ?f)) (quit-window t))))))) (defun org-extract-log-state-settings (x) @@ -15696,6 +15718,7 @@ fragments in the buffer." (interactive "P") (cond ((not (display-graphic-p)) nil) + ((and untrusted-content (not org--latex-preview-when-risky)) nil) ;; Clear whole buffer. ((equal arg '(64)) (org-clear-latex-preview (point-min) (point-max)) diff --git a/lisp/org/ox-beamer.el b/lisp/org/ox-beamer.el index 3d4d998432d..d3a90179d73 100644 --- a/lisp/org/ox-beamer.el +++ b/lisp/org/ox-beamer.el @@ -1008,7 +1008,10 @@ will be displayed when `org-export-show-temporary-export-buffer' is non-nil." (interactive) (org-export-to-buffer 'beamer "*Org BEAMER Export*" - async subtreep visible-only body-only ext-plist (lambda () (LaTeX-mode)))) + async subtreep visible-only body-only ext-plist + (if (fboundp 'major-mode-remap) + (major-mode-remap 'latex-mode) + #'LaTeX-mode))) ;;;###autoload (defun org-beamer-export-to-latex diff --git a/lisp/org/ox-koma-letter.el b/lisp/org/ox-koma-letter.el index aef25232c20..38460d1749e 100644 --- a/lisp/org/ox-koma-letter.el +++ b/lisp/org/ox-koma-letter.el @@ -911,7 +911,9 @@ non-nil." (let (org-koma-letter-special-contents) (org-export-to-buffer 'koma-letter "*Org KOMA-LETTER Export*" async subtreep visible-only body-only ext-plist - (lambda () (LaTeX-mode))))) + (if (fboundp 'major-mode-remap) + (major-mode-remap 'latex-mode) + #'LaTeX-mode)))) ;;;###autoload (defun org-koma-letter-export-to-latex diff --git a/lisp/org/ox-latex.el b/lisp/org/ox-latex.el index 9d250f716b6..98b388081ea 100644 --- a/lisp/org/ox-latex.el +++ b/lisp/org/ox-latex.el @@ -978,7 +978,7 @@ The most comprehensive option can be set with, which causes source code to be run through `engrave-faces-latex-buffer', which generates colorings using Emacs' font-lock information. This requires the Emacs package -engrave-faces (available from ELPA), and the LaTeX package +engrave-faces (available from GNU ELPA), and the LaTeX package fvextra be installed. The styling of the engraved result can be customized with @@ -1262,9 +1262,10 @@ block-specific options, you may use the following syntax: (defcustom org-latex-engraved-theme nil "The theme that should be used for engraved code, when non-nil. -This can be set to any theme defined in `engrave-faces-themes' or -loadable by Emacs. When set to t, the current Emacs theme is -used. When nil, no theme is applied." +This can be set to any theme defined in `engrave-faces-themes' +(from the engrave-faces package) or loadable by Emacs. When set +to t, the current Emacs theme is used. When nil, no theme is +applied." :group 'org-export-latex :package-version '(Org . "9.6") :type 'symbol) @@ -1631,7 +1632,7 @@ explicitly been loaded. Then it is added to the rest of package's options. The optional argument to Babel or the mandatory argument to -`\babelprovide' command may be \"AUTO\" which is then replaced +`\\babelprovide' command may be \"AUTO\" which is then replaced with the language of the document or `org-export-default-language' unless language in question is already loaded. @@ -3666,7 +3667,7 @@ CONTENTS is the contents of the object." ;; takes care of tables with a "verbatim" mode. Otherwise, it ;; delegates the job to either `org-latex--table.el-table', ;; `org-latex--org-table', `org-latex--math-table' or -;; `org-latex--org-tabbing' functions, +;; `org-table--org-tabbing' functions, ;; depending of the type of the table and the mode requested. ;; ;; `org-latex--align-string' is a subroutine used to build alignment @@ -4159,7 +4160,10 @@ will be displayed when `org-export-show-temporary-export-buffer' is non-nil." (interactive) (org-export-to-buffer 'latex "*Org LATEX Export*" - async subtreep visible-only body-only ext-plist (lambda () (LaTeX-mode)))) + async subtreep visible-only body-only ext-plist + (if (fboundp 'major-mode-remap) + (major-mode-remap 'latex-mode) + #'LaTeX-mode))) ;;;###autoload (defun org-latex-convert-region-to-latex () diff --git a/lisp/org/ox.el b/lisp/org/ox.el index 19bf559c9e7..bf2d9b569af 100644 --- a/lisp/org/ox.el +++ b/lisp/org/ox.el @@ -6608,7 +6608,7 @@ use it to set a major mode there, e.g., (interactive) (org-export-to-buffer \\='latex \"*Org LATEX Export*\" async subtreep visible-only body-only ext-plist - #\\='LaTeX-mode)) + (major-mode-remap \\='latex-mode))) When expressed as an anonymous function, using `lambda', POST-PROCESS needs to be quoted. diff --git a/lisp/outline.el b/lisp/outline.el index 96e0d0df205..40a75701cbf 100644 --- a/lisp/outline.el +++ b/lisp/outline.el @@ -260,7 +260,7 @@ non-nil and point is located on the heading line.") '( ;; Highlight headings according to the level. (eval . (list (or outline-search-function - (concat "^\\(?:" outline-regexp "\\).*")) + (concat "^\\(?:" outline-regexp "\\).*" outline-heading-end-regexp)) 0 '(if outline-minor-mode (if outline-minor-mode-highlight (list 'face (outline-font-lock-face))) @@ -318,8 +318,8 @@ Using the value `insert' is not recommended in editable buffers because it modifies them. When the value is `in-margins', then clickable buttons are displayed in the margins before the headings. -When the value is `t', clickable buttons are displayed -in the buffer before the headings. The values `t' and +When the value is t, clickable buttons are displayed +in the buffer before the headings. The values t and `in-margins' can be used in editing buffers because they don't modify the buffer." ;; The value `insert' is not intended to be customizable. @@ -686,7 +686,7 @@ If POS is nil, use `point' instead." (defun outline-back-to-heading (&optional invisible-ok) "Move to previous heading line, or beg of this line if it's a heading. Only visible heading lines are considered, unless INVISIBLE-OK is non-nil." - (beginning-of-line) + (forward-line 0) (or (outline-on-heading-p invisible-ok) (let (found) (save-excursion @@ -705,7 +705,7 @@ Only visible heading lines are considered, unless INVISIBLE-OK is non-nil." "Return t if point is on a (visible) heading line. If INVISIBLE-OK is non-nil, an invisible heading line is ok too." (save-excursion - (beginning-of-line) + (forward-line 0) (and (bolp) (or invisible-ok (not (outline-invisible-p))) (if outline-search-function (funcall outline-search-function nil nil nil t) @@ -725,7 +725,7 @@ If INVISIBLE-OK is non-nil, an invisible heading line is ok too." (not (string-match (concat "\\`\\(?:" outline-regexp "\\)") (concat head " ")))) (setq head (concat head " "))) - (unless (bolp) (end-of-line) (newline)) + (unless (bolp) (goto-char (pos-eol)) (newline)) (insert head) (unless (eolp) (save-excursion (newline-and-indent))) @@ -941,9 +941,7 @@ With ARG, repeats or can move backward if negative. A heading line is one that starts with a `*' (or that `outline-regexp' matches)." (interactive "p") - (if (< arg 0) - (beginning-of-line) - (end-of-line)) + (goto-char (if (< arg 0) (pos-bol) (pos-eol))) (let ((regexp (unless outline-search-function (concat "^\\(?:" outline-regexp "\\)"))) found-heading-p) @@ -963,7 +961,7 @@ A heading line is one that starts with a `*' (or that (re-search-forward regexp nil 'move))) (outline-invisible-p (match-beginning 0)))) (setq arg (1- arg))) - (if found-heading-p (beginning-of-line)))) + (if found-heading-p (forward-line 0)))) (defun outline-previous-visible-heading (arg) "Move to the previous heading line. @@ -980,7 +978,7 @@ This puts point at the start of the current subtree, and mark at the end." (let ((beg)) (if (outline-on-heading-p) ;; we are already looking at a heading - (beginning-of-line) + (forward-line 0) ;; else go back to previous heading (outline-previous-visible-heading 1)) (setq beg (point)) @@ -1183,7 +1181,7 @@ of the current heading, or to 1 if the current line is not a heading." (cond (current-prefix-arg (prefix-numeric-value current-prefix-arg)) ((save-excursion - (beginning-of-line) + (forward-line 0) (if outline-search-function (funcall outline-search-function nil nil nil t) (looking-at outline-regexp))) @@ -1243,7 +1241,7 @@ This also unhides the top heading-less body, if any." (interactive) (save-excursion (outline-back-to-heading) - (if (not (outline-invisible-p (line-end-position))) + (if (not (outline-invisible-p (pos-eol))) (outline-hide-subtree) (outline-show-children) (outline-show-entry)))) @@ -1834,7 +1832,7 @@ With a prefix argument, show headings up to that LEVEL." (defun outline--insert-button (type) (with-silent-modifications (save-excursion - (beginning-of-line) + (forward-line 0) (let ((icon (nth (if (eq type 'close) 1 0) outline--button-icons)) (o (seq-find (lambda (o) (overlay-get o 'outline-button)) (overlays-at (point))))) @@ -1842,7 +1840,7 @@ With a prefix argument, show headings up to that LEVEL." (when (eq outline-minor-mode-use-buttons 'insert) (let ((inhibit-read-only t)) (insert (apply #'propertize " " (text-properties-at (point)))) - (beginning-of-line))) + (forward-line 0))) (setq o (make-overlay (point) (1+ (point)))) (overlay-put o 'outline-button t) (overlay-put o 'evaporate t)) @@ -1866,7 +1864,7 @@ With a prefix argument, show headings up to that LEVEL." (when from (save-excursion (goto-char from) - (setq from (line-beginning-position)))) + (setq from (pos-bol)))) (outline-map-region (lambda () (let ((close-p (save-excursion diff --git a/lisp/pcmpl-git.el b/lisp/pcmpl-git.el index facca4107a1..95b6859dd23 100644 --- a/lisp/pcmpl-git.el +++ b/lisp/pcmpl-git.el @@ -88,7 +88,7 @@ Files listed by `git ls-files ARGS' satisfy the predicate." (pcomplete-entries nil (pcmpl-git--tracked-file-predicate "-m")))) ;; Complete all tracked files - ((or "mv" "rm" "grep" "status") + ((or "mv" "rm" "grep" "status" "blame") (pcomplete-here (pcomplete-entries nil (pcmpl-git--tracked-file-predicate)))) ;; Complete revisions diff --git a/lisp/pcmpl-linux.el b/lisp/pcmpl-linux.el index 3aee0b296f6..d0defc54174 100644 --- a/lisp/pcmpl-linux.el +++ b/lisp/pcmpl-linux.el @@ -61,7 +61,7 @@ (pcomplete-opt "hVanfFrsvwt(pcmpl-linux-fs-types)o?L?U?") (while (pcomplete-here (pcomplete-entries) nil #'identity))) -(defconst pcmpl-linux-fs-modules-path-format "/lib/modules/%s/kernel/fs/") +(defvar pcmpl-linux-fs-modules-path-format "/lib/modules/%s/kernel/fs/") (defun pcmpl-linux-fs-types () "Return a list of available fs modules on GNU/Linux systems." @@ -69,7 +69,7 @@ (directory-files (format pcmpl-linux-fs-modules-path-format kernel-ver)))) -(defconst pcmpl-linux-mtab-file "/etc/mtab") +(defvar pcmpl-linux-mtab-file "/etc/mtab") (defun pcmpl-linux-mounted-directories () "Return a list of mounted directory names." diff --git a/lisp/pcomplete.el b/lisp/pcomplete.el index 196c5f159cd..0b34712a50c 100644 --- a/lisp/pcomplete.el +++ b/lisp/pcomplete.el @@ -1140,7 +1140,7 @@ Typing SPC flushes the help buffer." (let (event) (prog1 (catch 'done - (while (with-current-buffer (get-buffer "*Completions*") + (while (with-current-buffer "*Completions*" (setq event (read-event))) (cond ((eq event ?\s) diff --git a/lisp/play/cookie1.el b/lisp/play/cookie1.el index c8e9d097a5f..c4697a0d3b9 100644 --- a/lisp/play/cookie1.el +++ b/lisp/play/cookie1.el @@ -65,7 +65,7 @@ (defconst cookie-delimiter "\n%%\n\\|\n%\n\\|\0" "Delimiter used to separate cookie file entries.") -(defvar cookie-cache (make-vector 511 0) +(defvar cookie-cache (obarray-make 511) "Cache of cookie files that have already been snarfed.") (defun cookie-check-file (file) diff --git a/lisp/play/decipher.el b/lisp/play/decipher.el index bfc28ec9f89..56f166c10f1 100644 --- a/lisp/play/decipher.el +++ b/lisp/play/decipher.el @@ -481,7 +481,7 @@ The most useful commands are: "Checkpoint the current cipher alphabet. This records the current alphabet so you can return to it later. You may have any number of checkpoints. -Type `\\[decipher-restore-checkpoint]' to restore a checkpoint." +Type \\[decipher-restore-checkpoint] to restore a checkpoint." (interactive "sCheckpoint description: " decipher-mode) (or (stringp desc) (setq desc "")) @@ -508,7 +508,7 @@ Type `\\[decipher-restore-checkpoint]' to restore a checkpoint." If point is not on a checkpoint line, moves to the first checkpoint line. If point is on a checkpoint, restores that checkpoint. -Type `\\[decipher-make-checkpoint]' to make a checkpoint." +Type \\[decipher-make-checkpoint] to make a checkpoint." (interactive nil decipher-mode) (beginning-of-line) (if (looking-at "%!\\([A-Z ]+\\)!") @@ -524,7 +524,7 @@ Type `\\[decipher-make-checkpoint]' to make a checkpoint." ;; Move to the first checkpoint: (goto-char (point-min)) (if (re-search-forward "^%![A-Z ]+!" nil t) - (message "Select the checkpoint to restore and type `%s'" + (message "Select the checkpoint to restore and type %s" (substitute-command-keys "\\[decipher-restore-checkpoint]")) (error "No checkpoints in this buffer")))) diff --git a/lisp/proced.el b/lisp/proced.el index 3435f1ab8cd..1d257b6bd4d 100644 --- a/lisp/proced.el +++ b/lisp/proced.el @@ -362,9 +362,13 @@ of `proced-grammar-alist'." :type 'integer) (defcustom proced-auto-update-flag nil - "Non-nil for auto update of a Proced buffer. -Can be changed interactively via `proced-toggle-auto-update'." - :type 'boolean) + "Non-nil means auto update proced buffers. +Special value `visible' means only update proced buffers that are currently +displayed in a window. Can be changed interactively via +`proced-toggle-auto-update'." + :type '(radio (const :tag "Don't auto update" nil) + (const :tag "Only update visible proced buffers" visible) + (const :tag "Update all proced buffers" t))) (make-variable-buffer-local 'proced-auto-update-flag) (defcustom proced-tree-flag nil @@ -951,28 +955,40 @@ Proced buffers." "Auto-update Proced buffers using `run-at-time'. If there are no proced buffers, cancel the timer." - (unless (seq-filter (lambda (buf) - (with-current-buffer buf - (when (eq major-mode 'proced-mode) - (if proced-auto-update-flag - (proced-update t t)) - t))) - (buffer-list)) + (if-let (buffers (match-buffers '(derived-mode . proced-mode))) + (dolist (buf buffers) + (when-let ((flag (buffer-local-value 'proced-auto-update-flag buf)) + ((or (not (eq flag 'visible)) + (get-buffer-window buf 'visible)))) + (with-current-buffer buf + (proced-update t t)))) (cancel-timer proced-auto-update-timer) (setq proced-auto-update-timer nil))) (defun proced-toggle-auto-update (arg) "Change whether this Proced buffer is updated automatically. With prefix ARG, update this buffer automatically if ARG is positive, -otherwise do not update. Sets the variable `proced-auto-update-flag'. -The time interval for updates is specified via `proced-auto-update-interval'." +update the buffer only when the buffer is displayed in a window if ARG is 0, +otherwise do not update. Sets the variable `proced-auto-update-flag' by +cycling between nil, `visible' and t. The time interval for updates is +specified via `proced-auto-update-interval'." (interactive (list (or current-prefix-arg 'toggle)) proced-mode) (setq proced-auto-update-flag - (cond ((eq arg 'toggle) (not proced-auto-update-flag)) - (arg (> (prefix-numeric-value arg) 0)) + (cond ((eq arg 'toggle) + (cond ((not proced-auto-update-flag) 'visible) + ((eq proced-auto-update-flag 'visible) t) + (t nil))) + (arg + (setq arg (prefix-numeric-value arg)) + (message "%s" arg) + (cond ((> arg 0) t) + ((eq arg 0) 'visible) + (t nil))) (t (not proced-auto-update-flag)))) (message "Proced auto update %s" - (if proced-auto-update-flag "enabled" "disabled"))) + (cond ((eq proced-auto-update-flag 'visible) "enabled (only when buffer is visible)") + (proced-auto-update-flag "enabled (unconditionally)") + (t "disabled")))) ;;; Mark @@ -2261,7 +2277,7 @@ If LOG is a string and there are more args, it is formatted with those ARGS. Usually the LOG string ends with a \\n. End each bunch of errors with (proced-log t signal): this inserts the current time, buffer and signal at the start of the page, -and \f (formfeed) at the end." +and \\f (formfeed) at the end." (let ((obuf (current-buffer))) (with-current-buffer (get-buffer-create proced-log-buffer) (goto-char (point-max)) diff --git a/lisp/profiler.el b/lisp/profiler.el index 80f84037a63..4e02cd1d890 100644 --- a/lisp/profiler.el +++ b/lisp/profiler.el @@ -38,8 +38,7 @@ (defcustom profiler-sampling-interval 1000000 "Default sampling interval in nanoseconds." - :type 'natnum - :group 'profiler) + :type 'natnum) ;;; Utilities @@ -68,7 +67,7 @@ collect c into s do (cl-decf i) finally return - (apply 'string (if (eq (car s) ?,) (cdr s) s))) + (apply #'string (if (eq (car s) ?,) (cdr s) s))) (profiler-ensure-string number))) (defun profiler-format (fmt &rest args) @@ -76,7 +75,7 @@ for arg in args for str = (cond ((consp subfmt) - (apply 'profiler-format subfmt arg)) + (apply #'profiler-format subfmt arg)) ((stringp subfmt) (format subfmt arg)) ((and (symbolp subfmt) @@ -91,7 +90,8 @@ if (< width len) collect (progn (put-text-property (max 0 (- width 2)) len 'invisible 'profiler str) - str) into frags + str) + into frags else collect (let ((padding (make-string (max 0 (- width len)) ?\s))) @@ -100,32 +100,11 @@ (right (concat padding str)))) into frags finally return (apply #'concat frags))) - - -;;; Entries - -(defun profiler-format-entry (entry) - "Format ENTRY in human readable string. -ENTRY would be a function name of a function itself." - (cond ((memq (car-safe entry) '(closure lambda)) - (format "#<lambda %#x>" (sxhash entry))) - ((byte-code-function-p entry) - (format "#<compiled %#x>" (sxhash entry))) - ((or (subrp entry) (symbolp entry) (stringp entry)) - (format "%s" entry)) - (t - (format "#<unknown %#x>" (sxhash entry))))) - -(defun profiler-fixup-entry (entry) - (if (symbolp entry) - entry - (profiler-format-entry entry))) - ;;; Backtraces (defun profiler-fixup-backtrace (backtrace) - (apply 'vector (mapcar 'profiler-fixup-entry backtrace))) + (apply #'vector (mapcar #'help-fns-function-name backtrace))) ;;; Logs @@ -434,18 +413,15 @@ Optional argument MODE means only check for the specified mode (cpu or mem)." (defcustom profiler-report-closed-mark "+" "An indicator of closed calltrees." - :type 'string - :group 'profiler) + :type 'string) (defcustom profiler-report-open-mark "-" "An indicator of open calltrees." - :type 'string - :group 'profiler) + :type 'string) (defcustom profiler-report-leaf-mark " " "An indicator of calltree leaves." - :type 'string - :group 'profiler) + :type 'string) (defvar profiler-report-cpu-line-format '((17 right ((12 right) @@ -474,17 +450,18 @@ Do not touch this variable directly.") (let ((string (cond ((eq entry t) "Others") - ((and (symbolp entry) - (fboundp entry)) - (propertize (symbol-name entry) - 'face 'link - 'follow-link "\r" - 'mouse-face 'highlight - 'help-echo "\ + (t (propertize (help-fns-function-name entry) + ;; Override the `button-map' which + ;; otherwise adds RET, mouse-1, and TAB + ;; bindings we don't want. :-( + 'keymap '(make-sparse-keymap) + 'follow-link "\r" + ;; FIXME: The help-echo code gets confused + ;; by the `follow-link' property and rewrites + ;; `mouse-2' to `mouse-1' :-( + 'help-echo "\ mouse-2: jump to definition\n\ -RET: expand or collapse")) - (t - (profiler-format-entry entry))))) +RET: expand or collapse"))))) (propertize string 'profiler-entry entry))) (defun profiler-report-make-name-part (tree) @@ -719,10 +696,13 @@ point." (current-buffer)) (and event (setq event (event-end event)) (posn-set-point event)) - (let ((tree (profiler-report-calltree-at-point))) - (when tree - (let ((entry (profiler-calltree-entry tree))) - (find-function entry)))))) + (save-excursion + (forward-line 0) + (let ((eol (pos-eol))) + (forward-button 1) + (if (> (point) eol) + (error "No entry found") + (push-button)))))) (defun profiler-report-describe-entry () "Describe entry at point." diff --git a/lisp/progmodes/bug-reference.el b/lisp/progmodes/bug-reference.el index 29ff521253b..977a3d72cb7 100644 --- a/lisp/progmodes/bug-reference.el +++ b/lisp/progmodes/bug-reference.el @@ -493,7 +493,7 @@ and set it if applicable." ;; the values of the From, To, and Cc headers. (let (header-values) (with-current-buffer - (get-buffer gnus-original-article-buffer) + gnus-original-article-buffer (save-excursion (goto-char (point-min)) ;; The Newsgroup is omitted because we already matched diff --git a/lisp/progmodes/c-ts-common.el b/lisp/progmodes/c-ts-common.el index 07161025d5d..e48bcc64f14 100644 --- a/lisp/progmodes/c-ts-common.el +++ b/lisp/progmodes/c-ts-common.el @@ -37,9 +37,8 @@ ;; ;; For indenting statements: ;; -;; - Set `c-ts-common-indent-offset', -;; `c-ts-common-indent-block-type-regexp', and -;; `c-ts-common-indent-bracketless-type-regexp', then use simple-indent +;; - Set `c-ts-common-indent-offset', and +;; `c-ts-common-indent-type-regexp-alist', then use simple-indent ;; offset `c-ts-common-statement-offset' in ;; `treesit-simple-indent-rules'. @@ -331,9 +330,9 @@ If NODE is nil, return nil." Assumes the anchor is (point-min), i.e., the 0th column. This function basically counts the number of block nodes (i.e., -brackets) (defined by `c-ts-common-indent-block-type-regexp') +brackets) (see `c-ts-common-indent-type-regexp-alist') between NODE and the root node (not counting NODE itself), and -multiply that by `c-ts-common-indent-offset'. +multiplies that by `c-ts-common-indent-offset'. To support GNU style, on each block level, this function also checks whether the opening bracket { is on its own line, if so, diff --git a/lisp/progmodes/c-ts-mode.el b/lisp/progmodes/c-ts-mode.el index e5835bdb62d..3a89f0f494b 100644 --- a/lisp/progmodes/c-ts-mode.el +++ b/lisp/progmodes/c-ts-mode.el @@ -97,7 +97,7 @@ "Toggle the comment style between block and line comments. Optional numeric ARG, if supplied, switches to block comment style when positive, to line comment style when negative, and -just toggles it when zero or left out." +just toggles it when zero or omitted." (interactive "P") (let ((prevstate-line (string= comment-start "// "))) (when (or (not arg) @@ -147,9 +147,9 @@ symbol." "Style used for indentation. The selected style could be one of GNU, K&R, LINUX or BSD. If -one of the supplied styles doesn't suffice, a function could be -set instead. This function is expected to return a list that -follows the form of `treesit-simple-indent-rules'." +one of the supplied styles doesn't suffice, the value could be +a function instead. This function is expected to return a list +that follows the form of `treesit-simple-indent-rules'." :version "29.1" :type '(choice (symbol :tag "Gnu" gnu) (symbol :tag "K&R" k&r) @@ -202,8 +202,8 @@ To set the default indent style globally, use (if (derived-mode-p 'c-ts-mode) 'c 'cpp)))))) (defcustom c-ts-mode-emacs-sources-support t - "Whether to enable Emacs source-specific features. -This enables detection of definitions of Lisp function using + "Whether to enable Emacs source-specific C features. +This enables detection of definitions of Lisp functions via the DEFUN macro. This needs to be set before enabling `c-ts-mode'; if you change the value after enabling `c-ts-mode', toggle the mode off and on @@ -243,7 +243,7 @@ again." < and > are usually punctuation, e.g., in ->. But when used for templates, they should be considered pairs. -This function checks for < and > in the changed RANGES and apply +This function checks for < and > in the changed RANGES and applies appropriate text property to alter the syntax of template delimiters < and >'s." (goto-char beg) @@ -284,9 +284,9 @@ is actually the parent of point at the moment of indentation." "Return the start of the previous named sibling of NODE. This anchor handles the special case where the previous sibling -is a labeled_statement, in that case, return the child of the +is a labeled_statement; in that case, return the child of the labeled statement instead. (Actually, recursively go down until -the node isn't a labeled_statement.) Eg, +the node isn't a labeled_statement.) E.g., label: int x = 1; @@ -295,10 +295,11 @@ label: The anchor of \"int y = 2;\" should be \"int x = 1;\" rather than the labeled_statement. -Return nil if a) there is no prev-sibling, or 2) prev-sibling +Return nil if a) there is no prev-sibling, or b) prev-sibling doesn't have a child. -PARENT and BOL are like other anchor functions." +PARENT is NODE's parent, BOL is the beginning of non-whitespace +characters of the current line." (when-let ((prev-sibling (or (treesit-node-prev-sibling node t) (treesit-node-prev-sibling @@ -336,7 +337,7 @@ PARENT and BOL are like other anchor functions." (defun c-ts-mode--standalone-parent-skip-preproc (_n parent &rest _) "Like the standalone-parent anchor but skips preproc nodes. -PARENT is the same as other anchor functions." +PARENT is the parent of the current node." (save-excursion (treesit-node-start (treesit-parent-until @@ -353,13 +354,15 @@ PARENT is the same as other anchor functions." (defun c-ts-mode--standalone-grandparent (_node parent bol &rest args) "Like the standalone-parent anchor but pass it the grandparent. -PARENT, BOL, ARGS are the same as other anchor functions." +PARENT is NODE's parent, BOL is the beginning of non-whitespace +characters of the current line." (apply (alist-get 'standalone-parent treesit-simple-indent-presets) parent (treesit-node-parent parent) bol args)) (defun c-ts-mode--else-heuristic (node parent bol &rest _) "Heuristic matcher for when \"else\" is followed by a closing bracket. -NODE, PARENT, and BOL are the same as in other matchers." +PARENT is NODE's parent, BOL is the beginning of non-whitespace +characters of the current line." (and (null node) (save-excursion (forward-line -1) @@ -757,7 +760,7 @@ MODE is either `c' or `cpp'." (defun c-ts-mode--declarator-identifier (node &optional qualified) "Return the identifier of the declarator node NODE. -If QUALIFIED is non-nil, include the names space part of the +If QUALIFIED is non-nil, include the namespace part of the identifier and return a qualified_identifier." (pcase (treesit-node-type node) ;; Recurse. @@ -782,7 +785,7 @@ identifier and return a qualified_identifier." node))) (defun c-ts-mode--fontify-declarator (node override start end &rest _args) - "Fontify a declarator (whatever under the \"declarator\" field). + "Fontify a declarator (whatever is under the \"declarator\" field). For NODE, OVERRIDE, START, END, and ARGS, see `treesit-font-lock-rules'." (let* ((identifier (c-ts-mode--declarator-identifier node)) @@ -817,7 +820,7 @@ For NODE, OVERRIDE, START, END, and ARGS, see (defun c-ts-mode--fontify-variable (node override start end &rest _) "Fontify an identifier node if it is a variable. -Don't fontify if it is a function identifier. For NODE, +Don't fontify it if it is a function identifier. For NODE, OVERRIDE, START, END, and ARGS, see `treesit-font-lock-rules'." (when (not (equal (treesit-node-type (treesit-node-parent node)) @@ -911,7 +914,8 @@ Return nil if NODE is not a defun node or doesn't have a name." t)) ((or "struct_specifier" "enum_specifier" "union_specifier" "class_specifier" - "namespace_definition") + "namespace_definition" + "preproc_def" "preproc_function_def") (treesit-node-child-by-field-name node "name")) ;; DEFUNs in Emacs sources. ("expression_statement" @@ -922,11 +926,22 @@ Return nil if NODE is not a defun node or doesn't have a name." name))) t)) +;;; Outline minor mode + +(defun c-ts-mode--outline-predicate (node) + "Match outlines on lines with function names." + (or (and (equal (treesit-node-type node) "function_declarator") + (equal (treesit-node-type (treesit-node-parent node)) + "function_definition")) + ;; DEFUNs in Emacs sources. + (and c-ts-mode-emacs-sources-support + (c-ts-mode--emacs-defun-p node)))) + ;;; Defun navigation (defun c-ts-mode--defun-valid-p (node) "Return non-nil if NODE is a valid defun node. -Ie, NODE is not nested." +That is, NODE is not nested." (let ((top-level-p (lambda (node) (not (treesit-node-top-level node (rx (or "function_definition" @@ -965,8 +980,7 @@ Basically, if NODE is a class, return non-nil; if NODE is a function but is under a class, return non-nil; if NODE is a top-level function, return nil. -This is for the Class subindex in -`treesit-simple-imenu-settings'." +This is for the Class subindex in `treesit-simple-imenu-settings'." (pcase (treesit-node-type node) ;; The Class subindex only has class_specifier and ;; function_definition. @@ -977,7 +991,7 @@ This is for the Class subindex in (defun c-ts-mode--defun-skipper () "Custom defun skipper for `c-ts-mode' and friends. -Structs in C ends with a semicolon, but the semicolon is not +Structs in C end with a semicolon, but the semicolon is not considered part of the struct node, so point would stop before the semicolon. This function skips the semicolon." (when (looking-at (rx (* (or " " "\t")) ";")) @@ -997,7 +1011,7 @@ the semicolon. This function skips the semicolon." (list node parent bol))) (defun c-ts-mode--emacs-defun-p (node) - "Return non-nil if NODE is a Lisp function defined using DEFUN. + "Return non-nil if NODE is a Lisp function defined via DEFUN. This function detects Lisp primitives defined in Emacs source files using the DEFUN macro." (and (equal (treesit-node-type node) "expression_statement") @@ -1018,15 +1032,15 @@ files using the DEFUN macro." "Return the defun node at point. In addition to regular C functions, this function recognizes -definitions of Lisp primitrives in Emacs source files using DEFUN, -if `c-ts-mode-emacs-sources-support' is non-nil. +definitions of Lisp primitrives in Emacs source files defined +via DEFUN, if `c-ts-mode-emacs-sources-support' is non-nil. Note that DEFUN is parsed by tree-sitter as two separate nodes, one for the declaration and one for the body; this function returns the declaration node. If RANGE is non-nil, return (BEG . END) where BEG end END -encloses the whole defun. This is for when the entire defun +enclose the whole defun. This is for when the entire defun is required, not just the declaration part for DEFUN." (when-let* ((node (treesit-defun-at-point)) (defun-range (cons (treesit-node-start node) @@ -1055,7 +1069,7 @@ is required, not just the declaration part for DEFUN." "Return the name of the current defun. This is used for `add-log-current-defun-function'. In addition to regular C functions, this function also recognizes -Emacs primitives defined using DEFUN in Emacs sources, +Emacs primitives defined via DEFUN in Emacs sources, if `c-ts-mode-emacs-sources-support' is non-nil." (or (treesit-add-log-current-defun) (c-ts-mode--defun-name (c-ts-mode--emacs-defun-at-point)))) @@ -1133,7 +1147,7 @@ For BOL see `treesit-simple-indent-rules'." (defun c-ts-mode--reverse-ranges (ranges beg end) "Reverse RANGES and return the new ranges between BEG and END. -Positions that were included RANGES are not in the returned +Positions that were included in RANGES are not in the returned ranges, and vice versa. Return nil if RANGES is nil. This way, passing the returned @@ -1179,7 +1193,6 @@ BEG and END are described in `treesit-range-rules'." "C-c C-c" #'comment-region "C-c C-k" #'c-ts-mode-toggle-comment-style) -;;;###autoload (define-derived-mode c-ts-base-mode prog-mode "C" "Major mode for editing C, powered by tree-sitter. @@ -1195,7 +1208,9 @@ BEG and END are described in `treesit-range-rules'." "enum_specifier" "union_specifier" "class_specifier" - "namespace_definition") + "namespace_definition" + "preproc_def" + "preproc_function_def") (and c-ts-mode-emacs-sources-support '(;; DEFUN. "expression_statement" @@ -1259,6 +1274,10 @@ BEG and END are described in `treesit-range-rules'." eos) c-ts-mode--defun-for-class-in-imenu-p nil)))) + ;; Outline minor mode + (setq-local treesit-outline-predicate + #'c-ts-mode--outline-predicate) + (setq-local treesit-font-lock-feature-list c-ts-mode--feature-list)) @@ -1270,7 +1289,7 @@ BEG and END are described in `treesit-range-rules'." This mode is independent from the classic cc-mode.el based `c-mode', so configuration variables of that mode, like -`c-basic-offset', doesn't affect this mode. +`c-basic-offset', don't affect this mode. To use tree-sitter C/C++ modes by default, evaluate @@ -1279,7 +1298,7 @@ To use tree-sitter C/C++ modes by default, evaluate (add-to-list \\='major-mode-remap-alist \\='(c-or-c++-mode . c-or-c++-ts-mode)) -in your configuration." +in your init files." :group 'c :after-hook (c-ts-mode-set-modeline) @@ -1314,6 +1333,8 @@ in your configuration." (lambda (_pos) 'c)) (treesit-font-lock-recompute-features '(emacs-devel))))) +(derived-mode-add-parents 'c-ts-mode '(c-mode)) + ;;;###autoload (define-derived-mode c++-ts-mode c-ts-base-mode "C++" "Major mode for editing C++, powered by tree-sitter. @@ -1329,7 +1350,7 @@ To use tree-sitter C/C++ modes by default, evaluate (add-to-list \\='major-mode-remap-alist \\='(c-or-c++-mode . c-or-c++-ts-mode)) -in your configuration. +in your init files. Since this mode uses a parser, unbalanced brackets might cause some breakage in indentation/fontification. Therefore, it's @@ -1357,6 +1378,8 @@ recommended to enable `electric-pair-mode' with this mode." (setq-local add-log-current-defun-function #'c-ts-mode--emacs-current-defun-name)))) +(derived-mode-add-parents 'c++-ts-mode '(c++-mode)) + (easy-menu-define c-ts-mode-menu (list c-ts-mode-map c++-ts-mode-map) "Menu for `c-ts-mode' and `c++-ts-mode'." '("C/C++" @@ -1422,38 +1445,35 @@ matching on file name insufficient for detecting major mode that should be used. This function attempts to use file contents to determine whether -the code is C or C++ and based on that chooses whether to enable +the code is C or C++, and based on that chooses whether to enable `c-ts-mode' or `c++-ts-mode'." + (declare (obsolete c-or-c++-mode "30.1")) (interactive) - (if (save-excursion - (save-restriction - (save-match-data ; Why `save-match-data'? - (widen) - (goto-char (point-min)) - (re-search-forward c-ts-mode--c-or-c++-regexp nil t)))) - (c++-ts-mode) - (c-ts-mode))) + (let ((mode + (if (save-excursion + (save-restriction + (save-match-data ; Why `save-match-data'? + (widen) + (goto-char (point-min)) + (re-search-forward c-ts-mode--c-or-c++-regexp nil t)))) + 'c++-ts-mode + 'c-ts-mode))) + (funcall (major-mode-remap mode)))) + ;; The entries for C++ must come first to prevent *.c files be taken ;; as C++ on case-insensitive filesystems, since *.C files are C++, ;; not C. (if (treesit-ready-p 'cpp) - (add-to-list 'auto-mode-alist - '("\\(\\.ii\\|\\.\\(CC?\\|HH?\\)\\|\\.[ch]\\(pp\\|xx\\|\\+\\+\\)\\|\\.\\(cc\\|hh\\)\\)\\'" - . c++-ts-mode))) + (add-to-list 'major-mode-remap-defaults + '(c++-mode . c++-ts-mode))) (when (treesit-ready-p 'c) - (add-to-list 'auto-mode-alist - '("\\(\\.[chi]\\|\\.lex\\|\\.y\\(acc\\)?\\)\\'" . c-ts-mode)) - (add-to-list 'auto-mode-alist '("\\.x[pb]m\\'" . c-ts-mode)) - ;; image-mode's association must be before the C mode, otherwise XPM - ;; images will be initially visited as C files. Also note that the - ;; regexp must be different from what files.el does, or else - ;; add-to-list will not add the association where we want it. - (add-to-list 'auto-mode-alist '("\\.x[pb]m\\'" . image-mode))) - -(if (and (treesit-ready-p 'cpp) - (treesit-ready-p 'c)) - (add-to-list 'auto-mode-alist '("\\.h\\'" . c-or-c++-ts-mode))) + (add-to-list 'major-mode-remap-defaults '(c++-mode . c++-ts-mode)) + (add-to-list 'major-mode-remap-defaults '(c-mode . c-ts-mode))) + +(when (and (treesit-ready-p 'cpp) + (treesit-ready-p 'c)) + (add-to-list 'major-mode-remap-defaults '(c-or-c++-mode . c-or-c++-ts-mode))) (provide 'c-ts-mode) (provide 'c++-ts-mode) diff --git a/lisp/progmodes/cc-defs.el b/lisp/progmodes/cc-defs.el index f84d95dbc94..e45ab76ec07 100644 --- a/lisp/progmodes/cc-defs.el +++ b/lisp/progmodes/cc-defs.el @@ -2425,7 +2425,7 @@ system." (error "Unknown base mode `%s'" base-mode)) (put mode 'c-fallback-mode base-mode)) -(defvar c-lang-constants (make-vector 151 0)) +(defvar c-lang-constants (obarray-make 151)) ;; Obarray used as a cache to keep track of the language constants. ;; The constants stored are those defined by `c-lang-defconst' and the values ;; computed by `c-lang-const'. It's mostly used at compile time but it's not @@ -2630,7 +2630,7 @@ constant. A file is identified by its base name." ;; Clear the evaluated values that depend on this source. (let ((agenda (get sym 'dependents)) - (visited (make-vector 101 0)) + (visited (obarray-make 101)) ptr) (while agenda (setq sym (car agenda) diff --git a/lisp/progmodes/cc-engine.el b/lisp/progmodes/cc-engine.el index 4c591fbba36..8c505e9556a 100644 --- a/lisp/progmodes/cc-engine.el +++ b/lisp/progmodes/cc-engine.el @@ -11476,7 +11476,7 @@ This function might do hidden buffer changes." ;; an arglist it would be a meaningless expression because ;; the result isn't used. We therefore choose to recognize ;; it as a declaration when there's "symmetrical WS" around - ;; the "*" or the flag `c-assymetry-fontification-flag' is + ;; the "*" or the flag `c-asymmetry-fontification-flag' is ;; not set. We only allow a suffix (which makes the ;; construct look like a function call) when `at-decl-start' ;; provides additional evidence that we do have a @@ -12346,13 +12346,21 @@ comment at the start of cc-engine.el for more info." (zerop (c-backward-token-2 1 t lim)) t) (or (looking-at c-block-stmt-1-key) - (and (eq (char-after) ?\() - (zerop (c-backward-token-2 1 t lim)) - (if (looking-at c-block-stmt-hangon-key) - (zerop (c-backward-token-2 1 t lim)) - t) - (or (looking-at c-block-stmt-2-key) - (looking-at c-block-stmt-1-2-key)))) + (or + (and + (eq (char-after) ?\() + (zerop (c-backward-token-2 1 t lim)) + (if (looking-at c-block-stmt-hangon-key) + (zerop (c-backward-token-2 1 t lim)) + t) + (or (looking-at c-block-stmt-2-key) + (looking-at c-block-stmt-1-2-key))) + (and (looking-at c-paren-clause-key) + (zerop (c-backward-token-2 1 t lim)) + (if (looking-at c-negation-op-re) + (zerop (c-backward-token-2 1 t lim)) + t) + (looking-at c-block-stmt-with-key)))) (point)))) (defun c-after-special-operator-id (&optional lim) diff --git a/lisp/progmodes/cc-fonts.el b/lisp/progmodes/cc-fonts.el index 89f197b98e6..6419d6cf05a 100644 --- a/lisp/progmodes/cc-fonts.el +++ b/lisp/progmodes/cc-fonts.el @@ -1112,7 +1112,7 @@ casts and declarations are fontified. Used on level 2 and higher." ;; 'c-decl-type-start (according to TYPES). Stop at LIMIT. ;; ;; If TYPES is t, fontify all identifiers as types; if it is a number, a - ;; buffer position, additionally set the `c-deftype' text property on the + ;; buffer position, additionally set the `c-typedef' text property on the ;; keyword at that position; if it is nil fontify as either variables or ;; functions, otherwise TYPES is a face to use. If NOT-TOP is non-nil, we ;; are not at the top-level ("top-level" includes being directly inside a diff --git a/lisp/progmodes/cc-langs.el b/lisp/progmodes/cc-langs.el index ad21bd1d5ef..06b919f26fd 100644 --- a/lisp/progmodes/cc-langs.el +++ b/lisp/progmodes/cc-langs.el @@ -817,7 +817,7 @@ there be copies of the opener contained in the multi-line string." (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'. + ;; matches for `c-ml-string-cpp-or-opener-re'. t (if (c-lang-const c-anchored-cpp-prefix) (+ 2 (regexp-opt-depth (c-lang-const c-anchored-cpp-prefix))) 2)) @@ -1599,6 +1599,12 @@ operators." (c-lang-defvar c-assignment-op-regexp (c-lang-const c-assignment-op-regexp)) +(c-lang-defconst c-negation-op-re + ;; Regexp matching the negation operator. + t "!\\([^=]\\|$\\)") + +(c-lang-defvar c-negation-op-re (c-lang-const c-negation-op-re)) + (c-lang-defconst c-arithmetic-operators "List of all arithmetic operators, including \"+=\", etc." ;; Note: in the following, there are too many operators for AWK and IDL. @@ -3163,6 +3169,30 @@ Keywords here should also be in `c-block-stmt-1-kwds'." (c-lang-const c-block-stmt-2-kwds))))) (c-lang-defvar c-opt-block-stmt-key (c-lang-const c-opt-block-stmt-key)) +(c-lang-defconst c-paren-clause-kwds + "Keywords which can stand in the place of paren sexps in conditionals. +This applies only to conditionals in `c-block-stmt-with-kwds'." + t nil + c++ '("consteval")) + +(c-lang-defconst c-paren-clause-key + ;; Regexp matching a keyword in `c-paren-clause-kwds'. + t (c-make-keywords-re t + (c-lang-const c-paren-clause-kwds))) +(c-lang-defvar c-paren-clause-key (c-lang-const c-paren-clause-key)) + +(c-lang-defconst c-block-stmt-with-kwds + "Statement keywords which can be followed by a keyword instead of a parens. +Such a keyword is a member of `c-paren-clause-kwds." + t nil + c++ '("if")) + +(c-lang-defconst c-block-stmt-with-key + ;; Regexp matching a keyword in `c-block-stmt-with-kwds'. + t (c-make-keywords-re t + (c-lang-const c-block-stmt-with-kwds))) +(c-lang-defvar c-block-stmt-with-key (c-lang-const c-block-stmt-with-key)) + (c-lang-defconst c-simple-stmt-kwds "Statement keywords followed by an expression or nothing." t '("break" "continue" "goto" "return") @@ -3511,7 +3541,7 @@ Note that Java specific rules are currently applied to tell this from (let* ((alist (c-lang-const c-keyword-member-alist)) kwd lang-const-list - (obarray (make-vector (* (length alist) 2) 0))) + (obarray (obarray-make (* (length alist) 2)))) (while alist (setq kwd (caar alist) lang-const-list (cdar alist) diff --git a/lisp/progmodes/cc-mode.el b/lisp/progmodes/cc-mode.el index 64a679eacc7..1a9d0907bd0 100644 --- a/lisp/progmodes/cc-mode.el +++ b/lisp/progmodes/cc-mode.el @@ -2902,15 +2902,19 @@ This function attempts to use file contents to determine whether the code is C or C++ and based on that chooses whether to enable `c-mode' or `c++-mode'." (interactive) - (if (save-excursion - (save-restriction - (save-match-data - (widen) - (goto-char (point-min)) - (re-search-forward c-or-c++-mode--regexp - (+ (point) c-guess-region-max) t)))) - (c++-mode) - (c-mode))) + (let ((mode + (if (save-excursion + (save-restriction + (save-match-data + (widen) + (goto-char (point-min)) + (re-search-forward c-or-c++-mode--regexp + (+ (point) c-guess-region-max) t)))) + 'c++-mode + 'c-mode))) + (funcall (if (fboundp 'major-mode-remap) + (major-mode-remap mode) + mode)))) ;; Support for C++ diff --git a/lisp/progmodes/cmake-ts-mode.el b/lisp/progmodes/cmake-ts-mode.el index d933e4ebb81..b70806f4c30 100644 --- a/lisp/progmodes/cmake-ts-mode.el +++ b/lisp/progmodes/cmake-ts-mode.el @@ -32,10 +32,8 @@ (declare-function treesit-parser-create "treesit.c") (declare-function treesit-query-capture "treesit.c") -(declare-function treesit-induce-sparse-tree "treesit.c") -(declare-function treesit-node-child "treesit.c") -(declare-function treesit-node-start "treesit.c") (declare-function treesit-node-type "treesit.c") +(declare-function treesit-search-subtree "treesit.c") (defcustom cmake-ts-mode-indent-offset 2 "Number of spaces for each indentation step in `cmake-ts-mode'." @@ -195,37 +193,14 @@ Check if a node type is available, then return the right font lock rules." '((ERROR) @font-lock-warning-face)) "Tree-sitter font-lock settings for `cmake-ts-mode'.") -(defun cmake-ts-mode--imenu () - "Return Imenu alist for the current buffer." - (let* ((node (treesit-buffer-root-node)) - (func-tree (treesit-induce-sparse-tree - node "function_def" nil 1000)) - (func-index (cmake-ts-mode--imenu-1 func-tree))) - (append - (when func-index `(("Function" . ,func-index)))))) - -(defun cmake-ts-mode--imenu-1 (node) - "Helper for `cmake-ts-mode--imenu'. -Find string representation for NODE and set marker, then recurse -the subtrees." - (let* ((ts-node (car node)) - (children (cdr node)) - (subtrees (mapcan #'cmake-ts-mode--imenu-1 - children)) - (name (when ts-node - (pcase (treesit-node-type ts-node) - ("function_def" - (treesit-node-text - (treesit-node-child (treesit-node-child ts-node 0) 2) t))))) - (marker (when ts-node - (set-marker (make-marker) - (treesit-node-start ts-node))))) - (cond - ((or (null ts-node) (null name)) subtrees) - (subtrees - `((,name ,(cons name marker) ,@subtrees))) - (t - `((,name . ,marker)))))) +(defun cmake-ts-mode--defun-name (node) + "Return the defun name of NODE. +Return nil if there is no name or if NODE is not a defun node." + (pcase (treesit-node-type node) + ((or "function_def" "macro_def") + (treesit-node-text + (treesit-search-subtree node "^argument$" nil nil 3) + t)))) ;;;###autoload (define-derived-mode cmake-ts-mode prog-mode "CMake" @@ -241,8 +216,15 @@ the subtrees." (setq-local comment-end "") (setq-local comment-start-skip (rx "#" (* (syntax whitespace)))) + ;; Defuns. + (setq-local treesit-defun-type-regexp (rx (or "function" "macro") + "_def")) + (setq-local treesit-defun-name-function #'cmake-ts-mode--defun-name) + ;; Imenu. - (setq-local imenu-create-index-function #'cmake-ts-mode--imenu) + (setq-local treesit-simple-imenu-settings + `(("Function" "^function_def$") + ("Macro" "^macro_def$"))) (setq-local which-func-functions nil) ;; Indent. @@ -261,6 +243,8 @@ the subtrees." (treesit-major-mode-setup))) +(derived-mode-add-parents 'cmake-ts-mode '(cmake-mode)) + (if (treesit-ready-p 'cmake) (add-to-list 'auto-mode-alist '("\\(?:CMakeLists\\.txt\\|\\.cmake\\)\\'" . cmake-ts-mode))) diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el index 4af6a96900a..11d400e145a 100644 --- a/lisp/progmodes/compile.el +++ b/lisp/progmodes/compile.el @@ -362,6 +362,28 @@ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1)) (ruby-Test::Unit "^ [[ ]?\\([^ (].*\\):\\([1-9][0-9]*\\)\\(\\]\\)?:in " 1 2) + ;; Tested with Lua 5.1, 5.2, 5.3, 5.4, and LuaJIT 2.1. + (lua + ,(rx bol + (+? (not (in "\t\n"))) + ": " + (group (+? (not (in "\t\n")))) + ":" + (group (+ (in "0-9"))) + ": " + (+ nonl) + "\nstack traceback:\n\t") + 1 2 nil 2 1) + (lua-stack + ,(rx bol "\t" + (| "[C]:" + (: (group (+? (not (in "\t\n")))) + ":" + (? (group (+ (in "0-9"))) + ":"))) + " in ") + 1 2 nil 0 1) + (gmake ;; Set GNU make error messages as INFO level. ;; It starts with the name of the make program which is variable, @@ -1868,6 +1890,12 @@ process from additional information inserted by Emacs." (defvar-local compilation--start-time nil "The time when the compilation started as returned by `float-time'.") +(defun compilation--downcase-mode-name (mode) + "Downcase the name of major MODE, even if MODE is not a string. +The function `downcase' will barf if passed the name of a `major-mode' +which is not a string, but instead a symbol or a list." + (downcase (format-mode-line mode))) + ;;;###autoload (defun compilation-start (command &optional mode name-function highlight-regexp continue) @@ -2059,11 +2087,12 @@ Returns the compilation buffer created." (get-buffer-process (with-no-warnings (comint-exec - outbuf (downcase mode-name) + outbuf (compilation--downcase-mode-name mode-name) shell-file-name nil `(,shell-command-switch ,command))))) - (start-file-process-shell-command (downcase mode-name) - outbuf command)))) + (start-file-process-shell-command + (compilation--downcase-mode-name mode-name) + outbuf command)))) ;; Make the buffer's mode line show process state. (setq mode-line-process '((:propertize ":%s" face compilation-mode-line-run) @@ -2768,7 +2797,8 @@ Prefix arg N says how many files to move backwards (or forwards, if negative)." (let ((buffer (compilation-find-buffer))) (if (get-buffer-process buffer) (interrupt-process (get-buffer-process buffer)) - (error "The %s process is not running" (downcase mode-name))))) + (error "The %s process is not running" + (compilation--downcase-mode-name mode-name))))) (defalias 'compile-mouse-goto-error 'compile-goto-error) @@ -3122,7 +3152,16 @@ and overlay is highlighted between MK and END-MK." (cancel-timer next-error-highlight-timer)) (remove-hook 'pre-command-hook #'compilation-goto-locus-delete-o)) - + +(defun compilation--expand-fn (directory filename) + "Expand FILENAME or resolve its true name. +Unlike `expand-file-name', `file-truename' follows symlinks, which +we try to avoid if possible." + (let* ((expandedname (expand-file-name filename directory))) + (if (file-exists-p expandedname) + expandedname + (file-truename (file-name-concat directory filename))))) + (defun compilation-find-file-1 (marker filename directory &optional formats) (or formats (setq formats '("%s"))) (let ((dirs compilation-search-path) @@ -3143,8 +3182,8 @@ and overlay is highlighted between MK and END-MK." fmts formats) ;; For each directory, try each format string. (while (and fmts (null buffer)) - (setq name (file-truename - (file-name-concat thisdir (format (car fmts) filename))) + (setq name (compilation--expand-fn thisdir + (format (car fmts) filename)) buffer (and (file-exists-p name) (find-file-noselect name)) fmts (cdr fmts))) @@ -3166,8 +3205,8 @@ and overlay is highlighted between MK and END-MK." (setq thisdir (car dirs) fmts formats) (while (and fmts (null buffer)) - (setq name (file-truename - (file-name-concat thisdir (format (car fmts) filename))) + (setq name (compilation--expand-fn thisdir + (format (car fmts) filename)) buffer (and (file-exists-p name) (find-file-noselect name)) fmts (cdr fmts))) @@ -3227,8 +3266,7 @@ attempts to find a file whose name is produced by (format FMT FILENAME)." (ding) (sit-for 2)) ((and (file-directory-p name) (not (file-exists-p - (setq name (file-truename - (file-name-concat name filename)))))) + (setq name (compilation--expand-fn name filename))))) (message "No `%s' in directory %s" filename origname) (ding) (sit-for 2)) (t diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el index 9f7f29b8182..11709bfe00b 100644 --- a/lisp/progmodes/cperl-mode.el +++ b/lisp/progmodes/cperl-mode.el @@ -162,6 +162,9 @@ for constructs with multiline if/unless/while/until/for/foreach condition." (defcustom cperl-file-style nil "Indentation style to use in cperl-mode. +Setting this option will override options as given in +`cperl-style-alist' for the keyword provided here. If nil, then +the individual options as customized are used. \"PBP\" is the style recommended in the Book \"Perl Best Practices\" by Damian Conway. \"CPerl\" is the traditional style of cperl-mode, and \"PerlStyle\" follows the Perl documentation @@ -1130,7 +1133,7 @@ Unless KEEP, removes the old indentation." ["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..." + ("Default indent styles..." ["CPerl" (cperl-set-style "CPerl") t] ["PBP" (cperl-set-style "PBP") t] ["PerlStyle" (cperl-set-style "PerlStyle") t] @@ -1141,6 +1144,15 @@ Unless KEEP, removes the old indentation." ["Whitesmith" (cperl-set-style "Whitesmith") t] ["Memorize Current" (cperl-set-style "Current") t] ["Memorized" (cperl-set-style-back) cperl-old-style]) + ("Indent styles for current buffer..." + ["CPerl" (cperl-set-style "CPerl") t] + ["PBP" (cperl-file-style "PBP") t] + ["PerlStyle" (cperl-file-style "PerlStyle") t] + ["GNU" (cperl-file-style "GNU") t] + ["C++" (cperl-file-style "C++") t] + ["K&R" (cperl-file-style "K&R") t] + ["BSD" (cperl-file-style "BSD") t] + ["Whitesmith" (cperl-file-style "Whitesmith") t]) ("Micro-docs" ["Tips" (describe-variable 'cperl-tips) t] ["Problems" (describe-variable 'cperl-problems) t] @@ -1922,9 +1934,12 @@ or as help on variables `cperl-tips', `cperl-problems', ;; Setup Flymake (add-hook 'flymake-diagnostic-functions #'perl-flymake nil t)) +(derived-mode-add-parents 'cperl-mode '(perl-mode)) + (defun cperl--set-file-style () (when cperl-file-style - (cperl-set-style cperl-file-style))) + (cperl-file-style cperl-file-style))) + ;; Fix for perldb - make default reasonable (defun cperl-db () @@ -4001,7 +4016,10 @@ recursive calls in starting lines of here-documents." ;; 1+6+2+1+1+6+1+1+1=20 extra () before this: "\\|" ;; -------- backslash-escaped stuff, don't interpret it - "\\\\\\(['`\"($]\\)") ; BACKWACKED something-hairy + "\\\\\\(['`\"($]\\)" ; BACKWACKED something-hairy + "\\|" + ;; -------- $\ is a variable in code, but not in a string + "\\(\\$\\\\\\)") ""))) warning-message) (unwind-protect @@ -4055,7 +4073,12 @@ recursive calls in starting lines of here-documents." (cperl-modify-syntax-type bb cperl-st-punct))) ;; No processing in strings/comments beyond this point: ((or (nth 3 state) (nth 4 state)) - t) ; Do nothing in comment/string + ;; Edge case: In a double-quoted string, $\ is not the + ;; punctuation variable, $ must not quote \ here. We + ;; generally make $ a punctuation character in strings + ;; and comments (Bug#69604). + (when (match-beginning 22) + (cperl-modify-syntax-type (match-beginning 22) cperl-st-punct))) ((match-beginning 1) ; POD section ;; "\\(\\`\n?\\|^\n\\)=" (setq b (match-beginning 0) @@ -6496,6 +6519,10 @@ See examples in `cperl-style-examples'.") (defun cperl-set-style (style) "Set CPerl mode variables to use one of several different indentation styles. +This command sets the default values for the variables. It does +not affect buffers visiting files where the style has been set as +a file or directory variable. To change the indentation style of +a buffer, use the command `cperl-file-style' instead. The arguments are a string representing the desired style. The list of styles is in `cperl-style-alist', available styles are \"CPerl\", \"PBP\", \"PerlStyle\", \"GNU\", \"K&R\", \"BSD\", \"C++\" @@ -6516,7 +6543,8 @@ side-effect of memorizing only. Examples in `cperl-style-examples'." (let ((style (cdr (assoc style cperl-style-alist))) setting) (while style (setq setting (car style) style (cdr style)) - (set (car setting) (cdr setting))))) + (set-default-toplevel-value (car setting) (cdr setting)))) + (set-default-toplevel-value 'cperl-file-style style)) (defun cperl-set-style-back () "Restore a style memorized by `cperl-set-style'." @@ -6526,7 +6554,20 @@ side-effect of memorizing only. Examples in `cperl-style-examples'." (while cperl-old-style (setq setting (car cperl-old-style) cperl-old-style (cdr cperl-old-style)) - (set (car setting) (cdr setting))))) + (set-default-toplevel-value (car setting) (cdr setting))))) + +(defun cperl-file-style (style) + "Set the indentation style for the current buffer to STYLE. +The list of styles is in `cperl-style-alist', available styles +are \"CPerl\", \"PBP\", \"PerlStyle\", \"GNU\", \"K&R\", \"BSD\", \"C++\" +and \"Whitesmith\"." + (interactive + (list (completing-read "Enter style: " cperl-style-alist nil 'insist))) + (dolist (setting (cdr (assoc style cperl-style-alist)) style) + (let ((option (car setting)) + (value (cdr setting))) + (set (make-local-variable option) value))) + (setq-local cperl-file-style style)) (declare-function Info-find-node "info" (filename nodename &optional no-going-back strict-case @@ -6581,14 +6622,13 @@ side-effect of memorizing only. Examples in `cperl-style-examples'." read)))) (let ((cmd-desc (concat "^" (regexp-quote command) "[^a-zA-Z_0-9]")) ; "tr///" - pos isvar height iniheight frheight buf win fr1 fr2 iniwin not-loner + pos isvar height iniheight frheight buf win iniwin not-loner max-height char-height buf-list) (if (string-match "^-[a-zA-Z]$" command) (setq cmd-desc "^-X[ \t\n]")) (setq isvar (string-match "^[$@%]" command) buf (cperl-info-buffer isvar) - iniwin (selected-window) - fr1 (window-frame iniwin)) + iniwin (selected-window)) (set-buffer buf) (goto-char (point-min)) (or isvar @@ -6609,11 +6649,7 @@ side-effect of memorizing only. Examples in `cperl-style-examples'." (or (not win) (eq (window-buffer win) buf) (set-window-buffer win buf)) - (and win (setq fr2 (window-frame win))) - (if (or (not fr2) (eq fr1 fr2)) - (pop-to-buffer buf) - (special-display-popup-frame buf) ; Make it visible - (select-window win)) + (pop-to-buffer buf) (goto-char pos) ; Needed (?!). ;; Resize (setq iniheight (window-height) diff --git a/lisp/progmodes/csharp-mode.el b/lisp/progmodes/csharp-mode.el index 7bf57bcbe21..9782eb443f2 100644 --- a/lisp/progmodes/csharp-mode.el +++ b/lisp/progmodes/csharp-mode.el @@ -495,9 +495,12 @@ compilation and evaluation time conflicts." (unless (eq (char-after) ?{) (ignore-errors (backward-up-list 1 t t))) (save-excursion - ;; 'new' should be part of the line + ;; 'new' should be part of the line, but should not trigger if + ;; statement has already ended, like for 'var x = new X();'. + ;; Also, deal with the possible end of line obscured by a + ;; trailing comment. (goto-char (c-point 'iopl)) - (looking-at ".*new.*"))) + (looking-at "^[^//]*new[^//]*;$"))) ;; Line should not already be terminated (save-excursion (goto-char (c-point 'eopl)) @@ -998,6 +1001,8 @@ Key bindings: (add-to-list 'auto-mode-alist '("\\.cs\\'" . csharp-ts-mode))) +(derived-mode-add-parents 'csharp-ts-mode '(csharp-mode)) + (provide 'csharp-mode) ;;; csharp-mode.el ends here diff --git a/lisp/progmodes/dockerfile-ts-mode.el b/lisp/progmodes/dockerfile-ts-mode.el index 334f3064d98..e31fd86bbdf 100644 --- a/lisp/progmodes/dockerfile-ts-mode.el +++ b/lisp/progmodes/dockerfile-ts-mode.el @@ -31,10 +31,8 @@ (eval-when-compile (require 'rx)) (declare-function treesit-parser-create "treesit.c") -(declare-function treesit-induce-sparse-tree "treesit.c") (declare-function treesit-node-child "treesit.c") (declare-function treesit-node-child-by-field-name "treesit.c") -(declare-function treesit-node-start "treesit.c") (declare-function treesit-node-type "treesit.c") (defvar dockerfile-ts-mode--syntax-table @@ -118,38 +116,15 @@ continuation to the previous entry." '((ERROR) @font-lock-warning-face)) "Tree-sitter font-lock settings.") -(defun dockerfile-ts-mode--imenu () - "Return Imenu alist for the current buffer." - (let* ((node (treesit-buffer-root-node)) - (stage-tree (treesit-induce-sparse-tree - node "from_instruction" - nil 1000)) - (stage-index (dockerfile-ts-mode--imenu-1 stage-tree))) - (when stage-index `(("Stage" . ,stage-index))))) - -(defun dockerfile-ts-mode--imenu-1 (node) - "Helper for `dockerfile-ts-mode--imenu'. -Find string representation for NODE and set marker, then recurse -the subtrees." - (let* ((ts-node (car node)) - (children (cdr node)) - (subtrees (mapcan #'dockerfile-ts-mode--imenu-1 - children)) - (name (when ts-node - (pcase (treesit-node-type ts-node) - ("from_instruction" - (treesit-node-text - (or (treesit-node-child-by-field-name ts-node "as") - (treesit-node-child ts-node 1)) t))))) - (marker (when ts-node - (set-marker (make-marker) - (treesit-node-start ts-node))))) - (cond - ((or (null ts-node) (null name)) subtrees) - (subtrees - `((,name ,(cons name marker) ,@subtrees))) - (t - `((,name . ,marker)))))) +(defun dockerfile-ts-mode--stage-name (node) + "Return the stage name of NODE. +Return nil if there is no name or if NODE is not a stage node." + (pcase (treesit-node-type node) + ("from_instruction" + (treesit-node-text + (or (treesit-node-child-by-field-name node "as") + (treesit-node-child node 1)) + t)))) ;;;###autoload (define-derived-mode dockerfile-ts-mode prog-mode "Dockerfile" @@ -166,8 +141,8 @@ the subtrees." (setq-local comment-start-skip (rx "#" (* (syntax whitespace)))) ;; Imenu. - (setq-local imenu-create-index-function - #'dockerfile-ts-mode--imenu) + (setq-local treesit-simple-imenu-settings + `(("Stage" "\\`from_instruction\\'" nil dockerfile-ts-mode--stage-name))) (setq-local which-func-functions nil) ;; Indent. @@ -190,6 +165,8 @@ the subtrees." (treesit-major-mode-setup))) +(derived-mode-add-parents 'dockerfile-ts-mode '(dockerfile-mode)) + (if (treesit-ready-p 'dockerfile) (add-to-list 'auto-mode-alist ;; NOTE: We can't use `rx' here, as it breaks bootstrap. diff --git a/lisp/progmodes/eglot.el b/lisp/progmodes/eglot.el index d330e6e23cb..7d2f1a55165 100644 --- a/lisp/progmodes/eglot.el +++ b/lisp/progmodes/eglot.el @@ -2,12 +2,12 @@ ;; Copyright (C) 2018-2024 Free Software Foundation, Inc. -;; Version: 1.16 +;; Version: 1.17 ;; Author: João Távora <joaotavora@gmail.com> ;; Maintainer: João Távora <joaotavora@gmail.com> ;; URL: https://github.com/joaotavora/eglot ;; Keywords: convenience, languages -;; Package-Requires: ((emacs "26.3") (jsonrpc "1.0.23") (flymake "1.2.1") (project "0.9.8") (xref "1.6.2") (eldoc "1.14.0") (seq "2.23") (external-completion "0.1")) +;; Package-Requires: ((emacs "26.3") (jsonrpc "1.0.24") (flymake "1.2.1") (project "0.9.8") (xref "1.6.2") (eldoc "1.14.0") (seq "2.23") (external-completion "0.1")) ;; This is a GNU ELPA :core package. Avoid adding functionality ;; that is not available in the version of Emacs recorded above or any @@ -226,90 +226,108 @@ automatically)." when probe return (cons probe args) finally (funcall err))))))) -(defvar eglot-server-programs `(((rust-ts-mode rust-mode) . ("rust-analyzer")) - ((cmake-mode cmake-ts-mode) . ("cmake-language-server")) - (vimrc-mode . ("vim-language-server" "--stdio")) - ((python-mode python-ts-mode) - . ,(eglot-alternatives - '("pylsp" "pyls" ("pyright-langserver" "--stdio") "jedi-language-server" "ruff-lsp"))) - ((js-json-mode json-mode json-ts-mode) - . ,(eglot-alternatives '(("vscode-json-language-server" "--stdio") - ("vscode-json-languageserver" "--stdio") - ("json-languageserver" "--stdio")))) - (((js-mode :language-id "javascript") - (js-ts-mode :language-id "javascript") - (tsx-ts-mode :language-id "typescriptreact") - (typescript-ts-mode :language-id "typescript") - (typescript-mode :language-id "typescript")) - . ("typescript-language-server" "--stdio")) - ((bash-ts-mode sh-mode) . ("bash-language-server" "start")) - ((php-mode phps-mode) - . ,(eglot-alternatives - '(("phpactor" "language-server") - ("php" "vendor/felixfbecker/language-server/bin/php-language-server.php")))) - ((c-mode c-ts-mode c++-mode c++-ts-mode objc-mode) - . ,(eglot-alternatives - '("clangd" "ccls"))) - (((caml-mode :language-id "ocaml") - (tuareg-mode :language-id "ocaml") reason-mode) - . ("ocamllsp")) - ((ruby-mode ruby-ts-mode) - . ("solargraph" "socket" "--port" :autoport)) - (haskell-mode - . ("haskell-language-server-wrapper" "--lsp")) - (elm-mode . ("elm-language-server")) - (mint-mode . ("mint" "ls")) - (kotlin-mode . ("kotlin-language-server")) - ((go-mode go-dot-mod-mode go-dot-work-mode go-ts-mode go-mod-ts-mode) - . ("gopls")) - ((R-mode ess-r-mode) . ("R" "--slave" "-e" - "languageserver::run()")) - ((java-mode java-ts-mode) . ("jdtls")) - ((dart-mode dart-ts-mode) - . ("dart" "language-server" - "--client-id" "emacs.eglot-dart")) - ((elixir-mode elixir-ts-mode heex-ts-mode) - . ,(if (and (fboundp 'w32-shell-dos-semantics) - (w32-shell-dos-semantics)) - '("language_server.bat") - (eglot-alternatives - '("language_server.sh" "start_lexical.sh")))) - (ada-mode . ("ada_language_server")) - (scala-mode . ,(eglot-alternatives - '("metals" "metals-emacs"))) - (racket-mode . ("racket" "-l" "racket-langserver")) - ((tex-mode context-mode texinfo-mode bibtex-mode) - . ,(eglot-alternatives '("digestif" "texlab"))) - (erlang-mode . ("erlang_ls" "--transport" "stdio")) - ((yaml-ts-mode yaml-mode) . ("yaml-language-server" "--stdio")) - (nix-mode . ,(eglot-alternatives '("nil" "rnix-lsp" "nixd"))) - (nickel-mode . ("nls")) - (gdscript-mode . ("localhost" 6008)) - ((fortran-mode f90-mode) . ("fortls")) - (futhark-mode . ("futhark" "lsp")) - ((lua-mode lua-ts-mode) . ,(eglot-alternatives - '("lua-language-server" "lua-lsp"))) - (zig-mode . ("zls")) - ((css-mode css-ts-mode) - . ,(eglot-alternatives '(("vscode-css-language-server" "--stdio") - ("css-languageserver" "--stdio")))) - (html-mode . ,(eglot-alternatives '(("vscode-html-language-server" "--stdio") ("html-languageserver" "--stdio")))) - ((dockerfile-mode dockerfile-ts-mode) . ("docker-langserver" "--stdio")) - ((clojure-mode clojurescript-mode clojurec-mode clojure-ts-mode) - . ("clojure-lsp")) - ((csharp-mode csharp-ts-mode) - . ,(eglot-alternatives - '(("omnisharp" "-lsp") - ("csharp-ls")))) - (purescript-mode . ("purescript-language-server" "--stdio")) - ((perl-mode cperl-mode) . ("perl" "-MPerl::LanguageServer" "-e" "Perl::LanguageServer::run")) - (markdown-mode - . ,(eglot-alternatives - '(("marksman" "server") - ("vscode-markdown-language-server" "--stdio")))) - (graphviz-dot-mode . ("dot-language-server" "--stdio")) - (terraform-mode . ("terraform-ls" "serve")) - ((uiua-ts-mode uiua-mode) . ("uiua" "lsp"))) +(defvar eglot-server-programs + ;; FIXME: Maybe this info should be distributed into the major modes + ;; themselves where they could set a buffer-local `eglot-server-program' + ;; instead of keeping this database centralized. + ;; FIXME: With `derived-mode-add-parents' in Emacs≥30, some of + ;; those entries can be simplified, but we keep them for when + ;; `eglot.el' is installed via GNU ELPA in an older Emacs. + `(((rust-ts-mode rust-mode) . ("rust-analyzer")) + ((cmake-mode cmake-ts-mode) . ("cmake-language-server")) + (vimrc-mode . ("vim-language-server" "--stdio")) + ((python-mode python-ts-mode) + . ,(eglot-alternatives + '("pylsp" "pyls" ("basedpyright-langserver" "--stdio") + ("pyright-langserver" "--stdio") + "jedi-language-server" "ruff-lsp"))) + ((js-json-mode json-mode json-ts-mode) + . ,(eglot-alternatives '(("vscode-json-language-server" "--stdio") + ("vscode-json-languageserver" "--stdio") + ("json-languageserver" "--stdio")))) + (((js-mode :language-id "javascript") + (js-ts-mode :language-id "javascript") + (tsx-ts-mode :language-id "typescriptreact") + (typescript-ts-mode :language-id "typescript") + (typescript-mode :language-id "typescript")) + . ("typescript-language-server" "--stdio")) + ((bash-ts-mode sh-mode) . ("bash-language-server" "start")) + ((php-mode phps-mode php-ts-mode) + . ,(eglot-alternatives + '(("phpactor" "language-server") + ("php" "vendor/felixfbecker/language-server/bin/php-language-server.php")))) + ((c-mode c-ts-mode c++-mode c++-ts-mode objc-mode) + . ,(eglot-alternatives + '("clangd" "ccls"))) + (((caml-mode :language-id "ocaml") + (tuareg-mode :language-id "ocaml") reason-mode) + . ("ocamllsp")) + ((ruby-mode ruby-ts-mode) + . ("solargraph" "socket" "--port" :autoport)) + (haskell-mode + . ("haskell-language-server-wrapper" "--lsp")) + (elm-mode . ("elm-language-server")) + (mint-mode . ("mint" "ls")) + ((kotlin-mode kotlin-ts-mode) . ("kotlin-language-server")) + ((go-mode go-dot-mod-mode go-dot-work-mode go-ts-mode go-mod-ts-mode) + . ("gopls")) + ((R-mode ess-r-mode) . ("R" "--slave" "-e" + "languageserver::run()")) + ((java-mode java-ts-mode) . ("jdtls")) + ((dart-mode dart-ts-mode) + . ("dart" "language-server" + "--client-id" "emacs.eglot-dart")) + ((elixir-mode elixir-ts-mode heex-ts-mode) + . ,(if (and (fboundp 'w32-shell-dos-semantics) + (w32-shell-dos-semantics)) + '("language_server.bat") + (eglot-alternatives + '("language_server.sh" "start_lexical.sh")))) + (ada-mode . ("ada_language_server")) + (scala-mode . ,(eglot-alternatives + '("metals" "metals-emacs"))) + (racket-mode . ("racket" "-l" "racket-langserver")) + ((tex-mode context-mode texinfo-mode bibtex-mode) + . ,(eglot-alternatives '("digestif" "texlab"))) + (erlang-mode . ("erlang_ls" "--transport" "stdio")) + ((yaml-ts-mode yaml-mode) . ("yaml-language-server" "--stdio")) + (nix-mode . ,(eglot-alternatives '("nil" "rnix-lsp" "nixd"))) + (nickel-mode . ("nls")) + ((nushell-mode nushell-ts-mode) . ("nu" "--lsp")) + (gdscript-mode . ("localhost" 6008)) + (fennel-mode . ("fennel-ls")) + (move-mode . ("move-analyzer")) + ((fortran-mode f90-mode) . ("fortls")) + (futhark-mode . ("futhark" "lsp")) + ((lua-mode lua-ts-mode) . ,(eglot-alternatives + '("lua-language-server" "lua-lsp"))) + (zig-mode . ("zls")) + ((css-mode css-ts-mode) + . ,(eglot-alternatives '(("vscode-css-language-server" "--stdio") + ("css-languageserver" "--stdio")))) + (html-mode . ,(eglot-alternatives + '(("vscode-html-language-server" "--stdio") + ("html-languageserver" "--stdio")))) + ((dockerfile-mode dockerfile-ts-mode) . ("docker-langserver" "--stdio")) + ((clojure-mode clojurescript-mode clojurec-mode clojure-ts-mode) + . ("clojure-lsp")) + ((csharp-mode csharp-ts-mode) + . ,(eglot-alternatives + '(("omnisharp" "-lsp") + ("csharp-ls")))) + (purescript-mode . ("purescript-language-server" "--stdio")) + ((perl-mode cperl-mode) + . ("perl" "-MPerl::LanguageServer" "-e" "Perl::LanguageServer::run")) + (markdown-mode + . ,(eglot-alternatives + '(("marksman" "server") + ("vscode-markdown-language-server" "--stdio")))) + (graphviz-dot-mode . ("dot-language-server" "--stdio")) + (terraform-mode . ("terraform-ls" "serve")) + ((uiua-ts-mode uiua-mode) . ("uiua" "lsp")) + (sml-mode + . ,(lambda (_interactive project) + (list "millet-ls" (project-root project))))) "How the command `eglot' guesses the server to start. An association list of (MAJOR-MODE . CONTACT) pairs. MAJOR-MODE identifies the buffers that are to be managed by a specific @@ -575,7 +593,7 @@ It is nil if Eglot is not byte-complied.") (defvaralias 'eglot-{} 'eglot--{}) -(defconst eglot--{} (make-hash-table :size 1) "The empty JSON object.") +(defconst eglot--{} (make-hash-table :size 0) "The empty JSON object.") (defun eglot--executable-find (command &optional remote) "Like Emacs 27's `executable-find', ignore REMOTE on Emacs 26." @@ -590,7 +608,7 @@ It is nil if Eglot is not byte-complied.") (let ((vec (copy-sequence url-path-allowed-chars))) (aset vec ?: nil) ;; see github#639 vec) - "Like `url-path-allows-chars' but more restrictive.") + "Like `url-path-allowed-chars' but more restrictive.") ;;; Message verification helpers @@ -1797,6 +1815,12 @@ If optional MARKER, return a marker instead" ;;; More helpers +(defconst eglot--uri-path-allowed-chars + (let ((vec (copy-sequence url-path-allowed-chars))) + (aset vec ?: nil) ;; see github#639 + vec) + "Like `url-path-allowed-chars' but more restrictive.") + (defun eglot--snippet-expansion-fn () "Compute a function to expand snippets. Doubles as an indicator of snippet support." @@ -3054,9 +3078,14 @@ for which LSP on-type-formatting should be requested." finally (cl-return comp))) (defun eglot--dumb-allc (pat table pred _point) (funcall table pat pred t)) +(defun eglot--dumb-tryc (pat table pred point) + (let ((probe (funcall table pat pred nil))) + (cond ((eq probe t) t) + (probe (cons probe (length probe))) + (t (cons pat point))))) (add-to-list 'completion-category-defaults '(eglot-capf (styles eglot--dumb-flex))) -(add-to-list 'completion-styles-alist '(eglot--dumb-flex ignore eglot--dumb-allc)) +(add-to-list 'completion-styles-alist '(eglot--dumb-flex eglot--dumb-tryc eglot--dumb-allc)) (defun eglot-completion-at-point () "Eglot's `completion-at-point' function." @@ -3115,7 +3144,8 @@ for which LSP on-type-formatting should be requested." items))) ;; (trace-values "Requested" (length proxies) cachep bounds) (setq eglot--capf-session - (if cachep (list bounds retval resolved orig-pos) :none)) + (if cachep (list bounds retval resolved orig-pos + bounds-string) :none)) (setq local-cache retval))))) (resolve-maybe ;; Maybe completion/resolve JSON object `lsp-comp' into @@ -3135,7 +3165,8 @@ for which LSP on-type-formatting should be requested." (>= (cdr bounds) (cdr (nth 0 eglot--capf-session)))) (setq local-cache (nth 1 eglot--capf-session) resolved (nth 2 eglot--capf-session) - orig-pos (nth 3 eglot--capf-session)) + orig-pos (nth 3 eglot--capf-session) + bounds-string (nth 4 eglot--capf-session)) ;; (trace-values "Recalling cache" (length local-cache) bounds orig-pos) ) (list @@ -3605,16 +3636,17 @@ edit proposed by the server." (defun eglot--code-action-bounds () "Calculate appropriate bounds depending on region and point." - (let (diags) + (let (diags boftap) (cond ((use-region-p) `(,(region-beginning) ,(region-end))) ((setq diags (flymake-diagnostics (point))) (cl-loop for d in diags minimizing (flymake-diagnostic-beg d) into beg maximizing (flymake-diagnostic-end d) into end finally (cl-return (list beg end)))) + ((setq boftap (bounds-of-thing-at-point 'sexp)) + (list (car boftap) (cdr boftap))) (t - (let ((boftap (bounds-of-thing-at-point 'sexp))) - (list (car boftap) (cdr boftap))))))) + (list (point) (point)))))) (defun eglot-code-actions (beg &optional end action-kind interactive) "Find LSP code actions of type ACTION-KIND between BEG and END. diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el index 00910fb67c7..8a713bd19a2 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -221,7 +221,7 @@ All commands in `lisp-mode-shared-map' are inherited by this map." (load (byte-compile-dest-file buffer-file-name))) (declare-function native-compile "comp") -(declare-function comp-write-bytecode-file "comp") +(declare-function comp--write-bytecode-file "comp") (defun emacs-lisp-native-compile () "Native-compile the current buffer's file (if it has changed). @@ -233,7 +233,7 @@ visited by the current buffer." (byte-to-native-output-buffer-file nil) (eln (native-compile buffer-file-name))) (when eln - (comp-write-bytecode-file eln)))) + (comp--write-bytecode-file eln)))) (defun emacs-lisp-native-compile-and-load () "Native-compile the current buffer's file (if it has changed), then load it. @@ -309,7 +309,7 @@ Comments in the form will be lost." INTERACTIVE non-nil means ask the user for confirmation; this happens in interactive invocations." (interactive "p") - (if lexical-binding + (if (and (local-variable-p 'lexical-binding) lexical-binding) (when interactive (message "lexical-binding already enabled!") (ding)) @@ -371,6 +371,12 @@ be used instead. ;; Font-locking support. +(defun elisp--font-lock-shorthand (_limit) + ;; Add faces on shorthands between point and LIMIT. + ;; ... + ;; Return nil to tell font-lock, that there's nothing left to do. + nil) + (defun elisp--font-lock-flush-elisp-buffers (&optional file) ;; We're only ever called from after-load-functions, load-in-progress can ;; still be t in case of nested loads. @@ -657,12 +663,13 @@ functions are annotated with \"<f>\" via the (save-excursion (backward-sexp 1) (skip-chars-forward "`',‘#") - (point)) + (min (point) pos)) (scan-error pos))) (end - (unless (or (eq beg (point-max)) - (member (char-syntax (char-after beg)) - '(?\" ?\())) + (cond + ((and (< beg (point-max)) + (memq (char-syntax (char-after beg)) + '(?w ?\\ ?_))) (condition-case nil (save-excursion (goto-char beg) @@ -670,7 +677,11 @@ functions are annotated with \"<f>\" via the (skip-chars-backward "'’") (when (>= (point) pos) (point))) - (scan-error pos)))) + (scan-error pos))) + ((or (>= beg (point-max)) + (memq (char-syntax (char-after beg)) + '(?\) ?\s))) + beg))) ;; t if in function position. (funpos (eq (char-before beg) ?\()) (quoted (elisp--form-quoted-p beg)) @@ -1577,9 +1588,6 @@ character)." (buffer-substring-no-properties beg end)) )))) - -(defvar elisp--eval-last-sexp-fake-value (make-symbol "t")) - (defun eval-sexp-add-defvars (exp &optional pos) "Prepend EXP with all the `defvar's that precede it in the buffer. POS specifies the starting position where EXP was found and defaults to point." @@ -1621,16 +1629,10 @@ integer value is also printed as a character of that codepoint. 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) - (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) - debug-on-error)))) - (unless (eq (cdr value) elisp--eval-last-sexp-fake-value) - (setq debug-on-error (cdr value))) - (car value)))) + (values--store-value + (handler-bind ((error (if eval-expression-debug-on-error + #'eval-expression--debug #'ignore))) + (elisp--eval-last-sexp eval-last-sexp-arg-internal)))) (defun elisp--eval-defun-1 (form) "Treat some expressions in FORM specially. @@ -1689,8 +1691,7 @@ 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) - (edebugging edebug-all-defs) + (let ((edebugging edebug-all-defs) elisp--eval-defun-result) (save-excursion ;; Arrange for eval-region to "read" the (possibly) altered form. @@ -1769,15 +1770,9 @@ which see." (defvar edebug-all-defs) (eval-defun (not edebug-all-defs))) (t - (if (null eval-expression-debug-on-error) - (elisp--eval-defun) - (let (new-value value) - (let ((debug-on-error elisp--eval-last-sexp-fake-value)) - (setq value (elisp--eval-defun)) - (setq new-value debug-on-error)) - (unless (eq elisp--eval-last-sexp-fake-value new-value) - (setq debug-on-error new-value)) - value))))) + (handler-bind ((error (if eval-expression-debug-on-error + #'eval-expression--debug #'ignore))) + (elisp--eval-defun))))) ;;; ElDoc Support diff --git a/lisp/progmodes/elixir-ts-mode.el b/lisp/progmodes/elixir-ts-mode.el index b493195eedd..9804152d9ab 100644 --- a/lisp/progmodes/elixir-ts-mode.el +++ b/lisp/progmodes/elixir-ts-mode.el @@ -360,13 +360,19 @@ (defvar elixir-ts--font-lock-settings (treesit-font-lock-rules :language 'elixir - :feature 'elixir-function-name + :feature 'elixir-definition `((call target: (identifier) @target-identifier + (arguments + (call target: (identifier) @font-lock-function-name-face + (arguments))) + (:match ,elixir-ts--definition-keywords-re @target-identifier)) + (call target: (identifier) @target-identifier (arguments (identifier) @font-lock-function-name-face) (:match ,elixir-ts--definition-keywords-re @target-identifier)) (call target: (identifier) @target-identifier (arguments - (call target: (identifier) @font-lock-function-name-face)) + (call target: (identifier) @font-lock-function-name-face + (arguments ((identifier)) @font-lock-variable-name-face))) (:match ,elixir-ts--definition-keywords-re @target-identifier)) (call target: (identifier) @target-identifier (arguments @@ -379,13 +385,15 @@ (:match ,elixir-ts--definition-keywords-re @target-identifier)) (call target: (identifier) @target-identifier (arguments - (call target: (identifier) @font-lock-function-name-face)) + (call target: (identifier) @font-lock-function-name-face + (arguments ((identifier)) @font-lock-variable-name-face))) (do_block) (:match ,elixir-ts--definition-keywords-re @target-identifier)) (call target: (identifier) @target-identifier (arguments (binary_operator - left: (call target: (identifier) @font-lock-function-name-face))) + left: (call target: (identifier) @font-lock-function-name-face + (arguments ((identifier)) @font-lock-variable-name-face)))) (do_block) (:match ,elixir-ts--definition-keywords-re @target-identifier)) (unary_operator @@ -521,8 +529,8 @@ operator: "/" right: (integer))) (call target: (dot right: (identifier) @font-lock-function-call-face)) - (unary_operator operator: "&" @font-lock-variable-name-face - operand: (integer) @font-lock-variable-name-face) + (unary_operator operator: "&" @font-lock-variable-use-face + operand: (integer) @font-lock-variable-use-face) (unary_operator operator: "&" @font-lock-operator-face operand: (list))) @@ -537,16 +545,18 @@ :language 'elixir :feature 'elixir-variable - '((binary_operator left: (identifier) @font-lock-variable-name-face) - (binary_operator right: (identifier) @font-lock-variable-name-face) - (arguments ( (identifier) @font-lock-variable-name-face)) - (tuple (identifier) @font-lock-variable-name-face) - (list (identifier) @font-lock-variable-name-face) - (pair value: (identifier) @font-lock-variable-name-face) - (body (identifier) @font-lock-variable-name-face) - (unary_operator operand: (identifier) @font-lock-variable-name-face) - (interpolation (identifier) @font-lock-variable-name-face) - (do_block (identifier) @font-lock-variable-name-face)) + '((binary_operator left: (identifier) @font-lock-variable-use-face) + (binary_operator right: (identifier) @font-lock-variable-use-face) + (arguments ( (identifier) @font-lock-variable-use-face)) + (tuple (identifier) @font-lock-variable-use-face) + (list (identifier) @font-lock-variable-use-face) + (pair value: (identifier) @font-lock-variable-use-face) + (body (identifier) @font-lock-variable-use-face) + (unary_operator operand: (identifier) @font-lock-variable-use-face) + (interpolation (identifier) @font-lock-variable-use-face) + (do_block (identifier) @font-lock-variable-use-face) + (access_call target: (identifier) @font-lock-variable-use-face) + (access_call "[" key: (identifier) @font-lock-variable-use-face "]")) :language 'elixir :feature 'elixir-builtin @@ -697,11 +707,10 @@ Return nil if NODE is not a defun node or doesn't have a name." ;; Font-lock. (setq-local treesit-font-lock-settings elixir-ts--font-lock-settings) (setq-local treesit-font-lock-feature-list - '(( elixir-comment elixir-doc elixir-function-name) + '(( elixir-comment elixir-doc elixir-definition) ( elixir-string elixir-keyword elixir-data-type) - ( elixir-sigil elixir-variable elixir-builtin - elixir-string-escape) - ( elixir-function-call elixir-operator elixir-number ))) + ( elixir-sigil elixir-builtin elixir-string-escape) + ( elixir-function-call elixir-variable elixir-operator elixir-number ))) ;; Imenu. @@ -734,17 +743,18 @@ Return nil if NODE is not a defun node or doesn't have a name." heex-ts--indent-rules)) (setq-local treesit-font-lock-feature-list - '(( elixir-comment elixir-doc elixir-function-name + '(( elixir-comment elixir-doc elixir-definition heex-comment heex-keyword heex-doctype ) ( elixir-string elixir-keyword elixir-data-type heex-component heex-tag heex-attribute heex-string ) - ( elixir-sigil elixir-variable elixir-builtin - elixir-string-escape) - ( elixir-function-call elixir-operator elixir-number )))) + ( elixir-sigil elixir-builtin elixir-string-escape) + ( elixir-function-call elixir-variable elixir-operator elixir-number )))) (treesit-major-mode-setup) (setq-local syntax-propertize-function #'elixir-ts--syntax-propertize))) +(derived-mode-add-parents 'elixir-ts-mode '(elixir-mode)) + (if (treesit-ready-p 'elixir) (progn (add-to-list 'auto-mode-alist '("\\.elixir\\'" . elixir-ts-mode)) diff --git a/lisp/progmodes/etags-regen.el b/lisp/progmodes/etags-regen.el new file mode 100644 index 00000000000..6cd78d3577a --- /dev/null +++ b/lisp/progmodes/etags-regen.el @@ -0,0 +1,431 @@ +;;; etags-regen.el --- Auto-(re)regenerating tags -*- lexical-binding: t -*- + +;; Copyright (C) 2021-2023 Free Software Foundation, Inc. + +;; Author: Dmitry Gutov <dmitry@gutov.dev> +;; Keywords: tools + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Simple automatic tags generation with updates on save. +;; +;; This mode provides automatic indexing for Emacs "go to definition" +;; feature, the `xref-go-forward' command (bound to `M-.' by default). +;; +;; At the moment reindexing works off before/after-save-hook, but to +;; handle more complex changes (for example, the user switching to +;; another branch from the terminal) we can look into plugging into +;; something like `filenotify'. +;; +;; Note that this feature disables itself if the user has some tags +;; table already visited (with `M-x visit-tags-table', or through an +;; explicit prompt triggered by some feature that requires tags). + +;;; Code: + +(require 'cl-lib) + +(defgroup etags-regen nil + "Auto-(re)generating tags." + :group 'tools) + +(defvar etags-regen--tags-file nil) +(defvar etags-regen--tags-root nil) +(defvar etags-regen--new-file nil) + +(declare-function project-root "project") +(declare-function project-files "project") +(declare-function dired-glob-regexp "dired") + +(defcustom etags-regen-program (executable-find "etags") + "Name of the etags program used by `etags-regen-mode'. + +If you only have `ctags' installed, you can also set this to +\"ctags -e\". Some features might not be supported this way." + ;; Always having our 'etags' here would be easier, but we can't + ;; always rely on it being installed. So it might be ctags's etags. + :type 'file + :version "30.1") + +(defcustom etags-regen-tags-file "TAGS" + "Name of the tags file to create inside the project by `etags-regen-mode'. + +The value should either be a simple file name (no directory +specified), or a function that accepts the project root directory +and returns a distinct absolute file name for its tags file. The +latter possibility is useful when you prefer to store the tag +files somewhere else, for example in `temporary-file-directory'." + :type '(choice (string :tag "File name") + (function :tag "Function that returns file name")) + :version "30.1") + +(defcustom etags-regen-program-options nil + "List of additional options for etags program invoked by `etags-regen-mode'." + :type '(repeat string) + :version "30.1") + +(defcustom etags-regen-regexp-alist nil + "Mapping of languages to etags regexps for `etags-regen-mode'. + +These regexps are used in addition to the tags made with the +standard parsing based on the language. + +The value must be a list where each element has the +form (LANGUAGES . TAG-REGEXPS) where both LANGUAGES and +TAG-REGEXPS are lists of strings. + +Each language should be one of the recognized by etags, see +`etags --help'. Each tag regexp should be a string in the format +documented for the `--regex' arguments (without `{language}'). + +We currently support only Emacs's etags program with this option." + :type '(repeat + (cons + :tag "Languages group" + (repeat (string :tag "Language name")) + (repeat (string :tag "Tag Regexp")))) + :version "30.1") + +;;;###autoload +(put 'etags-regen-regexp-alist 'safe-local-variable + (lambda (value) + (and (listp value) + (seq-every-p + (lambda (group) + (and (consp group) + (listp (car group)) + (listp (cdr group)) + (seq-every-p #'stringp (car group)) + (seq-every-p #'stringp (cdr group)))) + value)))) + +;; We have to list all extensions: etags falls back to Fortran +;; when it cannot determine the type of the file. +;; http://lists.gnu.org/archive/html/emacs-devel/2018-01/msg00323.html +(defcustom etags-regen-file-extensions + '("rb" "js" "py" "pl" "el" "c" "cpp" "cc" "h" "hh" "hpp" + "java" "go" "cl" "lisp" "prolog" "php" "erl" "hrl" + "F" "f" "f90" "for" "cs" "a" "asm" "ads" "adb" "ada") + "Code file extensions for `etags-regen-mode'. + +File extensions to generate the tags for." + :type '(repeat (string :tag "File extension")) + :version "30.1") + +;;;###autoload +(put 'etags-regen-file-extensions 'safe-local-variable + (lambda (value) (and (listp value) (seq-every-p #'stringp value)))) + +;; FIXME: We don't support root anchoring yet. +(defcustom etags-regen-ignores nil + "Additional ignore rules, in the format of `project-ignores'." + :type '(repeat + (string :tag "Glob to ignore")) + :version "30.1") + +;;;###autoload +(put 'etags-regen-ignores 'safe-local-variable + (lambda (value) (and (listp value) (seq-every-p #'stringp value)))) + +(defvar etags-regen--errors-buffer-name "*etags-regen-tags-errors*") + +(defvar etags-regen--rescan-files-limit 100) + +(defun etags-regen--all-mtimes (proj) + (let ((files (etags-regen--all-files proj)) + (mtimes (make-hash-table :test 'equal)) + file-name-handler-alist) + (dolist (f files) + (condition-case nil + (puthash f + (file-attribute-modification-time + (file-attributes f)) + mtimes) + (file-missing nil))) + mtimes)) + +(defun etags-regen--choose-tags-file (proj) + (if (functionp etags-regen-tags-file) + (funcall etags-regen-tags-file (project-root proj)) + (expand-file-name etags-regen-tags-file (project-root proj)))) + +(defun etags-regen--refresh (proj) + (save-excursion + (let* ((tags-file (etags-regen--choose-tags-file proj)) + (tags-mtime (file-attribute-modification-time + (file-attributes tags-file))) + (all-mtimes (etags-regen--all-mtimes proj)) + added-files + changed-files + removed-files) + (etags-regen--visit-table tags-file (project-root proj)) + (set-buffer (get-file-buffer tags-file)) + (dolist (file (tags-table-files)) + (let ((mtime (gethash file all-mtimes))) + (cond + ((null mtime) + (push file removed-files)) + ((time-less-p tags-mtime mtime) + (push file changed-files) + (remhash file all-mtimes)) + (t + (remhash file all-mtimes))))) + (maphash + (lambda (key _value) + (push key added-files)) + all-mtimes) + (if (> (+ (length added-files) + (length changed-files) + (length removed-files)) + etags-regen--rescan-files-limit) + (progn + (message "etags-regen: Too many changes, falling back to full rescan") + (etags-regen--tags-cleanup)) + (dolist (file (nconc removed-files changed-files)) + (etags-regen--remove-tag file)) + (when (or changed-files added-files) + (apply #'etags-regen--append-tags + (nconc changed-files added-files))) + (when (or changed-files added-files removed-files) + (let ((save-silently t) + (message-log-max nil)) + (save-buffer 0))))))) + +(defun etags-regen--maybe-generate () + (let (proj) + (when (and etags-regen--tags-root + (not (file-in-directory-p default-directory + etags-regen--tags-root))) + (etags-regen--tags-cleanup)) + (when (and (not etags-regen--tags-root) + ;; If existing table is visited that's not generated by + ;; this mode, skip all functionality. + (not (or tags-file-name + tags-table-list)) + (file-exists-p (etags-regen--choose-tags-file + (setq proj (project-current))))) + (message "Found existing tags table, refreshing...") + (etags-regen--refresh proj)) + (when (and (not (or tags-file-name + tags-table-list)) + (setq proj (or proj (project-current)))) + (message "Generating new tags table...") + (let ((start (time-to-seconds))) + (etags-regen--tags-generate proj) + (message "...done (%.2f s)" (- (time-to-seconds) start)))))) + +(defun etags-regen--all-files (proj) + (let* ((root (project-root proj)) + (default-directory root) + ;; TODO: Make the scanning more efficient, e.g. move the + ;; filtering by glob to project (project-files-filtered...). + (files (project-files proj)) + (match-re (concat + "\\." + (regexp-opt etags-regen-file-extensions) + "\\'")) + (ir-start (1- (length root))) + (ignores-regexps + (mapcar #'etags-regen--ignore-regexp + etags-regen-ignores))) + (cl-delete-if + (lambda (f) (or (not (string-match-p match-re f)) + (string-match-p "/\\.#" f) ;Backup files. + (cl-some (lambda (ignore) (string-match ignore f ir-start)) + ignores-regexps))) + files))) + +(defun etags-regen--ignore-regexp (ignore) + (require 'dired) + ;; It's somewhat brittle to rely on Dired. + (let ((re (dired-glob-regexp ignore))) + ;; We could implement root anchoring here, but \\= doesn't work in + ;; string-match :-(. + (concat (unless (eq ?/ (aref re 3)) "/") + ;; Cutting off the anchors added by `dired-glob-regexp'. + (substring re 2 (- (length re) 2)) + ;; This way we allow a glob to match against a directory + ;; name, or a file name. And when it ends with / already, + ;; no need to add the anchoring. + (unless (eq ?/ (aref re (- (length re) 3))) + ;; Either match a full name segment, or eos. + "\\(?:/\\|\\'\\)")))) + +(defun etags-regen--tags-generate (proj) + (let* ((root (project-root proj)) + (default-directory root) + (files (etags-regen--all-files proj)) + (tags-file (etags-regen--choose-tags-file proj)) + (ctags-p (etags-regen--ctags-p)) + (command (format "%s %s %s - -o %s" + etags-regen-program + (mapconcat #'identity + (etags-regen--build-program-options ctags-p) + " ") + ;; ctags's etags requires '-L' for stdin input. + (if ctags-p "-L" "") + tags-file))) + (with-temp-buffer + (mapc (lambda (f) + (insert f "\n")) + files) + (shell-command-on-region (point-min) (point-max) command + nil nil etags-regen--errors-buffer-name t)) + (etags-regen--visit-table tags-file root))) + +(defun etags-regen--visit-table (tags-file root) + ;; Invalidate the scanned tags after any change is written to disk. + (add-hook 'after-save-hook #'etags-regen--update-file) + (add-hook 'before-save-hook #'etags-regen--mark-as-new) + (setq etags-regen--tags-file tags-file + etags-regen--tags-root root) + (visit-tags-table etags-regen--tags-file)) + +(defun etags-regen--ctags-p () + (string-search "Ctags" + (shell-command-to-string + (format "%s --version" etags-regen-program)))) + +(defun etags-regen--build-program-options (ctags-p) + (when (and etags-regen-regexp-alist ctags-p) + (user-error "etags-regen-regexp-alist is not supported with Ctags")) + (nconc + (mapcan + (lambda (group) + (mapcan + (lambda (lang) + (mapcar (lambda (regexp) + (concat "--regex=" + (shell-quote-argument + (format "{%s}%s" lang regexp)))) + (cdr group))) + (car group))) + etags-regen-regexp-alist) + (mapcar #'shell-quote-argument + etags-regen-program-options))) + +(defun etags-regen--update-file () + ;; TODO: Maybe only do this when Emacs is idle for a bit. Or defer + ;; the updates and do them later in bursts when the table is used. + (let* ((file-name buffer-file-name) + (tags-file-buf (and etags-regen--tags-root + (get-file-buffer etags-regen--tags-file))) + (relname (concat "/" (file-relative-name file-name + etags-regen--tags-root))) + (ignores etags-regen-ignores) + pr should-scan) + (save-excursion + (when tags-file-buf + (cond + ((and etags-regen--new-file + (kill-local-variable 'etags-regen--new-file) + (setq pr (project-current)) + (equal (project-root pr) etags-regen--tags-root) + (member file-name (project-files pr))) + (set-buffer tags-file-buf) + (setq should-scan t)) + ((progn (set-buffer tags-file-buf) + (etags-regen--remove-tag file-name)) + (setq should-scan t)))) + (when (and should-scan + (not (cl-some + (lambda (ignore) + (string-match-p + (etags-regen--ignore-regexp ignore) + relname)) + ignores))) + (etags-regen--append-tags file-name) + (let ((save-silently t) + (message-log-max nil)) + (save-buffer 0)))))) + +(defun etags-regen--remove-tag (file-name) + (goto-char (point-min)) + (when (search-forward (format "\f\n%s," file-name) nil t) + (let ((start (match-beginning 0))) + (search-forward "\f\n" nil 'move) + (let ((inhibit-read-only t)) + (delete-region start + (if (eobp) + (point) + (- (point) 2))))) + t)) + +(defun etags-regen--append-tags (&rest file-names) + (goto-char (point-max)) + (let ((options (etags-regen--build-program-options (etags-regen--ctags-p))) + (inhibit-read-only t)) + ;; XXX: call-process is significantly faster, though. + ;; Like 10ms vs 20ms here. But `shell-command' makes it easy to + ;; direct stderr to a separate buffer. + (shell-command + (format "%s %s %s -o -" + etags-regen-program (mapconcat #'identity options " ") + (mapconcat #'identity file-names " ")) + t etags-regen--errors-buffer-name)) + ;; FIXME: Is there a better way to do this? + ;; Completion table is the only remaining place where the + ;; update is not incremental. + (setq-default tags-completion-table nil)) + +(defun etags-regen--mark-as-new () + (when (and etags-regen--tags-root + (not buffer-file-number)) + (setq-local etags-regen--new-file t))) + +(defun etags-regen--tags-cleanup () + (when etags-regen--tags-file + (let ((buffer (get-file-buffer etags-regen--tags-file))) + (and buffer + (kill-buffer buffer))) + (tags-reset-tags-tables) + (setq tags-file-name nil + tags-table-list nil + etags-regen--tags-file nil + etags-regen--tags-root nil)) + (remove-hook 'after-save-hook #'etags-regen--update-file) + (remove-hook 'before-save-hook #'etags-regen--mark-as-new)) + +(defvar etags-regen-mode-map (make-sparse-keymap)) + +;;;###autoload +(define-minor-mode etags-regen-mode + "Minor mode to automatically generate and update tags tables. + +This minor mode generates the tags table automatically based on +the current project configuration, and later updates it as you +edit the files and save the changes. + +If you select a tags table manually (for example, using +\\[visit-tags-table]), then this mode will be effectively +disabled for the entire session. Use \\[tags-reset-tags-tables] +to countermand the effect of a previous \\[visit-tags-table]." + :global t + (if etags-regen-mode + (progn + (advice-add 'etags--xref-backend :before + #'etags-regen--maybe-generate) + (advice-add 'tags-completion-at-point-function :before + #'etags-regen--maybe-generate)) + (advice-remove 'etags--xref-backend #'etags-regen--maybe-generate) + (advice-remove 'tags-completion-at-point-function #'etags-regen--maybe-generate) + (etags-regen--tags-cleanup))) + +(provide 'etags-regen) + +;;; etags-regen.el ends here diff --git a/lisp/progmodes/etags.el b/lisp/progmodes/etags.el index b9bd772ddfc..597612196fd 100644 --- a/lisp/progmodes/etags.el +++ b/lisp/progmodes/etags.el @@ -1488,7 +1488,7 @@ hits the start of file." (setq symbs (symbol-value symbs)) (insert (format-message "symbol `%s' has no value\n" symbs)) (setq symbs nil))) - (if (vectorp symbs) + (if (obarrayp symbs) (mapatoms ins-symb symbs) (dolist (sy symbs) (funcall ins-symb (car sy)))) @@ -2065,7 +2065,8 @@ for \\[find-tag] (which see)." (user-error "%s" (substitute-command-keys "No tags table loaded; try \\[visit-tags-table]"))) - (let ((comp-data (tags-completion-at-point-function))) + (let ((comp-data (tags-completion-at-point-function)) + (completion-ignore-case (find-tag--completion-ignore-case))) (if (null comp-data) (user-error "Nothing to complete") (completion-in-region (car comp-data) (cadr comp-data) @@ -2183,7 +2184,7 @@ file name, add `tag-partial-file-name-match-p' to the list value.") (setq symbs (symbol-value symbs)) (warn "symbol `%s' has no value" symbs) (setq symbs nil)) - (if (vectorp symbs) + (if (obarrayp symbs) (mapatoms add-xref symbs) (dolist (sy symbs) (funcall add-xref (car sy)))) diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el index 3f8aec27833..779c612f479 100644 --- a/lisp/progmodes/flymake.el +++ b/lisp/progmodes/flymake.el @@ -715,7 +715,7 @@ associated `flymake-category' return DEFAULT." (delete-overlay ov))) (defun flymake--eol-overlay-summary (src-ovs) - "Helper function for `flymake--eol-overlay-update'." + "Helper function for `flymake--update-eol-overlays'." (cl-flet ((summarize (d) (propertize (flymake-diagnostic-oneliner d t) 'face (flymake--lookup-type-property (flymake--diag-type d) @@ -744,7 +744,7 @@ associated `flymake-category' return DEFAULT." (defun flymake--update-eol-overlays () "Update the `before-string' property of end-of-line overlays." - (save-excursion + (save-restriction (widen) (dolist (o (overlays-in (point-min) (point-max))) (when (overlay-get o 'flymake--eol-overlay) @@ -1569,13 +1569,19 @@ correctly.") ,flymake-mode-line-lighter mouse-face mode-line-highlight help-echo - ,(lambda (&rest _) - (concat - (format "%s known backends\n" (hash-table-count flymake--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 (w &rest _) + (with-current-buffer (window-buffer w) + ;; Mouse can activate tool-tip without window being active. + ;; `flymake--state' is buffer local and is null when line + ;; lighter appears in *Help* `describe-mode'. + (concat + (unless (null flymake--state) + (concat + (format "%s known backends\n" (hash-table-count flymake--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] @@ -1637,14 +1643,16 @@ correctly.") (defvar flymake--mode-line-counter-map (let ((map (make-sparse-keymap))) + ;; BEWARE: `mouse-wheel-UP-event' corresponds to `wheel-DOWN' events + ;; and vice versa!! (define-key map (vector 'mode-line mouse-wheel-down-event) #'flymake--mode-line-counter-scroll-prev) (define-key map [mode-line wheel-down] - #'flymake--mode-line-counter-scroll-prev) + #'flymake--mode-line-counter-scroll-next) (define-key map (vector 'mode-line mouse-wheel-up-event) #'flymake--mode-line-counter-scroll-next) (define-key map [mode-line wheel-up] - #'flymake--mode-line-counter-scroll-next) + #'flymake--mode-line-counter-scroll-prev) map)) (defun flymake--mode-line-counter-1 (type) diff --git a/lisp/progmodes/gdb-mi.el b/lisp/progmodes/gdb-mi.el index e08653f7f9e..c8b086cfad2 100644 --- a/lisp/progmodes/gdb-mi.el +++ b/lisp/progmodes/gdb-mi.el @@ -1880,7 +1880,8 @@ this trigger is subscribed to `gdb-buf-publisher' and called with (defun gdb-clear-inferior-io () (with-current-buffer (gdb-get-buffer-create 'gdb-inferior-io) - (erase-buffer))) + (let ((inhibit-read-only t)) + (erase-buffer)))) (defconst breakpoint-xpm-data @@ -2866,7 +2867,8 @@ current thread and update GDB buffers." (defun gdb-clear-partial-output () (with-current-buffer (gdb-get-buffer-create 'gdb-partial-output-buffer) - (erase-buffer))) + (let ((inhibit-read-only t)) + (erase-buffer)))) ;; Parse GDB/MI result records: this process converts ;; list [...] -> list diff --git a/lisp/progmodes/go-ts-mode.el b/lisp/progmodes/go-ts-mode.el index 65adc1c55ea..cc330688dc3 100644 --- a/lisp/progmodes/go-ts-mode.el +++ b/lisp/progmodes/go-ts-mode.el @@ -261,7 +261,11 @@ (treesit-major-mode-setup))) +(derived-mode-add-parents 'go-ts-mode '(go-mode)) + (if (treesit-ready-p 'go) + ;; FIXME: Should we instead put `go-mode' in `auto-mode-alist' + ;; and then use `major-mode-remap-defaults' to map it to `go-ts-mode'? (add-to-list 'auto-mode-alist '("\\.go\\'" . go-ts-mode))) (defun go-ts-mode--defun-name (node &optional skip-prefix) @@ -437,6 +441,8 @@ what the parent of the node would be if it were a node." (treesit-major-mode-setup))) +(derived-mode-add-parents 'go-mod-ts-mode '(go-mod-mode)) + (if (treesit-ready-p 'gomod) (add-to-list 'auto-mode-alist '("/go\\.mod\\'" . go-mod-ts-mode))) diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el index be6357f4139..f10b047cc74 100644 --- a/lisp/progmodes/gud.el +++ b/lisp/progmodes/gud.el @@ -243,7 +243,7 @@ Check it when `gud-running' is t") :visible (eq gud-minor-mode 'gdbmi)] ["Print Expression" gud-print :enable (not gud-running)] - ["Dump object-Derefenrece" gud-pstar + ["Dump object-Dereference" gud-pstar :label (if (eq gud-minor-mode 'jdb) "Dump object" "Print Dereference") @@ -3671,8 +3671,7 @@ Treats actions as defuns." (remove-hook 'after-save-hook #'gdb-create-define-alist t)))) (defcustom gud-tooltip-modes '( gud-mode c-mode c++-mode fortran-mode - python-mode c-ts-mode c++-ts-mode - python-ts-mode) + python-mode) "List of modes for which to enable GUD tooltips." :type '(repeat (symbol :tag "Major mode")) :group 'tooltip) @@ -3708,10 +3707,9 @@ only tooltips in the buffer containing the overlay arrow." #'gud-tooltip-activate-mouse-motions-if-enabled) (dolist (buffer (buffer-list)) (with-current-buffer buffer - (if (and gud-tooltip-mode - (memq major-mode gud-tooltip-modes)) - (gud-tooltip-activate-mouse-motions t) - (gud-tooltip-activate-mouse-motions nil))))) + (gud-tooltip-activate-mouse-motions + (and gud-tooltip-mode + (derived-mode-p gud-tooltip-modes)))))) (defvar gud-tooltip-mouse-motions-active nil "Locally t in a buffer if tooltip processing of mouse motion is enabled.") diff --git a/lisp/progmodes/heex-ts-mode.el b/lisp/progmodes/heex-ts-mode.el index 7b53a44deb2..07b8bfdc74f 100644 --- a/lisp/progmodes/heex-ts-mode.el +++ b/lisp/progmodes/heex-ts-mode.el @@ -166,6 +166,16 @@ With ARG, do it many times. Negative ARG means move backward." ("Slot" "\\`slot\\'" nil nil) ("Tag" "\\`tag\\'" nil nil))) + ;; Outline minor mode + ;; `heex-ts-mode' inherits from `html-mode' that sets + ;; regexp-based outline variables. So need to restore + ;; the default values of outline variables to be able + ;; to use `treesit-outline-predicate' derived + ;; from `treesit-simple-imenu-settings' above. + (kill-local-variable 'outline-heading-end-regexp) + (kill-local-variable 'outline-regexp) + (kill-local-variable 'outline-level) + (setq-local treesit-font-lock-settings heex-ts--font-lock-settings) (setq-local treesit-simple-indent-rules heex-ts--indent-rules) @@ -177,6 +187,8 @@ With ARG, do it many times. Negative ARG means move backward." (treesit-major-mode-setup))) +(derived-mode-add-parents 'heex-ts-mode '(heex-mode)) + (if (treesit-ready-p 'heex) ;; Both .heex and the deprecated .leex files should work ;; with the tree-sitter-heex grammar. diff --git a/lisp/progmodes/hideif.el b/lisp/progmodes/hideif.el index 3b7eb393561..98e567299a1 100644 --- a/lisp/progmodes/hideif.el +++ b/lisp/progmodes/hideif.el @@ -390,7 +390,7 @@ If there is a marked region from START to END it only shows the symbols within." (defun hif-after-revert-function () (and hide-ifdef-mode hide-ifdef-hiding (hide-ifdefs nil nil t))) -(add-hook 'after-revert-hook 'hif-after-revert-function) +(add-hook 'after-revert-hook #'hif-after-revert-function) (defun hif-end-of-line () "Find the end-point of line concatenation." @@ -474,7 +474,7 @@ Everything including these lines is made invisible." (defun hif-eval (form) "Evaluate hideif internal representation." - (let ((val (eval form))) + (let ((val (eval form t))) (if (stringp val) (or (get-text-property 0 'hif-value val) val) @@ -542,7 +542,7 @@ that form should be displayed.") (defconst hif-cpp-prefix "\\(^\\|\r\\)?[ \t]*#[ \t]*") (defconst hif-ifxdef-regexp (concat hif-cpp-prefix "if\\(n\\)?def")) (defconst hif-ifndef-regexp (concat hif-cpp-prefix "ifndef")) -(defconst hif-ifx-regexp (concat hif-cpp-prefix "if\\((\\|\\(n?def\\)?[ \t]+\\)")) +(defvar hif-ifx-regexp (concat hif-cpp-prefix "if\\((\\|\\(n?def\\)?[ \t]+\\)")) (defconst hif-elif-regexp (concat hif-cpp-prefix "elif")) (defconst hif-else-regexp (concat hif-cpp-prefix "else")) (defconst hif-endif-regexp (concat hif-cpp-prefix "endif")) @@ -679,7 +679,7 @@ that form should be displayed.") ("..." . hif-etc) ("defined" . hif-defined))) -(defconst hif-valid-token-list (mapcar 'cdr hif-token-alist)) +(defconst hif-valid-token-list (mapcar #'cdr hif-token-alist)) (defconst hif-token-regexp ;; The ordering of regexp grouping is crucial to `hif-strtok' @@ -690,7 +690,7 @@ that form should be displayed.") ;; decimal/octal: "\\|\\(\\([+-]?[0-9']+\\(\\.[0-9']*\\)?\\)\\([eE][+-]?[0-9]+\\)?" hif-numtype-suffix-regexp "?\\)" - "\\|" (regexp-opt (mapcar 'car hif-token-alist) t) + "\\|" (regexp-opt (mapcar #'car hif-token-alist) t) "\\|\\(\\w+\\)")) ;; C++11 Unicode string literals (L"" u8"" u"" U"" R"" LR"" u8R"" uR"") @@ -867,7 +867,7 @@ Assuming we've just performed a `hif-token-regexp' lookup." (t (setq hif-simple-token-only nil) - (intern-safe string))))) + (hif--intern-safe string))))) (defun hif-backward-comment (&optional start end) "If we're currently within a C(++) comment, skip them backwards." @@ -1448,7 +1448,7 @@ This macro cannot be evaluated alone without parameters input." (t (error "Invalid token to stringify")))) -(defun intern-safe (str) +(defun hif--intern-safe (str) (if (stringp str) (intern str))) @@ -1750,7 +1750,7 @@ and `+='...)." ;; Split REM-BODY @ __VA_ARGS__ into LEFT and right (setq part nil) (if (zerop va) - (setq left nil ; __VA_ARGS__ trimed + (setq left nil ; __VA_ARGS__ trimmed rem-body (cdr rem-body)) (setq left rem-body rem-body (cdr (nthcdr va rem-body))) ; _V_ removed diff --git a/lisp/progmodes/hideshow.el b/lisp/progmodes/hideshow.el index b181b21118f..07616960565 100644 --- a/lisp/progmodes/hideshow.el +++ b/lisp/progmodes/hideshow.el @@ -254,6 +254,9 @@ This has effect only if `search-invisible' is set to `open'." ;;;###autoload (defvar hs-special-modes-alist + ;; FIXME: Currently the check is made via + ;; (assoc major-mode hs-special-modes-alist) so it doesn't pay attention + ;; to the mode hierarchy. (mapcar #'purecopy '((c-mode "{" "}" "/[*/]" nil nil) (c-ts-mode "{" "}" "/[*/]" nil nil) diff --git a/lisp/progmodes/idlw-help.el b/lisp/progmodes/idlw-help.el index 217b2ab6691..7bed69a738b 100644 --- a/lisp/progmodes/idlw-help.el +++ b/lisp/progmodes/idlw-help.el @@ -631,7 +631,7 @@ Needs additional info stored in global `idlwave-completion-help-info'." Those words in `idlwave-completion-help-links' have links. The `idlwave-help-link' face is used for this." (if idlwave-highlight-help-links-in-completion - (with-current-buffer (get-buffer "*Completions*") + (with-current-buffer "*Completions*" (save-excursion (let* ((case-fold-search t) (props (list 'face 'idlwave-help-link)) diff --git a/lisp/progmodes/idlw-shell.el b/lisp/progmodes/idlw-shell.el index b5470b5490d..b5d91f46b17 100644 --- a/lisp/progmodes/idlw-shell.el +++ b/lisp/progmodes/idlw-shell.el @@ -96,8 +96,8 @@ (defcustom idlwave-shell-prompt-pattern "^\r? ?IDL> " "Regexp to match IDL prompt at beginning of a line. -For example, \"^\r?IDL> \" or \"^\r?WAVE> \". -The \"^\r?\" is needed, to indicate the beginning of the line, with +For example, \"^\\r?IDL> \" or \"^\\r?WAVE> \". +The \"^\\r?\" is needed, to indicate the beginning of the line, with optional return character (which IDL seems to output randomly). This variable is used to initialize `comint-prompt-regexp' in the process buffer." @@ -829,7 +829,7 @@ IDL has currently stepped.") 3. Routine Info ------------ - `\\[idlwave-routine-info]' displays information about an IDL routine near point, + \\[idlwave-routine-info] displays information about an IDL routine near point, just like in `idlwave-mode'. The module used is the one at point or the one whose argument list is being edited. To update IDLWAVE's knowledge about compiled or edited modules, use diff --git a/lisp/progmodes/idlwave.el b/lisp/progmodes/idlwave.el index 4b96461d773..30442fa0d34 100644 --- a/lisp/progmodes/idlwave.el +++ b/lisp/progmodes/idlwave.el @@ -657,7 +657,7 @@ When you specify a class, this information can be stored as a text property on the `->' arrow in the source code, so that during the same editing session, IDLWAVE will not have to ask again. When this variable is non-nil, IDLWAVE will store and reuse the class information. -The class stored can be checked and removed with `\\[idlwave-routine-info]' +The class stored can be checked and removed with \\[idlwave-routine-info] on the arrow. The default of this variable is nil, since the result of commands then diff --git a/lisp/progmodes/java-ts-mode.el b/lisp/progmodes/java-ts-mode.el index 0b1ac49b99f..bb4a7df3340 100644 --- a/lisp/progmodes/java-ts-mode.el +++ b/lisp/progmodes/java-ts-mode.el @@ -74,7 +74,12 @@ ((parent-is "program") column-0 0) ((match "}" "element_value_array_initializer") parent-bol 0) - ((node-is "}") column-0 c-ts-common-statement-offset) + ((node-is + ,(format "\\`%s\\'" + (regexp-opt '("constructor_body" "class_body" "interface_body" + "block" "switch_block" "array_initializer")))) + parent-bol 0) + ((node-is "}") standalone-parent 0) ((node-is ")") parent-bol 0) ((node-is "else") parent-bol 0) ((node-is "]") parent-bol 0) @@ -86,10 +91,10 @@ ((parent-is "array_initializer") parent-bol java-ts-mode-indent-offset) ((parent-is "annotation_type_body") column-0 c-ts-common-statement-offset) ((parent-is "interface_body") column-0 c-ts-common-statement-offset) - ((parent-is "constructor_body") column-0 c-ts-common-statement-offset) + ((parent-is "constructor_body") standalone-parent java-ts-mode-indent-offset) ((parent-is "enum_body_declarations") parent-bol 0) ((parent-is "enum_body") column-0 c-ts-common-statement-offset) - ((parent-is "switch_block") column-0 c-ts-common-statement-offset) + ((parent-is "switch_block") standalone-parent java-ts-mode-indent-offset) ((parent-is "record_declaration_body") column-0 c-ts-common-statement-offset) ((query "(method_declaration (block _ @indent))") parent-bol java-ts-mode-indent-offset) ((query "(method_declaration (block (_) @indent))") parent-bol java-ts-mode-indent-offset) @@ -125,7 +130,7 @@ ((parent-is "case_statement") parent-bol java-ts-mode-indent-offset) ((parent-is "labeled_statement") parent-bol java-ts-mode-indent-offset) ((parent-is "do_statement") parent-bol java-ts-mode-indent-offset) - ((parent-is "block") column-0 c-ts-common-statement-offset))) + ((parent-is "block") standalone-parent java-ts-mode-indent-offset))) "Tree-sitter indent rules.") (defvar java-ts-mode--keywords @@ -401,6 +406,8 @@ Return nil if there is no name or if NODE is not a defun node." ("Method" "\\`method_declaration\\'" nil nil))) (treesit-major-mode-setup)) +(derived-mode-add-parents 'java-ts-mode '(java-mode)) + (if (treesit-ready-p 'java) (add-to-list 'auto-mode-alist '("\\.java\\'" . java-ts-mode))) diff --git a/lisp/progmodes/js.el b/lisp/progmodes/js.el index 0115feb0e97..6cb84592896 100644 --- a/lisp/progmodes/js.el +++ b/lisp/progmodes/js.el @@ -3418,6 +3418,26 @@ This function is intended for use in `after-change-functions'." ;;; Tree sitter integration +(defun js--treesit-font-lock-compatibility-definition-feature () + "Font lock helper, to handle different releases of tree-sitter-javascript. +Check if a node type is available, then return the right font lock rules +for \"definition\" feature." + (condition-case nil + (progn (treesit-query-capture 'javascript '((function_expression) @cap)) + ;; Starting from version 0.20.2 of the grammar. + '((function_expression + name: (identifier) @font-lock-function-name-face) + (variable_declarator + name: (identifier) @font-lock-function-name-face + value: [(function_expression) (arrow_function)]))) + (error + ;; An older version of the grammar. + '((function + name: (identifier) @font-lock-function-name-face) + (variable_declarator + name: (identifier) @font-lock-function-name-face + value: [(function) (arrow_function)]))))) + (defun js-jsx--treesit-indent-compatibility-bb1f97b () "Indent rules helper, to handle different releases of tree-sitter-javascript. Check if a node type is available, then return the right indent rules." @@ -3529,8 +3549,7 @@ Check if a node type is available, then return the right indent rules." :language 'javascript :feature 'definition - '((function - name: (identifier) @font-lock-function-name-face) + `(,@(js--treesit-font-lock-compatibility-definition-feature) (class_declaration name: (identifier) @font-lock-type-face) @@ -3550,10 +3569,6 @@ Check if a node type is available, then return the right indent rules." name: (identifier) @font-lock-variable-name-face) (variable_declarator - name: (identifier) @font-lock-function-name-face - value: [(function) (arrow_function)]) - - (variable_declarator name: [(array_pattern (identifier) @font-lock-variable-name-face) (object_pattern (shorthand_property_identifier_pattern) @font-lock-variable-name-face)]) @@ -3702,6 +3717,9 @@ Currently there are `js-mode' and `js-ts-mode'." (define-derived-mode js-mode js-base-mode "JavaScript" "Major mode for editing JavaScript." :group 'js + (js--mode-setup)) + +(defun js--mode-setup () ;; Ensure all CC Mode "lang variables" are set to valid values. (c-init-language-vars js-mode) (setq-local indent-line-function #'js-indent-line) @@ -3898,6 +3916,8 @@ See `treesit-thing-settings' for more information.") (add-to-list 'auto-mode-alist '("\\(\\.js[mx]\\|\\.har\\)\\'" . js-ts-mode)))) +(derived-mode-add-parents 'js-ts-mode '(js-mode)) + (defvar js-ts--s-p-query (when (treesit-available-p) (treesit-query-compile 'javascript @@ -3924,7 +3944,9 @@ See `treesit-thing-settings' for more information.") (put-text-property (1- ne) ne 'syntax-table syntax))))) ;;;###autoload -(define-derived-mode js-json-mode js-mode "JSON" +(define-derived-mode js-json-mode prog-mode "JSON" + :syntax-table js-mode-syntax-table + (js--mode-setup) ;Reuse most of `js-mode', but not as parent (bug#67463). (setq-local js-enabled-frameworks nil) ;; Speed up `syntax-ppss': JSON files can be big but can't hold ;; regexp matchers nor #! thingies (and `js-enabled-frameworks' is nil). diff --git a/lisp/progmodes/json-ts-mode.el b/lisp/progmodes/json-ts-mode.el index 32bc10bbda9..1fb96555010 100644 --- a/lisp/progmodes/json-ts-mode.el +++ b/lisp/progmodes/json-ts-mode.el @@ -164,6 +164,8 @@ Return nil if there is no name or if NODE is not a defun node." (treesit-major-mode-setup)) +(derived-mode-add-parents 'json-ts-mode '(json-mode)) + (if (treesit-ready-p 'json) (add-to-list 'auto-mode-alist '("\\.json\\'" . json-ts-mode))) diff --git a/lisp/progmodes/lua-ts-mode.el b/lisp/progmodes/lua-ts-mode.el index 3b600f59521..407ef230c32 100644 --- a/lisp/progmodes/lua-ts-mode.el +++ b/lisp/progmodes/lua-ts-mode.el @@ -26,8 +26,8 @@ ;; This package provides `lua-ts-mode' which is a major mode for Lua ;; files that uses Tree Sitter to parse the language. ;; -;; This package is compatible with and tested against the grammar -;; for Lua found at https://github.com/MunifTanjim/tree-sitter-lua +;; This package is compatible with and tested against the grammar for +;; Lua found at https://github.com/tree-sitter-grammars/tree-sitter-lua ;;; Code: @@ -60,66 +60,77 @@ :options '(flymake-mode hs-minor-mode outline-minor-mode) - :group 'lua-ts :version "30.1") (defcustom lua-ts-indent-offset 4 "Number of spaces for each indentation step in `lua-ts-mode'." :type 'natnum :safe 'natnump - :group 'lua-ts :version "30.1") (defcustom lua-ts-luacheck-program "luacheck" "Location of the Luacheck program." :type '(choice (const :tag "None" nil) string) - :group 'lua-ts :version "30.1") (defcustom lua-ts-inferior-buffer "*Lua*" "Name of the inferior Lua buffer." :type 'string :safe 'stringp - :group 'lua-ts :version "30.1") (defcustom lua-ts-inferior-program "lua" "Program to run in the inferior Lua process." :type '(choice (const :tag "None" nil) string) - :group 'lua-ts :version "30.1") (defcustom lua-ts-inferior-options '("-i") "Command line options for the inferior Lua process." :type '(repeat string) - :group 'lua-ts :version "30.1") (defcustom lua-ts-inferior-startfile nil "File to load into the inferior Lua process at startup." :type '(choice (const :tag "None" nil) (file :must-match t)) - :group 'lua-ts :version "30.1") (defcustom lua-ts-inferior-prompt ">" "Prompt used by the inferior Lua process." :type 'string :safe 'stringp - :group 'lua-ts :version "30.1") (defcustom lua-ts-inferior-prompt-continue ">>" "Continuation prompt used by the inferior Lua process." :type 'string :safe 'stringp - :group 'lua-ts :version "30.1") (defcustom lua-ts-inferior-history nil "File used to save command history of the inferior Lua process." :type '(choice (const :tag "None" nil) file) :safe 'string-or-null-p - :group 'lua-ts + :version "30.1") + +(defcustom lua-ts-indent-continuation-lines t + "Controls how multi-line if/else statements are aligned. + +If t, then continuation lines are indented by `lua-ts-indent-offset': + + if a + and b then + print(1) + end + +If nil, then continuation lines are aligned with the beginning of +the statement: + + if a + and b then + print(1) + end" + :type 'boolean + :safe 'booleanp :version "30.1") (defvar lua-ts--builtins @@ -295,6 +306,8 @@ values of OVERRIDE." (node-is ")") (node-is "}")) standalone-parent 0) + ((match null "table_constructor") + standalone-parent lua-ts-indent-offset) ((or (and (parent-is "arguments") lua-ts--first-child-matcher) (and (parent-is "parameters") lua-ts--first-child-matcher) (and (parent-is "table_constructor") lua-ts--first-child-matcher)) @@ -329,6 +342,17 @@ values of OVERRIDE." ((or (match "end" "function_definition") (node-is "end")) standalone-parent 0) + ((n-p-gp "expression_list" "assignment_statement" "variable_declaration") + lua-ts--variable-declaration-continuation-anchor + lua-ts-indent-offset) + ((and (parent-is "binary_expression") + lua-ts--variable-declaration-continuation) + lua-ts--variable-declaration-continuation-anchor + lua-ts-indent-offset) + ((and (lambda (&rest _) lua-ts-indent-continuation-lines) + (parent-is "binary_expression")) + standalone-parent lua-ts-indent-offset) + ((parent-is "binary_expression") standalone-parent 0) ((or (parent-is "function_declaration") (parent-is "function_definition") (parent-is "do_statement") @@ -415,6 +439,22 @@ values of OVERRIDE." (treesit-induce-sparse-tree parent #'lua-ts--function-definition-p))) (= 1 (length (cadr sparse-tree))))) +(defun lua-ts--variable-declaration-continuation (node &rest _) + "Matches if NODE is part of a multi-line variable declaration." + (treesit-parent-until node + (lambda (p) + (equal "variable_declaration" + (treesit-node-type p))))) + +(defun lua-ts--variable-declaration-continuation-anchor (node &rest _) + "Return the start position of the variable declaration for NODE." + (save-excursion + (goto-char (treesit-node-start + (lua-ts--variable-declaration-continuation node))) + (when (looking-back (rx bol (* whitespace)) + (line-beginning-position)) + (point)))) + (defvar lua-ts--syntax-table (let ((table (make-syntax-table))) (modify-syntax-entry ?+ "." table) @@ -577,7 +617,7 @@ Calls REPORT-FN directly." nil t))) (select-window (display-buffer lua-ts-inferior-buffer '((display-buffer-reuse-window - display-buffer-pop-up-frame) + display-buffer-pop-up-window) (reusable-frames . t)))) (get-buffer-process (current-buffer))) @@ -725,7 +765,7 @@ Calls REPORT-FN directly." "vararg_expression")))) (text "comment")))) - ;; Imenu. + ;; Imenu/Outline. (setq-local treesit-simple-imenu-settings `(("Requires" "\\`function_call\\'" @@ -740,16 +780,6 @@ Calls REPORT-FN directly." ;; Which-function. (setq-local which-func-functions (treesit-defun-at-point)) - ;; Outline. - (setq-local outline-regexp - (rx (seq (0+ space) - (or (seq "--[[" (0+ space) eol) - (seq symbol-start - (or "do" "for" "if" "repeat" "while" - (seq (? (seq "local" (1+ space))) - "function")) - symbol-end))))) - ;; Align. (setq-local align-indent-before-aligning t) @@ -757,6 +787,8 @@ Calls REPORT-FN directly." (add-hook 'flymake-diagnostic-functions #'lua-ts-flymake-luacheck nil 'local)) +(derived-mode-add-parents 'lua-ts-mode '(lua-mode)) + (when (treesit-ready-p 'lua) (add-to-list 'auto-mode-alist '("\\.lua\\'" . lua-ts-mode))) diff --git a/lisp/progmodes/modula2.el b/lisp/progmodes/modula2.el index 09cb848fd52..2bb31988290 100644 --- a/lisp/progmodes/modula2.el +++ b/lisp/progmodes/modula2.el @@ -325,20 +325,20 @@ followed by the first character of the construct. ;; ;; Module definitions. ("\\<\\(INTERFACE\\|MODULE\\|PROCEDURE\\)\\>[ \t]*\\(\\sw+\\)?" - (1 font-lock-keyword-face) (2 font-lock-function-name-face nil t)) + (1 'font-lock-keyword-face) (2 'font-lock-function-name-face nil t)) ;; ;; Import directives. ("\\<\\(EXPORTS\\|FROM\\|IMPORT\\)\\>" - (1 font-lock-keyword-face) + (1 'font-lock-keyword-face) (font-lock-match-c-style-declaration-item-and-skip-to-next nil (goto-char (match-end 0)) - (1 font-lock-constant-face))) + (1 'font-lock-constant-face))) ;; ;; Pragmas as warnings. ;; Spencer Allain <sallain@teknowledge.com> says do them as comments... ;; ("<\\*.*\\*>" . font-lock-warning-face) ;; ... but instead we fontify the first word. - ("<\\*[ \t]*\\(\\sw+\\)" 1 font-lock-warning-face prepend) + ("<\\*[ \t]*\\(\\sw+\\)" 1 'font-lock-warning-face prepend) ) "Subdued level highlighting for Modula-3 modes.") @@ -366,26 +366,29 @@ followed by the first character of the construct. "LOOPHOLE" "MAX" "MIN" "NARROW" "NEW" "NUMBER" "ORD" "ROUND" "SUBARRAY" "TRUNC" "TYPECODE" "VAL"))) ) - (list - ;; - ;; Keywords except those fontified elsewhere. - (concat "\\<\\(" m3-keywords "\\)\\>") - ;; - ;; Builtins. - (cons (concat "\\<\\(" m3-builtins "\\)\\>") 'font-lock-builtin-face) - ;; - ;; Type names. - (cons (concat "\\<\\(" m3-types "\\)\\>") 'font-lock-type-face) - ;; - ;; Fontify tokens as function names. - '("\\<\\(END\\|EXCEPTION\\|RAISES?\\)\\>[ \t{]*" - (1 font-lock-keyword-face) + `( + ;; + ;; Keywords except those fontified elsewhere. + ,(concat "\\<\\(" m3-keywords "\\)\\>") + ;; + ;; Builtins. + (,(concat "\\<\\(" m3-builtins "\\)\\>") + (0 'font-lock-builtin-face)) + ;; + ;; Type names. + (,(concat "\\<\\(" m3-types "\\)\\>") + (0 'font-lock-type-face)) + ;; + ;; Fontify tokens as function names. + ("\\<\\(END\\|EXCEPTION\\|RAISES?\\)\\>[ \t{]*" + (1 'font-lock-keyword-face) (font-lock-match-c-style-declaration-item-and-skip-to-next nil (goto-char (match-end 0)) - (1 font-lock-function-name-face))) - ;; - ;; Fontify constants as references. - '("\\<\\(FALSE\\|NIL\\|NULL\\|TRUE\\)\\>" . font-lock-constant-face) + (1 'font-lock-function-name-face))) + ;; + ;; Fontify constants as references. + ("\\<\\(FALSE\\|NIL\\|NULL\\|TRUE\\)\\>" + (0 'font-lock-constant-face)) )))) "Gaudy level highlighting for Modula-3 modes.") diff --git a/lisp/progmodes/opascal.el b/lisp/progmodes/opascal.el index 5e8263cb646..a80e12b8129 100644 --- a/lisp/progmodes/opascal.el +++ b/lisp/progmodes/opascal.el @@ -281,7 +281,7 @@ nested routine.") (eval-when-compile (pcase-defmacro opascal--in (set) - `(pred (pcase--flip memq ,set)))) + `(pred (memq _ ,set)))) (defun opascal-string-of (start end) ;; Returns the buffer string from start to end. diff --git a/lisp/progmodes/perl-mode.el b/lisp/progmodes/perl-mode.el index f74390841fe..f6c4dbed1e2 100644 --- a/lisp/progmodes/perl-mode.el +++ b/lisp/progmodes/perl-mode.el @@ -251,7 +251,16 @@ ;; correctly the \() construct (Bug#11996) as well as references ;; to string values. ("\\(\\\\\\)['`\"($]" (1 (unless (nth 3 (syntax-ppss)) - (string-to-syntax ".")))) + (string-to-syntax ".")))) + ;; A "$" in Perl code must escape the next char to protect against + ;; misinterpreting Perl's punctuation variables as unbalanced + ;; quotes or parens. This is not needed in strings and broken in + ;; the special case of "$\"" (Bug#69604). Make "$" a punctuation + ;; char in strings. + ("\\$" (0 (if (save-excursion + (nth 3 (syntax-ppss (match-beginning 0)))) + (string-to-syntax ".") + (string-to-syntax "/")))) ;; Handle funny names like $DB'stop. ("\\$ ?{?\\^?[_[:alpha:]][_[:alnum:]]*\\('\\)[_[:alpha:]]" (1 "_")) ;; format statements diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index a6f14a0865c..a10e24f3e28 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -229,7 +229,8 @@ See the doc string of `project-find-functions' for the general form of the project instance object." (unless directory (setq directory (or project-current-directory-override default-directory))) - (let ((pr (project--find-in-directory directory))) + (let ((pr (project--find-in-directory directory)) + (non-essential (not maybe-prompt))) (cond (pr) ((unless project-current-directory-override @@ -602,7 +603,7 @@ See `project-vc-extra-root-markers' for the marker value format.") (goto-char (point-min)) ;; Kind of a hack to distinguish a submodule from ;; other cases of .git files pointing elsewhere. - (looking-at "gitdir: [./]+/\\.git/modules/")) + (looking-at "gitdir: .+/\\.git/\\(worktrees/.*\\)?modules/")) t) (t nil)))) @@ -808,8 +809,10 @@ DIRS must contain directory names." (with-temp-buffer (setq default-directory dir) (let ((enable-local-variables :all)) - (hack-dir-local-variables-non-file-buffer)) - (symbol-value var))) + (hack-dir-local-variables)) + ;; Don't use `hack-local-variables-apply' to avoid setting modes. + (alist-get var file-local-variables-alist + (symbol-value var)))) (cl-defmethod project-buffers ((project (head vc))) (let* ((root (expand-file-name (file-name-as-directory (project-root project)))) @@ -992,9 +995,7 @@ requires quoting, e.g. `\\[quoted-insert]<space>'." ;;;###autoload (defun project-or-external-find-regexp (regexp) - "Find all matches for REGEXP in the project roots or external roots. -With \\[universal-argument] prefix, you can specify the file name -pattern to search for." + "Find all matches for REGEXP in the project roots or external roots." (interactive (list (project--read-regexp))) (require 'xref) (let* ((pr (project-current t)) @@ -1363,6 +1364,7 @@ If you exit the `query-replace', you can later continue the (defvar compilation-read-command) (declare-function compilation-read-command "compile") +(declare-function recompile "compile") (defun project-prefixed-buffer-name (mode) (concat "*" @@ -1396,6 +1398,18 @@ If non-nil, it overrides `compilation-buffer-name-function' for compilation-buffer-name-function))) (call-interactively #'compile))) +(defun project-recompile (&optional edit-command) + "Run `recompile' with appropriate buffer." + (declare (interactive-only recompile)) + (interactive "P") + (let ((compilation-buffer-name-function + (or project-compilation-buffer-name-function + ;; Should we error instead? When there's no + ;; project-specific naming, there is no point in using + ;; this command. + compilation-buffer-name-function))) + (recompile edit-command))) + (defcustom project-ignore-buffer-conditions nil "List of conditions to filter the buffers to be switched to. If any of these conditions are satisfied for a buffer in the @@ -1502,7 +1516,8 @@ ARG, show only buffers that are visiting files." (lambda (buffer) (let ((name (buffer-name buffer)) (file (buffer-file-name buffer))) - (and (or (not (string= (substring name 0 1) " ")) + (and (or Buffer-menu-show-internal + (not (string= (substring name 0 1) " ")) file) (not (eq buffer (current-buffer))) (or file (not Buffer-menu-files-only))))) @@ -1512,6 +1527,7 @@ ARG, show only buffers that are visiting files." (let ((buf (list-buffers-noselect arg (with-current-buffer (get-buffer-create "*Buffer List*") + (setq-local Buffer-menu-show-internal nil) (let ((Buffer-menu-files-only arg)) (funcall buffer-list-function)))))) (with-current-buffer buf @@ -1694,7 +1710,10 @@ With some possible metadata (to be decided).") (let ((name (car elem))) (list (if (file-remote-p name) name (abbreviate-file-name name))))) - (read (current-buffer)))))) + (condition-case nil + (read (current-buffer)) + (end-of-file + (warn "Failed to read the projects list file due to unexpected EOF"))))))) (unless (seq-every-p (lambda (elt) (stringp (car-safe elt))) project--list) @@ -1850,12 +1869,12 @@ Otherwise, `default-directory' is temporarily set to the current project's root. If OVERRIDING-MAP is non-nil, it will be used as -`overriding-local-map' to provide shorter bindings from that map -which will take priority over the global ones." +`overriding-terminal-local-map' to provide shorter bindings +from that map which will take priority over the global ones." (interactive) (let* ((pr (project-current t)) (prompt-format (or prompt-format "[execute in %s]:")) - (command (let ((overriding-local-map overriding-map)) + (command (let ((overriding-terminal-local-map overriding-map)) (key-binding (read-key-sequence (format prompt-format (project-root pr))) t))) @@ -2124,12 +2143,10 @@ is part of the default mode line beginning with Emacs 30." :group 'project :version "30.1") -(defvar project-menu-entry - `(menu-item "Project" ,(bound-and-true-p menu-bar-project-menu))) - (defvar project-mode-line-map (let ((map (make-sparse-keymap))) - (define-key map [mode-line down-mouse-1] project-menu-entry) + (define-key map [mode-line down-mouse-1] + (bound-and-true-p menu-bar-project-item)) map)) (defvar project-mode-line-face nil diff --git a/lisp/progmodes/prolog.el b/lisp/progmodes/prolog.el index a65943a48eb..97f08a79ccd 100644 --- a/lisp/progmodes/prolog.el +++ b/lisp/progmodes/prolog.el @@ -1148,7 +1148,7 @@ line and comments can also be enclosed in /* ... */. If an optional argument SYSTEM is non-nil, set up mode for the given system. To find out what version of Prolog mode you are running, enter -`\\[prolog-mode-version]'. +\\[prolog-mode-version]. Commands: \\{prolog-mode-map}" @@ -1268,7 +1268,7 @@ imitating normal Unix input editing. \\[comint-quit-subjob] sends quit signal, likewise. To find out what version of Prolog mode you are running, enter -`\\[prolog-mode-version]'." +\\[prolog-mode-version]." (require 'compile) (setq comint-input-filter 'prolog-input-filter) (setq mode-line-process '(": %s")) diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index 1148da11a06..8279617b6e7 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -5,7 +5,7 @@ ;; Author: Fabián E. Gallina <fgallina@gnu.org> ;; URL: https://github.com/fgallina/python.el ;; Version: 0.28 -;; Package-Requires: ((emacs "24.4") (compat "28.1.2.1") (seq "2.23")) +;; Package-Requires: ((emacs "24.4") (compat "29.1.1.0") (seq "2.23")) ;; Maintainer: emacs-devel@gnu.org ;; Created: Jul 2010 ;; Keywords: languages @@ -128,9 +128,9 @@ ;; receiving escape sequences (with some limitations, i.e. completion ;; in blocks does not work). The code executed for the "fallback" ;; completion can be found in `python-shell-completion-setup-code' and -;; `python-shell-completion-string-code' variables. Their default -;; values enable completion for both CPython and IPython, and probably -;; any readline based shell (it's known to work with PyPy). If your +;; `python-shell-completion-get-completions'. Their default values +;; enable completion for both CPython and IPython, and probably any +;; readline based shell (it's known to work with PyPy). If your ;; Python installation lacks readline (like CPython for Windows), ;; installing pyreadline (URL `https://ipython.org/pyreadline.html') ;; should suffice. To troubleshoot why you are not getting any @@ -141,6 +141,12 @@ ;; If you see an error, then you need to either install pyreadline or ;; setup custom code that avoids that dependency. +;; By default, the "native" completion uses the built-in rlcompleter. +;; To use other readline completer (e.g. Jedi) or a custom one, you just +;; need to set it in the PYTHONSTARTUP file. You can set an +;; Emacs-specific completer by testing the environment variable +;; INSIDE_EMACS. + ;; Shell virtualenv support: The shell also contains support for ;; virtualenvs and other special environment modifications thanks to ;; `python-shell-process-environment' and `python-shell-exec-path'. @@ -267,7 +273,7 @@ (eval-when-compile (require 'subr-x)) ;For `string-empty-p' and `string-join'. (require 'treesit) (require 'pcase) -(require 'compat nil 'noerror) +(require 'compat) (require 'project nil 'noerror) (require 'seq) @@ -909,6 +915,7 @@ is used to limit the scan." "Put `syntax-table' property correctly on single/triple quotes." (let* ((ppss (save-excursion (backward-char 3) (syntax-ppss))) (string-start (and (eq t (nth 3 ppss)) (nth 8 ppss))) + (string-literal-concat (numberp (nth 3 ppss))) (quote-starting-pos (- (point) 3)) (quote-ending-pos (point))) (cond ((or (nth 4 ppss) ;Inside a comment @@ -921,6 +928,8 @@ is used to limit the scan." ((nth 5 ppss) ;; The first quote is escaped, so it's not part of a triple quote! (goto-char (1+ quote-starting-pos))) + ;; Handle string literal concatenation (bug#45897) + (string-literal-concat nil) ((null string-start) ;; This set of quotes delimit the start of a string. Put ;; string fence syntax on last quote. (bug#49518) @@ -1117,7 +1126,7 @@ fontified." (defun python--treesit-fontify-union-types (node override start end &optional type-regex &rest _) "Fontify nested union types in the type hints. -For examlpe, Lvl1 | Lvl2[Lvl3[Lvl4[Lvl5 | None]], Lvl2]. This +For example, Lvl1 | Lvl2[Lvl3[Lvl4[Lvl5 | None]], Lvl2]. This structure is represented via nesting binary_operator and subscript nodes. This function iterates over all levels and highlight identifier nodes. If TYPE-REGEX is not nil fontify type @@ -1275,7 +1284,7 @@ fontified." (subscript (identifier) @font-lock-type-face) (subscript (attribute attribute: (identifier) @font-lock-type-face))])) - ;; Patern matching: case [str(), pack0.Type0()]. Take only the + ;; Pattern matching: case [str(), pack0.Type0()]. Take only the ;; last identifier. (class_pattern (dotted_name (identifier) @font-lock-type-face :anchor)) @@ -1359,15 +1368,15 @@ For NODE, OVERRIDE, START, END, and ARGS, see (save-excursion (goto-char start) (while (re-search-forward (rx (or "\"\"\"" "'''")) end t) - (let ((node (treesit-node-at (point)))) - ;; The triple quotes surround a non-empty string. - (when (equal (treesit-node-type node) "string_content") - (let ((start (treesit-node-start node)) - (end (treesit-node-end node))) - (put-text-property (1- start) start - 'syntax-table (string-to-syntax "|")) - (put-text-property end (min (1+ end) (point-max)) - 'syntax-table (string-to-syntax "|")))))))) + (let ((node (treesit-node-at (- (point) 3)))) + ;; Handle triple-quoted strings. + (pcase (treesit-node-type node) + ("string_start" + (put-text-property (1- (point)) (point) + 'syntax-table (string-to-syntax "|"))) + ("string_end" + (put-text-property (- (point) 3) (- (point) 2) + 'syntax-table (string-to-syntax "|")))))))) ;;; Indentation @@ -3512,6 +3521,16 @@ eventually provide a shell." :version "25.1" :type 'hook) +(defconst python-shell-setup-code + "\ +try: + import tty +except ImportError: + pass +else: + tty.setraw(0)" + "Code used to setup the inferior Python processes.") + (defconst python-shell-eval-setup-code "\ def __PYTHON_EL_eval(source, filename): @@ -3577,10 +3596,12 @@ The coding cookie regexp is specified in PEP 263.") (format "exec(%s)\n" (python-shell--encode-string string)))))) ;; Bootstrap: the normal definition of `python-shell-send-string' ;; depends on the Python code sent here. + (python-shell-send-string-no-output python-shell-setup-code) (python-shell-send-string-no-output python-shell-eval-setup-code) (python-shell-send-string-no-output python-shell-eval-file-setup-code)) (with-current-buffer (current-buffer) (let ((inhibit-quit nil)) + (python-shell-readline-detect) (run-hooks 'python-shell-first-prompt-hook)))))) output) @@ -3601,7 +3622,6 @@ interpreter is run. Variables `python-shell-prompt-block-regexp', `python-shell-font-lock-enable', `python-shell-completion-setup-code', -`python-shell-completion-string-code', `python-eldoc-setup-code', `python-ffap-setup-code' can customize this mode for different Python interpreters. @@ -4241,8 +4261,9 @@ def __PYTHON_EL_get_completions(text): completions = [] completer = None + import json try: - import readline + import readline, re try: import __builtin__ @@ -4253,16 +4274,29 @@ def __PYTHON_EL_get_completions(text): is_ipython = ('__IPYTHON__' in builtins or '__IPYTHON__active' in builtins) - splits = text.split() - is_module = splits and splits[0] in ('from', 'import') - - if is_ipython and is_module: - from IPython.core.completerlib import module_completion - completions = module_completion(text.strip()) - elif is_ipython and '__IP' in builtins: - completions = __IP.complete(text) - elif is_ipython and 'get_ipython' in builtins: - completions = get_ipython().Completer.all_completions(text) + + if is_ipython and 'get_ipython' in builtins: + def filter_c(prefix, c): + if re.match('_+(i?[0-9]+)?$', c): + return False + elif c[0] == '%' and not re.match('[%a-zA-Z]+$', prefix): + return False + return True + + import IPython + try: + if IPython.version_info[0] >= 6: + from IPython.core.completer import provisionalcompleter + with provisionalcompleter(): + completions = [ + [c.text, c.start, c.end, c.type or '?', c.signature or ''] + for c in get_ipython().Completer.completions(text, len(text)) + if filter_c(text, c.text)] + else: + part, matches = get_ipython().Completer.complete(line_buffer=text) + completions = [text + m[len(part):] for m in matches if filter_c(text, m)] + except: + pass else: # Try to reuse current completer. completer = readline.get_completer() @@ -4285,7 +4319,7 @@ def __PYTHON_EL_get_completions(text): finally: if getattr(completer, 'PYTHON_EL_WRAPPED', False): completer.print_mode = True - return completions" + return json.dumps(completions)" "Code used to setup completion in inferior Python processes." :type 'string) @@ -4326,6 +4360,26 @@ When a match is found, native completion is disabled." :version "25.1" :type 'float) +(defvar python-shell-readline-completer-delims nil + "Word delimiters used by the readline completer. +It is automatically set by Python shell. An empty string means no +characters are considered delimiters and the readline completion +considers the entire line of input. A value of nil means the Python +shell has no readline support.") + +(defun python-shell-readline-detect () + "Detect the readline support for Python shell completion." + (let* ((process (python-shell-get-process)) + (output (python-shell-send-string-no-output " +try: + import readline + print(readline.get_completer_delims()) +except: + print('No readline support')" process))) + (setq-local python-shell-readline-completer-delims + (unless (string-search "No readline support" output) + (string-trim-right output))))) + (defvar python-shell-completion-native-redirect-buffer " *Python completions redirect*" "Buffer to be used to redirect output of readline commands.") @@ -4492,21 +4546,15 @@ With argument MSG show activation/deactivation message." (cond ((python-shell-completion-native-interpreter-disabled-p) (python-shell-completion-native-turn-off msg)) - ((python-shell-completion-native-setup) + ((and python-shell-readline-completer-delims + (python-shell-completion-native-setup)) (when msg (message "Shell native completion is enabled."))) - (t (lwarn - '(python python-shell-completion-native-turn-on-maybe) - :warning - (concat - "Your `python-shell-interpreter' doesn't seem to " - "support readline, yet `python-shell-completion-native-enable' " - (format "was t and %S is not part of the " - (file-name-nondirectory python-shell-interpreter)) - "`python-shell-completion-native-disabled-interpreters' " - "list. Native completions have been disabled locally. " - "Consider installing the python package \"readline\". ")) - (python-shell-completion-native-turn-off msg)))))) + (t + (when msg + (message (concat "Python does not use GNU readline;" + " no completion in multi-line commands."))) + (python-shell-completion-native-turn-off nil)))))) (defun python-shell-completion-native-turn-on-maybe-with-msg () "Like `python-shell-completion-native-turn-on-maybe' but force messages." @@ -4531,6 +4579,8 @@ With argument MSG show activation/deactivation message." (let* ((original-filter-fn (process-filter process)) (redirect-buffer (get-buffer-create python-shell-completion-native-redirect-buffer)) + (sep (if (string= python-shell-readline-completer-delims "") + "[\n\r]+" "[ \f\t\n\r\v()]+")) (trigger "\t") (new-input (concat input trigger)) (input-length @@ -4573,28 +4623,80 @@ With argument MSG show activation/deactivation message." process python-shell-completion-native-output-timeout comint-redirect-finished-regexp) (re-search-backward "0__dummy_completion__" nil t) - (cl-remove-duplicates - (split-string - (buffer-substring-no-properties - (line-beginning-position) (point-min)) - "[ \f\t\n\r\v()]+" t) - :test #'string=)))) + (let ((str (buffer-substring-no-properties + (line-beginning-position) (point-min)))) + ;; The readline completer is allowed to return a list + ;; of (text start end type signature) as a JSON + ;; string. See the return value for IPython in + ;; `python-shell-completion-setup-code'. + (if (string= "[" (substring str 0 1)) + (condition-case nil + (python--parse-json-array str) + (t (cl-remove-duplicates (split-string str sep t) + :test #'string=))) + (cl-remove-duplicates (split-string str sep t) + :test #'string=)))))) (set-process-filter process original-filter-fn))))) (defun python-shell-completion-get-completions (process input) "Get completions of INPUT using PROCESS." (with-current-buffer (process-buffer process) - (let ((completions - (python-util-strip-string - (python-shell-send-string-no-output - (format - "%s\nprint(';'.join(__PYTHON_EL_get_completions(%s)))" + (python--parse-json-array + (python-shell-send-string-no-output + (format "%s\nprint(__PYTHON_EL_get_completions(%s))" python-shell-completion-setup-code (python-shell--encode-string input)) - process)))) - (when (> (length completions) 2) - (split-string completions - "^'\\|^\"\\|;\\|'$\\|\"$" t))))) + process)))) + +(defun python-shell--get-multiline-input () + "Return lines at a multi-line input in Python shell." + (save-excursion + (let ((p (point)) lines) + (when (progn + (beginning-of-line) + (looking-back python-shell-prompt-block-regexp (pos-bol))) + (push (buffer-substring-no-properties (point) p) lines) + (while (progn (comint-previous-prompt 1) + (looking-back python-shell-prompt-block-regexp (pos-bol))) + (push (buffer-substring-no-properties (point) (pos-eol)) lines)) + (push (buffer-substring-no-properties (point) (pos-eol)) lines)) + lines))) + +(defun python-shell--extra-completion-context () + "Get extra completion context of current input in Python shell." + (let ((lines (python-shell--get-multiline-input)) + (python-indent-guess-indent-offset nil)) + (when (not (zerop (length lines))) + (with-temp-buffer + (delay-mode-hooks + (insert (string-join lines "\n")) + (python-mode) + (python-shell-completion-extra-context)))))) + +(defun python-shell-completion-extra-context (&optional pos) + "Get extra completion context at position POS in Python buffer. +If optional argument POS is nil, use current position. + +Readline completers could use current line as the completion +context, which may be insufficient. In this function, extra +context (e.g. multi-line function call) is found and reformatted +as one line, which is required by native completion." + (let (bound p) + (save-excursion + (and pos (goto-char pos)) + (setq bound (pos-bol)) + (python-nav-up-list -1) + (when (and (< (point) bound) + (or + (looking-back + (python-rx (group (+ (or "." symbol-name)))) (pos-bol) t) + (progn + (forward-line 0) + (looking-at "^[ \t]*\\(from \\)")))) + (setq p (match-beginning 1)))) + (when p + (replace-regexp-in-string + "\n[ \t]*" "" (buffer-substring-no-properties p (1- bound)))))) (defvar-local python-shell--capf-cache nil "Variable to store cached completions and invalidation keys.") @@ -4609,21 +4711,27 @@ using that one instead of current buffer's process." ;; Working on a shell buffer: use prompt end. (cdr (python-util-comint-last-prompt)) (line-beginning-position))) - (import-statement - (when (string-match-p - (rx (* space) word-start (or "from" "import") word-end space) - (buffer-substring-no-properties line-start (point))) - (buffer-substring-no-properties line-start (point)))) + (no-delims + (and (not (if is-shell-buffer + (eq 'font-lock-comment-face + (get-text-property (1- (point)) 'face)) + (python-syntax-context 'comment))) + (with-current-buffer (process-buffer process) + (if python-shell-completion-native-enable + (string= python-shell-readline-completer-delims "") + (or (string-match-p "ipython[23]?\\'" python-shell-interpreter) + (equal python-shell-readline-completer-delims "")))))) (start (if (< (point) line-start) (point) (save-excursion - (if (not (re-search-backward - (python-rx - (or whitespace open-paren close-paren - string-delimiter simple-operator)) - line-start - t 1)) + (if (or no-delims + (not (re-search-backward + (python-rx + (or whitespace open-paren close-paren + string-delimiter simple-operator)) + line-start + t 1))) line-start (forward-char (length (match-string-no-properties 0))) (point))))) @@ -4663,18 +4771,56 @@ using that one instead of current buffer's process." (t #'python-shell-completion-native-get-completions)))) (prev-prompt (car python-shell--capf-cache)) (re (or (cadr python-shell--capf-cache) regexp-unmatchable)) - (prefix (buffer-substring-no-properties start end))) + (prefix (buffer-substring-no-properties start end)) + (prefix-offset 0) + (extra-context (when no-delims + (if is-shell-buffer + (python-shell--extra-completion-context) + (python-shell-completion-extra-context)))) + (extra-offset (length extra-context))) + (unless (zerop extra-offset) + (setq prefix (concat extra-context prefix))) ;; To invalidate the cache, we check if the prompt position or the ;; completion prefix changed. (unless (and (equal prev-prompt (car prompt-boundaries)) - (string-match re prefix)) + (string-match re prefix) + (setq prefix-offset (- (length prefix) (match-end 1)))) (setq python-shell--capf-cache `(,(car prompt-boundaries) ,(if (string-empty-p prefix) regexp-unmatchable - (concat "\\`" (regexp-quote prefix) "\\(?:\\sw\\|\\s_\\)*\\'")) - ,@(funcall completion-fn process (or import-statement prefix))))) - (list start end (cddr python-shell--capf-cache)))) + (concat "\\`\\(" (regexp-quote prefix) "\\)\\(?:\\sw\\|\\s_\\)*\\'")) + ,@(funcall completion-fn process prefix)))) + (let ((cands (cddr python-shell--capf-cache))) + (cond + ((stringp (car cands)) + (if no-delims + ;; Reduce completion candidates due to long prefix. + (if-let ((Lp (length prefix)) + ((string-match "\\(\\sw\\|\\s_\\)+\\'" prefix)) + (L (match-beginning 0))) + ;; If extra-offset is not zero: + ;; start end + ;; o------------------o---------o-------o + ;; |<- extra-offset ->| + ;; |<----------- L ------------>| + ;; new-start + (list (+ start L (- extra-offset)) end + (mapcar (lambda (s) (substring s L)) cands)) + (list end end (mapcar (lambda (s) (substring s Lp)) cands))) + (list start end cands))) + ;; python-shell-completion(-native)-get-completions may produce a + ;; list of (text start end type signature) for completion. + ((consp (car cands)) + (list (+ start (nth 1 (car cands)) (- extra-offset)) + ;; Candidates may be cached, so the end position should + ;; be adjusted according to current completion prefix. + (+ start (nth 2 (car cands)) (- extra-offset) prefix-offset) + cands + :annotation-function + (lambda (c) (concat " " (nth 3 (assoc c cands)))) + :company-docsig + (lambda (c) (nth 4 (assoc c cands))))))))) (define-obsolete-function-alias 'python-shell-completion-complete-at-point @@ -6260,7 +6406,9 @@ point's current `syntax-ppss'." counter))) (python-util-forward-comment -1) (python-nav-beginning-of-statement) - (cond ((bobp)) + (cond ((and (bobp) (save-excursion + (python-util-forward-comment) + (looking-at-p re)))) ((python-info-assignment-statement-p) t) ((python-info-looking-at-beginning-of-defun)) (t nil)))))) @@ -6995,6 +7143,8 @@ implementations: `python-mode' and `python-ts-mode'." (add-to-list 'auto-mode-alist '("\\.py[iw]?\\'" . python-ts-mode)) (add-to-list 'interpreter-mode-alist '("python[0-9.]*" . python-ts-mode)))) +(derived-mode-add-parents 'python-ts-mode '(python-mode)) + ;;; Completion predicates for M-x ;; Commands that only make sense when editing Python code. (dolist (sym '(python-add-import diff --git a/lisp/progmodes/ruby-ts-mode.el b/lisp/progmodes/ruby-ts-mode.el index 598eaa461ff..7133cb0b5b0 100644 --- a/lisp/progmodes/ruby-ts-mode.el +++ b/lisp/progmodes/ruby-ts-mode.el @@ -1133,6 +1133,7 @@ leading double colon is not added." "singleton_class" "module" "method" + "singleton_method" "array" "hash" "parenthesized_statements" @@ -1178,6 +1179,19 @@ leading double colon is not added." ;; Imenu. (setq-local imenu-create-index-function #'ruby-ts--imenu) + ;; Outline minor mode. + (setq-local treesit-outline-predicate + (rx bos (or "singleton_method" + "method" + "alias" + "class" + "module") + eos)) + ;; Restore default values of outline variables + ;; to use `treesit-outline-predicate'. + (kill-local-variable 'outline-regexp) + (kill-local-variable 'outline-level) + (setq-local treesit-simple-indent-rules (ruby-ts--indent-rules)) ;; Font-lock. @@ -1196,19 +1210,11 @@ leading double colon is not added." (setq-local syntax-propertize-function #'ruby-ts--syntax-propertize)) +(derived-mode-add-parents 'ruby-ts-mode '(ruby-mode)) + (if (treesit-ready-p 'ruby) - ;; Copied from ruby-mode.el. - (add-to-list 'auto-mode-alist - (cons (concat "\\(?:\\.\\(?:" - "rbw?\\|ru\\|rake\\|thor" - "\\|jbuilder\\|rabl\\|gemspec\\|podspec" - "\\)" - "\\|/" - "\\(?:Gem\\|Rake\\|Cap\\|Thor" - "\\|Puppet\\|Berks\\|Brew" - "\\|Vagrant\\|Guard\\|Pod\\)file" - "\\)\\'") - 'ruby-ts-mode))) + (add-to-list 'major-mode-remap-defaults + '(ruby-mode . ruby-ts-mode))) (provide 'ruby-ts-mode) diff --git a/lisp/progmodes/rust-ts-mode.el b/lisp/progmodes/rust-ts-mode.el index c5fc57cc374..c67ac43e4d0 100644 --- a/lisp/progmodes/rust-ts-mode.el +++ b/lisp/progmodes/rust-ts-mode.el @@ -474,6 +474,8 @@ See `prettify-symbols-compose-predicate'." (treesit-major-mode-setup))) +(derived-mode-add-parents 'rust-ts-mode '(rust-mode)) + (if (treesit-ready-p 'rust) (add-to-list 'auto-mode-alist '("\\.rs\\'" . rust-ts-mode))) diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el index 0562415b4e5..ab95dc9f924 100644 --- a/lisp/progmodes/sh-script.el +++ b/lisp/progmodes/sh-script.el @@ -1054,7 +1054,8 @@ subshells can nest." ;; a normal command rather than the real `in' keyword. ;; I.e. we should look back to try and find the ;; corresponding `case'. - (and (looking-at ";\\(?:;&?\\|[&|]\\)\\|\\_<in") + ;; Also recognize OpenBSD's case X { ... } (bug#55764). + (and (looking-at ";\\(?:;&?\\|[&|]\\)\\|\\_<in\\|.{") ;; ";; esac )" is a case that looks ;; like a case-pattern but it's really just a close ;; paren after a case statement. I.e. if we skipped @@ -1638,6 +1639,8 @@ not written in Bash or sh." (setq-local treesit-defun-type-regexp "function_definition") (treesit-major-mode-setup))) +(derived-mode-add-parents 'bash-ts-mode '(sh-mode)) + (advice-add 'bash-ts-mode :around #'sh--redirect-bash-ts-mode ;; Give it lower precedence than normal advice, so other ;; advices take precedence over it. @@ -2057,9 +2060,9 @@ May return nil if the line should not be treated as continued." (sh-var-value 'sh-indent-for-case-label))) (`(:before . ,(or "(" "{" "[" "while" "if" "for" "case")) (cond - ((and (equal token "{") (smie-rule-parent-p "for")) + ((and (equal token "{") (smie-rule-parent-p "for" "case")) (let ((data (smie-backward-sexp "in"))) - (when (equal (nth 2 data) "for") + (when (member (nth 2 data) '("for" "case")) `(column . ,(smie-indent-virtual))))) ((not (smie-rule-prev-p "&&" "||" "|")) (when (smie-rule-hanging-p) @@ -2303,7 +2306,7 @@ 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., `\\[universal-argument]') don't insert any starting #! +(If given a prefix (i.e., \\[universal-argument]) don't insert any starting #! line.) When this function is called noninteractively, INSERT-FLAG (the third diff --git a/lisp/progmodes/typescript-ts-mode.el b/lisp/progmodes/typescript-ts-mode.el index e9c6afff440..ab1d76ab20e 100644 --- a/lisp/progmodes/typescript-ts-mode.el +++ b/lisp/progmodes/typescript-ts-mode.el @@ -124,6 +124,7 @@ Argument LANGUAGE is either `typescript' or `tsx'." ((parent-is "object_type") parent-bol typescript-ts-mode-indent-offset) ((parent-is "enum_body") parent-bol typescript-ts-mode-indent-offset) ((parent-is "class_body") parent-bol typescript-ts-mode-indent-offset) + ((parent-is "interface_body") parent-bol typescript-ts-mode-indent-offset) ((parent-is "arrow_function") parent-bol typescript-ts-mode-indent-offset) ((parent-is "parenthesized_expression") parent-bol typescript-ts-mode-indent-offset) ((parent-is "binary_expression") parent-bol typescript-ts-mode-indent-offset) @@ -199,183 +200,197 @@ Argument LANGUAGE is either `typescript' or `tsx'." [(nested_identifier (identifier)) (identifier)] @typescript-ts-jsx-tag-face))))) +(defun tsx-ts-mode--font-lock-compatibility-function-expression (language) + "Handle tree-sitter grammar breaking change for `function' expression. + +LANGUAGE can be `typescript' or `tsx'. Starting from version 0.20.4 of the +typescript/tsx grammar, `function' becomes `function_expression'." + (condition-case nil + (progn (treesit-query-capture language '((function_expression) @cap)) + ;; New version of the grammar + 'function_expression) + (treesit-query-error + ;; Old version of the grammar + 'function))) + (defun typescript-ts-mode--font-lock-settings (language) "Tree-sitter font-lock settings. Argument LANGUAGE is either `typescript' or `tsx'." - (treesit-font-lock-rules - :language language - :feature 'comment - `([(comment) (hash_bang_line)] @font-lock-comment-face) - - :language language - :feature 'constant - `(((identifier) @font-lock-constant-face - (:match "\\`[A-Z_][0-9A-Z_]*\\'" @font-lock-constant-face)) - [(true) (false) (null)] @font-lock-constant-face) - - :language language - :feature 'keyword - `([,@typescript-ts-mode--keywords] @font-lock-keyword-face - [(this) (super)] @font-lock-keyword-face) - - :language language - :feature 'string - `((regex pattern: (regex_pattern)) @font-lock-regexp-face - (string) @font-lock-string-face - (template_string) @js--fontify-template-string - (template_substitution ["${" "}"] @font-lock-misc-punctuation-face)) - - :language language - :override t ;; for functions assigned to variables - :feature 'declaration - `((function - name: (identifier) @font-lock-function-name-face) - (function_declaration - name: (identifier) @font-lock-function-name-face) - (function_signature - name: (identifier) @font-lock-function-name-face) - - (method_definition - name: (property_identifier) @font-lock-function-name-face) - (method_signature - name: (property_identifier) @font-lock-function-name-face) - (required_parameter (identifier) @font-lock-variable-name-face) - (optional_parameter (identifier) @font-lock-variable-name-face) - - (variable_declarator - name: (identifier) @font-lock-function-name-face - value: [(function) (arrow_function)]) - - (variable_declarator - name: (identifier) @font-lock-variable-name-face) - - (enum_declaration (identifier) @font-lock-type-face) - - (extends_clause value: (identifier) @font-lock-type-face) - ;; extends React.Component<T> - (extends_clause value: (member_expression - object: (identifier) @font-lock-type-face - property: (property_identifier) @font-lock-type-face)) - - (arrow_function - parameter: (identifier) @font-lock-variable-name-face) - - (variable_declarator - name: (array_pattern - (identifier) - (identifier) @font-lock-function-name-face) - value: (array (number) (function))) - - (catch_clause - parameter: (identifier) @font-lock-variable-name-face) - - ;; full module imports - (import_clause (identifier) @font-lock-variable-name-face) - ;; named imports with aliasing - (import_clause (named_imports (import_specifier - alias: (identifier) @font-lock-variable-name-face))) - ;; named imports without aliasing - (import_clause (named_imports (import_specifier - !alias - name: (identifier) @font-lock-variable-name-face))) - - ;; full namespace import (* as alias) - (import_clause (namespace_import (identifier) @font-lock-variable-name-face))) - - :language language - :feature 'identifier - `((nested_type_identifier - module: (identifier) @font-lock-type-face) - - (type_identifier) @font-lock-type-face - - (predefined_type) @font-lock-type-face - - (new_expression - constructor: (identifier) @font-lock-type-face) - - (enum_body (property_identifier) @font-lock-type-face) - - (enum_assignment name: (property_identifier) @font-lock-type-face) - - (variable_declarator - name: (identifier) @font-lock-variable-name-face) - - (for_in_statement - left: (identifier) @font-lock-variable-name-face) - - (arrow_function - parameters: - [(_ (identifier) @font-lock-variable-name-face) - (_ (_ (identifier) @font-lock-variable-name-face)) - (_ (_ (_ (identifier) @font-lock-variable-name-face)))])) - - :language language - :feature 'property - `((property_signature - name: (property_identifier) @font-lock-property-name-face) - (public_field_definition - name: (property_identifier) @font-lock-property-name-face) - - (pair key: (property_identifier) @font-lock-property-use-face) - - ((shorthand_property_identifier) @font-lock-property-use-face)) - - :language language - :feature 'expression - '((assignment_expression - left: [(identifier) @font-lock-function-name-face - (member_expression - property: (property_identifier) @font-lock-function-name-face)] - right: [(function) (arrow_function)])) - - :language language - :feature 'function - '((call_expression - function: - [(identifier) @font-lock-function-call-face - (member_expression - property: (property_identifier) @font-lock-function-call-face)])) - - :language language - :feature 'pattern - `((pair_pattern - key: (property_identifier) @font-lock-property-use-face - value: [(identifier) @font-lock-variable-name-face - (assignment_pattern left: (identifier) @font-lock-variable-name-face)]) - - (array_pattern (identifier) @font-lock-variable-name-face) - - ((shorthand_property_identifier_pattern) @font-lock-variable-name-face)) - - :language language - :feature 'jsx - (append (tsx-ts-mode--font-lock-compatibility-bb1f97b language) - `((jsx_attribute (property_identifier) @typescript-ts-jsx-attribute-face))) - - :language language - :feature 'number - `((number) @font-lock-number-face - ((identifier) @font-lock-number-face - (:match "\\`\\(?:NaN\\|Infinity\\)\\'" @font-lock-number-face))) - - :language language - :feature 'operator - `([,@typescript-ts-mode--operators] @font-lock-operator-face - (ternary_expression ["?" ":"] @font-lock-operator-face)) - - :language language - :feature 'bracket - '((["(" ")" "[" "]" "{" "}"]) @font-lock-bracket-face) - - :language language - :feature 'delimiter - '((["," "." ";" ":"]) @font-lock-delimiter-face) - - :language language - :feature 'escape-sequence - :override t - '((escape_sequence) @font-lock-escape-face))) + (let ((func-exp (tsx-ts-mode--font-lock-compatibility-function-expression language))) + (treesit-font-lock-rules + :language language + :feature 'comment + `([(comment) (hash_bang_line)] @font-lock-comment-face) + + :language language + :feature 'constant + `(((identifier) @font-lock-constant-face + (:match "\\`[A-Z_][0-9A-Z_]*\\'" @font-lock-constant-face)) + [(true) (false) (null)] @font-lock-constant-face) + + :language language + :feature 'keyword + `([,@typescript-ts-mode--keywords] @font-lock-keyword-face + [(this) (super)] @font-lock-keyword-face) + + :language language + :feature 'string + `((regex pattern: (regex_pattern)) @font-lock-regexp-face + (string) @font-lock-string-face + (template_string) @js--fontify-template-string + (template_substitution ["${" "}"] @font-lock-misc-punctuation-face)) + + :language language + :override t ;; for functions assigned to variables + :feature 'declaration + `((,func-exp + name: (identifier) @font-lock-function-name-face) + (function_declaration + name: (identifier) @font-lock-function-name-face) + (function_signature + name: (identifier) @font-lock-function-name-face) + + (method_definition + name: (property_identifier) @font-lock-function-name-face) + (method_signature + name: (property_identifier) @font-lock-function-name-face) + (required_parameter (identifier) @font-lock-variable-name-face) + (optional_parameter (identifier) @font-lock-variable-name-face) + + (variable_declarator + name: (identifier) @font-lock-function-name-face + value: [(,func-exp) (arrow_function)]) + + (variable_declarator + name: (identifier) @font-lock-variable-name-face) + + (enum_declaration (identifier) @font-lock-type-face) + + (extends_clause value: (identifier) @font-lock-type-face) + ;; extends React.Component<T> + (extends_clause value: (member_expression + object: (identifier) @font-lock-type-face + property: (property_identifier) @font-lock-type-face)) + + (arrow_function + parameter: (identifier) @font-lock-variable-name-face) + + (variable_declarator + name: (array_pattern + (identifier) + (identifier) @font-lock-function-name-face) + value: (array (number) (,func-exp))) + + (catch_clause + parameter: (identifier) @font-lock-variable-name-face) + + ;; full module imports + (import_clause (identifier) @font-lock-variable-name-face) + ;; named imports with aliasing + (import_clause (named_imports (import_specifier + alias: (identifier) @font-lock-variable-name-face))) + ;; named imports without aliasing + (import_clause (named_imports (import_specifier + !alias + name: (identifier) @font-lock-variable-name-face))) + + ;; full namespace import (* as alias) + (import_clause (namespace_import (identifier) @font-lock-variable-name-face))) + + :language language + :feature 'identifier + `((nested_type_identifier + module: (identifier) @font-lock-type-face) + + (type_identifier) @font-lock-type-face + + (predefined_type) @font-lock-type-face + + (new_expression + constructor: (identifier) @font-lock-type-face) + + (enum_body (property_identifier) @font-lock-type-face) + + (enum_assignment name: (property_identifier) @font-lock-type-face) + + (variable_declarator + name: (identifier) @font-lock-variable-name-face) + + (for_in_statement + left: (identifier) @font-lock-variable-name-face) + + (arrow_function + parameters: + [(_ (identifier) @font-lock-variable-name-face) + (_ (_ (identifier) @font-lock-variable-name-face)) + (_ (_ (_ (identifier) @font-lock-variable-name-face)))])) + + :language language + :feature 'property + `((property_signature + name: (property_identifier) @font-lock-property-name-face) + (public_field_definition + name: (property_identifier) @font-lock-property-name-face) + + (pair key: (property_identifier) @font-lock-property-use-face) + + ((shorthand_property_identifier) @font-lock-property-use-face)) + + :language language + :feature 'expression + `((assignment_expression + left: [(identifier) @font-lock-function-name-face + (member_expression + property: (property_identifier) @font-lock-function-name-face)] + right: [(,func-exp) (arrow_function)])) + + :language language + :feature 'function + '((call_expression + function: + [(identifier) @font-lock-function-call-face + (member_expression + property: (property_identifier) @font-lock-function-call-face)])) + + :language language + :feature 'pattern + `((pair_pattern + key: (property_identifier) @font-lock-property-use-face + value: [(identifier) @font-lock-variable-name-face + (assignment_pattern left: (identifier) @font-lock-variable-name-face)]) + + (array_pattern (identifier) @font-lock-variable-name-face) + + ((shorthand_property_identifier_pattern) @font-lock-variable-name-face)) + + :language language + :feature 'jsx + (append (tsx-ts-mode--font-lock-compatibility-bb1f97b language) + `((jsx_attribute (property_identifier) @typescript-ts-jsx-attribute-face))) + + :language language + :feature 'number + `((number) @font-lock-number-face + ((identifier) @font-lock-number-face + (:match "\\`\\(?:NaN\\|Infinity\\)\\'" @font-lock-number-face))) + + :language language + :feature 'operator + `([,@typescript-ts-mode--operators] @font-lock-operator-face + (ternary_expression ["?" ":"] @font-lock-operator-face)) + + :language language + :feature 'bracket + '((["(" ")" "[" "]" "{" "}"]) @font-lock-bracket-face) + + :language language + :feature 'delimiter + '((["," "." ";" ":"]) @font-lock-delimiter-face) + + :language language + :feature 'escape-sequence + :override t + '((escape_sequence) @font-lock-escape-face)))) (defvar typescript-ts-mode--sentence-nodes '("import_statement" @@ -491,6 +506,8 @@ This mode is intended to be inherited by concrete major modes." (treesit-major-mode-setup))) +(derived-mode-add-parents 'typescript-ts-mode '(typescript-mode)) + (if (treesit-ready-p 'typescript) (add-to-list 'auto-mode-alist '("\\.ts\\'" . typescript-ts-mode))) @@ -548,6 +565,8 @@ at least 3 (which is the default value)." (treesit-major-mode-setup))) +(derived-mode-add-parents 'tsx-ts-mode '(tsx-mode)) + (defvar typescript-ts--s-p-query (when (treesit-available-p) (treesit-query-compile 'typescript diff --git a/lisp/progmodes/verilog-mode.el b/lisp/progmodes/verilog-mode.el index 6081372af33..a83bad0e8ed 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: 2023.06.06.141322628 +;; Version: 2024.03.01.121933719 ;; 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 "2023-06-06-86c6984-vpo-GNU" +(defconst verilog-mode-version "2024-03-01-7448f97-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.") @@ -2556,11 +2556,13 @@ find the errors." (defconst verilog-assignment-operation-re-2 (concat "\\(.*?\\)" verilog-assignment-operator-re)) +;; Loosely related to IEEE 1800's concurrent_assertion_statement +(defconst verilog-concurrent-assertion-statement-re + "\\(\\<\\(assert\\|assume\\|cover\\|restrict\\)\\>\\s-+\\<\\(property\\|sequence\\)\\>\\)\\|\\(\\<assert\\>\\)") + (defconst verilog-label-re (concat verilog-identifier-sym-re "\\s-*:\\s-*")) (defconst verilog-property-re - (concat "\\(" verilog-label-re "\\)?" - ;; "\\(assert\\|assume\\|cover\\)\\s-+property\\>" - "\\(\\(assert\\|assume\\|cover\\)\\>\\s-+\\<property\\>\\)\\|\\(assert\\)")) + (concat "\\(" verilog-label-re "\\)?" verilog-concurrent-assertion-statement-re)) (defconst verilog-no-indent-begin-re (eval-when-compile @@ -2715,7 +2717,6 @@ find the errors." "\\(\\<fork\\>\\)\\|" ; 7 "\\(\\<if\\>\\)\\|" verilog-property-re "\\|" - "\\(\\(" verilog-label-re "\\)?\\<assert\\>\\)\\|" "\\(\\<clocking\\>\\)\\|" "\\(\\<task\\>\\)\\|" "\\(\\<function\\>\\)\\|" @@ -4843,7 +4844,7 @@ Uses `verilog-scan' cache." (not (or (looking-at "\\<") (forward-word-strictly -1))) ;; stop if we see an assertion (perhaps labeled) (and - (looking-at "\\(\\w+\\W*:\\W*\\)?\\(\\<\\(assert\\|assume\\|cover\\)\\>\\s-+\\<property\\>\\)\\|\\(\\<assert\\>\\)") + (looking-at (concat "\\(\\w+\\W*:\\W*\\)?" verilog-concurrent-assertion-statement-re)) (progn (setq h (point)) (save-excursion @@ -4970,7 +4971,7 @@ More specifically, point @ in the line foo : @ begin" (while t (verilog-re-search-backward (concat "\\(\\<module\\>\\)\\|\\(\\<connectmodule\\>\\)\\|\\(\\<randcase\\>\\|\\<case[xz]?\\>[^:]\\)\\|" - "\\(\\<endcase\\>\\)\\>") + "\\(\\<endcase\\>\\)") nil 'move) (cond ((match-end 4) @@ -5010,7 +5011,7 @@ More specifically, after a generate and before an endgenerate." (while (and (/= nest 0) (verilog-re-search-backward - "\\<\\(module\\)\\|\\(connectmodule\\)\\|\\(endmodule\\)\\|\\(generate\\)\\|\\(endgenerate\\)\\|\\(if\\)\\|\\(case\\)\\|\\(for\\)\\>" nil 'move) + "\\<\\(?:\\(module\\)\\|\\(connectmodule\\)\\|\\(endmodule\\)\\|\\(generate\\)\\|\\(endgenerate\\)\\|\\(if\\)\\|\\(case\\)\\|\\(for\\)\\)\\>" nil 'move) (cond ((match-end 1) ; module - we have crawled out (throw 'done 1)) @@ -5038,7 +5039,7 @@ More specifically, after a generate and before an endgenerate." (save-excursion (while (and (/= nest 0) - (verilog-re-search-backward "\\<\\(fork\\)\\|\\(join\\(_any\\|_none\\)?\\)\\>" lim 'move) + (verilog-re-search-backward "\\<\\(?:\\(fork\\)\\|\\(join\\(_any\\|_none\\)?\\)\\)\\>" lim 'move) (cond ((match-end 1) ; fork (setq nest (1- nest))) @@ -5335,7 +5336,7 @@ primitive or interface named NAME." (match-end 3) (goto-char there) (let ((nest 0) - (reg "\\(\\<begin\\>\\)\\|\\(\\<end\\>\\)\\|\\(\\<if\\>\\)\\|\\(assert\\)")) + (reg "\\(\\<begin\\>\\)\\|\\(\\<end\\>\\)\\|\\(\\<if\\>\\)\\|\\(\\<assert\\>\\)")) (catch 'skip (while (verilog-re-search-backward reg nil 'move) (cond @@ -5802,7 +5803,7 @@ FILENAME to find directory to run in, or defaults to `buffer-file-name'." (dir (file-name-directory (or filename buffer-file-name))) (cmd (concat "cd " dir "; " command))) (with-output-to-temp-buffer "*Verilog-Preprocessed*" - (with-current-buffer (get-buffer "*Verilog-Preprocessed*") + (with-current-buffer "*Verilog-Preprocessed*" (insert (concat "// " cmd "\n")) (call-process shell-file-name nil t nil shell-command-switch cmd) (verilog-mode) @@ -6244,7 +6245,7 @@ Return a list of two elements: (INDENT-TYPE INDENT-LEVEL)." (match-end 22)) (throw 'continue 'foo)) - ((looking-at "\\<class\\|struct\\|function\\|task\\>") + ((looking-at "\\<\\(?:class\\|struct\\|function\\|task\\)\\>") ;; *sigh* These words have an optional prefix: ;; extern {virtual|protected}? function a(); ;; and we don't want to confuse this with @@ -6268,12 +6269,16 @@ Return a list of two elements: (INDENT-TYPE INDENT-LEVEL)." (throw 'nesting 'defun)))) ;; - ((looking-at "\\<property\\>") + ((looking-at "\\<\\(property\\|sequence\\)\\>") ;; *sigh* - ;; {assert|assume|cover} property (); are complete - ;; and could also be labeled: - foo: assert property - ;; but - ;; property ID () ... needs endproperty + ;; - {assert|assume|cover|restrict} property (); are complete + ;; - cover sequence (); is complete + ;; and could also be labeled: + ;; - foo: assert property + ;; - bar: cover sequence + ;; but: + ;; - property ID () ... needs endproperty + ;; - sequence ID () ... needs endsequence (verilog-beg-of-statement) (if (looking-at verilog-property-re) (throw 'continue 'statement) ; We don't need an endproperty for these @@ -6940,7 +6945,7 @@ Also move point to constraint." (let ( (pt (point)) (pass 0)) (verilog-backward-ws&directives) (verilog-backward-token) - (if (looking-at (concat "\\<constraint\\|coverpoint\\|cross\\|with\\>\\|" verilog-in-constraint-re)) + (if (looking-at (concat "\\<\\(?:constraint\\|coverpoint\\|cross\\|with\\)\\>\\|" verilog-in-constraint-re)) (progn (setq pass 1) (if (looking-at "\\<with\\>") (progn (verilog-backward-ws&directives) @@ -6981,7 +6986,7 @@ Also move point to constraint." (save-excursion (if (and (equal (char-after) ?\{) (verilog-backward-token)) - (looking-at "\\<struct\\|union\\|packed\\|\\(un\\)?signed\\>") + (looking-at "\\<\\(?:struct\\|union\\|packed\\|\\(un\\)?signed\\)\\>") nil))) (defun verilog-at-struct-mv-p () @@ -6989,7 +6994,7 @@ Also move point to constraint." (let ((pt (point))) (if (and (equal (char-after) ?\{) (verilog-backward-token)) - (if (looking-at "\\<struct\\|union\\|packed\\|\\(un\\)?signed\\>") + (if (looking-at "\\<\\(?:struct\\|union\\|packed\\|\\(un\\)?signed\\)\\>") (progn (verilog-beg-of-statement) (point)) (progn (goto-char pt) nil)) (progn (goto-char pt) nil)))) @@ -9675,7 +9680,7 @@ Return an array of [outputs inouts inputs wire reg assign const gparam intf]." (cond ;; {..., a, b} requires us to recurse on a,b ;; To support {#{},{#{a,b}} we'll just split everything on [{},] - ((string-match "^\\s-*{\\(.*\\)}\\s-*$" expr) + ((string-match "^\\s-*'?{\\(.*\\)}\\s-*$" expr) (let ((mlst (split-string (match-string 1 expr) "[{},]")) mstr) (while (setq mstr (pop mlst)) @@ -9755,7 +9760,10 @@ Inserts the list of signals found, using submodi to look up each port." ;; We intentionally ignore (non-escaped) signals with .s in them ;; this prevents AUTOWIRE etc from noticing hierarchical sigs. (when port - (cond ((looking-at "[^\n]*AUTONOHOOKUP")) + (cond ((and verilog-auto-ignore-concat + (looking-at "[({]")) + nil) ; {...} or (...) historically ignored with auto-ignore-concat + ((looking-at "[^\n]*AUTONOHOOKUP")) ((looking-at "\\([a-zA-Z_][a-zA-Z_0-9]*\\)\\s-*)") (verilog-read-sub-decls-sig submoddecls par-values comment port @@ -11436,7 +11444,7 @@ This repairs those mis-inserted by an AUTOARG." (while (string-match (concat "\\([[({:*/<>+-]\\)" ; - must be last "(\\<\\([0-9A-Za-z_]+\\))" - "\\([])}:*/<>+-]\\)") + "\\([])}:*/<>.+-]\\)") out) (setq out (replace-match "\\1\\2\\3" nil nil out))) (while (string-match @@ -11531,7 +11539,8 @@ This repairs those mis-inserted by an AUTOARG." ;;(verilog-simplify-range-expression "[(TEST[1])-1:0]") ;;(verilog-simplify-range-expression "[1<<2:8>>2]") ; [4:2] ;;(verilog-simplify-range-expression "[2*4/(4-2) +2+4 <<4 >>2]") -;;(verilog-simplify-range-expression "[WIDTH*2/8-1:0]") +;;(verilog-simplify-range-expression "[WIDTH*2/8-1:0]") ; "[WIDTH*2/8-1:0]" +;;(verilog-simplify-range-expression "[(FOO).size:0]") ; "[FOO.size:0]" (defun verilog-clog2 (value) "Compute $clog2 - ceiling log2 of VALUE." @@ -12247,18 +12256,12 @@ If PAR-VALUES replace final strings with these parameter values." (vl-memory (verilog-sig-memory port-st)) (vl-mbits (if (verilog-sig-multidim port-st) (verilog-sig-multidim-string port-st) "")) - (vl-bits (if (or (eq verilog-auto-inst-vector t) - (and (eq verilog-auto-inst-vector `unsigned) - (not (verilog-sig-signed port-st))) - (not (assoc port (verilog-decls-get-signals moddecls))) - (not (equal (verilog-sig-bits port-st) - (verilog-sig-bits - (assoc port (verilog-decls-get-signals moddecls)))))) - (or (verilog-sig-bits port-st) "") - "")) + (vl-bits (or (verilog-sig-bits port-st) "")) (case-fold-search nil) (check-values par-values) - tpl-net dflt-bits) + auto-inst-vector + auto-inst-vector-tpl + tpl-net dflt-bits) ;; Replace parameters in bit-width (when (and check-values (not (equal vl-bits ""))) @@ -12281,6 +12284,16 @@ If PAR-VALUES replace final strings with these parameter values." vl-mbits (verilog-simplify-range-expression vl-mbits) vl-memory (when vl-memory (verilog-simplify-range-expression vl-memory)) vl-width (verilog-make-width-expression vl-bits))) ; Not in the loop for speed + (setq auto-inst-vector + (if (or (eq verilog-auto-inst-vector t) + (and (eq verilog-auto-inst-vector `unsigned) + (not (verilog-sig-signed port-st))) + (not (assoc port (verilog-decls-get-signals moddecls))) + (not (equal (verilog-sig-bits port-st) + (verilog-sig-bits + (assoc port (verilog-decls-get-signals moddecls)))))) + vl-bits + "")) ;; Default net value if not found (setq dflt-bits (if (or (and (verilog-sig-bits port-st) (verilog-sig-multidim port-st)) @@ -12290,7 +12303,7 @@ If PAR-VALUES replace final strings with these parameter values." (if vl-memory "." "") (if vl-memory vl-memory "") "*/") - (concat vl-bits)) + (concat auto-inst-vector)) tpl-net (concat port (if (and vl-modport ;; .modport cannot be added if attachment is @@ -12329,10 +12342,21 @@ If PAR-VALUES replace final strings with these parameter values." (if (numberp value) (setq value (number-to-string value))) value)) (substring tpl-net (match-end 0)))))) + ;; Get range based off template net + (setq auto-inst-vector-tpl + (if (or (eq verilog-auto-inst-vector t) + (and (eq verilog-auto-inst-vector `unsigned) + (not (verilog-sig-signed port-st))) + (not (assoc tpl-net (verilog-decls-get-signals moddecls))) + (not (equal (verilog-sig-bits port-st) + (verilog-sig-bits + (assoc tpl-net (verilog-decls-get-signals moddecls)))))) + vl-bits + "")) ;; Replace @ and [] magic variables in final output (setq tpl-net (verilog-string-replace-matches "@" tpl-num nil nil tpl-net)) (setq tpl-net (verilog-string-replace-matches "\\[\\]\\[\\]" dflt-bits nil nil tpl-net)) - (setq tpl-net (verilog-string-replace-matches "\\[\\]" vl-bits nil nil tpl-net))) + (setq tpl-net (verilog-string-replace-matches "\\[\\]" auto-inst-vector-tpl nil nil tpl-net))) ;; Insert it (when (or tpl-ass (not verilog-auto-inst-template-required)) (verilog--auto-inst-first indent-pt section) @@ -12502,7 +12526,7 @@ Typing \\[verilog-auto] will make this into: endmodule Where the list of inputs and outputs came from the inst module. - + Exceptions: Unless you are instantiating a module multiple times, or the module is @@ -12527,7 +12551,7 @@ Exceptions: // Outputs .o (o[31:0])); - + Templates: For multiple instantiations based upon a single template, create a @@ -12598,7 +12622,7 @@ Templates: .ptl_bus (ptl_busnew[3:0]), .... - + Multiple Module Templates: The same template lines can be applied to multiple modules with @@ -12613,7 +12637,7 @@ Multiple Module Templates: */ Note there is only one AUTO_TEMPLATE opening parenthesis. - + @ Templates: It is common to instantiate a cell multiple times, so templates make it @@ -12678,7 +12702,7 @@ Multiple Module Templates: .ptl_mapvalidx (BAR_ptl_mapvalid), .ptl_mapvalidp1x (ptl_mapvalid_BAR)); - + Regexp Templates: A template entry of the form @@ -12702,7 +12726,7 @@ Regexp Templates: subscript: .\\(.*\\)_l (\\1_[]), - + Lisp Templates: First any regular expression template is expanded. @@ -12747,7 +12771,7 @@ Lisp Templates: After the evaluation is completed, @ substitution and [] substitution occur. - + Ignoring Hookup: AUTOWIRE and related AUTOs will read the signals created by a template. @@ -12756,7 +12780,7 @@ Ignoring Hookup: .pci_req_l (pci_req_not_to_wire), //AUTONOHOOKUP - + For more information see the \\[verilog-faq] and forums at URL `https://www.veripool.org'." (save-excursion @@ -12910,7 +12934,7 @@ Typing \\[verilog-auto] will make this into: endmodule Where the list of parameter connections come from the inst module. - + Templates: You can customize the parameter connections using AUTO_TEMPLATEs, diff --git a/lisp/progmodes/vhdl-mode.el b/lisp/progmodes/vhdl-mode.el index 060880d7cf2..144bfa944d3 100644 --- a/lisp/progmodes/vhdl-mode.el +++ b/lisp/progmodes/vhdl-mode.el @@ -457,7 +457,7 @@ If no file name at all is printed out, set both \"File Message\" entries to 0 \(a default file name message will be printed out instead, does not work in XEmacs). -A compiler is selected for syntax analysis (`\\[vhdl-compile]') by +A compiler is selected for syntax analysis (\\[vhdl-compile]) by assigning its name to option `vhdl-compiler'. Please send any missing or erroneous compiler properties to the maintainer for @@ -1106,14 +1106,14 @@ For more information on format strings, see the documentation for the (defcustom vhdl-modify-date-prefix-string "-- Last update: " "Prefix string of modification date in VHDL file header. If actualization of the modification date is called (menu, -`\\[vhdl-template-modify]'), this string is searched and the rest +\\[vhdl-template-modify]), this string is searched and the rest of the line replaced by the current date." :type 'string :group 'vhdl-header) (defcustom vhdl-modify-date-on-saving t "Non-nil means update the modification date when the buffer is saved. -Calls function `\\[vhdl-template-modify]'). +Calls function \\[vhdl-template-modify]). NOTE: Activate the new setting in a VHDL buffer by using the menu entry \"Activate Options\"." @@ -4469,7 +4469,7 @@ Usage: according to option `vhdl-argument-list-indent'. If option `vhdl-indent-tabs-mode' is nil, spaces are used instead of - tabs. `\\[tabify]' and `\\[untabify]' allow the conversion of spaces to + tabs. \\[tabify] and \\[untabify] allow the conversion of spaces to tabs and vice versa. Syntax-based indentation can be very slow in large files. Option @@ -4780,7 +4780,7 @@ Usage: `vhdl-highlight-translate-off' is non-nil. For documentation and customization of the used colors see - customization group `vhdl-highlight-faces' (`\\[customize-group]'). For + customization group `vhdl-highlight-faces' (\\[customize-group]). For highlighting of matching parenthesis, see customization group `paren-showing'. Automatic buffer highlighting is turned on/off by option `global-font-lock-mode' (`font-lock-auto-fontify' in XEmacs). @@ -4840,14 +4840,14 @@ Usage: sessions using the \"Save Options\" menu entry. Options and their detailed descriptions can also be accessed by using - the \"Customize\" menu entry or the command `\\[customize-option]' - (`\\[customize-group]' for groups). Some customizations only take effect + the \"Customize\" menu entry or the command \\[customize-option] + (\\[customize-group] for groups). Some customizations only take effect after some action (read the NOTE in the option documentation). Customization can also be done globally (i.e. site-wide, read the INSTALL file). Not all options are described in this documentation, so go and see - what other useful user options there are (`\\[vhdl-customize]' or menu)! + what other useful user options there are (\\[vhdl-customize] or menu)! FILE EXTENSIONS: @@ -4876,7 +4876,7 @@ Usage: Maintenance: ------------ -To submit a bug report, enter `\\[vhdl-submit-bug-report]' within VHDL Mode. +To submit a bug report, enter \\[vhdl-submit-bug-report] within VHDL Mode. Add a description of the problem and include a reproducible test case. Questions and enhancement requests can be sent to <reto@gnu.org>. @@ -8398,6 +8398,44 @@ buffer." (message "Updating sensitivity lists...done"))) (when noninteractive (save-buffer))) +(defun vhdl--re2-region (beg-re end-re) + "Return a function searching for a region delimited by a pair of regexps. +BEG-RE and END-RE are the regexps delimiting the region to search for." + (lambda (proc-end) + (when (vhdl-re-search-forward beg-re proc-end t) + (save-excursion + (vhdl-re-search-forward end-re proc-end t))))) + +(defconst vhdl--signal-regions-functions + (list + ;; right-hand side of signal/variable assignment + ;; (special case: "<=" is relational operator in a condition) + (vhdl--re2-region "[<:]=" + ";\\|\\<\\(then\\|loop\\|report\\|severity\\|is\\)\\>") + ;; if condition + (vhdl--re2-region "^\\s-*if\\>" "\\<then\\>") + ;; elsif condition + (vhdl--re2-region "\\<elsif\\>" "\\<then\\>") + ;; while loop condition + (vhdl--re2-region "^\\s-*while\\>" "\\<loop\\>") + ;; exit/next condition + (vhdl--re2-region "\\<\\(exit\\|next\\)\\s-+\\w+\\s-+when\\>" ";") + ;; assert condition + (vhdl--re2-region "\\<assert\\>" "\\(\\<report\\>\\|\\<severity\\>\\|;\\)") + ;; case expression + (vhdl--re2-region "^\\s-*case\\>" "\\<is\\>") + ;; parameter list of procedure call, array index + (lambda (proc-end) + (when (re-search-forward "^\\s-*\\(\\w\\|\\.\\)+[ \t\n\r\f]*(" proc-end t) + (forward-char -1) + (save-excursion + (forward-sexp) + (while (looking-at "(") (forward-sexp)) (point))))) + "Define syntactic regions where signals are read. +Each function is called with one arg (a limit for the (forward) search) and +should return either nil or the end position of the region (in which case +point will be set to its beginning).") + (defun vhdl-update-sensitivity-list () "Update sensitivity list." (let ((proc-beg (point)) @@ -8418,35 +8456,6 @@ buffer." (let ;; scan for visible signals ((visible-list (vhdl-get-visible-signals)) - ;; define syntactic regions where signals are read - (scan-regions-list - `(;; right-hand side of signal/variable assignment - ;; (special case: "<=" is relational operator in a condition) - ((vhdl-re-search-forward "[<:]=" ,proc-end t) - (vhdl-re-search-forward ";\\|\\<\\(then\\|loop\\|report\\|severity\\|is\\)\\>" ,proc-end t)) - ;; if condition - ((vhdl-re-search-forward "^\\s-*if\\>" ,proc-end t) - (vhdl-re-search-forward "\\<then\\>" ,proc-end t)) - ;; elsif condition - ((vhdl-re-search-forward "\\<elsif\\>" ,proc-end t) - (vhdl-re-search-forward "\\<then\\>" ,proc-end t)) - ;; while loop condition - ((vhdl-re-search-forward "^\\s-*while\\>" ,proc-end t) - (vhdl-re-search-forward "\\<loop\\>" ,proc-end t)) - ;; exit/next condition - ((vhdl-re-search-forward "\\<\\(exit\\|next\\)\\s-+\\w+\\s-+when\\>" ,proc-end t) - (vhdl-re-search-forward ";" ,proc-end t)) - ;; assert condition - ((vhdl-re-search-forward "\\<assert\\>" ,proc-end t) - (vhdl-re-search-forward "\\(\\<report\\>\\|\\<severity\\>\\|;\\)" ,proc-end t)) - ;; case expression - ((vhdl-re-search-forward "^\\s-*case\\>" ,proc-end t) - (vhdl-re-search-forward "\\<is\\>" ,proc-end t)) - ;; parameter list of procedure call, array index - ((and (re-search-forward "^\\s-*\\(\\w\\|\\.\\)+[ \t\n\r\f]*(" ,proc-end t) - (1- (point))) - (progn (backward-char) (forward-sexp) - (while (looking-at "(") (forward-sexp)) (point))))) name field read-list sens-list signal-list tmp-list sens-beg sens-end beg end margin) ;; scan for signals in old sensitivity list @@ -8475,11 +8484,9 @@ buffer." (push (cons end (point)) seq-region-list) (beginning-of-line))) ;; scan for signals read in process - (while scan-regions-list + (dolist (scan-fun vhdl--signal-regions-functions) (goto-char proc-mid) - (while (and (setq beg (eval (nth 0 (car scan-regions-list)))) - (setq end (eval (nth 1 (car scan-regions-list))))) - (goto-char beg) + (while (setq end (funcall scan-fun proc-end)) (unless (or (vhdl-in-literal) (and seq-region-list (let ((tmp-list seq-region-list)) @@ -8518,8 +8525,7 @@ buffer." (car tmp-list)) (setq read-list (delete (car tmp-list) read-list))) (setq tmp-list (cdr tmp-list))))) - (goto-char (match-end 1))))) - (setq scan-regions-list (cdr scan-regions-list))) + (goto-char (match-end 1)))))) ;; update sensitivity list (goto-char sens-beg) (if sens-end @@ -14978,9 +14984,9 @@ otherwise use cached data." (vhdl-aput 'vhdl-directory-alist directory (list (list directory)))) (defun vhdl-speedbar-insert-hierarchy ( ent-alist-arg conf-alist-arg - package-alist ent-inst-list depth) - "Insert hierarchy of ENT-ALIST-ARG, CONF-ALIST-ARG, and PACKAGE-ALIST." - (if (not (or ent-alist-arg conf-alist-arg package-alist)) + pkg-alist ent-inst-list depth) + "Insert hierarchy of ENT-ALIST-ARG, CONF-ALIST-ARG, and PKG-ALIST." + (if (not (or ent-alist-arg conf-alist-arg pkg-alist)) (vhdl-speedbar-make-title-line "No VHDL design units!" depth) (let ((ent-alist ent-alist-arg) (conf-alist conf-alist-arg) @@ -15010,15 +15016,15 @@ otherwise use cached data." 'vhdl-speedbar-configuration-face depth) (setq conf-alist (cdr conf-alist))) ;; insert packages - (when package-alist (vhdl-speedbar-make-title-line "Packages:" depth)) - (while package-alist - (setq pack-entry (car package-alist)) + (when pkg-alist (vhdl-speedbar-make-title-line "Packages:" depth)) + (while pkg-alist + (setq pack-entry (car pkg-alist)) (vhdl-speedbar-make-pack-line (nth 0 pack-entry) (nth 1 pack-entry) (cons (nth 2 pack-entry) (nth 3 pack-entry)) (cons (nth 7 pack-entry) (nth 8 pack-entry)) depth) - (setq package-alist (cdr package-alist)))))) + (setq pkg-alist (cdr pkg-alist)))))) (declare-function speedbar-line-directory "speedbar" (&optional depth)) diff --git a/lisp/progmodes/which-func.el b/lisp/progmodes/which-func.el index bd68672f905..b36e13104e3 100644 --- a/lisp/progmodes/which-func.el +++ b/lisp/progmodes/which-func.el @@ -211,7 +211,7 @@ non-nil.") (when which-function-mode (unless (local-variable-p 'which-func-mode) (setq which-func-mode (or (eq which-func-modes t) - (member major-mode which-func-modes))) + (derived-mode-p which-func-modes))) (setq which-func--use-mode-line (member which-func-display '(mode mode-and-header))) (setq which-func--use-header-line @@ -239,7 +239,7 @@ It creates the Imenu index for the buffer, if necessary." (condition-case err (if (and which-func-mode - (not (member major-mode which-func-non-auto-modes)) + (not (derived-mode-p which-func-non-auto-modes)) (or (null which-func-maxout) (< buffer-saved-size which-func-maxout) (= which-func-maxout 0))) diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index 717b837a2e5..755c3db04fd 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -2176,7 +2176,7 @@ Such as the current syntax table and the applied syntax properties." (or (buffer-modified-p buf) (unless xref--hits-remote-id - (not (verify-visited-file-modtime (current-buffer)))))) + (not (verify-visited-file-modtime buf))))) ;; We can't use buffers whose contents diverge from disk (bug#54025). (setq buf nil)) (setq xref--last-file-buffer (cons file buf)))) diff --git a/lisp/register.el b/lisp/register.el index baad2c2a05d..822467a0d72 100644 --- a/lisp/register.el +++ b/lisp/register.el @@ -131,7 +131,12 @@ to the value of `register--read-with-preview-function'.") (defcustom register-use-preview 'traditional "Whether to show register preview when modifying registers. -When set to `t', show a preview buffer with navigation and highlighting. +When set to `t', show a preview buffer with navigation and +highlighting. +When set to \\='insist, behave as with `t', but allow exiting the +minibuffer by pressing the register name a second time. E.g., +press \"a\" to select register \"a\", then press \"a\" again to +exit the minibuffer. When nil, show a preview buffer without navigation and highlighting, and exit the minibuffer immediately after inserting response in minibuffer. When set to \\='never, behave as with nil, but with no preview buffer at @@ -141,6 +146,7 @@ according to `register-preview-delay'; this preserves the traditional behavior of Emacs 29 and before." :type '(choice (const :tag "Use preview" t) + (const :tag "Use preview and exit by pressing register name" insist) (const :tag "Use quick preview" nil) (const :tag "Never use preview" never) (const :tag "Basic preview like Emacs-29" traditional)) @@ -386,18 +392,21 @@ Format of each entry is controlled by the variable `register-preview-function'." (setq register-preview-function (register--preview-function register--read-with-preview-function))) (when (or show-empty (consp register-alist)) - (with-current-buffer-window - buffer - (cons 'display-buffer-below-selected - '((window-height . fit-window-to-buffer) - (preserve-size . (nil . t)))) - nil - (with-current-buffer standard-output - (setq cursor-in-non-selected-windows nil) - (mapc (lambda (elem) - (when (get-register (car elem)) - (insert (funcall register-preview-function elem)))) - register-alist))))) + (with-current-buffer-window buffer + register-preview-display-buffer-alist + nil + (with-current-buffer standard-output + (setq cursor-in-non-selected-windows nil) + (mapc (lambda (elem) + (when (get-register (car elem)) + (insert (funcall register-preview-function elem)))) + register-alist))))) + +(defcustom register-preview-display-buffer-alist '(display-buffer-at-bottom + (window-height . fit-window-to-buffer) + (preserve-size . (nil . t))) + "Window configuration for the register preview buffer." + :type display-buffer--action-custom-type) (defun register-preview-1 (buffer &optional show-empty types) "Pop up a window showing the preview of registers in BUFFER. @@ -415,9 +424,7 @@ Format of each entry is controlled by the variable `register-preview-function'." (when (or show-empty (consp registers)) (with-current-buffer-window buffer - (cons 'display-buffer-below-selected - '((window-height . fit-window-to-buffer) - (preserve-size . (nil . t)))) + register-preview-display-buffer-alist nil (with-current-buffer standard-output (setq cursor-in-non-selected-windows nil) @@ -540,7 +547,12 @@ or \\='never." (member new strs)) new old)) (delete-minibuffer-contents) - (insert input))) + (insert input) + ;; Exit minibuffer on second hit + ;; when *-use-preview == insist. + (when (and (string= new old) + (eq register-use-preview 'insist)) + (setq noconfirm t)))) (when (and smatch (not (string= input "")) (not (member input strs))) (setq input "") @@ -550,6 +562,10 @@ or \\='never." (setq pat input)))) (if (setq win (get-buffer-window buffer)) (with-selected-window win + (when noconfirm + ;; Happen only when + ;; *-use-preview == insist. + (exit-minibuffer)) (let ((ov (make-overlay (point-min) (point-min))) ;; Allow upper-case and lower-case letters diff --git a/lisp/replace.el b/lisp/replace.el index fa460a16063..01a892bbba7 100644 --- a/lisp/replace.el +++ b/lisp/replace.el @@ -1931,7 +1931,7 @@ See also `multi-occur'." (lambda (boo) (buffer-name (if (overlayp boo) (overlay-buffer boo) boo))) active-bufs)) - (with-current-buffer (get-buffer buf-name) + (with-current-buffer buf-name (rename-uniquely))) ;; Now find or create the output buffer. @@ -2916,7 +2916,7 @@ characters." ;; If last typed key in previous call of multi-buffer perform-replace ;; was `automatic-all', don't ask more questions in next files - (when (eq (lookup-key map (vector last-input-event)) 'automatic-all) + (when (eq (lookup-key map (vector last-input-event) t) 'automatic-all) (setq query-flag nil multi-buffer t)) (cond @@ -3100,7 +3100,7 @@ characters." ;; read-event that clobbers the match data. (set-match-data real-match-data) (setq key (vector key)) - (setq def (lookup-key map key)) + (setq def (lookup-key map key t)) ;; Restore the match data while we process the command. (cond ((eq def 'help) (let ((display-buffer-overriding-action diff --git a/lisp/server.el b/lisp/server.el index f75e9cb4fe5..b65053267a6 100644 --- a/lisp/server.el +++ b/lisp/server.el @@ -729,7 +729,9 @@ the `server-process' variable." (concat "Unable to start the Emacs server.\n" (cadr err) (substitute-command-keys - "\nTo start the server in this Emacs process, stop the existing server or call `\\[server-force-delete]' to forcibly disconnect it.")) + (concat "\nTo start the server in this Emacs process, stop " + "the existing server or call \\[server-force-delete] " + "to forcibly disconnect it."))) :warning) (setq leave-dead t))) ;; Now any previous server is properly stopped. @@ -1437,7 +1439,11 @@ invocations of \"emacs\".") ;; including code that needs to wait. (with-local-quit (condition-case err - (let ((buffers (server-visit-files files proc nowait))) + (let ((buffers (server-visit-files files proc nowait)) + ;; On Android, the Emacs server generally can't provide + ;; feedback to the user except by means of dialog boxes, + ;; which are displayed in the GUI emacsclient wrapper. + (use-dialog-box-override (featurep 'android))) (mapc 'funcall (nreverse commands)) (let ((server-eval-args-left (nreverse evalexprs))) (while server-eval-args-left diff --git a/lisp/shell.el b/lisp/shell.el index c5cfbd985ed..cd49d289403 100644 --- a/lisp/shell.el +++ b/lisp/shell.el @@ -606,6 +606,9 @@ Shell buffers. It implements `shell-completion-execonly' for (defvar sh-shell-file) +(declare-function w32-application-type "w32proc.c" + (program) t) + (define-derived-mode shell-mode comint-mode "Shell" "Major mode for interacting with an inferior shell. \\<shell-mode-map> @@ -754,6 +757,11 @@ command." ((string-equal shell "ksh") "echo $PWD ~-") ;; Bypass any aliases. TODO all shells could use this. ((string-equal shell "bash") "command dirs") + ((and (string-equal shell "bash.exe") + (eq system-type 'windows-nt) + (eq (w32-application-type (executable-find "bash.exe")) + 'msys)) + "command pwd -W") ((string-equal shell "zsh") "dirs -l") (t "dirs"))) ;; Bypass a bug in certain versions of bash. diff --git a/lisp/simple.el b/lisp/simple.el index 4f6d2ee12c3..0645f18cc78 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -2087,6 +2087,9 @@ of the prefix argument for `eval-expression' and ((= num -1) most-positive-fixnum) (t eval-expression-print-maximum-character))))) +(defun eval-expression--debug (err) + (funcall debugger 'error err :backtrace-base #'eval-expression--debug)) + ;; We define this, rather than making `eval' interactive, ;; for the sake of completion of names like eval-region, eval-buffer. (defun eval-expression (exp &optional insert-value no-truncate char-print-limit) @@ -2120,23 +2123,17 @@ this command arranges for all errors to enter the debugger." (cons (read--expression "Eval: ") (eval-expression-get-print-arguments current-prefix-arg))) - (let (result) + (let* (result + (runfun + (lambda () + (setq result + (values--store-value + (eval (let ((lexical-binding t)) (macroexpand-all exp)) + t)))))) (if (null eval-expression-debug-on-error) - (setq result - (values--store-value - (eval (let ((lexical-binding t)) (macroexpand-all exp)) t))) - (let ((old-value (make-symbol "t")) new-value) - ;; Bind debug-on-error to something unique so that we can - ;; detect when evalled code changes it. - (let ((debug-on-error old-value)) - (setq result - (values--store-value - (eval (let ((lexical-binding t)) (macroexpand-all exp)) t))) - (setq new-value debug-on-error)) - ;; If evalled code has changed the value of debug-on-error, - ;; propagate that change to the global binding. - (unless (eq old-value new-value) - (setq debug-on-error new-value)))) + (funcall runfun) + (handler-bind ((error #'eval-expression--debug)) + (funcall runfun))) (let ((print-length (unless no-truncate eval-expression-print-length)) (print-level (unless no-truncate eval-expression-print-level)) @@ -6422,7 +6419,7 @@ PROMPT is a string to prompt with." 0 (length s) '( keymap local-map action mouse-action - button category help-args) + read-only button category help-args) s) s) kill-ring)) @@ -9943,6 +9940,20 @@ Also see the `completion-auto-wrap' variable." (interactive "p") (next-completion (- n))) +(defun completion--move-to-candidate-start () + "If in a completion candidate, move point to its start." + (when (and (get-text-property (point) 'mouse-face) + (not (bobp)) + (get-text-property (1- (point)) 'mouse-face)) + (goto-char (previous-single-property-change (point) 'mouse-face)))) + +(defun completion--move-to-candidate-end () + "If in a completion candidate, move point to its end." + (when (and (get-text-property (point) 'mouse-face) + (not (eobp)) + (get-text-property (1+ (point)) 'mouse-face)) + (goto-char (or (next-single-property-change (point) 'mouse-face) (point-max))))) + (defun next-completion (n) "Move to the next item in the completions buffer. With prefix argument N, move N items (negative N means move @@ -10032,9 +10043,7 @@ Also see the `completion-auto-wrap' variable." (if (get-text-property (point) 'mouse-face) ;; If in a completion, move to the start of it. - (when (and (not (bobp)) - (get-text-property (1- (point)) 'mouse-face)) - (goto-char (previous-single-property-change (point) 'mouse-face))) + (completion--move-to-candidate-start) ;; Try to move to the previous completion. (setq pos (previous-single-property-change (point) 'mouse-face)) (if pos @@ -10049,10 +10058,11 @@ Also see the `completion-auto-wrap' variable." (while (> n 0) (setq found nil pos nil column (current-column) line (line-number-at-pos)) + (completion--move-to-candidate-end) (while (and (not found) (eq (forward-line 1) 0) (not (eobp)) - (eq (move-to-column column) column)) + (move-to-column column)) (when (get-text-property (point) 'mouse-face) (setq found t))) (when (not found) @@ -10073,9 +10083,10 @@ Also see the `completion-auto-wrap' variable." (while (< n 0) (setq found nil pos nil column (current-column) line (line-number-at-pos)) + (completion--move-to-candidate-start) (while (and (not found) (eq (forward-line -1) 0) - (eq (move-to-column column) column)) + (move-to-column column)) (when (get-text-property (point) 'mouse-face) (setq found t))) (when (not found) @@ -10287,6 +10298,8 @@ Called from `temp-buffer-show-hook'." :version "22.1" :group 'completion) +(defvar minibuffer-visible-completions--always-bind) + ;; This function goes in completion-setup-hook, so that it is called ;; after the text of the completion list buffer is written. (defun completion-setup-function () @@ -10324,13 +10337,28 @@ Called from `temp-buffer-show-hook'." ;; Maybe insert help string. (when completion-show-help (goto-char (point-min)) - (insert (substitute-command-keys - (if (display-mouse-p) - "Click or type \\[minibuffer-choose-completion] on a completion to select it.\n" - "Type \\[minibuffer-choose-completion] on a completion to select it.\n"))) - (insert (substitute-command-keys - "Type \\[minibuffer-next-completion] or \\[minibuffer-previous-completion] \ + (if minibuffer-visible-completions + (let ((helps + (with-current-buffer (window-buffer (active-minibuffer-window)) + (let ((minibuffer-visible-completions--always-bind t)) + (list + (substitute-command-keys + (if (display-mouse-p) + "Click or type \\[minibuffer-choose-completion-or-exit] on a completion to select it.\n" + "Type \\[minibuffer-choose-completion-or-exit] on a completion to select it.\n")) + (substitute-command-keys + "Type \\[minibuffer-next-completion], \\[minibuffer-previous-completion], \ +\\[minibuffer-next-line-completion], \\[minibuffer-previous-line-completion] \ to move point between completions.\n\n")))))) + (dolist (help helps) + (insert help))) + (insert (substitute-command-keys + (if (display-mouse-p) + "Click or type \\[minibuffer-choose-completion] on a completion to select it.\n" + "Type \\[minibuffer-choose-completion] on a completion to select it.\n"))) + (insert (substitute-command-keys + "Type \\[minibuffer-next-completion] or \\[minibuffer-previous-completion] \ +to move point between completions.\n\n"))))))) (add-hook 'completion-setup-hook #'completion-setup-function) @@ -10833,6 +10861,87 @@ and setting it to nil." (setq-local vis-mode-saved-buffer-invisibility-spec buffer-invisibility-spec) (setq buffer-invisibility-spec nil))) + + +(defvar read-passwd--mode-line-buffer nil + "Buffer to modify `mode-line-format' for showing/hiding passwords.") + +(defvar read-passwd--mode-line-icon nil + "Propertized mode line icon for showing/hiding passwords.") + +(defun read-passwd-toggle-visibility () + "Toggle minibuffer contents visibility. +Adapt also mode line." + (interactive) + (setq read-passwd--hide-password (not read-passwd--hide-password)) + (with-current-buffer read-passwd--mode-line-buffer + (setq read-passwd--mode-line-icon + `(:propertize + ,(if icon-preference + (icon-string + (if read-passwd--hide-password + 'read-passwd--show-password-icon + 'read-passwd--hide-password-icon)) + "") + mouse-face mode-line-highlight + local-map + (keymap + (mode-line keymap (mouse-1 . read-passwd-toggle-visibility))))) + (force-mode-line-update)) + (read-passwd--hide-password)) + +(define-minor-mode read-passwd-mode + "Toggle visibility of password in minibuffer." + :group 'mode-line + :group 'minibuffer + :keymap read-passwd-map + :version "30.1" + + (require 'icons) + ;; It would be preferable to use "👁" ("\N{EYE}"). However, there is + ;; no corresponding Unicode char with a slash. So we use symbols as + ;; fallback only, with "⦵" ("\N{CIRCLE WITH HORIZONTAL BAR}") for + ;; hiding the password. + (define-icon read-passwd--show-password-icon nil + '((image "reveal.svg" "reveal.pbm" :height (0.8 . em)) + (symbol "👁") + (text "<o>")) + "Mode line icon to show a hidden password." + :group mode-line-faces + :version "30.1" + :help-echo "mouse-1: Toggle password visibility") + (define-icon read-passwd--hide-password-icon nil + '((image "conceal.svg" "conceal.pbm" :height (0.8 . em)) + (symbol "⦵") + (text "<\\>")) + "Mode line icon to hide a visible password." + :group mode-line-faces + :version "30.1" + :help-echo "mouse-1: Toggle password visibility") + + (setq read-passwd--hide-password nil + ;; Stolen from `eldoc-minibuffer-message'. + read-passwd--mode-line-buffer + (window-buffer + (or (window-in-direction 'above (minibuffer-window)) + (minibuffer-selected-window) + (get-largest-window)))) + + (if read-passwd-mode + (with-current-buffer read-passwd--mode-line-buffer + ;; Add `read-passwd--mode-line-icon'. + (when (listp mode-line-format) + (setq mode-line-format + (cons '(:eval read-passwd--mode-line-icon) + mode-line-format)))) + (with-current-buffer read-passwd--mode-line-buffer + ;; Remove `read-passwd--mode-line-icon'. + (when (listp mode-line-format) + (setq mode-line-format (cdr mode-line-format))))) + + (when read-passwd-mode + (read-passwd-toggle-visibility))) + (defvar messages-buffer-mode-map (let ((map (make-sparse-keymap))) diff --git a/lisp/speedbar.el b/lisp/speedbar.el index 1cb72dc23e6..2ed97986fe7 100644 --- a/lisp/speedbar.el +++ b/lisp/speedbar.el @@ -3488,7 +3488,7 @@ functions to do caching and flushing if appropriate." nil -(eval-when-compile (condition-case nil (require 'imenu) (error nil))) +(eval-when-compile (require 'imenu)) (declare-function imenu--make-index-alist "imenu" (&optional no-error)) (defun speedbar-fetch-dynamic-imenu (file) diff --git a/lisp/sqlite.el b/lisp/sqlite.el index 46e35ac18d8..efc5997fb5c 100644 --- a/lisp/sqlite.el +++ b/lisp/sqlite.el @@ -32,7 +32,8 @@ If BODY completes normally, commit the changes and return the value of BODY. If BODY signals an error, or transaction commit fails, roll -back the transaction changes." +back the transaction changes before allowing the signal to +propagate." (declare (indent 1) (debug (form body))) (let ((db-var (gensym)) (func-var (gensym)) @@ -48,8 +49,8 @@ back the transaction changes." (setq ,res-var (funcall ,func-var)) (setq ,commit-var (sqlite-commit ,db-var)) ,res-var) - (or ,commit-var (sqlite-rollback ,db-var)))) - (funcall ,func-var)))) + (or ,commit-var (sqlite-rollback ,db-var))) + (funcall ,func-var))))) (provide 'sqlite) diff --git a/lisp/startup.el b/lisp/startup.el index b0669af7e24..0f0195eba57 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -393,7 +393,7 @@ If this is nil, Emacs uses `system-name'." "The email address of the current user. This defaults to either: the value of EMAIL environment variable; or user@host, using `user-login-name' and `mail-host-address' (or `system-name')." - :initialize 'custom-initialize-delay + :initialize #'custom-initialize-delay :set-after '(mail-host-address) :type 'string :group 'mail) @@ -492,7 +492,7 @@ DIRS are relative." (setq tail (cdr tail))) ;;Splice the new section in. (when tail - (setcdr tail (append (mapcar 'expand-file-name dirs) (cdr tail)))))) + (setcdr tail (append (mapcar #'expand-file-name dirs) (cdr tail)))))) ;; The default location for XDG-convention Emacs init files. (defconst startup--xdg-config-default "~/.config/emacs/") @@ -556,6 +556,17 @@ the updated value." (setq startup--original-eln-load-path (copy-sequence native-comp-eln-load-path)))) +(defun startup--rescale-elt-match-p (font-pattern font-object) + "Test whether FONT-OBJECT matches an element of `face-font-rescale-alist'. +FONT-OBJECT is a font-object that specifies a font to test. +FONT-PATTERN is the car of an element of `face-font-rescale-alist', +which can be either a regexp matching a font name or a font-spec." + (if (stringp font-pattern) + ;; FONT-PATTERN is a regexp, we need the name of FONT-OBJECT to match. + (string-match-p font-pattern (font-xlfd-name font-object)) + ;; FONT-PATTERN is a font-spec. + (font-match-p font-pattern font-object))) + (defvar android-fonts-enumerated nil "Whether or not fonts have been enumerated already. On Android, Emacs uses this variable internally at startup.") @@ -816,8 +827,9 @@ It is the default value of the variable `top-level'." (when (and (display-multi-font-p) (not (eq face-font-rescale-alist old-face-font-rescale-alist)) - (assoc (font-xlfd-name (face-attribute 'default :font)) - face-font-rescale-alist #'string-match-p)) + (assoc (face-attribute 'default :font) + face-font-rescale-alist + #'startup--rescale-elt-match-p)) (set-face-attribute 'default nil :font (font-spec))) ;; Modify the initial frame based on what .emacs puts into @@ -1019,6 +1031,9 @@ If STYLE is nil, display appropriately for the terminal." (when standard-display-table (aset standard-display-table char nil))))))) +(defun startup--debug (err) + (funcall debugger 'error err :backtrace-base #'startup--debug)) + (defun startup--load-user-init-file (filename-function &optional alternate-filename-function load-defaults) "Load a user init-file. @@ -1032,88 +1047,79 @@ is non-nil. This function sets `user-init-file' to the name of the loaded init-file, or to a default value if loading is not possible." - (let ((debug-on-error-from-init-file nil) - (debug-on-error-should-be-set nil) - (debug-on-error-initial - (if (eq init-file-debug t) - 'startup--witness ;Dummy but recognizable non-nil value. - init-file-debug)) - (d-i-e-from-init-file nil) - (d-i-e-initial - ;; Use (startup--witness) instead of nil, so we can detect when the - ;; init files set `debug-ignored-errors' to nil. - (if init-file-debug '(startup--witness) debug-ignored-errors)) - (d-i-e-standard debug-ignored-errors) - ;; The init file might contain byte-code with embedded NULs, - ;; which can cause problems when read back, so disable nul - ;; byte detection. (Bug#52554) - (inhibit-null-byte-detection t)) - (let ((debug-on-error debug-on-error-initial) - ;; If they specified --debug-init, enter the debugger - ;; on any error whatsoever. - (debug-ignored-errors d-i-e-initial)) + ;; The init file might contain byte-code with embedded NULs, + ;; which can cause problems when read back, so disable nul + ;; byte detection. (Bug#52554) + (let ((inhibit-null-byte-detection t) + (body + (lambda () + (when init-file-user + (let ((init-file-name (funcall filename-function))) + + ;; If `user-init-file' is t, then `load' will store + ;; the name of the file that it loads into + ;; `user-init-file'. + (setq user-init-file t) + (when init-file-name + (load (if (equal (file-name-extension init-file-name) + "el") + (file-name-sans-extension init-file-name) + init-file-name) + 'noerror 'nomessage)) + + (when (and (eq user-init-file t) alternate-filename-function) + (let ((alt-file (funcall alternate-filename-function))) + (unless init-file-name + (setq init-file-name alt-file)) + (and (equal (file-name-extension alt-file) "el") + (setq alt-file (file-name-sans-extension alt-file))) + (load alt-file 'noerror 'nomessage))) + + ;; If we did not find the user's init file, set + ;; user-init-file conclusively. Don't let it be + ;; set from default.el. + (when (eq user-init-file t) + (setq user-init-file init-file-name))) + + ;; If we loaded a compiled file, set `user-init-file' to + ;; the source version if that exists. + (if (equal (file-name-extension user-init-file) "elc") + (let* ((source (file-name-sans-extension user-init-file)) + (alt (concat source ".el"))) + (setq source (cond ((file-exists-p alt) alt) + ((file-exists-p source) source) + (t nil))) + (when source + (when (file-newer-than-file-p source user-init-file) + (message "Warning: %s is newer than %s" + source user-init-file) + (sit-for 1)) + (setq user-init-file source))) + ;; Else, perhaps the user init file was compiled + (when (and (equal (file-name-extension user-init-file) "eln") + ;; The next test is for builds without native + ;; compilation support or builds with unexec. + (boundp 'comp-eln-to-el-h)) + (if-let (source (gethash (file-name-nondirectory + user-init-file) + comp-eln-to-el-h)) + ;; source exists or the .eln file would not load + (setq user-init-file source) + (message "Warning: unknown source file for init file %S" + user-init-file) + (sit-for 1)))) + + (when (and load-defaults + (not inhibit-default-init)) + ;; Prevent default.el from changing the value of + ;; `inhibit-startup-screen'. + (let ((inhibit-startup-screen nil)) + (load "default" 'noerror 'nomessage))))))) + (if (eq init-file-debug t) + (handler-bind ((error #'startup--debug)) + (funcall body)) (condition-case-unless-debug error - (when init-file-user - (let ((init-file-name (funcall filename-function))) - - ;; If `user-init-file' is t, then `load' will store - ;; the name of the file that it loads into - ;; `user-init-file'. - (setq user-init-file t) - (when init-file-name - (load (if (equal (file-name-extension init-file-name) - "el") - (file-name-sans-extension init-file-name) - init-file-name) - 'noerror 'nomessage)) - - (when (and (eq user-init-file t) alternate-filename-function) - (let ((alt-file (funcall alternate-filename-function))) - (unless init-file-name - (setq init-file-name alt-file)) - (and (equal (file-name-extension alt-file) "el") - (setq alt-file (file-name-sans-extension alt-file))) - (load alt-file 'noerror 'nomessage))) - - ;; If we did not find the user's init file, set - ;; user-init-file conclusively. Don't let it be - ;; set from default.el. - (when (eq user-init-file t) - (setq user-init-file init-file-name))) - - ;; If we loaded a compiled file, set `user-init-file' to - ;; the source version if that exists. - (if (equal (file-name-extension user-init-file) "elc") - (let* ((source (file-name-sans-extension user-init-file)) - (alt (concat source ".el"))) - (setq source (cond ((file-exists-p alt) alt) - ((file-exists-p source) source) - (t nil))) - (when source - (when (file-newer-than-file-p source user-init-file) - (message "Warning: %s is newer than %s" - source user-init-file) - (sit-for 1)) - (setq user-init-file source))) - ;; Else, perhaps the user init file was compiled - (when (and (equal (file-name-extension user-init-file) "eln") - ;; The next test is for builds without native - ;; compilation support or builds with unexec. - (boundp 'comp-eln-to-el-h)) - (if-let (source (gethash (file-name-nondirectory user-init-file) - comp-eln-to-el-h)) - ;; source exists or the .eln file would not load - (setq user-init-file source) - (message "Warning: unknown source file for init file %S" - user-init-file) - (sit-for 1)))) - - (when (and load-defaults - (not inhibit-default-init)) - ;; Prevent default.el from changing the value of - ;; `inhibit-startup-screen'. - (let ((inhibit-startup-screen nil)) - (load "default" 'noerror 'nomessage)))) + (funcall body) (error (display-warning 'initialization @@ -1128,28 +1134,7 @@ the `--debug-init' option to view a complete error backtrace." (mapconcat (lambda (s) (prin1-to-string s t)) (cdr error) ", ")) :warning) - (setq init-file-had-error t))) - - ;; If we can tell that the init file altered debug-on-error, - ;; arrange to preserve the value that it set up. - (unless (eq debug-ignored-errors d-i-e-initial) - (if (memq 'startup--witness debug-ignored-errors) - ;; The init file wants to add errors to the standard - ;; value, so we need to emulate that. - (setq d-i-e-from-init-file - (list (append d-i-e-standard - (remq 'startup--witness - debug-ignored-errors)))) - ;; The init file _replaces_ the standard value. - (setq d-i-e-from-init-file (list debug-ignored-errors)))) - (or (eq debug-on-error debug-on-error-initial) - (setq debug-on-error-should-be-set t - debug-on-error-from-init-file debug-on-error))) - - (when d-i-e-from-init-file - (setq debug-ignored-errors (car d-i-e-from-init-file))) - (when debug-on-error-should-be-set - (setq debug-on-error debug-on-error-from-init-file)))) + (setq init-file-had-error t)))))) (defvar lisp-directory nil "Directory where Emacs's own *.el and *.elc Lisp files are installed.") @@ -1445,7 +1430,7 @@ please check its value") (error (princ (if (eq (car error) 'error) - (apply 'concat (cdr error)) + (apply #'concat (cdr error)) (if (memq 'file-error (get (car error) 'error-conditions)) (format "%s: %s" (nth 1 error) @@ -1659,7 +1644,9 @@ Consider using a subdirectory instead, e.g.: %s" (let ((dn (daemonp))) (when dn (when (stringp dn) (setq server-name dn)) - (server-start) + (condition-case err + (server-start) + (error (error "Unable to start daemon: %s; exiting" (error-message-string err)))) (if server-process (daemon-initialized) (if (stringp dn) @@ -1790,7 +1777,7 @@ If this is nil, no message will be displayed." "\n")) "A list of texts to show in the middle part of splash screens. Each element in the list should be a list of strings or pairs -`:face FACE', like `fancy-splash-insert' accepts them.") +`:KEYWORD VALUE', like what `fancy-splash-insert' accepts.") (defconst fancy-about-text `((:face (variable-pitch font-lock-comment-face) @@ -1883,7 +1870,7 @@ Each element in the list should be a list of strings or pairs "\tDisplay the Emacs manual in Info mode")) "A list of texts to show in the middle part of the About screen. Each element in the list should be a list of strings or pairs -`:face FACE', like `fancy-splash-insert' accepts them.") +`:KEYWORD VALUE', like what `fancy-splash-insert' accepts.") (defgroup fancy-splash-screen () @@ -1902,10 +1889,10 @@ Each element in the list should be a list of strings or pairs (let ((map (make-sparse-keymap))) (suppress-keymap map) (set-keymap-parent map button-buffer-map) - (define-key map "\C-?" 'scroll-down-command) - (define-key map [?\S-\ ] 'scroll-down-command) - (define-key map " " 'scroll-up-command) - (define-key map "q" 'exit-splash-screen) + (define-key map "\C-?" #'scroll-down-command) + (define-key map [?\S-\ ] #'scroll-down-command) + (define-key map " " #'scroll-up-command) + (define-key map "q" #'exit-splash-screen) map) "Keymap for splash screen buffer.") @@ -2058,10 +2045,6 @@ a face or button specification." (call-interactively 'recover-session))) " to recover the files you were editing.")))) - ;; Insert the permissions notice if the user has yet to grant Emacs - ;; storage permissions. - (when (fboundp 'android-after-splash-screen) - (funcall 'android-after-splash-screen t)) (when concise (fancy-splash-insert :face 'variable-pitch "\n" @@ -2114,6 +2097,10 @@ splash screen in another window." (make-local-variable 'startup-screen-inhibit-startup-screen) (if pure-space-overflow (insert pure-space-overflow-message)) + ;; Insert the permissions notice if the user has yet to grant Emacs + ;; storage permissions. + (when (fboundp 'android-before-splash-screen) + (funcall 'android-before-splash-screen t)) (unless concise (fancy-splash-head)) (dolist (text fancy-startup-text) @@ -2220,7 +2207,10 @@ splash screen in another window." (if pure-space-overflow (insert pure-space-overflow-message)) - + ;; Insert the permissions notice if the user has yet to grant + ;; Emacs storage permissions. + (when (fboundp 'android-before-splash-screen) + (funcall 'android-before-splash-screen nil)) ;; The convention for this piece of code is that ;; each piece of output starts with one or two newlines ;; and does not end with any newlines. @@ -2262,12 +2252,6 @@ splash screen in another window." (insert "\n\nIf an Emacs session crashed recently, " "type M-x recover-session RET\nto recover" " the files you were editing.\n")) - - ;; Insert the permissions notice if the user has yet to grant - ;; Emacs storage permissions. - (when (fboundp 'android-after-splash-screen) - (funcall 'android-after-splash-screen nil)) - (use-local-map splash-screen-keymap) ;; Display the input that we set up in the buffer. @@ -2343,7 +2327,7 @@ To quit a partially entered command, type Control-g.\n") ;; If C-h can't be invoked, temporarily disable its ;; binding, so where-is uses alternative bindings. (let ((map (make-sparse-keymap))) - (define-key map [?\C-h] 'undefined) + (define-key map [?\C-h] #'undefined) map)) minor-mode-overriding-map-alist))) @@ -2535,8 +2519,8 @@ A fancy display is used on graphic displays, normal otherwise." (fancy-about-screen) (normal-splash-screen nil))) -(defalias 'about-emacs 'display-about-screen) -(defalias 'display-splash-screen 'display-startup-screen) +(defalias 'about-emacs #'display-about-screen) +(defalias 'display-splash-screen #'display-startup-screen) ;; This avoids byte-compiler warning in the unexec build. (declare-function pdumper-stats "pdumper.c" ()) diff --git a/lisp/subr.el b/lisp/subr.el index d2b8ea17f74..90dbfc75d52 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -1,7 +1,6 @@ ;;; subr.el --- basic lisp subroutines for Emacs -*- lexical-binding:t -*- -;; Copyright (C) 1985-1986, 1992, 1994-1995, 1999-2024 Free Software -;; Foundation, Inc. +;; Copyright (C) 1985-2024 Free Software Foundation, Inc. ;; Maintainer: emacs-devel@gnu.org ;; Keywords: internal @@ -313,11 +312,20 @@ value of last one, or nil if there are none." cond '(empty-body unless) t))) (defsubst subr-primitive-p (object) - "Return t if OBJECT is a built-in primitive function." + "Return t if OBJECT is a built-in primitive written in C. +Such objects can be functions or special forms." (declare (side-effect-free error-free)) (and (subrp object) (not (subr-native-elisp-p object)))) +(defsubst primitive-function-p (object) + "Return t if OBJECT is a built-in primitive function. +This excludes special forms, since they are not functions." + (declare (side-effect-free error-free)) + (and (subrp object) + (not (or (subr-native-elisp-p object) + (eq (cdr (subr-arity object)) 'unevalled))))) + (defsubst xor (cond1 cond2) "Return the boolean exclusive-or of COND1 and COND2. If only one of the arguments is non-nil, return it; otherwise @@ -2023,6 +2031,8 @@ instead; it will indirectly limit the specpdl stack size as well.") (defvaralias 'native-comp-deferred-compilation 'native-comp-jit-compilation) +(define-obsolete-function-alias 'fetch-bytecode #'ignore "30.1") + ;;;; Alternate names for functions - these are not being phased out. @@ -2579,6 +2589,8 @@ Affects only hooks run in the current buffer." (list binding binding)) ((null (cdr binding)) (list (make-symbol "s") (car binding))) + ((eq '_ (car binding)) + (list (make-symbol "s") (cadr binding))) (t binding))) (when (> (length binding) 2) (signal 'error @@ -2619,7 +2631,7 @@ This is like `when-let' but doesn't handle a VARLIST of the form (defmacro and-let* (varlist &rest body) "Bind variables according to VARLIST and conditionally evaluate BODY. Like `when-let*', except if BODY is empty and all the bindings -are non-nil, then the result is non-nil." +are non-nil, then the result is the value of the last binding." (declare (indent 1) (debug if-let*)) (let (res) (if varlist @@ -2632,7 +2644,8 @@ are non-nil, then the result is non-nil." "Bind variables according to SPEC and evaluate THEN or ELSE. Evaluate each binding in turn, as in `let*', stopping if a binding value is nil. If all are non-nil return the value of -THEN, otherwise the last form in ELSE. +THEN, otherwise the value of the last form in ELSE, or nil if +there are none. Each element of SPEC is a list (SYMBOL VALUEFORM) that binds SYMBOL to the value of VALUEFORM. An element can additionally be @@ -2737,6 +2750,8 @@ By default we choose the head of the first list." (defun derived-mode-all-parents (mode &optional known-children) "Return all the parents of MODE, starting with MODE. +This includes the parents set by `define-derived-mode' and additional +ones set by `derived-mode-add-parents'. The returned list is not fresh, don't modify it. \n(fn MODE)" ;`known-children' is for internal use only. ;; Can't use `with-memoization' :-( @@ -2785,7 +2800,9 @@ The returned list is not fresh, don't modify it. (defun provided-mode-derived-p (mode &optional modes &rest old-modes) "Non-nil if MODE is derived from a mode that is a member of the list MODES. MODES can also be a single mode instead of a list. -If you just want to check `major-mode', use `derived-mode-p'. +This examines the parent modes set by `define-derived-mode' and also +additional ones set by `derived-mode-add-parents'. +If you just want to check the current `major-mode', use `derived-mode-p'. We also still support the deprecated calling convention: \(provided-mode-derived-p MODE &rest MODES)." (declare (side-effect-free t) @@ -2799,8 +2816,10 @@ We also still support the deprecated calling convention: (car modes))) (defun derived-mode-p (&optional modes &rest old-modes) - "Non-nil if the current major mode is derived from one of MODES. + "Return non-nil if the current major mode is derived from one of MODES. MODES should be a list of symbols or a single mode symbol instead of a list. +This examines the parent modes set by `define-derived-mode' and also +additional ones set by `derived-mode-add-parents'. We also still support the deprecated calling convention: \(derived-mode-p &rest MODES)." (declare (side-effect-free t) @@ -2820,7 +2839,8 @@ We also still support the deprecated calling convention: (defun derived-mode-add-parents (mode extra-parents) "Add EXTRA-PARENTS to the parents of MODE. Declares the parents of MODE to be its main parent (as defined -in `define-derived-mode') plus EXTRA-PARENTS." +in `define-derived-mode') plus EXTRA-PARENTS, which should be a list +of symbols." (put mode 'derived-mode-extra-parents extra-parents) (derived-mode--flush mode)) @@ -3095,7 +3115,7 @@ instead." LIBRARY should be a relative file name of the library, a string. It can omit the suffix (a.k.a. file-name extension) if NOSUFFIX is nil (which is the default, see below). -This command searches the directories in `load-path' like `\\[load-library]' +This command searches the directories in `load-path' like \\[load-library] to find the file that `\\[load-library] RET LIBRARY RET' would load. Optional second arg NOSUFFIX non-nil means don't add suffixes `load-suffixes' to the specified name LIBRARY. @@ -3367,14 +3387,27 @@ with Emacs. Do not call it directly in your own packages." (let ((map (make-sparse-keymap))) (set-keymap-parent map minibuffer-local-map) (define-key map "\C-u" #'delete-minibuffer-contents) ;bug#12570 + (define-key map "\t" #'read-passwd-toggle-visibility) map) "Keymap used while reading passwords.") -(defun read-password--hide-password () +(defvar read-passwd--hide-password t) + +(defun read-passwd--hide-password () + "Make password in minibuffer hidden or visible." (let ((beg (minibuffer-prompt-end))) (dotimes (i (1+ (- (buffer-size) beg))) - (put-text-property (+ i beg) (+ 1 i beg) - 'display (string (or read-hide-char ?*)))))) + (if read-passwd--hide-password + (put-text-property + (+ i beg) (+ 1 i beg) 'display (string (or read-hide-char ?*))) + (remove-list-of-text-properties (+ i beg) (+ 1 i beg) '(display))) + (put-text-property + (+ i beg) (+ 1 i beg) + 'help-echo "C-u: Clear password\nTAB: Toggle password visibility")))) + +;; Actually in textconv.c. +(defvar overriding-text-conversion-style) +(declare-function set-text-conversion-style "textconv.c") (defun read-passwd (prompt &optional confirm default) "Read a password, prompting with PROMPT, and return it. @@ -3412,21 +3445,27 @@ by doing (clear-string STRING)." (setq-local inhibit-modification-hooks nil) ;bug#15501. (setq-local show-paren-mode nil) ;bug#16091. (setq-local inhibit--record-char t) - (add-hook 'post-command-hook #'read-password--hide-password nil t)) + (read-passwd-mode 1) + (add-hook 'post-command-hook #'read-passwd--hide-password nil t)) (unwind-protect (let ((enable-recursive-minibuffers t) - (read-hide-char (or read-hide-char ?*))) + (read-hide-char (or read-hide-char ?*)) + (overriding-text-conversion-style 'password)) (read-string prompt nil t default)) ; t = "no history" (when (buffer-live-p minibuf) (with-current-buffer minibuf + (read-passwd-mode -1) ;; Not sure why but it seems that there might be cases where the ;; minibuffer is not always properly reset later on, so undo ;; whatever we've done here (bug#11392). (remove-hook 'after-change-functions - #'read-password--hide-password 'local) + #'read-passwd--hide-password 'local) (kill-local-variable 'post-self-insert-hook) ;; And of course, don't keep the sensitive data around. - (erase-buffer)))))))) + (erase-buffer) + ;; Then restore the previous text conversion style. + (when (fboundp 'set-text-conversion-style) + (set-text-conversion-style text-conversion-style))))))))) (defvar read-number-history nil "The default history for the `read-number' function.") @@ -3532,11 +3571,6 @@ causes it to evaluate `help-form' and display the result." (help-form-show))) ((memq char chars) (setq done t)) - ((and executing-kbd-macro (= char -1)) - ;; read-event returns -1 if we are in a kbd macro and - ;; there are no more events in the macro. Attempt to - ;; get an event interactively. - (setq executing-kbd-macro nil)) ((not inhibit-keyboard-quit) (cond ((and (null esc-flag) (eq char ?\e)) @@ -3718,10 +3752,10 @@ There is no need to explicitly add `help-char' to CHARS; (this-command this-command) (result (minibuffer-with-setup-hook (lambda () + (setq-local post-self-insert-hook nil) (add-hook 'post-command-hook (lambda () - ;; FIXME: Should we use `<='? - (if (= (1+ (minibuffer-prompt-end)) + (if (<= (1+ (minibuffer-prompt-end)) (point-max)) (exit-minibuffer))) nil 'local)) @@ -3821,19 +3855,25 @@ confusing to some users.") (defvar from--tty-menu-p nil "Non-nil means the current command was invoked from a TTY menu.") + +(declare-function android-detect-keyboard "androidfns.c") + +(defvar use-dialog-box-override nil + "Whether `use-dialog-box-p' should always return t.") + (defun use-dialog-box-p () "Return non-nil if the current command should prompt the user via a dialog box." - (and last-input-event ; not during startup - (or (consp last-nonmenu-event) ; invoked by a mouse event - (and (null last-nonmenu-event) - (consp last-input-event)) - (featurep 'android) ; Prefer dialog boxes on Android. - from--tty-menu-p) ; invoked via TTY menu - use-dialog-box)) - -;; Actually in textconv.c. -(defvar overriding-text-conversion-style) -(declare-function set-text-conversion-style "textconv.c") + (or use-dialog-box-override + (and last-input-event ; not during startup + (or (consp last-nonmenu-event) ; invoked by a mouse event + (and (null last-nonmenu-event) + (consp last-input-event)) + (and (featurep 'android) ; Prefer dialog boxes on + ; Android. + (not (android-detect-keyboard))) ; If no keyboard is + ; connected. + from--tty-menu-p) ; invoked via TTY menu + use-dialog-box))) (defun y-or-n-p (prompt) "Ask user a \"y or n\" question. @@ -4467,8 +4507,7 @@ Otherwise, return nil." (defun special-form-p (object) "Non-nil if and only if OBJECT is a special form." (declare (side-effect-free error-free)) - (if (and (symbolp object) (fboundp object)) - (setq object (indirect-function object))) + (if (symbolp object) (setq object (indirect-function object))) (and (subrp object) (eq (cdr (subr-arity object)) 'unevalled))) (defun plistp (object) @@ -4490,7 +4529,8 @@ Otherwise, return nil." Does not distinguish between functions implemented in machine code or byte-code." (declare (side-effect-free error-free)) - (or (subrp object) (byte-code-function-p object))) + (or (and (subrp object) (not (eq 'unevalled (cdr (subr-arity object))))) + (byte-code-function-p object))) (defun field-at-pos (pos) "Return the field at position POS, taking stickiness etc into account." @@ -5007,7 +5047,7 @@ read-only, and scans it for function and variable names to make them into clickable cross-references. See the related form `with-temp-buffer-window'." - (declare (debug t)) + (declare (debug t) (indent 1)) (let ((old-dir (make-symbol "old-dir")) (buf (make-symbol "buf"))) `(let* ((,old-dir default-directory) @@ -6727,6 +6767,8 @@ effectively rounded up." (progress-reporter-update reporter (or current-value min-value)) reporter)) +(defalias 'progress-reporter-make #'make-progress-reporter) + (defun progress-reporter-force-update (reporter &optional value new-message suffix) "Report progress of an operation in the echo area unconditionally. @@ -7497,6 +7539,28 @@ predicate conditions in CONDITION." (push buf bufs))) bufs)) +(defmacro handler-bind (handlers &rest body) + "Setup error HANDLERS around execution of BODY. +HANDLERS is a list of (CONDITIONS HANDLER) where +CONDITIONS should be a list of condition names (symbols) or +a single condition name, and HANDLER is a form whose evaluation +returns a function. +When an error is signaled during execution of BODY, if that +error matches CONDITIONS, then the associated HANDLER +function is called with the error object as argument. +HANDLERs can either transfer the control via a non-local exit, +or return normally. If a handler returns normally, the search for an +error handler continues from where it left off." + ;; FIXME: Completion support as in `condition-case'? + (declare (indent 1) (debug ((&rest (sexp form)) body))) + (let ((args '())) + (dolist (cond+handler handlers) + (let ((handler (car (cdr cond+handler))) + (conds (car cond+handler))) + (push `',(ensure-list conds) args) + (push handler args))) + `(handler-bind-1 (lambda () ,@body) ,@(nreverse args)))) + (defmacro with-memoization (place &rest code) "Return the value of CODE and stash it in PLACE. If PLACE's value is non-nil, then don't bother evaluating CODE diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el index 219f42848ef..fa22500a04e 100644 --- a/lisp/tab-bar.el +++ b/lisp/tab-bar.el @@ -1302,7 +1302,7 @@ tab bar might wrap to the second line when it shouldn't.") (ws . ,(window-state-get (frame-root-window (or frame (selected-frame))) 'writable)) (wc . ,(current-window-configuration)) - (wc-point . ,(point-marker)) + (wc-point . ,(copy-marker (window-point) window-point-insertion-type)) (wc-bl . ,bl) (wc-bbl . ,bbl) ,@(when tab-bar-history-mode @@ -1385,6 +1385,63 @@ inherits the current tab's `explicit-name' parameter." tabs)))) +(defcustom tab-bar-tab-post-select-functions nil + "List of functions to call after selecting a tab. +Two arguments are supplied: the previous tab that was selected before, +and the newly selected tab." + :type '(repeat function) + :group 'tab-bar + :version "30.1") + +(defcustom tab-bar-select-restore-windows #'tab-bar-select-restore-windows + "Function called when selecting a tab to handle windows whose buffer was killed. +When a tab-bar tab displays a window whose buffer was killed since +this tab was last selected, this function determines what to do with +that window. By default, either a random buffer is displayed instead of +the killed buffer, or the window gets deleted. However, with the help +of `window-restore-killed-buffer-windows' it's possible to handle such +situations better by displaying an information about the killed buffer." + :type '(choice (const :tag "No special handling" nil) + (const :tag "Show placeholder buffers" + tab-bar-select-restore-windows) + (function :tag "Function")) + :group 'tab-bar + :version "30.1") + +(defun tab-bar-select-restore-windows (_frame windows _type) + "Display a placeholder buffer in the window whose buffer was killed. +A button in the window allows to restore the killed buffer, +if it was visiting a file." + (dolist (quad windows) + (when (window-live-p (nth 0 quad)) + (let* ((window (nth 0 quad)) + (old-buffer (nth 1 quad)) + (file (when (bufferp old-buffer) + (buffer-file-name old-buffer))) + (name (or file + (and (bufferp old-buffer) + (fboundp 'buffer-last-name) + (buffer-last-name old-buffer)) + old-buffer)) + (new-buffer (generate-new-buffer + (format "*Old buffer %s*" name)))) + (with-current-buffer new-buffer + (set-auto-mode) + (insert (format-message "This window displayed the %s `%s'.\n" + (if file "file" "buffer") + name)) + (when file + (insert-button + "[Restore]" 'action + (lambda (_button) + (set-window-buffer window (find-file-noselect file)) + (set-window-start window (nth 2 quad) t) + (set-window-point window (nth 3 quad)))) + (insert "\n")) + (goto-char (point-min)) + (setq buffer-read-only t) + (set-window-buffer window new-buffer)))))) + (defvar tab-bar-minibuffer-restore-tab nil "Tab number for `tab-bar-minibuffer-restore-tab'.") @@ -1430,7 +1487,10 @@ Negative TAB-NUMBER counts tabs from the end of the tab bar." (let* ((from-tab (tab-bar--tab)) (to-tab (nth to-index tabs)) (wc (alist-get 'wc to-tab)) - (ws (alist-get 'ws to-tab))) + (ws (alist-get 'ws to-tab)) + (window-restore-killed-buffer-windows + (or tab-bar-select-restore-windows + window-restore-killed-buffer-windows))) ;; During the same session, use window-configuration to switch ;; tabs, because window-configurations are more reliable @@ -1455,13 +1515,7 @@ Negative TAB-NUMBER counts tabs from the end of the tab bar." ;; set-window-configuration does not restore the value of ;; point in the current buffer, so restore it separately. (when (and (markerp wc-point) - (marker-buffer wc-point) - ;; FIXME: After dired-revert, marker relocates to 1. - ;; window-configuration restores point to global point - ;; in this dired buffer, not to its window point, - ;; but this is slightly better than 1. - ;; Maybe better to save dired-filename in each window? - (not (eq 1 (marker-position wc-point)))) + (marker-buffer wc-point)) (goto-char wc-point)) (when wc-bl (set-frame-parameter nil 'buffer-list wc-bl)) @@ -1505,7 +1559,10 @@ Negative TAB-NUMBER counts tabs from the end of the tab bar." (tab-bar--current-tab-make (nth to-index tabs))) (unless tab-bar-mode - (message "Selected tab '%s'" (alist-get 'name to-tab)))) + (message "Selected tab '%s'" (alist-get 'name to-tab))) + + (run-hook-with-args 'tab-bar-tab-post-select-functions + from-tab to-tab)) (force-mode-line-update)))) diff --git a/lisp/tempo.el b/lisp/tempo.el index df78690bd31..b7ad680c2a9 100644 --- a/lisp/tempo.el +++ b/lisp/tempo.el @@ -164,7 +164,7 @@ documentation for the function `tempo-complete-tag' for more info. "Indicates if the tag collection needs to be rebuilt.") (defvar-local tempo-marks nil - "A list of marks to jump to with `\\[tempo-forward-mark]' and `\\[tempo-backward-mark]'.") + "A list of marks to jump to with \\[tempo-forward-mark] and \\[tempo-backward-mark].") (defvar-local tempo-match-finder "\\b\\([[:word:]]+\\)\\=" "The regexp or function used to find the string to match against tags. @@ -198,6 +198,10 @@ This is an abnormal hook where the functions are called with one argument (defvar-local tempo-region-start (make-marker) "Region start when inserting around the region.") +;; Insertion by the template at the region start position should move +;; the marker to preserve the original region contents. +(set-marker-insertion-type tempo-region-start t) + (defvar-local tempo-region-stop (make-marker) "Region stop when inserting around the region.") @@ -333,7 +337,8 @@ possible." (`(r> . ,rest) (if on-region (progn (goto-char tempo-region-stop) - (indent-region (mark) (point) nil)) + (indent-region tempo-region-start + tempo-region-stop)) (tempo-insert-prompt-compat rest))) (`(s ,name) (tempo-insert-named name)) (`(l . ,rest) (dolist (elt rest) (tempo-insert elt on-region))) @@ -344,7 +349,7 @@ possible." ('r> (if on-region (progn (goto-char tempo-region-stop) - (indent-region (mark) (point) nil)) + (indent-region tempo-region-start tempo-region-stop)) (tempo-insert-mark (point-marker)))) ('> (indent-according-to-mode)) ('& (if (not (or (= (current-column) 0) @@ -577,7 +582,7 @@ TAG-LIST is a symbol whose variable value is a tag list created with `tempo-add-tag'. COMPLETION-FUNCTION is an obsolete option for specifying an optional -function or string that is used by `\\[tempo-complete-tag]' to find a +function or string that is used by \\[tempo-complete-tag] to find a string to match the tag against. It has the same definition as the variable `tempo-match-finder'. In this version, supplying a COMPLETION-FUNCTION just sets `tempo-match-finder' locally." diff --git a/lisp/term.el b/lisp/term.el index 1857c9ed9e3..c15f6cf2e9f 100644 --- a/lisp/term.el +++ b/lisp/term.el @@ -658,7 +658,8 @@ executed once, when the buffer is created." ["Forward Output Group" term-next-prompt t] ["Kill Current Output Group" term-kill-output t])) map) - "Keymap for Term mode.") + "Keymap for \"line mode\" in Term mode. For custom keybindings purposes +please note there is also `term-raw-map'") (defvar term-escape-char nil "Escape character for char sub-mode of term mode. @@ -961,7 +962,9 @@ underlying shell." (dotimes (key 21) (keymap-set map (format "<f%d>" key) #'term-send-function-key))) map) - "Keyboard map for sending characters directly to the inferior process.") + "Keyboard map for sending characters directly to the inferior process. +For custom keybindings purposes please note there is also +`term-mode-map'") (easy-menu-define term-terminal-menu (list term-mode-map term-raw-map term-pager-break-map) @@ -1109,7 +1112,7 @@ variable `term-input-autoexpand', and addition is controlled by the variable `term-input-ignoredups'. Input to, and output from, the subprocess can cause the window to scroll to -the end of the buffer. See variables `term-scroll-to-bottom-on-input', +the end of the buffer. See variables `term-scroll-snap-to-bottom', and `term-scroll-to-bottom-on-output'. If you accidentally suspend your process, use \\[term-continue-subjob] @@ -1122,6 +1125,10 @@ particular subprocesses. This can be done by setting the hooks and the variable `term-prompt-regexp' to the appropriate regular expression. +If you define custom keybindings, make sure to assign them to the +correct keymap (or to both): use `term-raw-map' in raw mode and +`term-mode-map' in line mode. + Commands in raw mode: \\{term-raw-map} @@ -4342,7 +4349,7 @@ Typing SPC flushes the help buffer." (display-completion-list (sort completions 'string-lessp))) (message "Hit space to flush") (let (key first) - (if (with-current-buffer (get-buffer "*Completions*") + (if (with-current-buffer "*Completions*" (setq key (read-key-sequence nil) first (aref key 0)) (and (consp first) diff --git a/lisp/term/android-win.el b/lisp/term/android-win.el index 51163e5b9b2..6512ef81ff7 100644 --- a/lisp/term/android-win.el +++ b/lisp/term/android-win.el @@ -282,11 +282,12 @@ If it reflects the motion of an item above a frame, call `dnd-handle-movement' to move the cursor or scroll the window under the item pursuant to the pertinent user options. -If it reflects dropped text, insert such text within window at -the location of the drop. +If it holds dropped text, insert such text within window at the +location of the drop. -If it reflects a list of URIs, then open each URI, converting -content:// URIs into the special file names which represent them." +If it holds a list of URIs, or file names, then open each URI or +file name, converting content:// URIs into the special file +names which represent them." (interactive "e") (let ((message (caddr event)) (posn (event-start event))) @@ -304,18 +305,22 @@ content:// URIs into the special file names which represent them." (new-uri-list nil) (dnd-unescape-file-uris t)) (dolist (uri uri-list) - (ignore-errors - (let ((url (url-generic-parse-url uri))) - (when (equal (url-type url) "content") - ;; Replace URI with a matching /content file - ;; name. - (setq uri (format "file:/content/by-authority/%s%s" - (url-host url) - (url-filename url)) - ;; And guarantee that this file URI is not - ;; subject to URI decoding, for it must be - ;; transformed back into a content URI. - dnd-unescape-file-uris nil)))) + ;; If the URI is a preprepared file name, insert it directly. + (if (string-match-p "^/content/by-authority\\(-named\\)?/" uri) + (setq uri (concat "file:" uri) + dnd-unescape-file-uris nil) + (ignore-errors + (let ((url (url-generic-parse-url uri))) + (when (equal (url-type url) "content") + ;; Replace URI with a matching /content file + ;; name. + (setq uri (format "file:/content/by-authority/%s%s" + (url-host url) + (url-filename url)) + ;; And guarantee that this file URI is not + ;; subject to URI decoding, for it must be + ;; transformed back into a content URI. + dnd-unescape-file-uris nil))))) (push uri new-uri-list)) (dnd-handle-multiple-urls (posn-window posn) new-uri-list @@ -398,7 +403,7 @@ directory /content/storage. (inhibit-read-only t)) (fill-region (point-min) (point-max)))))))) -(defun android-after-splash-screen (fancy-p) +(defun android-before-splash-screen (fancy-p) "Insert a brief notice on the absence of storage permissions. If storage permissions are as yet denied to Emacs, insert a short notice to that effect, followed by a button that enables the user @@ -406,20 +411,20 @@ to grant such permissions. FANCY-P non-nil means the notice will be displayed with faces, in the style appropriate for its incorporation within the fancy splash -screen display; see `francy-splash-insert'." +screen display; see `fancy-splash-insert'." (unless (android-external-storage-available-p) (if fancy-p (fancy-splash-insert :face '(variable-pitch font-lock-function-call-face) - "\nPermissions necessary to access external storage directories have -been denied. Click " + "Permissions necessary to access external storage directories have" + "\nbeen denied. Click " :link '("here" android-display-storage-permission-popup) - " to grant them.") + " to grant them.\n") (insert - "Permissions necessary to access external storage directories have been -denied. ") - (insert-button "Click here to grant them." + "Permissions necessary to access external storage directories" + "\nhave been denied. ") + (insert-button "Click here to grant them.\n" 'action #'android-display-storage-permission-popup 'follow-link t) (newline)))) @@ -480,5 +485,138 @@ the UTF-8 coding system." (concat locale-base locale-modifier))) +;; Miscellaneous functions. + +(declare-function android-browse-url-internal "androidselect.c") + +(defun android-browse-url (url &optional send) + "Open URL in an external application. + +URL should be a URL-encoded URL with a scheme specified unless +SEND is non-nil. Signal an error upon failure. + +If SEND is nil, start a program that is able to display the URL, +such as a web browser. Otherwise, try to share URL using +programs such as email clients. + +If URL is a file URI, convert it into a `content' address +accessible to other programs." + (when-let* ((uri (url-generic-parse-url url)) + (filename (url-filename uri)) + ;; If `uri' is a file URI and the file resides in /content + ;; or /assets, copy it to a temporary file before + ;; providing it to other programs. + (replacement-url (and (string-match-p + "/\\(content\\|assets\\)[/$]" + filename) + (prog1 t + (copy-file + filename + (setq filename + (make-temp-file + "local" + nil + (let ((extension + (file-name-extension + filename))) + (if extension + (concat "." + extension) + nil)))) + t)) + (concat "file://" filename)))) + (setq url replacement-url)) + (android-browse-url-internal url send)) + + +;; Coding systems used by androidvfs.c. + +(define-ccl-program android-encode-jni + `(2 ((loop + (read r0) + (if (r0 < #x1) ; 0x0 is encoded specially in JNI environments. + ((write #xc0) + (write #x80)) + ((if (r0 < #x80) ; ASCII + ((write r0)) + (if (r0 < #x800) ; \u0080 - \u07ff + ((write ((r0 >> 6) | #xC0)) + (write ((r0 & #x3F) | #x80))) + ;; \u0800 - \uFFFF + (if (r0 < #x10000) + ((write ((r0 >> 12) | #xE0)) + (write (((r0 >> 6) & #x3F) | #x80)) + (write ((r0 & #x3F) | #x80))) + ;; Supplementary characters must be converted into + ;; surrogate pairs before encoding. + (;; High surrogate + (r1 = ((((r0 - #x10000) >> 10) & #x3ff) + #xD800)) + ;; Low surrogate. + (r2 = (((r0 - #x10000) & #x3ff) + #xDC00)) + ;; Write both surrogate characters. + (write ((r1 >> 12) | #xE0)) + (write (((r1 >> 6) & #x3F) | #x80)) + (write ((r1 & #x3F) | #x80)) + (write ((r2 >> 12) | #xE0)) + (write (((r2 >> 6) & #x3F) | #x80)) + (write ((r2 & #x3F) | #x80)))))))) + (repeat)))) + "Encode characters from the input buffer for Java virtual machines.") + +(define-ccl-program android-decode-jni + `(1 ((loop + ((read-if (r0 >= #x80) ; More than a one-byte sequence? + ((if (r0 < #xe0) + ;; Two-byte sequence; potentially a NULL + ;; character. + ((read r4) + (r4 &= #x3f) + (r0 = (((r0 & #x1f) << 6) | r4))) + (if (r0 < ?\xF0) + ;; Three-byte sequence, after which surrogate + ;; pairs should be processed. + ((read r4 r6) + (r4 = ((r4 & #x3f) << 6)) + (r6 &= #x3f) + (r0 = ((((r0 & #xf) << 12) | r4) | r6))) + ;; Four-byte sequences are not valid under the + ;; JVM specification, but Android produces them + ;; when encoding Emoji characters for being + ;; supposedly less of a surprise to applications. + ;; This is obviously not true of programs written + ;; to the letter of the documentation, but 50 + ;; million Frenchmen make a right (and this + ;; deviation from the norm is predictably absent + ;; from Android's documentation on the subject). + ((read r1 r4 r6) + (r1 = ((r1 & #x3f) << 12)) + (r4 = ((r4 & #x3f) << 6)) + (r6 &= #x3F) + (r0 = (((((r0 & #x07) << 18) | r1) | r4) | r6)))))))) + (if ((r0 & #xf800) == #xd800) + ;; High surrogate. + ((read-if (r2 >= #xe0) + ((r0 = ((r0 & #x3ff) << 10)) + (read r4 r6) + (r4 = ((r4 & #x3f) << 6)) + (r6 &= #x3f) + (r1 = ((((r2 & #xf) << 12) | r4) | r6)) + (r0 = (((r1 & #x3ff) | r0) + #xffff)))))) + (write r0) + (repeat)))) + "Decode JVM-encoded characters in the input buffer.") + +(define-coding-system 'android-jni + "CESU-8 based encoding for communication with the Android runtime." + :mnemonic ?J + :coding-type 'ccl + :eol-type 'unix + :ascii-compatible-p nil ; for \0 is encoded as a two-byte sequence. + :default-char ?\0 + :charset-list '(unicode) + :ccl-decoder 'android-decode-jni + :ccl-encoder 'android-encode-jni) + + (provide 'android-win) ;; android-win.el ends here. diff --git a/lisp/term/pc-win.el b/lisp/term/pc-win.el index 02ad6b85c37..92d65c75816 100644 --- a/lisp/term/pc-win.el +++ b/lisp/term/pc-win.el @@ -47,7 +47,7 @@ ;; This was copied from etc/rgb.txt, except that some values were changed ;; a bit to make them consistent with DOS console colors, and the RGB -;; values were scaled up to 16 bits, as `tty-define-color' requires. +;; values were scaled up to 16 bits, as `tty-color-define' requires. ;;; ;; The mapping between the 16 standard EGA/VGA colors and X color names ;; was done by running a Unix version of Emacs inside an X client and a diff --git a/lisp/textmodes/bibtex.el b/lisp/textmodes/bibtex.el index a8e2f03bd70..a6da34d6a41 100644 --- a/lisp/textmodes/bibtex.el +++ b/lisp/textmodes/bibtex.el @@ -1012,7 +1012,7 @@ if `bibtex-BibTeX-entry-alist' does not define a comment for FIELD." ("volumes" "Total number of volumes of a multi-volume work") ("year" "Year of publication")) "Alist of biblatex fields. -It has the same format as `bibtex-BibTeX-entry-alist'." +It has the same format as `bibtex-BibTeX-field-alist'." :group 'bibtex :version "28.1" :type 'bibtex-field-alist) diff --git a/lisp/textmodes/css-mode.el b/lisp/textmodes/css-mode.el index 425f3ec8a30..f5a20e0ca0e 100644 --- a/lisp/textmodes/css-mode.el +++ b/lisp/textmodes/css-mode.el @@ -1830,6 +1830,8 @@ can also be used to fill comments. (add-to-list 'auto-mode-alist '("\\.css\\'" . css-ts-mode)))) +(derived-mode-add-parents 'css-ts-mode '(css-mode)) + ;;;###autoload (define-derived-mode css-mode css-base-mode "CSS" "Major mode to edit Cascading Style Sheets (CSS). diff --git a/lisp/textmodes/flyspell.el b/lisp/textmodes/flyspell.el index de59294e9f0..09d4e8a8d1a 100644 --- a/lisp/textmodes/flyspell.el +++ b/lisp/textmodes/flyspell.el @@ -288,6 +288,15 @@ If this variable is nil, all regions are treated as small." "The key binding for flyspell auto correction." :type 'key-sequence) +(defcustom flyspell-check-changes nil + "If non-nil, spell-check only words that were edited. +By default, this is nil, and Flyspell checks every word across which +you move point, even if you haven't edited the word. Customizing this +option to a non-nil value will not flag mis-spelled words across which +you move point without editing them." + :type 'boolean + :version "30.1") + ;;*---------------------------------------------------------------------*/ ;;* Mode specific options */ ;;* ------------------------------------------------------------- */ @@ -610,7 +619,9 @@ are both non-nil." (flyspell-accept-buffer-local-defs 'force) (flyspell-delay-commands) (flyspell-deplacement-commands) - (add-hook 'post-command-hook (function flyspell-post-command-hook) t t) + (if flyspell-check-changes + (add-hook 'post-command-hook (function flyspell-check-changes) t t) + (add-hook 'post-command-hook (function flyspell-post-command-hook) t t)) (add-hook 'pre-command-hook (function flyspell-pre-command-hook) t t) (add-hook 'after-change-functions 'flyspell-after-change-function nil t) (add-hook 'hack-local-variables-hook @@ -709,6 +720,7 @@ has been used, the current word is not checked." ;;;###autoload (defun flyspell--mode-off () "Turn Flyspell mode off." + (remove-hook 'post-command-hook (function flyspell-check-changes) t) (remove-hook 'post-command-hook (function flyspell-post-command-hook) t) (remove-hook 'pre-command-hook (function flyspell-pre-command-hook) t) (remove-hook 'after-change-functions 'flyspell-after-change-function t) @@ -990,6 +1002,23 @@ Mostly we check word delimiters." (setq flyspell-changes (cdr flyspell-changes)))) (setq flyspell-previous-command command))))) +(defun flyspell-check-changes () + "Function to spell-check only edited words when point moves off the word. +This is installed by flyspell as `post-command-hook' when the user +option `flyspell-check-changes' is non-nil. It spell-checks a word +on moving point from the word only if the word was edited before the move." + (when flyspell-mode + (with-local-quit + (when (consp flyspell-changes) + (let ((start (car (car flyspell-changes))) + (stop (cdr (car flyspell-changes))) + (word (save-excursion (flyspell-get-word)))) + (unless (and word (<= (nth 1 word) start) (>= (nth 2 word) stop)) + (save-excursion + (goto-char start) + (flyspell-word)) + (setq flyspell-changes nil))))))) + ;;*---------------------------------------------------------------------*/ ;;* flyspell-notify-misspell ... */ ;;*---------------------------------------------------------------------*/ diff --git a/lisp/textmodes/html-ts-mode.el b/lisp/textmodes/html-ts-mode.el index 301f3e8791c..235e1055fa9 100644 --- a/lisp/textmodes/html-ts-mode.el +++ b/lisp/textmodes/html-ts-mode.el @@ -121,8 +121,21 @@ Return nil if there is no name or if NODE is not a defun node." ;; Imenu. (setq-local treesit-simple-imenu-settings '(("Element" "\\`tag_name\\'" nil nil))) + + ;; Outline minor mode. + (setq-local treesit-outline-predicate "\\`element\\'") + ;; `html-ts-mode' inherits from `html-mode' that sets + ;; regexp-based outline variables. So need to restore + ;; the default values of outline variables to be able + ;; to use `treesit-outline-predicate' above. + (kill-local-variable 'outline-regexp) + (kill-local-variable 'outline-heading-end-regexp) + (kill-local-variable 'outline-level) + (treesit-major-mode-setup)) +(derived-mode-add-parents 'html-ts-mode '(html-mode)) + (if (treesit-ready-p 'html) (add-to-list 'auto-mode-alist '("\\.html\\'" . html-ts-mode))) diff --git a/lisp/textmodes/page.el b/lisp/textmodes/page.el index e8621ee0383..a5de354fc0a 100644 --- a/lisp/textmodes/page.el +++ b/lisp/textmodes/page.el @@ -159,21 +159,23 @@ point, respectively." total before after))) (defun page--what-page () - "Return a list of the page and line number of point." + "Return a list of the page and line number of point. +The line number is relative to the start of the page." (save-restriction (widen) (save-excursion (let ((count 1) + (adjust (if (or (bolp) (looking-back page-delimiter nil)) 1 0)) (opoint (point))) (goto-char (point-min)) (while (re-search-forward page-delimiter opoint t) (when (= (match-beginning 0) (match-end 0)) (forward-char)) (setq count (1+ count))) - (list count (line-number-at-pos opoint)))))) + (list count (+ adjust (count-lines (point) opoint))))))) (defun what-page () - "Print page and line number of point." + "Display the page number, and the line number within that page." (interactive) (apply #'message (cons "Page %d, line %d" (page--what-page)))) diff --git a/lisp/textmodes/pixel-fill.el b/lisp/textmodes/pixel-fill.el index 25c0b46cee9..d26eaec2111 100644 --- a/lisp/textmodes/pixel-fill.el +++ b/lisp/textmodes/pixel-fill.el @@ -73,39 +73,41 @@ lines that are visually wider than PIXEL-WIDTH. If START isn't at the start of a line, the horizontal position of START, converted to pixel units, will be used as the indentation prefix on subsequent lines." - (save-excursion - (goto-char start) - (let ((indentation - (car (window-text-pixel-size nil (line-beginning-position) - (point)))) - (newline-end nil)) - (when (> indentation pixel-width) - (error "The indentation (%s) is wider than the fill width (%s)" - indentation pixel-width)) - (save-restriction - (narrow-to-region start end) - (goto-char (point-max)) - (when (looking-back "\n[ \t]*" (point-min)) - (setq newline-end t)) - (goto-char (point-min)) - ;; First replace all whitespace with space. - (while (re-search-forward "[ \t\n]+" nil t) - (cond - ((or (= (match-beginning 0) start) - (= (match-end 0) end)) - (delete-region (match-beginning 0) (match-end 0))) - ;; If there's just a single space here, don't replace. - ((not (and (= (- (match-end 0) (match-beginning 0)) 1) - (= (char-after (match-beginning 0)) ?\s))) - (replace-match - ;; We need to use a space that has an appropriate width. - (propertize " " 'face - (get-text-property (match-beginning 0) 'face)))))) - (goto-char start) - (pixel-fill--fill-line pixel-width indentation) - (goto-char (point-max)) - (when newline-end - (insert "\n")))))) + (save-window-excursion + (set-window-buffer nil (current-buffer)) + (save-excursion + (goto-char start) + (let ((indentation + (car (window-text-pixel-size nil (line-beginning-position) + (point)))) + (newline-end nil)) + (when (> indentation pixel-width) + (error "The indentation (%s) is wider than the fill width (%s)" + indentation pixel-width)) + (save-restriction + (narrow-to-region start end) + (goto-char (point-max)) + (when (looking-back "\n[ \t]*" (point-min)) + (setq newline-end t)) + (goto-char (point-min)) + ;; First replace all whitespace with space. + (while (re-search-forward "[ \t\n]+" nil t) + (cond + ((or (= (match-beginning 0) start) + (= (match-end 0) end)) + (delete-region (match-beginning 0) (match-end 0))) + ;; If there's just a single space here, don't replace. + ((not (and (= (- (match-end 0) (match-beginning 0)) 1) + (= (char-after (match-beginning 0)) ?\s))) + (replace-match + ;; We need to use a space that has an appropriate width. + (propertize " " 'face + (get-text-property (match-beginning 0) 'face)))))) + (goto-char start) + (pixel-fill--fill-line pixel-width indentation) + (goto-char (point-max)) + (when newline-end + (insert "\n"))))))) (defun pixel-fill--goto-pixel (width) (vertical-motion (cons (/ width (frame-char-width)) 0))) diff --git a/lisp/textmodes/refill.el b/lisp/textmodes/refill.el index bb6b6ebda0f..63789e887e2 100644 --- a/lisp/textmodes/refill.el +++ b/lisp/textmodes/refill.el @@ -106,10 +106,10 @@ This is used to optimize refilling.") ;; FIXME: forward-paragraph seems to disregard `use-hard-newlines', ;; leading to excessive refilling and wrong choice of fill-prefix. ;; might be a bug in my paragraphs.el. - (forward-paragraph) + (fill-forward-paragraph 1) (skip-syntax-backward "-") (let ((end (point)) - (beg (progn (backward-paragraph) (point))) + (beg (progn (fill-forward-paragraph -1) (point))) (obeg (overlay-start refill-ignorable-overlay)) (oend (overlay-end refill-ignorable-overlay))) (unless (> beg pos) ;Don't fill if point is outside the paragraph. diff --git a/lisp/textmodes/reftex-vars.el b/lisp/textmodes/reftex-vars.el index a0bc5c11ece..791b10412c9 100644 --- a/lisp/textmodes/reftex-vars.el +++ b/lisp/textmodes/reftex-vars.el @@ -235,11 +235,10 @@ distribution. Mixed-case symbols are convenience aliases.") "ConTeXt bib module" ((?\C-m . "\\cite[%l]") (?s . "\\cite[][%l]") - (?n . "\\nocite[%l]"))) - ) + (?n . "\\nocite[%l]")))) "Builtin versions of the citation format. The following conventions are valid for all alist entries: -`?\C-m' should always point to a straight \\cite{%l} macro. +`?\\C-m' should always point to a straight \\cite{%l} macro. `?t' should point to a textual citation (citation as a noun). `?p' should point to a parenthetical citation.") diff --git a/lisp/textmodes/rst.el b/lisp/textmodes/rst.el index 2cd78943883..5fbff4ba888 100644 --- a/lisp/textmodes/rst.el +++ b/lisp/textmodes/rst.el @@ -1147,14 +1147,14 @@ as well but give an additional message." (unless (fboundp forwarder-function) (defalias forwarder-function (lambda () + (:documentation + (format "Deprecated binding for %s, use \\[%s] instead." + def def)) (interactive) (call-interactively def) (message "[Deprecated use of key %s; use key %s instead]" (key-description (this-command-keys)) - (key-description key))) - ;; FIXME: In Emacs-25 we could use (:documentation ...) instead. - (format "Deprecated binding for %s, use \\[%s] instead." - def def))) + (key-description key))))) (dolist (dep-key deprecated) (define-key keymap dep-key forwarder-function))))) diff --git a/lisp/textmodes/tex-mode.el b/lisp/textmodes/tex-mode.el index 8968d8ec23b..02ee1242c72 100644 --- a/lisp/textmodes/tex-mode.el +++ b/lisp/textmodes/tex-mode.el @@ -511,17 +511,26 @@ An alternative value is \" . \", if you use a font with a narrow period." ;; This would allow highlighting \newcommand\CMD but requires ;; adapting subgroup numbers below. ;; (arg "\\(?:{\\(\\(?:[^{}\\]+\\|\\\\.\\|{[^}]*}\\)+\\)\\|\\\\[a-z*]+\\)")) - (inbraces-re (lambda (re) - (concat "\\(?:[^{}\\]\\|\\\\.\\|" re "\\)"))) - (arg (concat "{\\(" (funcall inbraces-re "{[^}]*}") "+\\)"))) - `( ;; Highlight $$math$$ and $math$. + (inbraces-re + (lambda (n) ;; Level of nesting of braces we should support. + (let ((re "[^}]")) + (dotimes (_ n) + (setq re + (concat "\\(?:[^{}\\]\\|\\\\.\\|{" re "*}\\)"))) + re))) + (arg (concat "{\\(" (funcall inbraces-re 2) "+\\)"))) + `(;; Verbatim-like args. + ;; Do it first, because we don't want to highlight them + ;; in comments (bug#68827), but we do want to highlight them + ;; in $math$. + (,(concat slash verbish opt arg) 3 'tex-verbatim keep) + ;; Highlight $$math$$ and $math$. ;; This is done at the very beginning so as to interact with the other ;; keywords in the same way as comments and strings. (,(concat "\\$\\$?\\(?:[^$\\{}]\\|\\\\.\\|{" - (funcall inbraces-re - (concat "{" (funcall inbraces-re "{[^}]*}") "*}")) + (funcall inbraces-re 6) "*}\\)+\\$?\\$") - (0 'tex-math)) + (0 'tex-math keep)) ;; Heading args. (,(concat slash headings "\\*?" opt arg) ;; If ARG ends up matching too much (if the {} don't match, e.g.) @@ -543,8 +552,6 @@ An alternative value is \" . \", if you use a font with a narrow period." (,(concat slash variables " *" arg) 2 font-lock-variable-name-face) ;; Include args. (,(concat slash includes opt arg) 3 font-lock-builtin-face) - ;; Verbatim-like args. - (,(concat slash verbish opt arg) 3 'tex-verbatim t) ;; Definitions. I think. ("^[ \t]*\\\\def *\\\\\\(\\(\\w\\|@\\)+\\)" 1 font-lock-function-name-face)))) @@ -602,14 +609,14 @@ An alternative value is \" . \", if you use a font with a narrow period." (list (concat (regexp-opt '("``" "\"<" "\"`" "<<" "«") t) "\\(\\(.\\|\n\\)+?\\)" (regexp-opt `("''" "\">" "\"'" ">>" "»") t)) - '(1 font-lock-keyword-face) - '(2 font-lock-string-face) - '(4 font-lock-keyword-face)) + '(1 'font-lock-keyword-face) + '(2 'font-lock-string-face) + '(4 'font-lock-keyword-face)) ;; ;; Command names, special and general. (cons (concat slash specials-1) 'font-lock-warning-face) (list (concat "\\(" slash specials-2 "\\)\\([^a-zA-Z@]\\|\\'\\)") - 1 'font-lock-warning-face) + '(1 'font-lock-warning-face)) (concat slash general) ;; ;; Font environments. It seems a bit dubious to use `bold' etc. faces @@ -677,7 +684,7 @@ An alternative value is \" . \", if you use a font with a narrow period." (eval-when-compile (defconst tex-syntax-propertize-rules (syntax-propertize-precompile-rules - ("\\\\verb\\**\\([^a-z@*]\\)" + ("\\\\verb\\**\\([^a-z@*]\\)" (1 (prog1 "\"" (tex-font-lock-verb (match-beginning 0) (char-after (match-beginning 1)))))))) @@ -761,7 +768,7 @@ automatically inserts its partner." (regexp-quote (buffer-substring arg-start arg-end))) (text-clone-create arg-start arg-end)))))))) (scan-error nil) - (error (message "Error in latex-env-before-change: %s" err))))) + (error (message "Error in latex-env-before-change: %S" err))))) (defun tex-font-lock-unfontify-region (beg end) (font-lock-default-unfontify-region beg end) @@ -849,7 +856,7 @@ START is the position of the \\ and DELIM is the delimiter char." (let ((char (nth 3 state))) (cond ((not char) - (if (eq 2 (nth 7 state)) 'tex-verbatim font-lock-comment-face)) + (if (eq 2 (nth 7 state)) 'tex-verbatim 'font-lock-comment-face)) ((eq char ?$) 'tex-math) ;; A \verb element. (t 'tex-verbatim)))) @@ -1029,14 +1036,20 @@ says which mode to use." ;; `tex--guess-mode' really tries to guess the *type* of file, ;; so we still need to consult `major-mode-remap-alist' ;; to see which mode to use for that type. - (alist-get mode major-mode-remap-alist mode)))))) + (major-mode-remap mode)))))) -;; The following three autoloaded aliases appear to conflict with -;; AUCTeX. We keep those confusing aliases for those users who may -;; have files annotated with -*- LaTeX -*- (e.g. because they received +;; Support files annotated with -*- LaTeX -*- (e.g. because they received ;; them from someone using AUCTeX). -;; FIXME: Turn them into autoloads so that AUCTeX can override them -;; with its own autoloads? Or maybe rely on `major-mode-remap-alist'? +;;;###autoload (add-to-list 'major-mode-remap-defaults '(TeX-mode . tex-mode)) +;;;###autoload (add-to-list 'major-mode-remap-defaults '(plain-TeX-mode . plain-tex-mode)) +;;;###autoload (add-to-list 'major-mode-remap-defaults '(LaTeX-mode . latex-mode)) + +;; FIXME: These aliases conflict with AUCTeX, but we still need them +;; because of packages out there which call these functions directly. +;; They should be patched to use `major-mode-remap'. +;; It would be nice to mark them obsolete somehow to encourage using +;; something else, but the obsolete declaration would become invalid +;; and confusing when AUCTeX *is* installed. ;;;###autoload (defalias 'TeX-mode #'tex-mode) ;;;###autoload (defalias 'plain-TeX-mode #'plain-tex-mode) ;;;###autoload (defalias 'LaTeX-mode #'latex-mode) @@ -1262,8 +1275,8 @@ Entering SliTeX mode runs the hook `text-mode-hook', then the hook (setq-local facemenu-end-add-face "}") (setq-local facemenu-remove-face-function t) (setq-local font-lock-defaults - '((tex-font-lock-keywords tex-font-lock-keywords-1 - tex-font-lock-keywords-2 tex-font-lock-keywords-3) + '(( tex-font-lock-keywords tex-font-lock-keywords-1 + tex-font-lock-keywords-2 tex-font-lock-keywords-3) nil nil nil nil ;; Who ever uses that anyway ??? (font-lock-mark-block-function . mark-paragraph) diff --git a/lisp/textmodes/text-mode.el b/lisp/textmodes/text-mode.el index 7d3b47a9c03..e8e1f4898ce 100644 --- a/lisp/textmodes/text-mode.el +++ b/lisp/textmodes/text-mode.el @@ -75,17 +75,25 @@ Many other modes, such as `mail-mode' and `outline-mode', inherit all the commands defined in this map.") -(defcustom text-mode-meta-tab-ispell-complete-word nil - "Whether M-TAB invokes `ispell-complete-word' in Text mode. +(defcustom text-mode-ispell-word-completion 'completion-at-point + "How Text mode provides Ispell word completion. + +By default, this option is set to `completion-at-point', which +means that Text mode adds an Ispell word completion function to +`completion-at-point-functions'. Any other non-nil value says to +bind M-TAB directly to `ispell-complete-word' instead. If this +is nil, Text mode neither binds M-TAB to `ispell-complete-word' +nor does it extend `completion-at-point-functions'. This user option only takes effect when you customize it in Custom or with `setopt', not with `setq'." :group 'text - :type 'boolean + :type '(choice (const completion-at-point) boolean) :version "30.1" :set (lambda (sym val) - (if (set sym val) - (keymap-set text-mode-map "C-M-i" #'ispell-complete-word) + (if (and (set sym val) + (not (eq val 'completion-at-point))) + (keymap-set text-mode-map "C-M-i" #'ispell-complete-word) (keymap-unset text-mode-map "C-M-i" t)))) (easy-menu-define text-mode-menu text-mode-map @@ -144,7 +152,8 @@ Turning on Text mode runs the normal hook `text-mode-hook'." ;; Enable text conversion in this buffer. (setq-local text-conversion-style t) (add-hook 'context-menu-functions 'text-mode-context-menu 10 t) - (add-hook 'completion-at-point-functions #'ispell-completion-at-point 10 t)) + (when (eq text-mode-ispell-word-completion 'completion-at-point) + (add-hook 'completion-at-point-functions #'ispell-completion-at-point 10 t))) (define-derived-mode paragraph-indent-text-mode text-mode "Parindent" "Major mode for editing text, with leading spaces starting a paragraph. diff --git a/lisp/textmodes/toml-ts-mode.el b/lisp/textmodes/toml-ts-mode.el index 1ba410045f5..1b621032f8a 100644 --- a/lisp/textmodes/toml-ts-mode.el +++ b/lisp/textmodes/toml-ts-mode.el @@ -153,6 +153,8 @@ Return nil if there is no name or if NODE is not a defun node." (treesit-major-mode-setup))) +(derived-mode-add-parents 'toml-ts-mode '(toml-mode)) + (if (treesit-ready-p 'toml) (add-to-list 'auto-mode-alist '("\\.toml\\'" . toml-ts-mode))) diff --git a/lisp/textmodes/yaml-ts-mode.el b/lisp/textmodes/yaml-ts-mode.el index 2b57b384300..210835585fe 100644 --- a/lisp/textmodes/yaml-ts-mode.el +++ b/lisp/textmodes/yaml-ts-mode.el @@ -30,6 +30,9 @@ (require 'treesit) (declare-function treesit-parser-create "treesit.c") +(declare-function treesit-node-start "treesit.c") +(declare-function treesit-node-end "treesit.c") +(declare-function treesit-node-type "treesit.c") (defvar yaml-ts-mode--syntax-table (let ((table (make-syntax-table))) @@ -117,6 +120,27 @@ '((ERROR) @font-lock-warning-face)) "Tree-sitter font-lock settings for `yaml-ts-mode'.") +(defun yaml-ts-mode--fill-paragraph (&optional justify) + "Fill paragraph. +Behaves like `fill-paragraph', but respects block node +boundaries. JUSTIFY is passed to `fill-paragraph'." + (interactive "*P") + (save-restriction + (widen) + (let ((node (treesit-node-at (point)))) + (if (member (treesit-node-type node) '("block_scalar" "comment")) + (let* ((start (treesit-node-start node)) + (end (treesit-node-end node)) + (start-marker (point-marker)) + (fill-paragraph-function nil)) + (save-excursion + (goto-char start) + (forward-line) + (move-marker start-marker (point)) + (narrow-to-region (point) end)) + (fill-region start-marker end justify)) + t)))) + ;;;###autoload (define-derived-mode yaml-ts-mode text-mode "YAML" "Major mode for editing YAML, powered by tree-sitter." @@ -141,8 +165,12 @@ (constant escape-sequence number property) (bracket delimiter error misc-punctuation))) + (setq-local fill-paragraph-function #'yaml-ts-mode--fill-paragraph) + (treesit-major-mode-setup))) +(derived-mode-add-parents 'yaml-ts-mode '(yaml-mode)) + (if (treesit-ready-p 'yaml) (add-to-list 'auto-mode-alist '("\\.ya?ml\\'" . yaml-ts-mode))) diff --git a/lisp/thingatpt.el b/lisp/thingatpt.el index 323d3d1cf6c..7896ad984df 100644 --- a/lisp/thingatpt.el +++ b/lisp/thingatpt.el @@ -619,36 +619,20 @@ point. Optional argument DISTANCE limits search for REGEXP forward and back from point." - (save-excursion - (let ((old-point (point)) - (forward-bound (and distance (+ (point) distance))) - (backward-bound (and distance (- (point) distance))) - match prev-pos new-pos) - (and (looking-at regexp) - (>= (match-end 0) old-point) - (setq match (point))) - ;; Search back repeatedly from end of next match. - ;; This may fail if next match ends before this match does. - (re-search-forward regexp forward-bound 'limit) - (setq prev-pos (point)) - (while (and (setq new-pos (re-search-backward regexp backward-bound t)) - ;; Avoid inflooping with some regexps, such as "^", - ;; matching which never moves point. - (< new-pos prev-pos) - (or (> (match-beginning 0) old-point) - (and (looking-at regexp) ; Extend match-end past search start - (>= (match-end 0) old-point) - (setq match (point)))))) - (if (not match) nil - (goto-char match) - ;; Back up a char at a time in case search skipped - ;; intermediate match straddling search start pos. - (while (and (not (bobp)) - (progn (backward-char 1) (looking-at regexp)) - (>= (match-end 0) old-point) - (setq match (point)))) - (goto-char match) - (looking-at regexp))))) + (let* ((old (point)) + (beg (if distance (max (point-min) (- old distance)) (point-min))) + (end (if distance (min (point-max) (+ old distance)))) + prev match) + (save-excursion + (goto-char beg) + (while (and (setq prev (point) + match (re-search-forward regexp end t)) + (< (match-end 0) old)) + (goto-char (match-beginning 0)) + ;; Avoid inflooping when `regexp' matches the empty string. + (unless (< prev (point)) (forward-char)))) + (and match (<= (match-beginning 0) old (match-end 0))))) + ;; Email addresses (defvar thing-at-point-email-regexp @@ -751,20 +735,33 @@ Signal an error if the entire string was not used." (let ((thing (thing-at-point 'symbol))) (if thing (intern thing)))) +(defvar thing-at-point-decimal-regexp + "-?[0-9]+\\.?[0-9]*" + "A regexp matching a decimal number.") + +(defvar thing-at-point-hexadecimal-regexp + "\\(0x\\|#x\\)\\([a-fA-F0-9]+\\)" + "A regexp matchin a hexadecimal number.") + ;;;###autoload (defun number-at-point () "Return the number at point, or nil if none is found. Decimal numbers like \"14\" or \"-14.5\", as well as hex numbers like \"0xBEEF09\" or \"#xBEEF09\", are recognized." (cond - ((thing-at-point-looking-at "\\(0x\\|#x\\)\\([a-fA-F0-9]+\\)" 500) + ((thing-at-point-looking-at thing-at-point-hexadecimal-regexp 500) (string-to-number (buffer-substring (match-beginning 2) (match-end 2)) 16)) - ((thing-at-point-looking-at "-?[0-9]+\\.?[0-9]*" 500) + ((thing-at-point-looking-at thing-at-point-decimal-regexp 500) (string-to-number (buffer-substring (match-beginning 0) (match-end 0)))))) +(put 'number 'bounds-of-thing-at-point + (lambda () + (and (or (thing-at-point-looking-at thing-at-point-hexadecimal-regexp 500) + (thing-at-point-looking-at thing-at-point-decimal-regexp 500)) + (cons (match-beginning 0) (match-end 0))))) (put 'number 'forward-op 'forward-word) (put 'number 'thing-at-point 'number-at-point) diff --git a/lisp/time.el b/lisp/time.el index e561f36398c..a8d3ab9c813 100644 --- a/lisp/time.el +++ b/lisp/time.el @@ -589,7 +589,7 @@ See `world-clock'." (defun world-clock () "Display a world clock buffer with times in various time zones. The variable `world-clock-list' specifies which time zones to use. -To turn off the world time display, go to the window and type `\\[quit-window]'." +To turn off the world time display, go to the window and type \\[quit-window]." (interactive) (if-let ((buffer (get-buffer world-clock-buffer-name))) (pop-to-buffer buffer) @@ -611,7 +611,7 @@ To turn off the world time display, go to the window and type `\\[quit-window]'. (defun world-clock-update (&optional _arg _noconfirm) "Update the `world-clock' buffer." (if (get-buffer world-clock-buffer-name) - (with-current-buffer (get-buffer world-clock-buffer-name) + (with-current-buffer world-clock-buffer-name (let ((op (point))) (world-clock-display (time--display-world-list)) (goto-char op))) diff --git a/lisp/tool-bar.el b/lisp/tool-bar.el index 4ca81fb01e0..96b61c7b229 100644 --- a/lisp/tool-bar.el +++ b/lisp/tool-bar.el @@ -165,6 +165,8 @@ color capability and based on the available image libraries." base-keymap) base-keymap))) +;; This function should return binds even if images can not be +;; displayed so the tool bar can still be displayed on terminals. (defun tool-bar-make-keymap-1 (&optional map) "Generate an actual keymap from `tool-bar-map', without caching. MAP is either a keymap to use as a source for menu items, or nil, @@ -180,15 +182,14 @@ in which case the value of `tool-bar-map' is used instead." (consp image-exp) (not (eq (car image-exp) 'image)) (fboundp (car image-exp))) - (if (not (display-images-p)) - (setq bind nil) - (let ((image (eval image-exp))) - (unless (and image (image-mask-p image)) - (setq image (append image '(:mask heuristic)))) - (setq bind (copy-sequence bind) - plist (nthcdr (if (consp (nth 4 bind)) 5 4) - bind)) - (plist-put plist :image image)))) + (let ((image (and (display-images-p) + (eval image-exp)))) + (unless (and image (image-mask-p image)) + (setq image (append image '(:mask heuristic)))) + (setq bind (copy-sequence bind) + plist (nthcdr (if (consp (nth 4 bind)) 5 4) + bind)) + (plist-put plist :image image))) bind)) (or map tool-bar-map))) diff --git a/lisp/touch-screen.el b/lisp/touch-screen.el index c2f8f8068d7..c8de1d8ee31 100644 --- a/lisp/touch-screen.el +++ b/lisp/touch-screen.el @@ -87,7 +87,7 @@ is being called from `read-sequence' or some similar function.") (defgroup touch-screen nil "Interact with Emacs from touch screen devices." :group 'mouse - :version "30.0") + :version "30.1") (defcustom touch-screen-display-keyboard nil "If non-nil, always display the on screen keyboard. @@ -1027,7 +1027,7 @@ POINT was initially placed upon, and pixel deltas describing how much point has moved relative to its previous position in the X and Y axes. -If the fourth element of `touchscreen-current-tool' is `scroll', +If the fourth element of `touch-screen-current-tool' is `scroll', then generate a `touchscreen-scroll' event with the window that POINT was initially placed upon, and pixel deltas describing how much point has moved relative to its previous position in the X diff --git a/lisp/transient.el b/lisp/transient.el index f9060f5ba85..c3b9448e2c4 100644 --- a/lisp/transient.el +++ b/lisp/transient.el @@ -5,7 +5,7 @@ ;; Author: Jonas Bernoulli <jonas@bernoul.li> ;; URL: https://github.com/magit/transient ;; Keywords: extensions -;; Version: 0.5.2 +;; Version: 0.6.0 ;; SPDX-License-Identifier: GPL-3.0-or-later @@ -93,17 +93,20 @@ enclosed in a `progn' form. ELSE-FORMS may be empty." then-form (cons 'progn else-forms))) -(defmacro transient--with-emergency-exit (&rest body) +(defmacro transient--with-emergency-exit (id &rest body) (declare (indent defun)) + (unless (keywordp id) + (setq body (cons id body)) + (setq id nil)) `(condition-case err (let ((debugger #'transient--exit-and-debug)) ,(macroexp-progn body)) ((debug error) - (transient--emergency-exit) + (transient--emergency-exit ,id) (signal (car err) (cdr err))))) (defun transient--exit-and-debug (&rest args) - (transient--emergency-exit) + (transient--emergency-exit :debugger) (apply #'debug args)) ;;; Options @@ -668,6 +671,7 @@ If `transient-save-history' is nil, then do nothing." (incompatible :initarg :incompatible :initform nil) (suffix-description :initarg :suffix-description) (variable-pitch :initarg :variable-pitch :initform nil) + (column-widths :initarg :column-widths :initform nil) (unwind-suffix :documentation "Internal use." :initform nil)) "Transient prefix command. @@ -725,7 +729,8 @@ slot is non-nil." :abstract t) (defclass transient-suffix (transient-child) - ((key :initarg :key) + ((definition :allocation :class :initform nil) + (key :initarg :key) (command :initarg :command) (transient :initarg :transient) (format :initarg :format :initform " %k %d") @@ -855,7 +860,6 @@ elements themselves.") ;;; Define -;;;###autoload (defmacro transient-define-prefix (name arglist &rest args) "Define NAME as a transient prefix command. @@ -947,7 +951,10 @@ ARGLIST. The infix arguments are usually accessed by using (pcase-let ((`(,class ,slots ,_ ,docstr ,body) (transient--expand-define-args args arglist))) `(progn - (defalias ',name (lambda ,arglist ,@body)) + (defalias ',name + ,(if (and (not body) class (oref-default class definition)) + `(oref-default ',class definition) + `(lambda ,arglist ,@body))) (put ',name 'interactive-only t) (put ',name 'function-documentation ,docstr) (put ',name 'transient--suffix @@ -998,7 +1005,7 @@ keyword. `(progn (defalias ',name #'transient--default-infix-command) (put ',name 'interactive-only t) - (put ',name 'command-modes (list 'not-a-mode)) + (put ',name 'completion-predicate #'transient--suffix-only) (put ',name 'function-documentation ,docstr) (put ',name 'transient--suffix (,(or class 'transient-switch) :command ',name ,@slots))))) @@ -1014,21 +1021,39 @@ example, sets a variable, use `transient-define-infix' instead. (defun transient--default-infix-command () ;; Most infix commands are but an alias for this command. - "Cannot show any documentation for this anonymous infix command. + "Cannot show any documentation for this transient infix command. + +When you request help for an infix command using `transient-help', that +usually shows the respective man-page and tries to jump to the location +where the respective argument is being described. + +If no man-page is specified for the containing transient menu, then the +docstring is displayed instead, if any. -This infix command was defined anonymously, i.e., it was define -inside a call to `transient-define-prefix'. +If the infix command doesn't have a docstring, as is the case here, then +this docstring is displayed instead, because technically infix commands +are aliases for `transient--default-infix-command'. -When you request help for such an infix command, then we usually -show the respective man-page and jump to the location where the -respective argument is being described. This isn't possible in -this case, because the `man-page' slot was not set in this case." +`describe-function' also shows the docstring of the infix command, +falling back to that of the same aliased command." (interactive) (let ((obj (transient-suffix-object))) (transient-infix-set obj (transient-infix-read obj))) (transient--show)) (put 'transient--default-infix-command 'interactive-only t) -(put 'transient--default-infix-command 'command-modes (list 'not-a-mode)) +(put 'transient--default-infix-command 'completion-predicate + #'transient--suffix-only) + +(defun transient--find-function-advised-original (fn func) + "Return nil instead of `transient--default-infix-command'. +When using `find-function' to jump to the definition of a transient +infix command/argument, then we want to actually jump to that, not to +the definition of `transient--default-infix-command', which all infix +commands are aliases for." + (let ((val (funcall fn func))) + (and val (not (eq val 'transient--default-infix-command)) val))) +(advice-add 'find-function-advised-original :around + #'transient--find-function-advised-original) (eval-and-compile (defun transient--expand-define-args (args &optional arglist) @@ -1057,7 +1082,8 @@ this case, because the `man-page' slot was not set in this case." args)))) (defun transient--parse-child (prefix spec) - (cl-etypecase spec + (cl-typecase spec + (null (error "Invalid transient--parse-child spec: %s" spec)) (symbol (let ((value (symbol-value spec))) (if (and (listp value) (or (listp (car value)) @@ -1066,7 +1092,8 @@ this case, because the `man-page' slot was not set in this case." (transient--parse-child prefix value)))) (vector (and-let* ((c (transient--parse-group prefix spec))) (list c))) (list (and-let* ((c (transient--parse-suffix prefix spec))) (list c))) - (string (list spec)))) + (string (list spec)) + (t (error "Invalid transient--parse-child spec: %s" spec)))) (defun transient--parse-group (prefix spec) (setq spec (append spec nil)) @@ -1087,12 +1114,16 @@ this case, because the `man-page' slot was not set in this case." (and (listp val) (not (eq (car val) 'lambda)))) (setq args (plist-put args key (macroexp-quote val)))) ((setq args (plist-put args key val)))))) + (unless (or spec class (not (plist-get args :setup-children))) + (message "WARNING: %s: When %s is used, %s must also be specified" + 'transient-define-prefix :setup-children :class)) (list 'vector (or level transient--default-child-level) - (or class - (if (vectorp car) - (quote 'transient-columns) - (quote 'transient-column))) + (cond (class) + ((or (vectorp car) + (and car (symbolp car))) + (quote 'transient-columns)) + ((quote 'transient-column))) (and args (cons 'list args)) (cons 'list (cl-mapcan (lambda (s) (transient--parse-child prefix s)) @@ -1131,14 +1162,15 @@ this case, because the `man-page' slot was not set in this case." (format "transient:%s:%s" prefix (let ((desc (plist-get args :description))) - (if (and desc (or (stringp desc) (symbolp desc))) + (if (and (stringp desc) + (length< desc 16)) desc (plist-get args :key))))))) (setq args (plist-put args :command `(prog1 ',sym (put ',sym 'interactive-only t) - (put ',sym 'command-modes (list 'not-a-mode)) + (put ',sym 'completion-predicate #'transient--suffix-only) (defalias ',sym ,(if (eq (car-safe cmd) 'lambda) cmd @@ -1161,7 +1193,7 @@ this case, because the `man-page' slot was not set in this case." args :command `(prog1 ',sym (put ',sym 'interactive-only t) - (put ',sym 'command-modes (list 'not-a-mode)) + (put ',sym 'completion-predicate #'transient--suffix-only) (defalias ',sym #'transient--default-infix-command)))) (cond ((and car (not (keywordp car))) (setq class 'transient-option) @@ -1199,13 +1231,34 @@ this case, because the `man-page' slot was not set in this case." (and (string-match "\\`\\(-[a-zA-Z]\\)\\(\\'\\|=\\)" arg) (match-string 1 arg)))) +(defun transient-command-completion-not-suffix-only-p (symbol _buffer) + "Say whether SYMBOL should be offered as a completion. +If the value of SYMBOL's `completion-predicate' property is +`transient--suffix-only', then return nil, otherwise return t. +This is the case when a command should only ever be used as a +suffix of a transient prefix command (as opposed to bindings +in regular keymaps or by using `execute-extended-command')." + (not (eq (get symbol 'completion-predicate) 'transient--suffix-only))) + +(defalias 'transient--suffix-only #'ignore + "Ignore ARGUMENTS, do nothing, and return nil. +Also see `transient-command-completion-not-suffix-only-p'. +Only use this alias as the value of the `completion-predicate' +symbol property.") + +(when (and (boundp 'read-extended-command-predicate) ; since Emacs 28.1 + (not read-extended-command-predicate)) + (setq read-extended-command-predicate + #'transient-command-completion-not-suffix-only-p)) + (defun transient-parse-suffix (prefix suffix) "Parse SUFFIX, to be added to PREFIX. PREFIX is a prefix command, a symbol. SUFFIX is a suffix command or a group specification (of the same forms as expected by `transient-define-prefix'). Intended for use in a group's `:setup-children' function." - (eval (car (transient--parse-child prefix suffix)))) + (cl-assert (and prefix (symbolp prefix))) + (eval (car (transient--parse-child prefix suffix)) t)) (defun transient-parse-suffixes (prefix suffixes) "Parse SUFFIXES, to be added to PREFIX. @@ -1213,6 +1266,7 @@ PREFIX is a prefix command, a symbol. SUFFIXES is a list of suffix command or a group specification (of the same forms as expected by `transient-define-prefix'). Intended for use in a group's `:setup-children' function." + (cl-assert (and prefix (symbolp prefix))) (mapcar (apply-partially #'transient-parse-suffix prefix) suffixes)) ;;; Edit @@ -1224,7 +1278,7 @@ Intended for use in a group's `:setup-children' function." (string suffix))) (mem (transient--layout-member loc prefix)) (elt (car mem))) - (setq suf (eval suf)) + (setq suf (eval suf t)) (cond ((not mem) (message "Cannot insert %S into %s; %s not found" @@ -1473,7 +1527,8 @@ drawing in the transient buffer.") (defvar transient--pending-suffix nil "The suffix that is currently being processed. -This is bound while the suffix predicate is being evaluated.") +This is bound while the suffix predicate is being evaluated, +and while functions that return faces are being evaluated.") (defvar transient--pending-group nil "The group that is currently being processed. @@ -1556,33 +1611,35 @@ probably use this instead: (get COMMAND \\='transient--suffix)" (when command (cl-check-type command command)) - (if (or transient--prefix - transient-current-prefix) - (let ((suffixes - (cl-remove-if-not - (lambda (obj) - (eq (oref obj command) - (or command - (if (eq this-command 'transient-set-level) - ;; This is how it can look up for which - ;; command it is setting the level. - this-original-command - this-command)))) - (or transient--suffixes - transient-current-suffixes)))) - (or (and (cdr suffixes) - (cl-find-if - (lambda (obj) - (equal (listify-key-sequence (transient--kbd (oref obj key))) - (listify-key-sequence (this-command-keys)))) - suffixes)) - (car suffixes))) - (and-let* ((obj (transient--suffix-prototype (or command this-command))) + (cond + (transient--pending-suffix) + ((or transient--prefix + transient-current-prefix) + (let ((suffixes + (cl-remove-if-not + (lambda (obj) + (eq (oref obj command) + (or command + (if (eq this-command 'transient-set-level) + ;; This is how it can look up for which + ;; command it is setting the level. + this-original-command + this-command)))) + (or transient--suffixes + transient-current-suffixes)))) + (or (and (cdr suffixes) + (cl-find-if + (lambda (obj) + (equal (listify-key-sequence (transient--kbd (oref obj key))) + (listify-key-sequence (this-command-keys)))) + suffixes)) + (car suffixes)))) + ((and-let* ((obj (transient--suffix-prototype (or command this-command))) (obj (clone obj))) (progn ; work around debbugs#31840 (transient-init-scope obj) (transient-init-value obj) - obj)))) + obj))))) (defun transient--suffix-prototype (command) (or (get command 'transient--suffix) @@ -1679,7 +1736,8 @@ to `transient-predicate-map'. Also see `transient-base-map'." "Hide common commands" "Show common permanently"))) (list "C-x l" "Show/hide suffixes" #'transient-set-level) - (list "C-x a" #'transient-toggle-level-limit)))))))) + (list "C-x a" #'transient-toggle-level-limit))))) + t))) (defvar-keymap transient-popup-navigation-map :doc "One of the keymaps used when popup navigation is enabled. @@ -1763,7 +1821,10 @@ of the corresponding object." ;; an unbound key, then Emacs calls the `undefined' command ;; but does not set `this-command', `this-original-command' ;; or `real-this-command' accordingly. Instead they are nil. - "<nil>" #'transient--do-warn) + "<nil>" #'transient--do-warn + ;; Bound to the `mouse-movement' event, this command is similar + ;; to `ignore'. + "<ignore-preserving-kill-region>" #'transient--do-noop) (defvar transient--transient-map nil) (defvar transient--predicate-map nil) @@ -1822,7 +1883,7 @@ of the corresponding object." (defun transient--make-predicate-map () (let* ((default (transient--resolve-pre-command (oref transient--prefix transient-suffix))) - (return (and transient-current-prefix (eq default t))) + (return (and transient--stack (eq default t))) (map (make-sparse-keymap))) (set-keymap-parent map transient-predicate-map) (when (or (and (slot-boundp transient--prefix 'transient-switch-frame) @@ -1913,7 +1974,7 @@ the \"scope\" of the transient (see `transient-define-prefix'). This function is also called internally in which case LAYOUT and EDIT may be non-nil." (transient--debug 'setup) - (transient--with-emergency-exit + (transient--with-emergency-exit :setup (cond ((not name) ;; Switching between regular and edit mode. @@ -2167,7 +2228,7 @@ value. Otherwise return CHILDREN as is." (defun transient--pre-command () (transient--debug 'pre-command) - (transient--with-emergency-exit + (transient--with-emergency-exit :pre-command ;; The use of `overriding-terminal-local-map' does not prevent the ;; lookup of command remappings in the overridden maps, which can ;; lead to a suffix being remapped to a non-suffix. We have to undo @@ -2229,14 +2290,14 @@ value. Otherwise return CHILDREN as is." (when (window-live-p transient--window) (let ((remain-in-minibuffer-window (and (minibuffer-selected-window) - (selected-window))) - (buf (window-buffer transient--window))) + (selected-window)))) ;; Only delete the window if it has never shown another buffer. (unless (eq (car (window-parameter transient--window 'quit-restore)) 'other) (with-demoted-errors "Error while exiting transient: %S" (delete-window transient--window))) - (kill-buffer buf) + (when-let ((buffer (get-buffer transient--buffer-name))) + (kill-buffer buffer)) (when remain-in-minibuffer-window (select-window remain-in-minibuffer-window))))) @@ -2254,7 +2315,10 @@ value. Otherwise return CHILDREN as is." ((and transient--prefix transient--redisplay-key) (setq transient--redisplay-key nil) (when transient--showp - (transient--show)))) + (if-let ((win (minibuffer-selected-window))) + (with-selected-window win + (transient--show)) + (transient--show))))) (transient--pop-keymap 'transient--transient-map) (transient--pop-keymap 'transient--redisplay-map) (remove-hook 'pre-command-hook #'transient--pre-command) @@ -2309,7 +2373,7 @@ value. Otherwise return CHILDREN as is." (remove-hook 'minibuffer-exit-hook ,exit))) ,@body))) -(static-if (>= emacs-major-version 30) +(static-if (>= emacs-major-version 30) ;transient--wrap-command (defun transient--wrap-command () (cl-assert (>= emacs-major-version 30) nil @@ -2317,27 +2381,31 @@ value. Otherwise return CHILDREN as is." (letrec ((prefix transient--prefix) (suffix this-command) - (advice (lambda (fn &rest args) - (interactive - (lambda (spec) - (let ((abort t)) - (unwind-protect - (prog1 (advice-eval-interactive-spec spec) - (setq abort nil)) - (when abort - (when-let ((unwind (oref prefix unwind-suffix))) - (transient--debug 'unwind-interactive) - (funcall unwind suffix)) - (advice-remove suffix advice) - (oset prefix unwind-suffix nil)))))) - (unwind-protect - (apply fn args) + (advice + (lambda (fn &rest args) + (interactive + (lambda (spec) + (let ((abort t)) + (unwind-protect + (prog1 (let ((debugger #'transient--exit-and-debug)) + (advice-eval-interactive-spec spec)) + (setq abort nil)) + (when abort (when-let ((unwind (oref prefix unwind-suffix))) - (transient--debug 'unwind-command) + (transient--debug 'unwind-interactive) (funcall unwind suffix)) (advice-remove suffix advice) - (oset prefix unwind-suffix nil))))) - (advice-add suffix :around advice '((depth . -99))))) + (oset prefix unwind-suffix nil)))))) + (unwind-protect + (let ((debugger #'transient--exit-and-debug)) + (apply fn args)) + (when-let ((unwind (oref prefix unwind-suffix))) + (transient--debug 'unwind-command) + (funcall unwind suffix)) + (advice-remove suffix advice) + (oset prefix unwind-suffix nil))))) + (when (symbolp this-command) + (advice-add suffix :around advice '((depth . -99)))))) (defun transient--wrap-command () (let* ((prefix transient--prefix) @@ -2347,7 +2415,8 @@ value. Otherwise return CHILDREN as is." (lambda (spec) (let ((abort t)) (unwind-protect - (prog1 (advice-eval-interactive-spec spec) + (prog1 (let ((debugger #'transient--exit-and-debug)) + (advice-eval-interactive-spec spec)) (setq abort nil)) (when abort (when-let ((unwind (oref prefix unwind-suffix))) @@ -2358,7 +2427,8 @@ value. Otherwise return CHILDREN as is." (advice-body (lambda (fn &rest args) (unwind-protect - (apply fn args) + (let ((debugger #'transient--exit-and-debug)) + (apply fn args)) (when-let ((unwind (oref prefix unwind-suffix))) (transient--debug 'unwind-command) (funcall unwind suffix)) @@ -2367,7 +2437,8 @@ value. Otherwise return CHILDREN as is." (setq advice `(lambda (fn &rest args) (interactive ,advice-interactive) (apply ',advice-body fn args))) - (advice-add suffix :around advice '((depth . -99)))))) + (when (symbolp this-command) + (advice-add suffix :around advice '((depth . -99))))))) (defun transient--premature-post-command () (and (equal (this-command-keys-vector) []) @@ -2386,7 +2457,7 @@ value. Otherwise return CHILDREN as is." (defun transient--post-command () (unless (transient--premature-post-command) (transient--debug 'post-command) - (transient--with-emergency-exit + (transient--with-emergency-exit :post-command (cond (transient--exitp (transient--post-exit)) ;; If `this-command' is the current transient prefix, then we ;; have already taken care of updating the transient buffer... @@ -2504,24 +2575,29 @@ value. Otherwise return CHILDREN as is." (if (symbolp arg) (message "-- %-22s (cmd: %s, event: %S, exit: %s%s)" arg - (or (and (symbolp this-command) this-command) - (if (byte-code-function-p this-command) - "#[...]" - this-command)) + (if (fboundp 'help-fns-function-name) + (help-fns-function-name this-command) + (if (byte-code-function-p this-command) + "#[...]" + this-command)) (key-description (this-command-keys-vector)) transient--exitp - (cond ((stringp (car args)) + (cond ((keywordp (car args)) + (format ", from: %s" + (substring (symbol-name (car args)) 1))) + ((stringp (car args)) (concat ", " (apply #'format args))) - (args + ((functionp (car args)) (concat ", " (apply (car args) (cdr args)))) (""))) (apply #'message arg args))))) -(defun transient--emergency-exit () +(defun transient--emergency-exit (&optional id) "Exit the current transient command after an error occurred. When no transient is active (i.e., when `transient--prefix' is -nil) then do nothing." - (transient--debug 'emergency-exit) +nil) then do nothing. Optional ID is a keyword identifying the +exit." + (transient--debug 'emergency-exit id) (when transient--prefix (setq transient--stack nil) (setq transient--exitp t) @@ -2545,6 +2621,7 @@ nil) then do nothing." (defun transient--get-pre-command (&optional cmd enforce-type) (or (and (not (eq enforce-type 'non-suffix)) + (symbolp cmd) (lookup-key transient--predicate-map (vector cmd))) (and (not (eq enforce-type 'suffix)) (transient--resolve-pre-command @@ -2907,7 +2984,7 @@ transient is active." (interactive) (transient-set-value (transient-prefix-object))) -(defalias 'transient-set-and-exit 'transient-set +(defalias 'transient-set-and-exit #'transient-set "Set active transient's value for this Emacs session and exit.") (defun transient-save () @@ -2915,7 +2992,7 @@ transient is active." (interactive) (transient-save-value (transient-prefix-object))) -(defalias 'transient-save-and-exit 'transient-save +(defalias 'transient-save-and-exit #'transient-save "Save active transient's value for this and future Emacs sessions and exit.") (defun transient-reset () @@ -3088,14 +3165,14 @@ infix command determines what the new value should be, based on the previous value.") (cl-defmethod transient-infix-read :around ((obj transient-infix)) - "Refresh the transient buffer buffer calling the next method. + "Refresh the transient buffer and call the next method. Also wrap `cl-call-next-method' with two macros: - `transient--with-suspended-override' allows use of minibuffer. - `transient--with-emergency-exit' arranges for the transient to be exited in case of an error." (transient--show) - (transient--with-emergency-exit + (transient--with-emergency-exit :infix-read (transient--with-suspended-override (cl-call-next-method obj)))) @@ -3177,8 +3254,10 @@ The last value is \"don't use any of these switches\"." "Elsewhere use the reader of the infix command COMMAND. Use this if you want to share an infix's history with a regular stand-alone command." - (cl-letf (((symbol-function #'transient--show) #'ignore)) - (transient-infix-read (transient--suffix-prototype command)))) + (if-let ((obj (transient--suffix-prototype command))) + (cl-letf (((symbol-function #'transient--show) #'ignore)) + (transient-infix-read obj)) + (error "Not a suffix command: `%s'" command))) ;;;; Readers @@ -3355,7 +3434,7 @@ the set, saved or default value for PREFIX." (transient--init-suffixes prefix))))) (defun transient-get-value () - (transient--with-emergency-exit + (transient--with-emergency-exit :get-value (cl-mapcan (lambda (obj) (and (or (not (slot-exists-p obj 'unsavable)) (not (oref obj unsavable))) @@ -3566,7 +3645,7 @@ have a history of their own.") (propertize "\n" 'face face 'line-height t)))) (defmacro transient-with-shadowed-buffer (&rest body) - "While in the transient buffer, temporarily make the shadowed buffer current." + "While in the transient buffer, temporarly make the shadowed buffer current." (declare (indent 0) (debug t)) `(with-current-buffer (or transient--shadowed-buffer (current-buffer)) ,@body)) @@ -3621,7 +3700,8 @@ have a history of their own.") (lambda (column) (transient--maybe-pad-keys column group) (transient-with-shadowed-buffer - (let ((rows (mapcar #'transient-format (oref column suffixes)))) + (let* ((transient--pending-group column) + (rows (mapcar #'transient-format (oref column suffixes)))) (when-let ((desc (transient-format-description column))) (push desc rows)) (flatten-tree rows)))) @@ -3630,10 +3710,15 @@ have a history of their own.") transient-align-variable-pitch)) (rs (apply #'max (mapcar #'length columns))) (cs (length columns)) - (cw (mapcar (lambda (col) - (apply #'max - (mapcar (if vp #'transient--pixel-width #'length) - col))) + (cw (mapcar (let ((widths (oref transient--prefix column-widths))) + (lambda (col) + (apply + #'max + (if-let ((min (pop widths))) + (if vp (* min (transient--pixel-width " ")) min) + 0) + (mapcar (if vp #'transient--pixel-width #'length) + col)))) columns)) (cc (transient--seq-reductions-from (apply-partially #'+ (* 3 (if vp (transient--pixel-width " ") 1))) @@ -3909,7 +3994,10 @@ If the OBJ's `key' is currently unreachable, then apply the face (face (slot-value obj slot))) (if (and (not (facep face)) (functionp face)) - (funcall face) + (let ((transient--pending-suffix obj)) + (if (= (car (func-arity face)) 1) + (funcall face obj) + (funcall face))) face))) (defun transient--key-face (&optional cmd enforce-type) diff --git a/lisp/treesit.el b/lisp/treesit.el index a68eed06e41..2b4893e6129 100644 --- a/lisp/treesit.el +++ b/lisp/treesit.el @@ -344,14 +344,13 @@ ancestor node which satisfies the predicate PRED; then it returns that ancestor node. It returns nil if no ancestor node was found that satisfies PRED. -PRED should be a function that takes one argument, the node to -examine, and returns a boolean value indicating whether that -node is a match. +PRED can be a predicate function, a regexp matching node type, +and more; see docstring of `treesit-thing-settings'. If INCLUDE-NODE is non-nil, return NODE if it satisfies PRED." (let ((node (if include-node node (treesit-node-parent node)))) - (while (and node (not (funcall pred node))) + (while (and node (not (treesit-node-match-p node pred))) (setq node (treesit-node-parent node))) node)) @@ -364,11 +363,10 @@ no longer satisfies the predicate PRED; it returns the last examined node that satisfies PRED. If no node satisfies PRED, it returns nil. -PRED should be a function that takes one argument, the node to -examine, and returns a boolean value indicating whether that -node is a match." +PRED can be a predicate function, a regexp matching node type, +and more; see docstring of `treesit-thing-settings'." (let ((last nil)) - (while (and node (funcall pred node)) + (while (and node (treesit-node-match-p node pred)) (setq last node node (treesit-node-parent node))) last)) @@ -595,8 +593,8 @@ that encompasses the region between START and END." (unless (and (consp range-offset) (numberp (car range-offset)) (numberp (cdr range-offset))) - (signal 'treesit-error (list "Value of :offset option should be a pair of numbers" range-offset))) - (setq offset range-offset))) + (signal 'treesit-error (list "Value of :offset option should be a pair of numbers" range-offset))) + (setq offset range-offset))) (query (if (functionp query) (push (list query nil nil) result) (when (null embed) @@ -606,7 +604,7 @@ that encompasses the region between START and END." (push (list (treesit-query-compile host query) embed local offset) result)) - (setq host nil embed nil offset nil)))) + (setq host nil embed nil offset nil local nil)))) (nreverse result))) (defun treesit--merge-ranges (old-ranges new-ranges start end) @@ -655,37 +653,47 @@ those inside are kept." if (<= start (car range) (cdr range) end) collect range)) -(defun treesit-local-parsers-at (&optional pos language) +(defun treesit-local-parsers-at (&optional pos language with-host) "Return all the local parsers at POS. POS defaults to point. Local parsers are those which only parse a limited region marked by an overlay with non-nil `treesit-parser' property. -If LANGUAGE is non-nil, only return parsers for LANGUAGE." +If LANGUAGE is non-nil, only return parsers for LANGUAGE. + +If WITH-HOST is non-nil, return a list of (PARSER . HOST-PARSER) +instead. HOST-PARSER is the host parser which created the local +PARSER." (let ((res nil)) (dolist (ov (overlays-at (or pos (point)))) - (when-let ((parser (overlay-get ov 'treesit-parser))) + (when-let ((parser (overlay-get ov 'treesit-parser)) + (host-parser (overlay-get ov 'treesit-host-parser))) (when (or (null language) (eq (treesit-parser-language parser) language)) - (push parser res)))) + (push (if with-host (cons parser host-parser) parser) res)))) (nreverse res))) -(defun treesit-local-parsers-on (&optional beg end language) +(defun treesit-local-parsers-on (&optional beg end language with-host) "Return all the local parsers between BEG END. BEG and END default to the beginning and end of the buffer's accessible portion. Local parsers are those which have an `embedded' tag, and only parse a limited region marked by an overlay with a non-nil `treesit-parser' -property. If LANGUAGE is non-nil, only return parsers for LANGUAGE." +property. If LANGUAGE is non-nil, only return parsers for LANGUAGE. + +If WITH-HOST is non-nil, return a list of (PARSER . HOST-PARSER) +instead. HOST-PARSER is the host parser which created the local +PARSER." (let ((res nil)) (dolist (ov (overlays-in (or beg (point-min)) (or end (point-max)))) - (when-let ((parser (overlay-get ov 'treesit-parser))) + (when-let ((parser (overlay-get ov 'treesit-parser)) + (host-parser (overlay-get ov 'treesit-host-parser))) (when (or (null language) (eq (treesit-parser-language parser) language)) - (push parser res)))) + (push (if with-host (cons parser host-parser) parser) res)))) (nreverse res))) (defun treesit--update-ranges-local @@ -701,7 +709,8 @@ parser for EMBEDDED-LANG." (treesit-parser-delete parser)))) ;; Update range. (let* ((host-lang (treesit-query-language query)) - (ranges (treesit-query-range host-lang query beg end))) + (host-parser (treesit-parser-create host-lang)) + (ranges (treesit-query-range host-parser query beg end))) (pcase-dolist (`(,beg . ,end) ranges) (let ((has-parser nil)) (dolist (ov (overlays-in beg end)) @@ -719,6 +728,7 @@ parser for EMBEDDED-LANG." embedded-lang nil t 'embedded)) (ov (make-overlay beg end nil nil t))) (overlay-put ov 'treesit-parser embedded-parser) + (overlay-put ov 'treesit-host-parser host-parser) (treesit-parser-set-included-ranges embedded-parser `((,beg . ,end))))))))) @@ -1372,7 +1382,15 @@ as comment due to incomplete parse tree." ;; `treesit-update-ranges' will force the host language's parser to ;; reparse and set correct ranges for embedded parsers. Then ;; `treesit-parser-root-node' will force those parsers to reparse. - (treesit-update-ranges) + (let ((len (+ (* (window-body-height) (window-body-width)) 800))) + ;; FIXME: As a temporary fix, this prevents Emacs from updating + ;; every single local parsers in the buffer every time there's an + ;; edit. Moving forward, we need some way to properly track the + ;; regions which need update on parser ranges, like what jit-lock + ;; and syntax-ppss does. + (treesit-update-ranges + (max (point-min) (- (point) len)) + (min (point-max) (+ (point) len)))) ;; Force repase on _all_ the parsers might not be necessary, but ;; this is probably the most robust way. (dolist (parser (treesit-parser-list)) @@ -1393,7 +1411,7 @@ START and END mark the current to-be-propertized region." (if (and new-start (< new-start start)) (progn (setq treesit--syntax-propertize-start nil) - (cons new-start end)) + (cons (max new-start (point-min)) end)) nil))) ;;; Indent @@ -1665,7 +1683,7 @@ no-node comment-end - Matches if text after point matches `treesit-comment-end'. + Matches if text after point matches `comment-end-skip'. catch-all @@ -1800,11 +1818,17 @@ Return (ANCHOR . OFFSET). This function is used by (forward-line 0) (skip-chars-forward " \t") (point))) - (local-parsers (treesit-local-parsers-at bol)) + (local-parsers (treesit-local-parsers-at bol nil t)) (smallest-node - (cond ((null (treesit-parser-list)) nil) - (local-parsers (treesit-node-at - bol (car local-parsers))) + (cond ((car local-parsers) + (let ((local-parser (caar local-parsers)) + (host-parser (cdar local-parsers))) + (if (eq (treesit-node-start + (treesit-parser-root-node local-parser)) + bol) + (treesit-node-at bol host-parser) + (treesit-node-at bol local-parser)))) + ((null (treesit-parser-list)) nil) ((eq 1 (length (treesit-parser-list nil nil t))) (treesit-node-at bol)) ((treesit-language-at bol) @@ -2213,7 +2237,7 @@ for invalid node. This is used by `treesit-beginning-of-defun' and friends.") (defvar-local treesit-defun-tactic 'nested - "Determines how does Emacs treat nested defuns. + "Determines how Emacs treats nested defuns. If the value is `top-level', Emacs only moves across top-level defuns, if the value is `nested', Emacs recognizes nested defuns.") @@ -2229,9 +2253,8 @@ If the value is nil, no skipping is performed.") (defvar-local treesit-defun-name-function nil "A function that is called with a node and returns its defun name or nil. If the node is a defun node, return the defun name, e.g., the -function name of a function. If the node is not a defun node, or -the defun node doesn't have a name, or the node is nil, return -nil.") +name of a function. If the node is not a defun node, or the +defun node doesn't have a name, or the node is nil, return nil.") (defvar-local treesit-add-log-defun-delimiter "." "The delimiter used to connect several defun names. @@ -2644,9 +2667,17 @@ function is called recursively." (setq parent (treesit-node-top-level parent thing t) prev nil next nil)) - ;; If TACTIC is `restricted', the implementation is very simple. + ;; If TACTIC is `restricted', the implementation is simple. + ;; In principle we don't go to parent's beg/end for + ;; `restricted' tactic, but if the parent is a "leaf thing" + ;; (doesn't have any child "thing" inside it), then we can + ;; move to the beg/end of it (bug#68899). (if (eq tactic 'restricted) - (setq pos (funcall advance (if (> arg 0) next prev))) + (setq pos (funcall + advance + (cond ((and (null next) (null prev)) parent) + ((> arg 0) next) + (t prev)))) ;; For `nested', it's a bit more work: ;; Move... (if (> arg 0) @@ -2696,12 +2727,12 @@ function is called recursively." ;; TODO: In corporate into thing-at-point. (defun treesit-thing-at-point (thing tactic) - "Return the THING at point or nil if none is found. + "Return the THING at point, or nil if none is found. -THING can be a symbol, regexp, a predicate function, and more, +THING can be a symbol, a regexp, a predicate function, and more; see `treesit-thing-settings' for details. -Return the top-level THING if TACTIC is `top-level', return the +Return the top-level THING if TACTIC is `top-level'; return the smallest enclosing THING as POS if TACTIC is `nested'." (let ((node (treesit--thing-at (point) thing))) @@ -2710,11 +2741,11 @@ smallest enclosing THING as POS if TACTIC is `nested'." node))) (defun treesit-defun-at-point () - "Return the defun node at point or nil if none is found. + "Return the defun node at point, or nil if none is found. -Respects `treesit-defun-tactic': return the top-level defun if it -is `top-level', return the immediate parent defun if it is -`nested'. +Respects `treesit-defun-tactic': returns the top-level defun if it +is `top-level', otherwise return the immediate parent defun if it +is `nested'. Return nil if `treesit-defun-type-regexp' isn't set and `defun' isn't defined in `treesit-thing-settings'." @@ -2836,6 +2867,71 @@ ENTRY. MARKER marks the start of each tree-sitter node." index)))) treesit-simple-imenu-settings))) +;;; Outline minor mode + +(defvar-local treesit-outline-predicate nil + "Predicate used to find outline headings in the syntax tree. +The predicate can be a function, a regexp matching node type, +and more; see docstring of `treesit-thing-settings'. +It matches the nodes located on lines with outline headings. +Intended to be set by a major mode. When nil, the predicate +is constructed from the value of `treesit-simple-imenu-settings' +when a major mode sets it.") + +(defun treesit-outline-predicate--from-imenu (node) + ;; Return an outline searching predicate created from Imenu. + ;; Return the value suitable to set `treesit-outline-predicate'. + ;; Create this predicate from the value `treesit-simple-imenu-settings' + ;; that major modes set to find Imenu entries. The assumption here + ;; is that the positions of Imenu entries most of the time coincide + ;; with the lines of outline headings. When this assumption fails, + ;; you can directly set a proper value to `treesit-outline-predicate'. + (seq-some + (lambda (setting) + (and (string-match-p (nth 1 setting) (treesit-node-type node)) + (or (null (nth 2 setting)) + (funcall (nth 2 setting) node)))) + treesit-simple-imenu-settings)) + +(defun treesit-outline-search (&optional bound move backward looking-at) + "Search for the next outline heading in the syntax tree. +See the descriptions of arguments in `outline-search-function'." + (if looking-at + (when-let* ((node (or (treesit--thing-at (pos-eol) treesit-outline-predicate) + (treesit--thing-at (pos-bol) treesit-outline-predicate))) + (start (treesit-node-start node))) + (eq (pos-bol) (save-excursion (goto-char start) (pos-bol)))) + + (let* ((pos + ;; When function wants to find the current outline, point + ;; is at the beginning of the current line. When it wants + ;; to find the next outline, point is at the second column. + (if (eq (point) (pos-bol)) + (if (bobp) (point) (1- (point))) + (pos-eol))) + (found (treesit--navigate-thing pos (if backward -1 1) 'beg + treesit-outline-predicate))) + (if found + (if (or (not bound) (if backward (>= found bound) (<= found bound))) + (progn + (goto-char found) + (goto-char (pos-bol)) + (set-match-data (list (point) (pos-eol))) + t) + (when move (goto-char bound)) + nil) + (when move (goto-char (or bound (if backward (point-min) (point-max))))) + nil)))) + +(defun treesit-outline-level () + "Return the depth of the current outline heading." + (let* ((node (treesit-node-at (point) nil t)) + (level (if (treesit-node-match-p node treesit-outline-predicate) + 1 0))) + (while (setq node (treesit-parent-until node treesit-outline-predicate)) + (setq level (1+ level))) + (if (zerop level) 1 level))) + ;;; Activating tree-sitter (defun treesit-ready-p (language &optional quiet) @@ -2966,6 +3062,17 @@ before calling this function." (setq-local imenu-create-index-function #'treesit-simple-imenu)) + ;; Outline minor mode. + (when (and (or treesit-outline-predicate treesit-simple-imenu-settings) + (not (seq-some #'local-variable-p + '(outline-search-function + outline-regexp outline-level)))) + (unless treesit-outline-predicate + (setq treesit-outline-predicate + #'treesit-outline-predicate--from-imenu)) + (setq-local outline-search-function #'treesit-outline-search + outline-level #'treesit-outline-level)) + ;; Remove existing local parsers. (dolist (ov (overlays-in (point-min) (point-max))) (when-let ((parser (overlay-get ov 'treesit-parser))) @@ -3417,7 +3524,8 @@ The value should be an alist where each element has the form (LANG . (URL REVISION SOURCE-DIR CC C++)) Only LANG and URL are mandatory. LANG is the language symbol. -URL is the Git repository URL for the grammar. +URL is the URL of the grammar's Git repository or a directory +where the repository has been cloned. REVISION is the Git tag or branch of the desired version, defaulting to the latest default branch. @@ -3551,6 +3659,26 @@ content as signal data, and erase buffer afterwards." (buffer-string))) (erase-buffer))) +(defun treesit--git-checkout-branch (repo-dir revision) + "Checkout REVISION in a repo located in REPO-DIR." + (treesit--call-process-signal + "git" nil t nil "-C" repo-dir "checkout" revision)) + +(defun treesit--git-clone-repo (url revision workdir) + "Clone repo pointed by URL at commit REVISION to WORKDIR. + +REVISION may be nil, in which case the cloned repo will be at its +default branch." + (message "Cloning repository") + ;; git clone xxx --depth 1 --quiet [-b yyy] workdir + (if revision + (treesit--call-process-signal + "git" nil t nil "clone" url "--depth" "1" "--quiet" + "-b" revision workdir) + (treesit--call-process-signal + "git" nil t nil "clone" url "--depth" "1" "--quiet" + workdir))) + (defun treesit--install-language-grammar-1 (out-dir lang url &optional revision source-dir cc c++) "Install and compile a tree-sitter language grammar library. @@ -3564,8 +3692,12 @@ For LANG, URL, REVISION, SOURCE-DIR, GRAMMAR-DIR, CC, C++, see `treesit-language-source-alist'. If anything goes wrong, this function signals an error." (let* ((lang (symbol-name lang)) + (maybe-repo-dir (expand-file-name url)) + (url-is-dir (file-accessible-directory-p maybe-repo-dir)) (default-directory (make-temp-file "treesit-workdir" t)) - (workdir (expand-file-name "repo")) + (workdir (if url-is-dir + maybe-repo-dir + (expand-file-name "repo"))) (source-dir (expand-file-name (or source-dir "src") workdir)) (cc (or cc (seq-find #'executable-find '("cc" "gcc" "c99")) ;; If no C compiler found, just use cc and let @@ -3580,15 +3712,10 @@ function signals an error." (lib-name (concat "libtree-sitter-" lang soext))) (unwind-protect (with-temp-buffer - (message "Cloning repository") - ;; git clone xxx --depth 1 --quiet [-b yyy] workdir - (if revision - (treesit--call-process-signal - "git" nil t nil "clone" url "--depth" "1" "--quiet" - "-b" revision workdir) - (treesit--call-process-signal - "git" nil t nil "clone" url "--depth" "1" "--quiet" - workdir)) + (if url-is-dir + (when revision + (treesit--git-checkout-branch workdir revision)) + (treesit--git-clone-repo url revision workdir)) ;; We need to go into the source directory because some ;; header files use relative path (#include "../xxx"). ;; cd "${sourcedir}" @@ -3635,7 +3762,9 @@ function signals an error." ;; Ignore errors, in case the old version is still used. (ignore-errors (delete-file old-fname))) (message "Library installed to %s/%s" out-dir lib-name)) - (when (file-exists-p workdir) + ;; Remove workdir if it's not a repo owned by user and we + ;; managed to create it in the first place. + (when (and (not url-is-dir) (file-exists-p workdir)) (delete-directory workdir t))))) ;;; Etc diff --git a/lisp/url/url-cache.el b/lisp/url/url-cache.el index 0d27321cc47..ce6de2b3ee4 100644 --- a/lisp/url/url-cache.el +++ b/lisp/url/url-cache.el @@ -70,7 +70,7 @@ FILE can be created or overwritten." ;;;###autoload (defun url-store-in-cache (&optional buff) "Store buffer BUFF in the cache." - (with-current-buffer (get-buffer (or buff (current-buffer))) + (with-current-buffer (or buff (current-buffer)) (let ((fname (url-cache-create-filename (url-view-url t)))) (if (url-cache-prepare fname) (let ((coding-system-for-write 'binary)) diff --git a/lisp/url/url-cid.el b/lisp/url/url-cid.el index 17a0318e652..d80037f8fe9 100644 --- a/lisp/url/url-cid.el +++ b/lisp/url/url-cid.el @@ -1,6 +1,6 @@ ;;; url-cid.el --- Content-ID URL loader -*- lexical-binding: t; -*- -;; Copyright (C) 1998-1999, 2004-2024 Free Software Foundation, Inc. +;; Copyright (C) 1998-2024 Free Software Foundation, Inc. ;; Keywords: comm, data, processes @@ -52,12 +52,7 @@ ;;;###autoload (defun url-cid (url) - (cond - ((fboundp 'mm-get-content-id) - ;; Using Pterodactyl Gnus or later - (with-current-buffer (generate-new-buffer " *url-cid*") - (url-cid-gnus (url-filename url)))) - (t - (message "Unable to handle CID URL: %s" url)))) + (with-current-buffer (generate-new-buffer " *url-cid*") + (url-cid-gnus (url-filename url)))) ;;; url-cid.el ends here diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el index d6a1d0eade8..184c1278072 100644 --- a/lisp/url/url-http.el +++ b/lisp/url/url-http.el @@ -427,7 +427,7 @@ Use `url-http-referer' as the Referer-header (subject to `url-privacy-level')." ;; Parsing routines (defun url-http-clean-headers () - "Remove trailing \r from header lines. + "Remove trailing \\r from header lines. This allows us to use `mail-fetch-field', etc. Return the number of characters removed." (let ((end (marker-position url-http-end-of-headers))) diff --git a/lisp/url/url-ldap.el b/lisp/url/url-ldap.el index 1bdd5099637..6aaea606c27 100644 --- a/lisp/url/url-ldap.el +++ b/lisp/url/url-ldap.el @@ -1,6 +1,6 @@ ;;; url-ldap.el --- LDAP Uniform Resource Locator retrieval code -*- lexical-binding: t; -*- -;; Copyright (C) 1998-1999, 2004-2024 Free Software Foundation, Inc. +;; Copyright (C) 1998-2024 Free Software Foundation, Inc. ;; Keywords: comm, data, processes @@ -92,12 +92,8 @@ "'>" dn "</a>")) (defun url-ldap-certificate-formatter (data) - (condition-case () - (require 'ssl) - (error nil)) - (let ((vals (if (fboundp 'ssl-certificate-information) - (ssl-certificate-information data) - (tls-certificate-information data)))) + ;; FIXME: tls.el is obsolete. + (let ((vals (tls-certificate-information data))) (if (not vals) "<b>Unable to parse certificate</b>" (concat "<table border=0>\n" diff --git a/lisp/url/url-mailto.el b/lisp/url/url-mailto.el index c2d347a1646..50293ab3f05 100644 --- a/lisp/url/url-mailto.el +++ b/lisp/url/url-mailto.el @@ -1,6 +1,6 @@ ;;; url-mailto.el --- Mail Uniform Resource Locator retrieval code -*- lexical-binding: t; -*- -;; Copyright (C) 1996-1999, 2004-2024 Free Software Foundation, Inc. +;; Copyright (C) 1996-2024 Free Software Foundation, Inc. ;; Keywords: comm, data, processes @@ -28,12 +28,7 @@ (require 'url-util) ;;;###autoload -(defun url-mail (&rest args) - (interactive "P") - (if (fboundp 'message-mail) - (apply 'message-mail args) - (or (apply 'mail args) - (error "Mail aborted")))) +(defalias 'url-mail #'message-mail) (defun url-mail-goto-field (field) (if (not field) @@ -57,8 +52,6 @@ (save-excursion (insert "\n")))))) -(declare-function mail-send-and-exit "sendmail") - ;;;###autoload (defun url-mailto (url) "Handle the mailto: URL syntax." @@ -111,8 +104,6 @@ ;; (setq func (intern-soft (concat "mail-" (caar args)))) (insert (mapconcat 'identity (cdar args) ", "))) (setq args (cdr args))) - ;; (url-mail-goto-field "User-Agent") -;; (insert url-package-name "/" url-package-version " URL/" url-version) (if (not url-request-data) (progn (set-buffer-modified-p nil) @@ -128,8 +119,8 @@ (goto-char (point-max)) (insert url-request-data) ;; It seems Microsoft-ish to send without warning. - ;; Fixme: presumably this should depend on a privacy setting. - (if (y-or-n-p "Send this auto-generated mail? ") + ;; FIXME: presumably this should depend on a privacy setting. + (if (y-or-n-p "Send this auto-generated mail?") (let ((buffer (current-buffer))) (cond ((eq url-mail-command 'compose-mail) (funcall (get mail-user-agent 'sendfunc) nil)) diff --git a/lisp/url/url-util.el b/lisp/url/url-util.el index 28d1885387d..5f45b98c7a5 100644 --- a/lisp/url/url-util.el +++ b/lisp/url/url-util.el @@ -335,7 +335,7 @@ appropriate coding-system; see `decode-coding-string'." str (substring str (match-end 0))))) (concat tmp str))) -(defconst url-unreserved-chars +(defvar url-unreserved-chars '(?a ?b ?c ?d ?e ?f ?g ?h ?i ?j ?k ?l ?m ?n ?o ?p ?q ?r ?s ?t ?u ?v ?w ?x ?y ?z ?A ?B ?C ?D ?E ?F ?G ?H ?I ?J ?K ?L ?M ?N ?O ?P ?Q ?R ?S ?T ?U ?V ?W ?X ?Y ?Z ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9 diff --git a/lisp/use-package/use-package-ensure-system-package.el b/lisp/use-package/use-package-ensure-system-package.el index 025721746cc..6c7f8c0a1ea 100644 --- a/lisp/use-package/use-package-ensure-system-package.el +++ b/lisp/use-package/use-package-ensure-system-package.el @@ -5,7 +5,6 @@ ;; Author: Justin Talbott <justin@waymondo.com> ;; Keywords: convenience, tools, extensions ;; URL: https://github.com/waymondo/use-package-ensure-system-package -;; Version: 0.2 ;; Package-Requires: ((use-package "2.1") (system-packages "1.0.4")) ;; Filename: use-package-ensure-system-package.el diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index 03efe0fdb31..66043059d14 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -240,6 +240,8 @@ The default \"-b\" means to ignore whitespace-only changes, :help "Apply the current hunk to the source file and go to the next"] ["Test applying hunk" diff-test-hunk :help "See whether it's possible to apply the current hunk"] + ["Apply all hunks" diff-apply-buffer + :help "Apply all hunks in the current diff buffer"] ["Apply diff with Ediff" diff-ediff-patch :help "Call `ediff-patch-file' on the current buffer"] ["Create Change Log entries" diff-add-change-log-entries-other-window @@ -517,8 +519,8 @@ use the face `diff-removed' for removed lines, and the face ("^Only in .*\n" . 'diff-nonexistent) ("^Binary files .* differ\n" . 'diff-file-header) ("^\\(#\\)\\(.*\\)" - (1 font-lock-comment-delimiter-face) - (2 font-lock-comment-face)) + (1 'font-lock-comment-delimiter-face) + (2 'font-lock-comment-face)) ("^diff: .*" (0 'diff-error)) ("^[^-=+*!<>#].*\n" (0 'diff-context)) (,#'diff--font-lock-syntax) @@ -944,7 +946,8 @@ like \(diff-merge-strings \"b/foo\" \"b/bar\" \"/a/c/foo\")." (when (and (string-match (concat "\\`\\(.*?\\)\\(.*\\)\\(.*\\)\n" "\\1\\(.*\\)\\3\n" - "\\(.*\\(\\2\\).*\\)\\'") str) + "\\(.*\\(\\2\\).*\\)\\'") + str) (equal to (match-string 5 str))) (concat (substring str (match-beginning 5) (match-beginning 6)) (match-string 4 str) @@ -1616,7 +1619,7 @@ modified lines of the diff." nil))) (when (eq diff-buffer-type 'git) (setq diff-outline-regexp - (concat "\\(^diff --git.*\n\\|" diff-hunk-header-re "\\)"))) + (concat "\\(^diff --git.*\\|" diff-hunk-header-re "\\)"))) (setq-local outline-level #'diff--outline-level) (setq-local outline-regexp diff-outline-regexp)) @@ -1999,7 +2002,7 @@ With a prefix argument, REVERSE the hunk." (diff-find-source-location nil reverse))) (cond ((null line-offset) - (error "Can't find the text to patch")) + (user-error "Can't find the text to patch")) ((with-current-buffer buf (and buffer-file-name (backup-file-name-p buffer-file-name) @@ -2008,7 +2011,7 @@ With a prefix argument, REVERSE the hunk." (yes-or-no-p (format "Really apply this hunk to %s? " (file-name-nondirectory buffer-file-name))))))) - (error "%s" + (user-error "%s" (substitute-command-keys (format "Use %s\\[diff-apply-hunk] to apply it to the other file" (if (not reverse) "\\[universal-argument] "))))) @@ -2275,6 +2278,24 @@ Return new point, if it was moved." (end (progn (diff-end-of-hunk) (point)))) (diff--refine-hunk beg end))))) +(defun diff--refine-propertize (beg end face) + (let ((ol (make-overlay beg end))) + (overlay-put ol 'diff-mode 'fine) + (overlay-put ol 'evaporate t) + (overlay-put ol 'face face))) + +(defcustom diff-refine-nonmodified nil + "If non-nil, also highlight the added/removed lines as \"refined\". +The lines highlighted when this is non-nil are those that were +added or removed in their entirety, as opposed to lines some +parts of which were modified. The added lines are highlighted +using the `diff-refine-added' face, while the removed lines are +highlighted using the `diff-refine-removed' face. +This is currently implemented only for diff formats supported +by `diff-refine-hunk'." + :version "30.1" + :type 'boolean) + (defun diff--refine-hunk (start end) (require 'smerge-mode) (goto-char start) @@ -2289,41 +2310,68 @@ Return new point, if it was moved." (goto-char beg) (pcase style ('unified - (while (re-search-forward "^-" end t) + (while (re-search-forward "^[-+]" end t) (let ((beg-del (progn (beginning-of-line) (point))) beg-add end-add) - (when (and (diff--forward-while-leading-char ?- end) - ;; Allow for "\ No newline at end of file". - (progn (diff--forward-while-leading-char ?\\ end) - (setq beg-add (point))) - (diff--forward-while-leading-char ?+ end) - (progn (diff--forward-while-leading-char ?\\ end) - (setq end-add (point)))) + (cond + ((eq (char-after) ?+) + (diff--forward-while-leading-char ?+ end) + (when diff-refine-nonmodified + (diff--refine-propertize beg-del (point) 'diff-refine-added))) + ((and (diff--forward-while-leading-char ?- end) + ;; Allow for "\ No newline at end of file". + (progn (diff--forward-while-leading-char ?\\ end) + (setq beg-add (point))) + (diff--forward-while-leading-char ?+ end) + (progn (diff--forward-while-leading-char ?\\ end) + (setq end-add (point)))) (smerge-refine-regions beg-del beg-add beg-add end-add - nil #'diff-refine-preproc props-r props-a))))) + nil #'diff-refine-preproc props-r props-a)) + (t ;; If we're here, it's because + ;; (diff--forward-while-leading-char ?+ end) failed. + (when diff-refine-nonmodified + (diff--refine-propertize beg-del (point) + 'diff-refine-removed))))))) ('context (let* ((middle (save-excursion (re-search-forward "^---" end t))) (other middle)) - (while (and middle - (re-search-forward "^\\(?:!.*\n\\)+" middle t)) - (smerge-refine-regions (match-beginning 0) (match-end 0) - (save-excursion - (goto-char other) - (re-search-forward "^\\(?:!.*\n\\)+" end) - (setq other (match-end 0)) - (match-beginning 0)) - other - (if diff-use-changed-face props-c) - #'diff-refine-preproc - (unless diff-use-changed-face props-r) - (unless diff-use-changed-face props-a))))) + (when middle + (while (re-search-forward "^\\(?:!.*\n\\)+" middle t) + (smerge-refine-regions (match-beginning 0) (match-end 0) + (save-excursion + (goto-char other) + (re-search-forward "^\\(?:!.*\n\\)+" end) + (setq other (match-end 0)) + (match-beginning 0)) + other + (if diff-use-changed-face props-c) + #'diff-refine-preproc + (unless diff-use-changed-face props-r) + (unless diff-use-changed-face props-a))) + (when diff-refine-nonmodified + (goto-char beg) + (while (re-search-forward "^\\(?:-.*\n\\)+" middle t) + (diff--refine-propertize (match-beginning 0) + (match-end 0) + 'diff-refine-removed)) + (goto-char middle) + (while (re-search-forward "^\\(?:\\+.*\n\\)+" end t) + (diff--refine-propertize (match-beginning 0) + (match-end 0) + 'diff-refine-added)))))) (_ ;; Normal diffs. (let ((beg1 (1+ (point)))) - (when (re-search-forward "^---.*\n" end t) + (cond + ((re-search-forward "^---.*\n" end t) ;; It's a combined add&remove, so there's something to do. (smerge-refine-regions beg1 (match-beginning 0) (match-end 0) end - nil #'diff-refine-preproc props-r props-a))))))) + nil #'diff-refine-preproc props-r props-a)) + (diff-refine-nonmodified + (diff--refine-propertize + beg1 end + (if (eq (char-after beg1) ?<) + 'diff-refine-removed 'diff-refine-added))))))))) (defun diff--iterate-hunks (max fun) "Iterate over all hunks between point and MAX. @@ -2817,6 +2865,57 @@ and the position in MAX." (defvar-local diff--syntax-file-attributes nil) (put 'diff--syntax-file-attributes 'permanent-local t) +(defvar diff--cached-revision-buffers nil + "List of ((FILE . REVISION) . BUFFER) in MRU order.") + +(defvar diff--cache-clean-timer nil) +(defconst diff--cache-clean-interval 3600) ; seconds + +(defun diff--cache-clean () + "Discard the least recently used half of the cache." + (let ((n (/ (length diff--cached-revision-buffers) 2))) + (mapc #'kill-buffer (mapcar #'cdr (nthcdr n diff--cached-revision-buffers))) + (setq diff--cached-revision-buffers + (ntake n diff--cached-revision-buffers))) + (diff--cache-schedule-clean)) + +(defun diff--cache-schedule-clean () + (setq diff--cache-clean-timer + (and diff--cached-revision-buffers + (run-with-timer diff--cache-clean-interval nil + #'diff--cache-clean)))) + +(defun diff--get-revision-properties (file revision text line-nb) + "Get font-lock properties from FILE at REVISION for TEXT at LINE-NB." + (let* ((file-rev (cons file revision)) + (entry (assoc file-rev diff--cached-revision-buffers)) + (buffer (cdr entry))) + (if (buffer-live-p buffer) + (progn + ;; Don't re-initialize the buffer (which would throw + ;; away the previous fontification work). + (setq file nil) + (setq diff--cached-revision-buffers + (cons entry + (delq entry diff--cached-revision-buffers)))) + ;; Cache miss: create a new entry. + (setq buffer (get-buffer-create (format " *diff-syntax:%s.~%s~*" + file revision))) + (condition-case nil + (vc-find-revision-no-save file revision diff-vc-backend buffer) + (error + (kill-buffer buffer) + (setq buffer nil)) + (:success + (push (cons file-rev buffer) + diff--cached-revision-buffers)))) + (when diff--cache-clean-timer + (cancel-timer diff--cache-clean-timer)) + (diff--cache-schedule-clean) + (and buffer + (with-current-buffer buffer + (diff-syntax-fontify-props file text line-nb))))) + (defun diff-syntax-fontify-hunk (beg end old) "Highlight source language syntax in diff hunk between BEG and END. When OLD is non-nil, highlight the hunk from the old source." @@ -2867,22 +2966,8 @@ When OLD is non-nil, highlight the hunk from the old source." (insert-file-contents file) (setq diff--syntax-file-attributes attrs))) (diff-syntax-fontify-props file text line-nb))))) - ;; Get properties from a cached revision - (let* ((buffer-name (format " *diff-syntax:%s.~%s~*" - file revision)) - (buffer (get-buffer buffer-name))) - (if buffer - ;; Don't re-initialize the buffer (which would throw - ;; away the previous fontification work). - (setq file nil) - (setq buffer (ignore-errors - (vc-find-revision-no-save - file revision - diff-vc-backend - (get-buffer-create buffer-name))))) - (when buffer - (with-current-buffer buffer - (diff-syntax-fontify-props file text line-nb)))))))) + (diff--get-revision-properties file revision + text line-nb))))) (let ((file (car (diff-hunk-file-names old)))) (cond ((and file diff-default-directory @@ -3014,7 +3099,7 @@ hunk text is not found in the source file." (goto-char (point-min)) (while (progn (diff-file-next) (not (eobp))) (push (diff-find-file-name nil t) files))) - (list backend (nreverse files) nil nil 'patch))) + (list backend (delete nil (nreverse files)) nil nil 'patch))) (defun diff--filter-substring (str) (when diff-font-lock-prettify diff --git a/lisp/vc/log-edit.el b/lisp/vc/log-edit.el index 72867f14d2f..1f766eea455 100644 --- a/lisp/vc/log-edit.el +++ b/lisp/vc/log-edit.el @@ -575,19 +575,82 @@ the \\[vc-prefix-map] prefix for VC commands, for example). "Insert FUNC-NAMES, following ChangeLog formatting." (if (not func-names) (insert ":") + ;; Insert a space unless this list of defun names is being + ;; inserted at the start of a line or after a space character. (unless (or (memq (char-before) '(?\n ?\s)) (> (current-column) fill-column)) (insert " ")) - (cl-loop for first-fun = t then nil - for def in func-names do - (when (> (+ (current-column) (string-width def)) fill-column) - (unless first-fun - (insert ")")) - (insert "\n")) - (insert (if (memq (char-before) '(?\n ?\s)) - "(" ", ") - def)) - (insert "):"))) + (let ((inside-paren-pair nil) + (first-line t) + name) + ;; Now insert the functions names one by one, inserting newlines + ;; as appropriate. + (while func-names + (setq name (car func-names)) + (setq func-names (cdr func-names)) + ;; If inserting `name' after preexisting text in the first + ;; line would overflow the fill column, place it on its own + ;; line. + (if (and first-line + (> (current-column) 0) + (> (+ (current-column) + (string-width name) + ;; If this be the last name, the column must be + ;; followed by an extra colon character. + (if func-names 1 2)) + fill-column)) + (progn + (insert "\n") + ;; Iterate over this function name again. + (setq func-names (cons name func-names))) + (if inside-paren-pair + ;; If `name' is not the first item in a list of defuns + ;; and inserting it would overflow the fill column, + ;; start a new list of defuns on the next line. + (if (> (+ (current-column) + (string-width name) + ;; If this be the last name, the column must + ;; be followed by an extra colon character; + ;; however, there are two separator characters + ;; that will be deleted, so the number of + ;; columns to add to this in the case of + ;; `name' being final and in other cases are 0 + ;; and 1 respectively. + (if func-names 0 1)) + fill-column) + (progn + (delete-char -2) + (insert ")\n") + (setq inside-paren-pair nil + ;; Iterate over this function name again. + func-names (cons name func-names))) + ;; Insert this defun name with a separator attached. + (insert name ", ")) + ;; Otherwise, decide whether to start a list of defuns or + ;; to insert `name' on its own line. + (if (> (+ (current-column) + (string-width name) + (if func-names 1 2)) ; The column number of + ; line after inserting + ; `name'... + fill-column) + ;; ...would leave insufficient space for any + ;; subsequent defun names so insert it on its own + ;; line. + (insert (if func-names + (format "(%s)\n" name) + (format "(%s):" name))) + ;; Insert a new defun list, unless `name' is the last + ;; function name. + (insert (if (not func-names) + (format "(%s):" name) + (setq inside-paren-pair t) + (format "(%s, " name)))))) + (setq first-line nil)) + ;; Close any open list of defuns. + (when inside-paren-pair + (delete-char -2) + (insert "):"))))) (defun log-edit-fill-entry (&optional justify) "Like \\[fill-paragraph], but for filling ChangeLog-formatted entries. @@ -595,32 +658,70 @@ Consecutive function entries without prose (i.e., lines of the form \"(FUNCTION):\") will be combined into \"(FUNC1, FUNC2):\" according to `fill-column'." (save-excursion - (pcase-let ((`(,beg ,end) (log-edit-changelog-paragraph))) + (let* ((range (log-edit-changelog-paragraph)) + (beg (car range)) + (end (cadr range))) (if (= beg end) ;; Not a ChangeLog entry, fill as normal. nil - (cl-callf copy-marker end) + (setq end (copy-marker end)) (goto-char beg) - (cl-loop - for defuns-beg = - (and (< beg end) - (re-search-forward - (concat "\\(?1:" change-log-unindented-file-names-re - "\\)\\|^\\(?1:\\)[[:blank:]]*(") - end t) - (copy-marker (match-end 1))) - ;; Fill prose between log entries. - do (let ((fill-indent-according-to-mode t) - (end (if defuns-beg (match-beginning 0) end)) - (beg (progn (goto-char beg) (line-beginning-position)))) - (when (<= (line-end-position) end) - (fill-region beg end justify))) - while defuns-beg - for defuns = (progn (goto-char defuns-beg) - (change-log-read-defuns end)) - do (progn (delete-region defuns-beg (point)) - (log-edit--insert-filled-defuns defuns) - (setq beg (point)))) + (let* ((defuns-beg nil) + (defuns nil)) + (while + (progn + ;; Match a regexp against the next ChangeLog entry. + ;; `defuns-beg' will be the end of the file name, + ;; which marks the beginning of the list of defuns. + (setq defuns-beg + (and (< beg end) + (re-search-forward + (concat "\\(?1:" + change-log-unindented-file-names-re + "\\)\\|^\\(?1:\\)[[:blank:]]*(") + end t) + (copy-marker (match-end 1)))) + ;; Fill the intervening prose between the end of the + ;; last match and the beginning of the current match. + (let ((fill-indent-according-to-mode t) + (end (if defuns-beg + (match-beginning 0) end)) + (beg (progn (goto-char beg) + (line-beginning-position))) + space-beg space-end) + (when (<= (line-end-position) end) + ;; Replace space characters within parentheses + ;; that resemble ChangeLog defun names between BEG + ;; and END with non-breaking spaces to prevent + ;; them from being considered break points by + ;; `fill-region'. + (save-excursion + (goto-char beg) + (when (re-search-forward + "^[[:blank:]]*(.*\\([[:space:]]\\).*):" + end t) + (replace-regexp-in-region "[[:space:]]" " " + (setq space-beg + (copy-marker + (match-beginning 0))) + (setq space-end + (copy-marker + (match-end 0)))))) + (fill-region beg end justify)) + ;; Restore the spaces replaced by NBSPs. + (when space-beg + (replace-string-in-region " " " " + space-beg space-end) + (set-marker space-beg nil) + (set-marker space-end nil))) + defuns-beg) + (goto-char defuns-beg) + (setq defuns (change-log-read-defuns end)) + (progn + (delete-region defuns-beg (point)) + (log-edit--insert-filled-defuns defuns) + (setq beg (point)))) + nil) t)))) (defun log-edit-hide-buf (&optional buf where) @@ -1288,3 +1389,7 @@ line of MSG." (provide 'log-edit) ;;; log-edit.el ends here + +;; Local Variables: +;; coding: utf-8-unix +;; End: diff --git a/lisp/vc/vc-cvs.el b/lisp/vc/vc-cvs.el index 52039f8da74..63b566b0afe 100644 --- a/lisp/vc/vc-cvs.el +++ b/lisp/vc/vc-cvs.el @@ -476,7 +476,7 @@ The changes are between FIRST-REVISION and SECOND-REVISION." (concat "-j" first-revision) (concat "-j" second-revision)) (vc-file-setprop file 'vc-state 'edited) - (with-current-buffer (get-buffer "*vc*") + (with-current-buffer "*vc*" (goto-char (point-min)) (if (re-search-forward "conflicts during merge" nil t) (progn @@ -495,7 +495,7 @@ The changes are between FIRST-REVISION and SECOND-REVISION." (vc-cvs-command nil nil file "update") ;; Analyze the merge result reported by CVS, and set ;; file properties accordingly. - (with-current-buffer (get-buffer "*vc*") + (with-current-buffer "*vc*" (goto-char (point-min)) ;; get new working revision (if (re-search-forward diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index fed15ae2033..b23a5ca95a1 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -817,27 +817,31 @@ or an empty string if none." cmds)) (defun vc-git-dir-extra-headers (dir) - (let ((str (with-output-to-string - (with-current-buffer standard-output - (vc-git--out-ok "symbolic-ref" "HEAD")))) + (let ((str (vc-git--out-str "symbolic-ref" "HEAD")) (stash-list (vc-git-stash-list)) (default-directory dir) (in-progress (vc-git--cmds-in-progress)) - branch remote remote-url stash-button stash-string) + branch remote-url stash-button stash-string tracking-branch) (if (string-match "^\\(refs/heads/\\)?\\(.+\\)$" str) (progn (setq branch (match-string 2 str)) - (setq remote - (with-output-to-string - (with-current-buffer standard-output - (vc-git--out-ok "config" - (concat "branch." branch ".remote"))))) - (when (string-match "\\([^\n]+\\)" remote) - (setq remote (match-string 1 remote))) - (when (> (length remote) 0) - (setq remote-url (vc-git-repository-url dir remote)))) - (setq branch "not (detached HEAD)")) + (let ((remote (vc-git--out-str + "config" (concat "branch." branch ".remote"))) + (merge (vc-git--out-str + "config" (concat "branch." branch ".merge")))) + (when (string-match "\\([^\n]+\\)" remote) + (setq remote (match-string 1 remote))) + (when (string-match "^\\(refs/heads/\\)?\\(.+\\)$" merge) + (setq tracking-branch (match-string 2 merge))) + (pcase remote + ("." + (setq remote-url "none (tracking local branch)")) + ((pred (not string-empty-p)) + (setq + remote-url (vc-git-repository-url dir remote) + tracking-branch (concat remote "/" tracking-branch)))))) + (setq branch "none (detached HEAD)")) (when stash-list (let* ((len (length stash-list)) (limit @@ -890,6 +894,11 @@ or an empty string if none." (propertize "Branch : " 'face 'vc-dir-header) (propertize branch 'face 'vc-dir-header-value) + (when tracking-branch + (concat + "\n" + (propertize "Tracking : " 'face 'vc-dir-header) + (propertize tracking-branch 'face 'vc-dir-header-value))) (when remote-url (concat "\n" @@ -1411,9 +1420,16 @@ This prompts for a branch to merge from." (vc-message-unresolved-conflicts buffer-file-name))) (defun vc-git-clone (remote directory rev) - (if rev - (vc-git--out-ok "clone" "--branch" rev remote directory) + "Attempt to clone REMOTE repository into DIRECTORY at revision REV." + (cond + ((null rev) (vc-git--out-ok "clone" remote directory)) + ((ignore-errors + (vc-git--out-ok "clone" "--branch" rev remote directory))) + ((vc-git--out-ok "clone" remote directory) + (let ((default-directory directory)) + (vc-git--out-ok "checkout" rev))) + ((error "Failed to check out %s at %s" remote rev))) directory) ;;; HISTORY FUNCTIONS @@ -1982,6 +1998,7 @@ This requires git 1.8.4 or later, for the \"-L\" option of \"git log\"." (defvar compilation-environment) ;; Derived from `lgrep'. +;;;###autoload (defun vc-git-grep (regexp &optional files dir) "Run git grep, searching for REGEXP in FILES in directory DIR. The search is limited to file names matching shell pattern FILES. @@ -2218,8 +2235,17 @@ The difference to vc-do-command is that this function always invokes (apply #'process-file vc-git-program nil buffer nil "--no-pager" command args))) (defun vc-git--out-ok (command &rest args) + "Run `git COMMAND ARGS...' and insert standard output in current buffer. +Return whether the process exited with status zero." (zerop (apply #'vc-git--call '(t nil) command args))) +(defun vc-git--out-str (command &rest args) + "Run `git COMMAND ARGS...' and return standard output as a string. +The exit status is ignored." + (with-output-to-string + (with-current-buffer standard-output + (apply #'vc-git--out-ok command args)))) + (defun vc-git--run-command-string (file &rest args) "Run a git command on FILE and return its output as string. FILE can be nil." diff --git a/lisp/vc/vc-hooks.el b/lisp/vc/vc-hooks.el index 1ef1388e21f..8f212e96933 100644 --- a/lisp/vc/vc-hooks.el +++ b/lisp/vc/vc-hooks.el @@ -185,8 +185,9 @@ revision number and lock status." "Version Control minor mode. This minor mode is automatically activated whenever you visit a file under control of one of the revision control systems in `vc-handled-backends'. -VC commands are globally reachable under the prefix `\\[vc-prefix-map]': -\\{vc-prefix-map}") +VC commands are globally reachable under the prefix \\[vc-prefix-map]: +\\{vc-prefix-map}" + nil) (defmacro vc-error-occurred (&rest body) `(condition-case nil (progn ,@body nil) (error t))) @@ -197,7 +198,7 @@ VC commands are globally reachable under the prefix `\\[vc-prefix-map]': ;; during any subsequent VC operations, and forget them when ;; the buffer is killed. -(defvar vc-file-prop-obarray (make-vector 17 0) +(defvar vc-file-prop-obarray (obarray-make 17) "Obarray for per-file properties.") (defvar vc-touched-properties nil) @@ -325,30 +326,37 @@ This function performs the check each time it is called. To rely on the result of a previous call, use `vc-backend' instead. If the file was previously registered under a certain backend, then that backend is tried first." - (let (handler) - (cond - ((and (file-name-directory file) - (string-match vc-ignore-dir-regexp (file-name-directory file))) - nil) - ((setq handler (find-file-name-handler file 'vc-registered)) - ;; handler should set vc-backend and return t if registered - (funcall handler 'vc-registered file)) - (t - ;; There is no file name handler. - ;; Try vc-BACKEND-registered for each handled BACKEND. - (catch 'found - (let ((backend (vc-file-getprop file 'vc-backend))) - (mapc - (lambda (b) - (and (vc-call-backend b 'registered file) - (vc-file-setprop file 'vc-backend b) - (throw 'found t))) - (if (or (not backend) (eq backend 'none)) - vc-handled-backends - (cons backend vc-handled-backends)))) - ;; File is not registered. - (vc-file-setprop file 'vc-backend 'none) - nil))))) + ;; Subprocesses (and with them, VC backends) can't run from /contents + ;; or /actions, which are fictions maintained by Emacs that do not + ;; exist in the filesystem. + (if (and (eq system-type 'android) + (string-match-p "/\\(content\\|assets\\)[/$]" + (expand-file-name file))) + nil + (let (handler) + (cond + ((and (file-name-directory file) + (string-match vc-ignore-dir-regexp (file-name-directory file))) + nil) + ((setq handler (find-file-name-handler file 'vc-registered)) + ;; handler should set vc-backend and return t if registered + (funcall handler 'vc-registered file)) + (t + ;; There is no file name handler. + ;; Try vc-BACKEND-registered for each handled BACKEND. + (catch 'found + (let ((backend (vc-file-getprop file 'vc-backend))) + (mapc + (lambda (b) + (and (vc-call-backend b 'registered file) + (vc-file-setprop file 'vc-backend b) + (throw 'found t))) + (if (or (not backend) (eq backend 'none)) + vc-handled-backends + (cons backend vc-handled-backends)))) + ;; File is not registered. + (vc-file-setprop file 'vc-backend 'none) + nil)))))) (defun vc-backend (file-or-list) "Return the version control type of FILE-OR-LIST, nil if it's not registered. @@ -356,15 +364,22 @@ If the argument is a list, the files must all have the same back end." ;; `file' can be nil in several places (typically due to the use of ;; code like (vc-backend buffer-file-name)). (cond ((stringp file-or-list) - (let ((property (vc-file-getprop file-or-list 'vc-backend))) - ;; Note that internally, Emacs remembers unregistered - ;; files by setting the property to `none'. - (cond ((eq property 'none) nil) - (property) - ;; vc-registered sets the vc-backend property - (t (if (vc-registered file-or-list) - (vc-file-getprop file-or-list 'vc-backend) - nil))))) + ;; Subprocesses (and with them, VC backends) can't run from + ;; /contents or /actions, which are fictions maintained by + ;; Emacs that do not exist in the filesystem. + (if (and (eq system-type 'android) + (string-match-p "/\\(content\\|assets\\)[/$]" + (expand-file-name file-or-list))) + nil + (let ((property (vc-file-getprop file-or-list 'vc-backend))) + ;; Note that internally, Emacs remembers unregistered + ;; files by setting the property to `none'. + (cond ((eq property 'none) nil) + (property) + ;; vc-registered sets the vc-backend property + (t (if (vc-registered file-or-list) + (vc-file-getprop file-or-list 'vc-backend) + nil)))))) ((and file-or-list (listp file-or-list)) (vc-backend (car file-or-list))) (t diff --git a/lisp/vc/vc-rcs.el b/lisp/vc/vc-rcs.el index 1a43b440d18..33377ce1cc8 100644 --- a/lisp/vc/vc-rcs.el +++ b/lisp/vc/vc-rcs.el @@ -1177,7 +1177,7 @@ variable `vc-rcs-release' is set to the returned value." (or vc-rcs-release (setq vc-rcs-release (or (and (zerop (vc-do-command "*vc*" nil "rcs" nil "-V")) - (with-current-buffer (get-buffer "*vc*") + (with-current-buffer "*vc*" (vc-parse-buffer "^RCS version \\([0-9.]+ *.*\\)" 1))) 'unknown)))) diff --git a/lisp/vc/vc-svn.el b/lisp/vc/vc-svn.el index 96baa642b44..ae281e54519 100644 --- a/lisp/vc/vc-svn.el +++ b/lisp/vc/vc-svn.el @@ -436,7 +436,7 @@ The changes are between FIRST-VERSION and SECOND-VERSION." (concat first-version ":" second-version) first-version)) (vc-file-setprop file 'vc-state 'edited) - (with-current-buffer (get-buffer "*vc*") + (with-current-buffer "*vc*" (goto-char (point-min)) (if (looking-at "C ") 1 ; signal conflict @@ -450,7 +450,7 @@ The changes are between FIRST-VERSION and SECOND-VERSION." (vc-svn-command nil 0 file "update") ;; Analyze the merge result reported by SVN, and set ;; file properties accordingly. - (with-current-buffer (get-buffer "*vc*") + (with-current-buffer "*vc*" (goto-char (point-min)) ;; get new working revision (if (re-search-forward diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index b8cc44fc3dc..f26e5cc751d 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -935,7 +935,7 @@ is sensitive to blank lines." (defun vc-clear-context () "Clear all cached file properties." (interactive) - (fillarray vc-file-prop-obarray 0)) + (obarray-clear vc-file-prop-obarray)) (defmacro with-vc-properties (files form settings) "Execute FORM, then maybe set per-file properties for FILES. @@ -2703,20 +2703,22 @@ Not all VC backends support short logs!") (defun vc-print-log-setup-buttons (working-revision is-start-revision limit pl-return) "Insert at the end of the current buffer buttons to show more log entries. In the new log, leave point at WORKING-REVISION (if non-nil). -LIMIT is the current maximum number of entries shown. Does -nothing if IS-START-REVISION is non-nil and LIMIT is 1, or if -LIMIT is nil, or if PL-RETURN is `limit-unsupported'." +LIMIT is the current maximum number of entries shown, or the +revision (string) before which to stop. Does nothing if +IS-START-REVISION is non-nil and LIMIT is 1, or if LIMIT is nil, +or if PL-RETURN is `limit-unsupported'." ;; LIMIT=1 is set by vc-annotate-show-log-revision-at-line ;; or by vc-print-root-log with current-prefix-arg=1. ;; In either case only one revision is wanted, no buttons. (when (and limit (not (eq 'limit-unsupported pl-return)) (not (and is-start-revision - (= limit 1)))) + (eql limit 1)))) (let ((entries 0)) (goto-char (point-min)) (while (re-search-forward log-view-message-re nil t) (cl-incf entries)) - (if (< entries limit) + (if (or (stringp limit) + (< entries limit)) ;; The log has been printed in full. Perhaps it started ;; with a copy or rename? ;; FIXME: We'd probably still want this button even when @@ -2811,7 +2813,8 @@ button for. Same for CURRENT-REVISION. LIMIT means the usual." Leave point at WORKING-REVISION, if it is non-nil. If IS-START-REVISION is non-nil, start the log from WORKING-REVISION \(not all backends support this); i.e., show only WORKING-REVISION and -earlier revisions. Show up to LIMIT entries (non-nil means unlimited)." +earlier revisions. Show up to LIMIT entries (nil means unlimited). +LIMIT can also be a string, which means the revision before which to stop." ;; Don't switch to the output buffer before running the command, ;; so that any buffer-local settings in the vc-controlled ;; buffer can be accessed by the command. @@ -3620,7 +3623,15 @@ revisions. When invoked interactively in a Log View buffer with marked revisions, use those." (interactive - (let ((revs (vc-prepare-patch-prompt-revisions)) to) + (let* ((revs (vc-prepare-patch-prompt-revisions)) + (subject + (and (length= revs 1) + (plist-get + (vc-call-backend + (vc-responsible-backend default-directory) + 'prepare-patch (car revs)) + :subject))) + to) (require 'message) (while (null (setq to (completing-read-multiple (format-prompt @@ -3633,10 +3644,9 @@ marked revisions, use those." (sit-for blink-matching-delay)) (list (string-join to ", ") (and (not vc-prepare-patches-separately) - (read-string "Subject: " "[PATCH] " nil nil t)) + (read-string "Subject: " (or subject "[PATCH] ") nil nil t)) revs))) (save-current-buffer - (vc-ensure-vc-buffer) (let ((patches (mapcar (lambda (rev) (vc-call-backend (vc-responsible-backend default-directory) @@ -3791,11 +3801,16 @@ to provide the `find-revision' operation instead." (vc-call-backend (vc-backend buffer-file-name) 'check-headers)) (defun vc-clone (remote &optional backend directory rev) - "Use BACKEND to clone REMOTE into DIRECTORY. -If successful, returns the string with the directory of the -checkout. If BACKEND is nil, iterate through every known backend -in `vc-handled-backends' until one succeeds. If REV is non-nil, -it indicates a specific revision to check out." + "Clone repository REMOTE using version-control BACKEND, into DIRECTORY. +If successful, return the string with the directory of the checkout; +otherwise return nil. +REMOTE should be a string, the URL of the remote repository or the name +of a directory (if the repository is local). +If DIRECTORY is nil or omitted, it defaults to `default-directory'. +If BACKEND is nil or omitted, the function iterates through every known +backend in `vc-handled-backends' until one succeeds to clone REMOTE. +If REV is non-nil, it indicates a specific revision to check out after +cloning; the syntax of REV depends on what BACKEND accepts." (setq directory (expand-file-name (or directory default-directory))) (if backend (progn diff --git a/lisp/vcursor.el b/lisp/vcursor.el index ec5adbd832c..15791285b13 100644 --- a/lisp/vcursor.el +++ b/lisp/vcursor.el @@ -433,7 +433,7 @@ Default is nil." (defcustom vcursor-interpret-input nil "If non-nil, input from the vcursor is treated as interactive input. This will cause text insertion to be much slower. Note that no special -interpretation of strings is done: \"\C-x\" is a string of four +interpretation of strings is done: \"\\C-x\" is a string of four characters. The default is simply to copy strings." :type 'boolean :version "20.3") diff --git a/lisp/visual-wrap.el b/lisp/visual-wrap.el new file mode 100644 index 00000000000..d95cf4bb569 --- /dev/null +++ b/lisp/visual-wrap.el @@ -0,0 +1,204 @@ +;;; visual-wrap.el --- Smart line-wrapping with wrap-prefix -*- lexical-binding: t -*- + +;; Copyright (C) 2011-2021, 2024 Free Software Foundation, Inc. + +;; Author: Stephen Berman <stephen.berman@gmx.net> +;; Stefan Monnier <monnier@iro.umontreal.ca> +;; Maintainer: emacs-devel@gnu.org +;; Keywords: convenience +;; Package: emacs + +;; This file is part of GNU Emacs. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This package provides the `visual-wrap-prefix-mode' minor mode +;; which sets the wrap-prefix property on the fly so that +;; single-long-line paragraphs get word-wrapped in a way similar to +;; what you'd get with M-q using adaptive-fill-mode, but without +;; actually changing the buffer's text. + +;;; Code: + +(defcustom visual-wrap-extra-indent 0 + "Number of extra spaces to indent in `visual-wrap-prefix-mode'. + +`visual-wrap-prefix-mode' indents the visual lines to the level +of the actual line plus `visual-wrap-extra-indent'. A negative +value will do a relative de-indent. + +Examples: + +actual indent = 2 +extra indent = -1 + + Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed + do eiusmod tempor incididunt ut labore et dolore magna + aliqua. Ut enim ad minim veniam, quis nostrud exercitation + ullamco laboris nisi ut aliquip ex ea commodo consequat. + +actual indent = 2 +extra indent = 2 + + Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed + do eiusmod tempor incididunt ut labore et dolore magna + aliqua. Ut enim ad minim veniam, quis nostrud exercitation + ullamco laboris nisi ut aliquip ex ea commodo consequat." + :type 'integer + :safe 'integerp + :version "30.1" + :group 'visual-line) + +(defun visual-wrap--face-extend-p (face) + ;; Before Emacs 27, faces always extended beyond EOL, so we check + ;; for a non-default background instead. + (cond + ((listp face) + (plist-get face (if (fboundp 'face-extend-p) :extend :background))) + ((symbolp face) + (if (fboundp 'face-extend-p) + (face-extend-p face nil t) + (face-background face nil t))))) + +(defun visual-wrap--prefix-face (fcp _beg end) + ;; If the fill-context-prefix already specifies a face, just use that. + (cond ((get-text-property 0 'face fcp)) + ;; Else, if the last character is a newline and has a face + ;; that extends beyond EOL, assume that this face spans the + ;; whole line and apply it to the prefix to preserve the + ;; "block" visual effect. + ;; + ;; NB: the face might not actually span the whole line: see + ;; for example removed lines in diff-mode, where the first + ;; character has the diff-indicator-removed face, while the + ;; rest of the line has the diff-removed face. + ((= (char-before end) ?\n) + (let ((eol-face (get-text-property (1- end) 'face))) + ;; `eol-face' can be a face, a "face value" + ;; (plist of face properties) or a list of one of those. + (if (or (not (consp eol-face)) (keywordp (car eol-face))) + ;; A single face. + (if (visual-wrap--face-extend-p eol-face) eol-face) + ;; A list of faces. Keep the ones that extend beyond EOL. + (delq nil (mapcar (lambda (f) + (if (visual-wrap--face-extend-p f) f)) + eol-face))))))) + +(defun visual-wrap--prefix (fcp) + (let ((fcp-len (string-width fcp))) + (cond + ((= 0 visual-wrap-extra-indent) + fcp) + ((< 0 visual-wrap-extra-indent) + (concat fcp (make-string visual-wrap-extra-indent ?\s))) + ((< 0 (+ visual-wrap-extra-indent fcp-len)) + (substring fcp + 0 + (+ visual-wrap-extra-indent fcp-len))) + (t + "")))) + +(defun visual-wrap-fill-context-prefix (beg end) + "Compute visual wrap prefix from text between BEG and END. +This is like `fill-context-prefix', but with prefix length adjusted +by `visual-wrap-extra-indent'." + (let* ((fcp + ;; `fill-context-prefix' ignores prefixes that look like + ;; paragraph starts, in order to avoid inadvertently + ;; creating a new paragraph while filling, but here we're + ;; only dealing with single-line "paragraphs" and we don't + ;; actually modify the buffer, so this restriction doesn't + ;; make much sense (and is positively harmful in + ;; taskpaper-mode where paragraph-start matches everything). + (or (let ((paragraph-start regexp-unmatchable)) + (fill-context-prefix beg end)) + ;; Note: fill-context-prefix may return nil; See: + ;; http://article.gmane.org/gmane.emacs.devel/156285 + "")) + (prefix (visual-wrap--prefix fcp)) + (face (visual-wrap--prefix-face fcp beg end))) + (if face + (propertize prefix 'face face) + prefix))) + +(defun visual-wrap-prefix-function (beg end) + "Indent the region between BEG and END with visual filling." + ;; Any change at the beginning of a line might change its wrap + ;; prefix, which affects the whole line. So we need to "round-up" + ;; `end' to the nearest end of line. We do the same with `beg' + ;; although it's probably not needed. + (goto-char end) + (unless (bolp) (forward-line 1)) + (setq end (point)) + (goto-char beg) + (forward-line 0) + (setq beg (point)) + (while (< (point) end) + (let ((lbp (point))) + (put-text-property + (point) (progn (search-forward "\n" end 'move) (point)) + 'wrap-prefix + (let ((pfx (visual-wrap-fill-context-prefix + lbp (point)))) + ;; Remove any `wrap-prefix' property that might have been + ;; added earlier. Otherwise, we end up with a string + ;; containing a `wrap-prefix' string containing a + ;; `wrap-prefix' string ... + (remove-text-properties + 0 (length pfx) '(wrap-prefix) pfx) + (let ((dp (get-text-property 0 'display pfx))) + (when (and dp (eq dp (get-text-property (1- lbp) 'display))) + ;; There's a `display' property which covers not just the + ;; prefix but also the previous newline. So it's not + ;; just making the prefix more pretty and could interfere + ;; or even defeat our efforts (e.g. it comes from + ;; `adaptive-fill-mode'). + (remove-text-properties + 0 (length pfx) '(display) pfx))) + pfx)))) + `(jit-lock-bounds ,beg . ,end)) + +;;;###autoload +(define-minor-mode visual-wrap-prefix-mode + "Display continuation lines with prefixes from surrounding context. +To enable this minor mode across all buffers, enable +`global-visual-wrap-prefix-mode'." + :lighter "" + :group 'visual-line + (if visual-wrap-prefix-mode + (progn + ;; HACK ATTACK! We want to run after font-lock (so our + ;; wrap-prefix includes the faces applied by font-lock), but + ;; jit-lock-register doesn't accept an `append' argument, so + ;; we add ourselves beforehand, to make sure we're at the end + ;; of the hook (bug#15155). + (add-hook 'jit-lock-functions + #'visual-wrap-prefix-function 'append t) + (jit-lock-register #'visual-wrap-prefix-function)) + (jit-lock-unregister #'visual-wrap-prefix-function) + (with-silent-modifications + (save-restriction + (widen) + (remove-text-properties (point-min) (point-max) '(wrap-prefix nil)))))) + +;;;###autoload +(define-globalized-minor-mode global-visual-wrap-prefix-mode + visual-wrap-prefix-mode visual-wrap-prefix-mode + :init-value nil + :group 'visual-line) + +(provide 'visual-wrap) +;;; visual-wrap.el ends here diff --git a/lisp/whitespace.el b/lisp/whitespace.el index 6f47e32beb5..15c1b83fcc1 100644 --- a/lisp/whitespace.el +++ b/lisp/whitespace.el @@ -1774,10 +1774,10 @@ cleaning up these problems." (when has-bogus (goto-char (point-max)) (insert (substitute-command-keys - " Type `\\[whitespace-cleanup]'") + " Type \\[whitespace-cleanup]") " to cleanup the buffer.\n\n" (substitute-command-keys - " Type `\\[whitespace-cleanup-region]'") + " Type \\[whitespace-cleanup-region]") " to cleanup a region.\n\n")) (whitespace-display-window (current-buffer)))))) has-bogus))) diff --git a/lisp/wid-browse.el b/lisp/wid-browse.el index bb56f3f62fb..d4000187bd1 100644 --- a/lisp/wid-browse.el +++ b/lisp/wid-browse.el @@ -141,7 +141,7 @@ The following commands are available: (setq key (nth 0 items) value (nth 1 items) printer (or (get key 'widget-keyword-printer) - 'widget-browse-sexp) + #'widget-browse-sexp) items (cdr (cdr items))) (widget-insert "\n" (symbol-name key) "\n\t") (funcall printer widget key value) @@ -204,24 +204,10 @@ VALUE is assumed to be a list of widgets." (defun widget-browse-sexp (_widget _key value) "Insert description of WIDGET's KEY VALUE. Nothing is assumed about value." - (let ((pp (condition-case signal - (pp-to-string value) - (error (prin1-to-string signal))))) - (when (string-match "\n\\'" pp) - (setq pp (substring pp 0 (1- (length pp))))) - (if (cond ((string-search "\n" pp) - nil) - ((> (length pp) (- (window-width) (current-column))) - nil) - (t t)) - (widget-insert pp) - (widget-create 'push-button - :tag "show" - :action (lambda (widget &optional _event) - (with-output-to-temp-buffer - "*Pp Eval Output*" - (princ (widget-get widget :value)))) - pp)))) + (require 'pp) + (declare-function pp-insert-short-sexp "pp" (sexp &optional width)) + (widget--allow-insertion + (pp-insert-short-sexp value))) (defun widget-browse-sexps (widget key value) "Insert description of WIDGET's KEY VALUE. @@ -235,11 +221,11 @@ VALUE is assumed to be a list of widgets." ;;; Keyword Printers. -(put :parent 'widget-keyword-printer 'widget-browse-widget) -(put :children 'widget-keyword-printer 'widget-browse-widgets) -(put :buttons 'widget-keyword-printer 'widget-browse-widgets) -(put :button 'widget-keyword-printer 'widget-browse-widget) -(put :args 'widget-keyword-printer 'widget-browse-sexps) +(put :parent 'widget-keyword-printer #'widget-browse-widget) +(put :children 'widget-keyword-printer #'widget-browse-widgets) +(put :buttons 'widget-keyword-printer #'widget-browse-widgets) +(put :button 'widget-keyword-printer #'widget-browse-widget) +(put :args 'widget-keyword-printer #'widget-browse-sexps) ;;; Widget Minor Mode. diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index cd06acd3f99..172da3db1e0 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -1,4 +1,4 @@ -;;; wid-edit.el --- Functions for creating and using widgets -*- lexical-binding:t -*- +;; wid-edit.el --- Functions for creating and using widgets -*- lexical-binding:t -*- ;; ;; Copyright (C) 1996-1997, 1999-2024 Free Software Foundation, Inc. ;; @@ -247,10 +247,10 @@ to evaluate to nil for the menu item to be meaningful." (eq (car value) :radio)) (setq selected (cdr value)))) (setq plist (cddr plist))) - (when (and (eval visible) - (eval enable) + (when (and (eval visible t) + (eval enable t) (or (not selected) - (not (eval selected)))) + (not (eval selected t)))) (push (cons (nth 1 def) ev) simplified))))) extended) (reverse simplified))) @@ -317,7 +317,7 @@ in the key vector, as in the argument of `define-key'." (when (keymapp items) (setq items (widget--simplify-menu items))) ;; Read the choice of name from the minibuffer. - (setq items (cl-remove-if 'stringp items)) + (setq items (cl-remove-if #'stringp items)) (let ((val (completing-read (concat title ": ") items nil t))) (if (stringp val) (let ((try (try-completion val items))) @@ -330,12 +330,11 @@ in the key vector, as in the argument of `define-key'." ;; Construct a menu of the choices ;; and then use it for prompting for a single character. (let ((next-digit ?0) - alist choice some-choice-enabled value) + alist some-choice-enabled value) (with-current-buffer (get-buffer-create " widget-choose") (erase-buffer) (insert "Available choices:\n\n") - (while items - (setq choice (pop items)) + (dolist (choice items) (when (consp choice) (insert (format "%c = %s\n" next-digit (car choice))) (push (cons next-digit (cdr choice)) alist) @@ -510,14 +509,20 @@ With CHECK-AFTER non-nil, considers also the content after point, if needed." ;; indented it. (not (eq (following-char) ?\s)))))) -(defmacro widget-specify-insert (&rest form) - "Execute FORM without inheriting any text properties." - (declare (debug (body))) +(defmacro widget--allow-insertion (&rest forms) + "Run FORMS such that they can insert widgets in the current buffer." + (declare (debug t)) + `(let ((inhibit-read-only t) + (inhibit-modification-hooks t)) ;; FIXME: Why? This is risky! + ,@forms)) + +(defmacro widget-specify-insert (&rest forms) + "Execute FORMS without inheriting any text properties." + (declare (debug t)) `(save-restriction - (let ((inhibit-read-only t) - (inhibit-modification-hooks t)) + (widget--allow-insertion (narrow-to-region (point) (point)) - (prog1 (progn ,@form) + (prog1 (progn ,@forms) (goto-char (point-max)))))) (defface widget-inactive @@ -659,12 +664,9 @@ The current value is assumed to be VALUE, unless UNBOUND is non-nil." (defun widget-get-sibling (widget) "Get the item WIDGET is assumed to toggle. This is only meaningful for radio buttons or checkboxes in a list." - (let* ((children (widget-get (widget-get widget :parent) :children)) - child) + (let* ((children (widget-get (widget-get widget :parent) :children))) (catch 'child - (while children - (setq child (car children) - children (cdr children)) + (dolist (child children) (when (eq (widget-get child :button) widget) (throw 'child child))) nil))) @@ -844,14 +846,14 @@ button is pressed or inactive, respectively. These are currently ignored." (defun widget-create (type &rest args) "Create widget of TYPE. The optional ARGS are additional keyword arguments." - (let ((widget (apply 'widget-convert type args))) + (let ((widget (apply #'widget-convert type args))) (widget-apply widget :create) widget)) (defun widget-create-child-and-convert (parent type &rest args) "As part of the widget PARENT, create a child widget TYPE. The child is converted, using the keyword arguments ARGS." - (let ((widget (apply 'widget-convert type args))) + (let ((widget (apply #'widget-convert type args))) (widget-put widget :parent parent) (unless (widget-get widget :indent) (widget-put widget :indent (+ (or (widget-get parent :indent) 0) @@ -905,18 +907,19 @@ The optional ARGS are additional keyword arguments." (keys args)) ;; First set the :args keyword. (while (cdr current) ;Look in the type. - (if (and (keywordp (cadr current)) - ;; If the last element is a keyword, - ;; it is still the :args element, - ;; even though it is a keyword. - (cddr current)) - (if (eq (cadr current) :args) - ;; If :args is explicitly specified, obey it. - (setq current nil) - ;; Some other irrelevant keyword. - (setq current (cdr (cdr current)))) - (setcdr current (list :args (cdr current))) - (setq current nil))) + (setq current + (if (and (keywordp (cadr current)) + ;; If the last element is a keyword, + ;; it is still the :args element, + ;; even though it is a keyword. + (cddr current)) + (if (eq (cadr current) :args) + ;; If :args is explicitly specified, obey it. + nil + ;; Some other irrelevant keyword. + (cdr (cdr current))) + (setcdr current (list :args (cdr current))) + nil))) (while (and args (not done)) ;Look in ARGS. (cond ((eq (car args) :args) ;; Handle explicit specification of :args. @@ -937,11 +940,9 @@ The optional ARGS are additional keyword arguments." ;; Finally set the keyword args. (while keys (let ((next (nth 0 keys))) - (if (keywordp next) - (progn - (widget-put widget next (nth 1 keys)) - (setq keys (nthcdr 2 keys))) - (setq keys nil)))) + (setq keys (when (keywordp next) + (widget-put widget next (nth 1 keys)) + (nthcdr 2 keys))))) ;; Convert the :value to internal format. (if (widget-member widget :value) (widget-put widget @@ -954,9 +955,8 @@ The optional ARGS are additional keyword arguments." ;;;###autoload (defun widget-insert (&rest args) "Call `insert' with ARGS even if surrounding text is read only." - (let ((inhibit-read-only t) - (inhibit-modification-hooks t)) - (apply 'insert args))) + (widget--allow-insertion + (apply #'insert args))) (defun widget-convert-text (type from to &optional button-from button-to @@ -967,7 +967,7 @@ and TO will be used as the widgets end points. If optional arguments BUTTON-FROM and BUTTON-TO are given, these will be used as the widgets button end points. Optional ARGS are extra keyword arguments for TYPE." - (let ((widget (apply 'widget-convert type :delete 'widget-leave-text args)) + (let ((widget (apply #'widget-convert type :delete 'widget-leave-text args)) (from (copy-marker from)) (to (copy-marker to))) (set-marker-insertion-type from t) @@ -984,7 +984,7 @@ Optional ARGS are extra keyword arguments for TYPE. No text will be inserted to the buffer, instead the text between FROM and TO will be used as the widgets end points, as well as the widgets button end points." - (apply 'widget-convert-text type from to from to args)) + (apply #'widget-convert-text type from to from to args)) (defun widget-leave-text (widget) "Remove markers and overlays from WIDGET and its children." @@ -1002,7 +1002,7 @@ button end points." (delete-overlay doc)) (when field (delete-overlay field)) - (mapc 'widget-leave-text (widget-get widget :children)))) + (mapc #'widget-leave-text (widget-get widget :children)))) (defun widget-text (widget) "Get the text representation of the widget." @@ -1017,7 +1017,7 @@ button end points." ;; Custom-mode) which key-binding of widget-keymap one wants to refer to. ;; https://lists.gnu.org/r/emacs-devel/2008-11/msg00480.html (define-obsolete-function-alias 'advertised-widget-backward - 'widget-backward "23.2") + #'widget-backward "23.2") ;;;###autoload (defvar widget-keymap @@ -1043,13 +1043,13 @@ Note that such modes will need to require wid-edit.") (defvar widget-field-keymap (let ((map (copy-keymap widget-keymap))) - (define-key map "\C-k" 'widget-kill-line) - (define-key map "\M-\t" 'widget-complete) - (define-key map "\C-m" 'widget-field-activate) + (define-key map "\C-k" #'widget-kill-line) + (define-key map "\M-\t" #'widget-complete) + (define-key map "\C-m" #'widget-field-activate) ;; Since the widget code uses a `field' property to identify fields, ;; ordinary beginning-of-line does the right thing. - ;; (define-key map "\C-a" 'widget-beginning-of-line) - (define-key map "\C-e" 'widget-end-of-line) + ;; (define-key map "\C-a" #'widget-beginning-of-line) + (define-key map "\C-e" #'widget-end-of-line) map) "Keymap used inside an editable field.") @@ -1057,8 +1057,8 @@ Note that such modes will need to require wid-edit.") (let ((map (copy-keymap widget-keymap))) ;; Since the widget code uses a `field' property to identify fields, ;; ordinary beginning-of-line does the right thing. - ;; (define-key map "\C-a" 'widget-beginning-of-line) - (define-key map "\C-e" 'widget-end-of-line) + ;; (define-key map "\C-a" #'widget-beginning-of-line) + (define-key map "\C-e" #'widget-end-of-line) map) "Keymap used inside a text field.") @@ -1299,7 +1299,7 @@ With optional ARG, move across that many fields." ;; Since the widget code uses a `field' property to identify fields, ;; ordinary beginning-of-line does the right thing. -(defalias 'widget-beginning-of-line 'beginning-of-line) +(defalias 'widget-beginning-of-line #'beginning-of-line) (defun widget-end-of-line () "Go to end of field or end of line, whichever is first. @@ -1376,19 +1376,18 @@ When not inside a field, signal an error." ;;;###autoload (defun widget-setup () "Setup current buffer so editing string widgets works." - (let ((inhibit-read-only t) - (inhibit-modification-hooks t) - field) - (while widget-field-new - (setq field (car widget-field-new) - widget-field-new (cdr widget-field-new) - widget-field-list (cons field widget-field-list)) - (let ((from (car (widget-get field :field-overlay))) - (to (cdr (widget-get field :field-overlay)))) - (widget-specify-field field - (marker-position from) (marker-position to)) - (set-marker from nil) - (set-marker to nil)))) + (widget--allow-insertion + (let (field) + (while widget-field-new + (setq field (car widget-field-new) + widget-field-new (cdr widget-field-new) + widget-field-list (cons field widget-field-list)) + (let ((from (car (widget-get field :field-overlay))) + (to (cdr (widget-get field :field-overlay)))) + (widget-specify-field field + (marker-position from) (marker-position to)) + (set-marker from nil) + (set-marker to nil))))) (widget-clear-undo) (widget-add-change)) @@ -1463,11 +1462,8 @@ When not inside a field, signal an error." (defun widget-field-find (pos) "Return the field at POS. Unlike (get-char-property POS \\='field), this works with empty fields too." - (let ((fields widget-field-list) - field found) - (while fields - (setq field (car fields) - fields (cdr fields)) + (let (found) + (dolist (field widget-field-list) (when (and (<= (widget-field-start field) pos) (<= pos (widget-field-end field))) (when found @@ -1482,11 +1478,11 @@ Unlike (get-char-property POS \\='field), this works with empty fields too." (let ((from-field (widget-field-find from)) (to-field (widget-field-find to))) (cond ((not (eq from-field to-field)) - (add-hook 'post-command-hook 'widget-add-change nil t) + (add-hook 'post-command-hook #'widget-add-change nil t) (signal 'text-read-only '("Change should be restricted to a single field"))) ((null from-field) - (add-hook 'post-command-hook 'widget-add-change nil t) + (add-hook 'post-command-hook #'widget-add-change nil t) (signal 'text-read-only '("Attempt to change text outside editable field"))) (widget-field-use-before-change @@ -1494,9 +1490,9 @@ Unlike (get-char-property POS \\='field), this works with empty fields too." from-field (list 'before-change from to))))))) (defun widget-add-change () - (remove-hook 'post-command-hook 'widget-add-change t) - (add-hook 'before-change-functions 'widget-before-change nil t) - (add-hook 'after-change-functions 'widget-after-change nil t)) + (remove-hook 'post-command-hook #'widget-add-change t) + (add-hook 'before-change-functions #'widget-before-change nil t) + (add-hook 'after-change-functions #'widget-after-change nil t)) (defun widget-after-change (from to _old) "Adjust field size and text properties." @@ -1516,12 +1512,12 @@ Unlike (get-char-property POS \\='field), this works with empty fields too." (insert-char ?\s (- (+ begin size) end)))) ((> (- end begin) size) ;; Field too large and - (if (or (< (point) (+ begin size)) - (> (point) end)) - ;; Point is outside extra space. - (setq begin (+ begin size)) - ;; Point is within the extra space. - (setq begin (point))) + (setq begin (if (or (< (point) (+ begin size)) + (> (point) end)) + ;; Point is outside extra space. + (+ begin size) + ;; Point is within the extra space. + (point))) (save-excursion (goto-char end) (while (and (eq (preceding-char) ?\s) @@ -1541,9 +1537,9 @@ Optional EVENT is the event that triggered the action." (defun widget-children-value-delete (widget) "Delete all :children and :buttons in WIDGET." - (mapc 'widget-delete (widget-get widget :children)) + (mapc #'widget-delete (widget-get widget :children)) (widget-put widget :children nil) - (mapc 'widget-delete (widget-get widget :buttons)) + (mapc #'widget-delete (widget-get widget :buttons)) (widget-put widget :buttons nil)) (defun widget-children-validate (widget) @@ -1594,13 +1590,13 @@ The value of the :type attribute should be an unconverted widget type." (defun widget-types-copy (widget) "Copy :args as widget types in WIDGET." - (widget-put widget :args (mapcar 'widget-copy (widget-get widget :args))) + (widget-put widget :args (mapcar #'widget-copy (widget-get widget :args))) widget) ;; Made defsubst to speed up face editor creation. (defsubst widget-types-convert-widget (widget) "Convert :args as widget types in WIDGET." - (widget-put widget :args (mapcar 'widget-convert (widget-get widget :args))) + (widget-put widget :args (mapcar #'widget-convert (widget-get widget :args))) widget) (defun widget-value-convert-widget (widget) @@ -1655,17 +1651,18 @@ The value of the :type attribute should be an unconverted widget type." (defun widget-default-completions (widget) "Return completion data, like `completion-at-point-functions' would." (let ((completions (widget-get widget :completions))) - (if completions - (list (widget-field-start widget) - (max (point) (widget-field-text-end widget)) - completions) - (if (widget-get widget :complete) - (lambda () (widget-apply widget :complete)) - (if (widget-get widget :complete-function) - (lambda () - (let ((widget--completing-widget widget)) - (call-interactively - (widget-get widget :complete-function))))))))) + (cond + (completions + (list (widget-field-start widget) + (max (point) (widget-field-text-end widget)) + completions)) + ((widget-get widget :complete) + (lambda () (widget-apply widget :complete))) + ((widget-get widget :complete-function) + (lambda () + (let ((widget--completing-widget widget)) + (call-interactively + (widget-get widget :complete-function)))))))) (defun widget-default-create (widget) "Create WIDGET at point in the current buffer." @@ -1773,24 +1770,23 @@ The value of the :type attribute should be an unconverted widget type." (inactive-overlay (widget-get widget :inactive)) (button-overlay (widget-get widget :button-overlay)) (sample-overlay (widget-get widget :sample-overlay)) - (doc-overlay (widget-get widget :doc-overlay)) - (inhibit-modification-hooks t) - (inhibit-read-only t)) - (widget-apply widget :value-delete) - (widget-children-value-delete widget) - (when inactive-overlay - (delete-overlay inactive-overlay)) - (when button-overlay - (delete-overlay button-overlay)) - (when sample-overlay - (delete-overlay sample-overlay)) - (when doc-overlay - (delete-overlay doc-overlay)) - (when (< from to) - ;; Kludge: this doesn't need to be true for empty formats. - (delete-region from to)) - (set-marker from nil) - (set-marker to nil)) + (doc-overlay (widget-get widget :doc-overlay))) + (widget--allow-insertion + (widget-apply widget :value-delete) + (widget-children-value-delete widget) + (when inactive-overlay + (delete-overlay inactive-overlay)) + (when button-overlay + (delete-overlay button-overlay)) + (when sample-overlay + (delete-overlay sample-overlay)) + (when doc-overlay + (delete-overlay doc-overlay)) + (when (< from to) + ;; Kludge: this doesn't need to be true for empty formats. + (delete-region from to)) + (set-marker from nil) + (set-marker to nil))) (widget-clear-undo)) (defun widget-default-value-set (widget value) @@ -1811,9 +1807,9 @@ The value of the :type attribute should be an unconverted widget type." (widget-put widget :value value) (widget-apply widget :create)) (if offset - (if (< offset 0) - (goto-char (+ (widget-get widget :to) offset 1)) - (goto-char (min (+ from offset) (1- (widget-get widget :to)))))))) + (goto-char (if (< offset 0) + (+ (widget-get widget :to) offset 1) + (min (+ from offset) (1- (widget-get widget :to)))))))) (defun widget-default-value-inline (widget) "Wrap value in a list unless it is inline." @@ -1976,8 +1972,8 @@ as the argument to `documentation-property'." ;; Only bind mouse-2, since mouse-1 will be translated accordingly to ;; the customization of `mouse-1-click-follows-link'. (define-key map [down-mouse-1] (lookup-key widget-global-map [down-mouse-1])) - (define-key map [down-mouse-2] 'widget-button-click) - (define-key map [mouse-2] 'widget-button-click) + (define-key map [down-mouse-2] #'widget-button-click) + (define-key map [mouse-2] #'widget-button-click) map) "Keymap used inside a link widget.") @@ -2325,13 +2321,10 @@ when he invoked the menu." ((and widget-choice-toggle (= (length args) 2) (memq old args)) - (if (eq old (nth 0 args)) - (nth 1 args) - (nth 0 args))) + (nth (if (eq old (nth 0 args)) 1 0) + args)) (t - (while args - (setq current (car args) - args (cdr args)) + (dolist (current args) (setq choices (cons (cons (widget-apply current :menu-tag-get) current) @@ -2424,9 +2417,8 @@ when he invoked the menu." (widget-toggle-action widget event) (let ((sibling (widget-get-sibling widget))) (when sibling - (if (widget-value widget) - (widget-apply sibling :activate) - (widget-apply sibling :deactivate)) + (widget-apply sibling + (if (widget-value widget) :activate :deactivate)) (widget-clear-undo)))) ;;; The `checklist' Widget. @@ -2475,7 +2467,7 @@ If the item is checked, CHOSEN is a cons whose cdr is the value." (cond ((eq escape ?%) (insert ?%)) ((eq escape ?b) - (setq button (apply 'widget-create-child-and-convert + (setq button (apply #'widget-create-child-and-convert widget 'checkbox :value (not (null chosen)) button-args))) @@ -2555,11 +2547,8 @@ Return an alist of (TYPE MATCH)." (defun widget-checklist-value-get (widget) ;; The values of all selected items. - (let ((children (widget-get widget :children)) - child result) - (while children - (setq child (car children) - children (cdr children)) + (let (result) + (dolist (child (widget-get widget :children)) (if (widget-value (widget-get child :button)) (setq result (append result (widget-apply child :value-inline))))) result)) @@ -2627,12 +2616,8 @@ Return an alist of (TYPE MATCH)." (defun widget-radio-value-create (widget) ;; Insert all values - (let ((args (widget-get widget :args)) - arg) - (while args - (setq arg (car args) - args (cdr args)) - (widget-radio-add-item widget arg)))) + (dolist (arg (widget-get widget :args)) + (widget-radio-add-item widget arg))) (defun widget-radio-add-item (widget type) "Add to radio widget WIDGET a new radio button item of type TYPE." @@ -2659,7 +2644,7 @@ Return an alist of (TYPE MATCH)." (cond ((eq escape ?%) (insert ?%)) ((eq escape ?b) - (setq button (apply 'widget-create-child-and-convert + (setq button (apply #'widget-create-child-and-convert widget 'radio-button :value (not (null chosen)) button-args))) @@ -2715,11 +2700,8 @@ Return an alist of (TYPE MATCH)." ;; We can't just delete and recreate a radio widget, since children ;; can be added after the original creation and won't be recreated ;; by `:create'. - (let ((children (widget-get widget :children)) - current found) - (while children - (setq current (car children) - children (cdr children)) + (let (found) + (dolist (current (widget-get widget :children)) (let* ((button (widget-get current :button)) (match (and (not found) (widget-apply current :match value)))) @@ -2746,13 +2728,9 @@ Return an alist of (TYPE MATCH)." (defun widget-radio-action (widget child event) ;; Check if a radio button was pressed. - (let ((children (widget-get widget :children)) - (buttons (widget-get widget :buttons)) - current) + (let ((buttons (widget-get widget :buttons))) (when (memq child buttons) - (while children - (setq current (car children) - children (cdr children)) + (dolist (current (widget-get widget :children)) (let* ((button (widget-get current :button))) (cond ((eq child button) (widget-value-set button t) @@ -2822,7 +2800,7 @@ Return an alist of (TYPE MATCH)." (and (widget--should-indent-p) (widget-get widget :indent) (insert-char ?\s (widget-get widget :indent))) - (apply 'widget-create-child-and-convert + (apply #'widget-create-child-and-convert widget 'insert-button (widget-get widget :append-button-args))) (t @@ -2842,9 +2820,9 @@ Return an alist of (TYPE MATCH)." (if answer (setq children (cons (widget-editable-list-entry-create widget - (if (widget-inline-p type t) - (car answer) - (car (car answer))) + (car (if (widget-inline-p type t) + answer + (car answer))) t) children) value (cdr answer)) @@ -2853,8 +2831,8 @@ Return an alist of (TYPE MATCH)." (defun widget-editable-list-value-get (widget) ;; Get value of the child widget. - (apply 'append (mapcar (lambda (child) (widget-apply child :value-inline)) - (widget-get widget :children)))) + (apply #'append (mapcar (lambda (child) (widget-apply child :value-inline)) + (widget-get widget :children)))) (defun widget-editable-list-match (widget value) ;; Value must be a list and all the members must match the type. @@ -2885,27 +2863,26 @@ The new widget gets inserted at the position of the BEFORE child." (last-deleted (when-let ((lst (widget-get widget :last-deleted))) (prog1 (pop lst) - (widget-put widget :last-deleted lst)))) - (inhibit-read-only t) - (inhibit-modification-hooks t)) - (cond (before - (goto-char (widget-get before :entry-from))) - (t - (goto-char (widget-get widget :value-pos)))) - (let ((child (widget-editable-list-entry-create - widget (and last-deleted - (widget-apply last-deleted - :value-to-external - (widget-get last-deleted :value))) - last-deleted))) - (when (< (widget-get child :entry-from) (widget-get widget :from)) - (set-marker (widget-get widget :from) - (widget-get child :entry-from))) - (if (eq (car children) before) - (widget-put widget :children (cons child children)) - (while (not (eq (car (cdr children)) before)) - (setq children (cdr children))) - (setcdr children (cons child (cdr children))))))) + (widget-put widget :last-deleted lst))))) + (widget--allow-insertion + (cond (before + (goto-char (widget-get before :entry-from))) + (t + (goto-char (widget-get widget :value-pos)))) + (let ((child (widget-editable-list-entry-create + widget (and last-deleted + (widget-apply last-deleted + :value-to-external + (widget-get last-deleted :value))) + last-deleted))) + (when (< (widget-get child :entry-from) (widget-get widget :from)) + (set-marker (widget-get widget :from) + (widget-get child :entry-from))) + (if (eq (car children) before) + (widget-put widget :children (cons child children)) + (while (not (eq (car (cdr children)) before)) + (setq children (cdr children))) + (setcdr children (cons child (cdr children)))))))) (widget-setup) (widget-apply widget :notify widget)) @@ -2921,25 +2898,19 @@ Save CHILD into the :last-deleted list, so it can be inserted later." (widget-put widget :last-deleted lst)) ;; Delete child from list of children. (save-excursion - (let ((buttons (copy-sequence (widget-get widget :buttons))) - button - (inhibit-read-only t) - (inhibit-modification-hooks t)) - (while buttons - (setq button (car buttons) - buttons (cdr buttons)) - (when (eq (widget-get button :widget) child) - (widget-put widget - :buttons (delq button (widget-get widget :buttons))) - (widget-delete button)))) + (widget--allow-insertion + (dolist (button (copy-sequence (widget-get widget :buttons))) + (when (eq (widget-get button :widget) child) + (widget-put widget + :buttons (delq button (widget-get widget :buttons))) + (widget-delete button)))) (let ((entry-from (widget-get child :entry-from)) - (entry-to (widget-get child :entry-to)) - (inhibit-read-only t) - (inhibit-modification-hooks t)) - (widget-delete child) - (delete-region entry-from entry-to) - (set-marker entry-from nil) - (set-marker entry-to nil)) + (entry-to (widget-get child :entry-to))) + (widget--allow-insertion + (widget-delete child) + (delete-region entry-from entry-to) + (set-marker entry-from nil) + (set-marker entry-to nil))) (widget-put widget :children (delq child (widget-get widget :children)))) (widget-setup) (widget-apply widget :notify widget)) @@ -2962,19 +2933,17 @@ Save CHILD into the :last-deleted list, so it can be inserted later." (cond ((eq escape ?%) (insert ?%)) ((eq escape ?i) - (setq insert (apply 'widget-create-child-and-convert + (setq insert (apply #'widget-create-child-and-convert widget 'insert-button (widget-get widget :insert-button-args)))) ((eq escape ?d) - (setq delete (apply 'widget-create-child-and-convert + (setq delete (apply #'widget-create-child-and-convert widget 'delete-button (widget-get widget :delete-button-args)))) ((eq escape ?v) - (if conv - (setq child (widget-create-child-value - widget type value)) - (setq child (widget-create-child-value - widget type (widget-default-get type))))) + (setq child (widget-create-child-value + widget type + (if conv value (widget-default-get type))))) (t (error "Unknown escape `%c'" escape))))) (let ((buttons (widget-get widget :buttons))) @@ -3014,13 +2983,10 @@ Save CHILD into the :last-deleted list, so it can be inserted later." (defun widget-group-value-create (widget) ;; Create each component. - (let ((args (widget-get widget :args)) - (value (widget-get widget :value)) - arg answer children) - (while args - (setq arg (car args) - args (cdr args) - answer (widget-match-inline arg value) + (let ((value (widget-get widget :value)) + answer children) + (dolist (arg (widget-get widget :args)) + (setq answer (widget-match-inline arg value) value (cdr answer)) (and (widget--should-indent-p) (widget-get widget :indent) @@ -3036,7 +3002,7 @@ Save CHILD into the :last-deleted list, so it can be inserted later." (defun widget-group-default-get (widget) ;; Get the default of the components. - (mapcar 'widget-default-get (widget-get widget :args))) + (mapcar #'widget-default-get (widget-get widget :args))) (defun widget-group-match (widget vals) ;; Match if the components match. @@ -3094,20 +3060,20 @@ The following properties have special meanings for this widget: "Display documentation for WIDGET's value. Ignore optional argument EVENT." (let* ((string (widget-get widget :value)) (symbol (intern string))) - (if (and (fboundp symbol) (boundp symbol)) - ;; If there are two doc strings, give the user a way to pick one. - (apropos (concat "\\`" (regexp-quote string) "\\'")) - (cond - ((fboundp symbol) - (describe-function symbol)) - ((facep symbol) - (describe-face symbol)) - ((featurep symbol) - (describe-package symbol)) - ((or (boundp symbol) (get symbol 'variable-documentation)) - (describe-variable symbol)) - (t - (message "No documentation available for %s" symbol)))))) + (cond + ((and (fboundp symbol) (boundp symbol)) + ;; If there are two doc strings, give the user a way to pick one. + (apropos (concat "\\`" (regexp-quote string) "\\'"))) + ((fboundp symbol) + (describe-function symbol)) + ((facep symbol) + (describe-face symbol)) + ((featurep symbol) + (describe-package symbol)) + ((or (boundp symbol) (get symbol 'variable-documentation)) + (describe-variable symbol)) + (t + (message "No documentation available for %s" symbol))))) (defcustom widget-documentation-links t "Add hyperlinks to documentation strings when non-nil." @@ -3240,7 +3206,7 @@ Optional ARGS specifies additional keyword arguments for the (unless (or (numberp doc-indent) (null doc-indent)) (setq doc-indent 0)) (widget-put widget :buttons - (cons (apply 'widget-create-child-and-convert + (cons (apply #'widget-create-child-and-convert widget 'documentation-string :indent doc-indent (nconc args (list doc))) @@ -3352,18 +3318,18 @@ It reads a file name from an editable text field." (must-match (widget-get widget :must-match))) (read-file-name (format-prompt prompt value) dir nil must-match file))))) -;;;(defun widget-file-action (widget &optional event) -;;; ;; Read a file name from the minibuffer. -;;; (let* ((value (widget-value widget)) -;;; (dir (file-name-directory value)) -;;; (file (file-name-nondirectory value)) -;;; (menu-tag (widget-apply widget :menu-tag-get)) -;;; (must-match (widget-get widget :must-match)) -;;; (answer (read-file-name (format-prompt menu-tag value) -;;; dir nil must-match file))) -;;; (widget-value-set widget (abbreviate-file-name answer)) -;;; (widget-setup) -;;; (widget-apply widget :notify widget event))) +;;(defun widget-file-action (widget &optional event) +;; ;; Read a file name from the minibuffer. +;; (let* ((value (widget-value widget)) +;; (dir (file-name-directory value)) +;; (file (file-name-nondirectory value)) +;; (menu-tag (widget-apply widget :menu-tag-get)) +;; (must-match (widget-get widget :must-match)) +;; (answer (read-file-name (format-prompt menu-tag value) +;; dir nil must-match file))) +;; (widget-value-set widget (abbreviate-file-name answer)) +;; (widget-setup) +;; (widget-apply widget :notify widget event))) ;; Fixme: use file-name-as-directory. (define-widget 'directory 'file @@ -3552,7 +3518,7 @@ It reads a directory name from an editable text field." (if (stringp value) (if (string-match "\\`[[:space:]]*\\'" value) widget-key-sequence-default-value - (read-kbd-macro value)) + (key-parse value)) value)) @@ -3825,7 +3791,7 @@ or a list with the default value of each component of the list WIDGET." :format "%{%t%}:\n%v" :match 'widget-vector-match :value-to-internal (lambda (_widget value) (append value nil)) - :value-to-external (lambda (_widget value) (apply 'vector value))) + :value-to-external (lambda (_widget value) (apply #'vector value))) (defun widget-vector-match (widget value) (and (vectorp value) @@ -3840,7 +3806,7 @@ or a list with the default value of each component of the list WIDGET." :value-to-internal (lambda (_widget value) (list (car value) (cdr value))) :value-to-external (lambda (_widget value) - (apply 'cons value))) + (apply #'cons value))) (defun widget-cons-match (widget value) (and (consp value) @@ -3927,7 +3893,7 @@ example: (args (if options (list `(checklist :inline t :greedy t - ,@(mapcar 'widget-plist-convert-option + ,@(mapcar #'widget-plist-convert-option options)) other) (list other)))) @@ -3940,9 +3906,7 @@ example: (if (listp option) (let ((key (nth 0 option))) (setq value-type (nth 1 option)) - (if (listp key) - (setq key-type key) - (setq key-type `(const ,key)))) + (setq key-type (if (listp key) key `(const ,key)))) (setq key-type `(const ,option) value-type widget-plist-value-type)) `(group :format "Key: %v" :inline t ,key-type ,value-type))) @@ -3972,7 +3936,7 @@ example: (args (if options (list `(checklist :inline t :greedy t - ,@(mapcar 'widget-alist-convert-option + ,@(mapcar #'widget-alist-convert-option options)) other) (list other)))) @@ -3985,9 +3949,7 @@ example: (if (listp option) (let ((key (nth 0 option))) (setq value-type (nth 1 option)) - (if (listp key) - (setq key-type key) - (setq key-type `(const ,key)))) + (setq key-type (if (listp key) key `(const ,key)))) (setq key-type `(const ,option) value-type widget-alist-value-type)) `(cons :format "Key: %v" ,key-type ,value-type))) @@ -4045,17 +4007,13 @@ current choice is inline." ((and widget-choice-toggle (= (length args) 2) (memq old args)) - (if (eq old (nth 0 args)) - (nth 1 args) - (nth 0 args))) + (nth (if (eq old (nth 0 args)) 1 0) + args)) (t - (while args - (setq current (car args) - args (cdr args)) - (setq choices - (cons (cons (widget-apply current :menu-tag-get) - current) - choices))) + (dolist (current args) + (push (cons (widget-apply current :menu-tag-get) + current) + choices)) (let ((val (completing-read prompt choices nil t))) (if (stringp val) (let ((try (try-completion val choices))) @@ -4206,7 +4164,7 @@ is inline." (help-echo (and widget (widget-get widget :help-echo)))) (if (functionp help-echo) (setq help-echo (funcall help-echo widget))) - (if help-echo (message "%s" (eval help-echo))))) + (if help-echo (message "%s" (eval help-echo t))))) (define-obsolete-function-alias 'widget-sublist #'seq-subseq "28.1") (define-obsolete-function-alias 'widget-visibility-value-create diff --git a/lisp/windmove.el b/lisp/windmove.el index bc2beed5055..b4e77102abd 100644 --- a/lisp/windmove.el +++ b/lisp/windmove.el @@ -641,7 +641,7 @@ Default value of MODIFIERS is `shift-meta'." (defun windmove-delete-in-direction (dir &optional arg) "Delete the window at direction DIR. -If prefix ARG is `\\[universal-argument]', also kill the buffer in that window. +If prefix ARG is \\[universal-argument], also kill the buffer in that window. With \\`M-0' prefix, delete the selected window and select the window at direction DIR. When `windmove-wrap-around' is non-nil, takes the window diff --git a/lisp/window.el b/lisp/window.el index e100f25526b..df55a7ca673 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -6174,6 +6174,12 @@ value can be also stored on disk and read back in a new session." (defvar window-state-put-stale-windows nil "Helper variable for `window-state-put'.") +(defvar window-state-put-kept-windows nil + "Helper variable for `window-state-put'.") + +(defvar window-state-put-selected-window nil + "Helper variable for `window-state-put'.") + (defun window--state-put-1 (state &optional window ignore totals pixelwise) "Helper function for `window-state-put'." (let ((type (car state))) @@ -6278,9 +6284,11 @@ value can be also stored on disk and read back in a new session." (set-window-parameter window (car parameter) (cdr parameter)))) ;; Process buffer related state. (when state - (let ((buffer (get-buffer (car state))) - (state (cdr state))) - (if buffer + (let* ((old-buffer-or-name (car state)) + (buffer (get-buffer old-buffer-or-name)) + (state (cdr state)) + (dedicated (cdr (assq 'dedicated state)))) + (if (buffer-live-p buffer) (with-current-buffer buffer (set-window-buffer window buffer) (set-window-hscroll window (cdr (assq 'hscroll state))) @@ -6338,7 +6346,7 @@ value can be also stored on disk and read back in a new session." window delta t ignore nil nil nil pixelwise)) (window-resize window delta t ignore pixelwise)))) ;; Set dedicated status. - (set-window-dedicated-p window (cdr (assq 'dedicated state))) + (set-window-dedicated-p window dedicated) ;; Install positions (maybe we should do this after all ;; windows have been created and sized). (ignore-errors @@ -6348,7 +6356,18 @@ value can be also stored on disk and read back in a new session." (set-window-point window (cdr (assq 'point state)))) ;; Select window if it's the selected one. (when (cdr (assq 'selected state)) - (select-window window)) + ;; This used to call 'select-window' which, however, + ;; can be partially undone because the current buffer + ;; may subsequently change twice: When leaving the + ;; present 'with-current-buffer' and when leaving the + ;; containing 'with-temp-buffer' form (Bug#69093). + ;; 'window-state-put-selected-window' should now work + ;; around that bug but we leave this 'select-window' + ;; in since some code run before the part that fixed + ;; it might still refer to this window as the selected + ;; one. + (select-window window) + (setq window-state-put-selected-window window)) (set-window-next-buffers window (delq nil (mapcar (lambda (buffer) @@ -6370,12 +6389,31 @@ value can be also stored on disk and read back in a new session." (set-marker (make-marker) m2 buffer)))))) prev-buffers)))) - ;; We don't want to raise an error in case the buffer does - ;; not exist anymore, so we switch to a previous one and - ;; save the window with the intention of deleting it later - ;; if possible. - (switch-to-prev-buffer window) - (push window window-state-put-stale-windows))))))) + (unless (window-minibuffer-p window) + ;; Preferably show a buffer previously shown in this + ;; window. + (switch-to-prev-buffer window) + (cond + ((functionp window-restore-killed-buffer-windows) + (let* ((start (cdr (assq 'start state))) + ;; Handle both - marker positions from writable + ;; states and markers from non-writable states. + (start-pos (if (markerp start) + (marker-last-position start) + start)) + (point (cdr (assq 'point state))) + (point-pos (if (markerp point) + (marker-last-position point) + point))) + (push (list window old-buffer-or-name + start-pos point-pos dedicated nil) + window-state-put-kept-windows))) + ((or (and dedicated + (eq window-restore-killed-buffer-windows 'dedicated)) + (memq window-restore-killed-buffer-windows '(nil delete))) + ;; Try to delete the window. + (push window window-state-put-stale-windows))) + (set-window-dedicated-p window nil)))))))) (defun window-state-put (state &optional window ignore) "Put window state STATE into WINDOW. @@ -6388,8 +6426,13 @@ If WINDOW is nil, create a new window before putting STATE into it. Optional argument IGNORE non-nil means ignore minimum window sizes and fixed size restrictions. IGNORE equal `safe' means windows can get as small as `window-safe-min-height' and -`window-safe-min-width'." +`window-safe-min-width'. + +If this function tries to restore a non-minibuffer window whose buffer +was killed since STATE was made, it will consult the variable +`window-restore-killed-buffer-windows' on how to proceed." (setq window-state-put-stale-windows nil) + (setq window-state-put-kept-windows nil) ;; When WINDOW is internal or nil, reduce it to a live one, ;; then create a new window on the same frame to put STATE into. @@ -6482,6 +6525,7 @@ windows can get as small as `window-safe-min-height' and (error "Window %s too small to accommodate state" window) (setq state (cdr state)) (setq window-state-put-list nil) + (setq window-state-put-selected-window nil) ;; Work on the windows of a temporary buffer to make sure that ;; splitting proceeds regardless of any buffer local values of ;; `window-size-fixed'. Release that buffer after the buffers of @@ -6490,14 +6534,20 @@ windows can get as small as `window-safe-min-height' and (set-window-buffer window (current-buffer)) (window--state-put-1 state window nil totals pixelwise) (window--state-put-2 ignore pixelwise)) + (when (window-live-p window-state-put-selected-window) + (select-window window-state-put-selected-window)) (while window-state-put-stale-windows (let ((window (pop window-state-put-stale-windows))) - ;; Avoid that 'window-deletable-p' throws an error if window + ;; Avoid that 'window-deletable-p' throws an error if window ;; was already deleted when exiting 'with-temp-buffer' above ;; (Bug#54028). (when (and (window-valid-p window) (eq (window-deletable-p window) t)) (delete-window window)))) + (when (functionp window-restore-killed-buffer-windows) + (funcall window-restore-killed-buffer-windows + frame window-state-put-kept-windows 'state) + (setq window-state-put-kept-windows nil)) (window--check frame)))) (defun window-state-buffers (state) @@ -7798,6 +7848,14 @@ Action alist entries are: and `preserve-size' are applied. The function is supposed to fill the window body with some contents that might depend on dimensions of the displayed window. + `post-command-select-window' -- A non-nil value means that after the + current command is executed and the hook `post-command-hook' is called, + the window displayed by this function will be selected. A nil value + means that if functions like `pop-to-buffer' selected another window, + at the end of this command that window will be deselected, and the + window that was selected before calling this function will remain + selected regardless of which windows were selected afterwards within + this command. The entries `window-height', `window-width', `window-size' and `preserve-size' are applied only when the window used for @@ -7853,6 +7911,17 @@ specified by the ACTION argument." (while (and functions (not window)) (setq window (funcall (car functions) buffer alist) functions (cdr functions))) + (when-let ((select (assq 'post-command-select-window alist))) + (letrec ((old-selected-window (selected-window)) + (postfun + (lambda () + (if (cdr select) + (when (window-live-p window) + (select-window window)) + (when (window-live-p old-selected-window) + (select-window old-selected-window))) + (remove-hook 'post-command-hook postfun)))) + (add-hook 'post-command-hook postfun))) (and (windowp window) window)))) (defun display-buffer-other-frame (buffer) @@ -8599,14 +8668,14 @@ buffer. ALIST is a buffer display action alist as compiled by use time is higher than this. - `window-min-width' specifies a preferred minimum width in - canonical frame columns. If it is the constant `full-width', + canonical frame columns. If it is the symbol `full-width', prefer a full-width window. - `window-min-height' specifies a preferred minimum height in - canonical frame lines. If it is the constant `full-height', + canonical frame lines. If it is the symbol `full-height', prefer a full-height window. -If ALIST contains a non-nil `inhibit-same--window' entry, do not +If ALIST contains a non-nil `inhibit-same-window' entry, do not return the selected window." (let ((windows (window-list-1 nil 'nomini (cdr (assq 'lru-frames alist)))) @@ -8730,11 +8799,11 @@ Distinctive features are: call. `window-min-width' specifies a preferred minimum width in - canonical frame columns. If it is the constant `full-width', + canonical frame columns. If it is the symbol `full-width', prefer a full-width window. `window-min-height' specifies a preferred minimum height in - canonical frame lines. If it is the constant `full-height', + canonical frame lines. If it is the symbol `full-height', prefer a full-height window. - If the preceding steps fail, try to pop up a new window on the @@ -10813,7 +10882,8 @@ Used in `repeat-mode'." "^ f" #'tear-off-window "^ t" #'tab-window-detach "-" #'fit-window-to-buffer - "0" #'delete-windows-on) + "0" #'delete-windows-on + "q" #'quit-window) (define-key ctl-x-map "w" window-prefix-map) (provide 'window) diff --git a/lisp/winner.el b/lisp/winner.el index 2aa59a86b25..19641a05bfc 100644 --- a/lisp/winner.el +++ b/lisp/winner.el @@ -178,7 +178,8 @@ You may want to include buffer names such as *Help*, *Apropos*, (setq winner-last-frames nil) (setq winner-last-command this-command)) (dolist (frame winner-modified-list) - (winner-insert-if-new frame)) + (if (frame-live-p frame) + (winner-insert-if-new frame))) (setq winner-modified-list nil) (winner-remember))) diff --git a/lisp/woman.el b/lisp/woman.el index a9af46fa387..2357ba6b132 100644 --- a/lisp/woman.el +++ b/lisp/woman.el @@ -2566,7 +2566,8 @@ If DELETE is non-nil then delete from point." ;; "\\(\\\\{\\)\\|\\(\n[.']\\)?[ \t]*\\\\}[ \t]*" ;; Interpret bogus `el \}' as `el \{', ;; especially for Tcl/Tk man pages: - "\\(\\\\{\\|el[ \t]*\\\\}\\)\\|\\(\n[.']\\)?[ \t]*\\\\}[ \t]*") + "\\(\\\\{\\|el[ \t]*\\\\}\\)\\|\\(\n[.']\\)?[ \t]*\\\\}[ \t]*" + nil t) (match-beginning 1)) (re-search-forward "\\\\}")) (delete-region (if delete from (match-beginning 0)) (point)) diff --git a/lisp/xt-mouse.el b/lisp/xt-mouse.el index cd00467f14f..081b8f32456 100644 --- a/lisp/xt-mouse.el +++ b/lisp/xt-mouse.el @@ -40,6 +40,8 @@ ;;; Code: +(require 'mwheel) + (defvar xterm-mouse-debug-buffer nil) (defun xterm-mouse-translate (_event) @@ -193,6 +195,12 @@ single byte." (cons n c)) (cons (- (setq c (xterm-mouse--read-coordinate)) 32) c)))) +(defun xterm-mouse--button-p (event btn) + (and (symbolp event) + (string-prefix-p "mouse-" (symbol-name event)) + (eq btn (car (read-from-string (symbol-name event) + (length "mouse-")))))) + ;; XTerm reports mouse events as ;; <EVENT-CODE> <X> <Y> in default mode, and ;; <EVENT-CODE> ";" <X> ";" <Y> <"M" or "m"> in extended mode. @@ -230,13 +238,22 @@ single byte." ;; Spurious release event without previous button-down ;; event: assume, that the last button was button 1. (t 1))) - (sym (if move 'mouse-movement - (intern (concat (if ctrl "C-" "") - (if meta "M-" "") - (if shift "S-" "") - (if down "down-" "") - "mouse-" - (number-to-string btn)))))) + (sym + (if move 'mouse-movement + (intern + (concat + (if ctrl "C-" "") + (if meta "M-" "") + (if shift "S-" "") + (if down "down-" "") + (cond + ;; BEWARE: `mouse-wheel-UP-event' corresponds to + ;; `wheel-DOWN' events and vice versa!! + ((xterm-mouse--button-p mouse-wheel-down-event btn) "wheel-up") + ((xterm-mouse--button-p mouse-wheel-up-event btn) "wheel-down") + ((xterm-mouse--button-p mouse-wheel-left-event btn) "wheel-left") + ((xterm-mouse--button-p mouse-wheel-right-event btn) "wheel-right") + (t (format "mouse-%d" btn)))))))) (list sym (1- x) (1- y)))) (defun xterm-mouse--set-click-count (event click-count) |