diff options
author | Gerd Möllmann <gerd@gnu.org> | 2022-12-31 09:04:56 +0100 |
---|---|---|
committer | Gerd Möllmann <gerd@gnu.org> | 2022-12-31 09:04:56 +0100 |
commit | 716d676747119f9950861f9a64a8e7871b0082d4 (patch) | |
tree | b71f94b50896736a007d6977c97679e1abd895a6 /lisp | |
parent | 54ec3973e298c3d2b3d81484f80053d881694f88 (diff) | |
parent | 7493b4026fc74a51c76c5b614bc83b864af9bc31 (diff) | |
download | emacs-scratch/pkg.tar.gz |
Merge remote-tracking branch 'origin/master' into scratch/pkgscratch/pkg
Diffstat (limited to 'lisp')
128 files changed, 2280 insertions, 1602 deletions
diff --git a/lisp/ChangeLog.14 b/lisp/ChangeLog.14 index eae47fe1985..1ce11c11adf 100644 --- a/lisp/ChangeLog.14 +++ b/lisp/ChangeLog.14 @@ -6299,7 +6299,7 @@ 2008-10-22 Vinicius Jose Latorre <viniciusjl@ig.com.br> - * ps-print.el: Deal with page sizes for label printes. Suggested by + * ps-print.el: Deal with page sizes for label printers. Suggested by Friedrich Delgado Friedrichs <friedel@nomaden.org>. (ps-print-version): New version 7.3.3. (ps-page-dimensions-database): New page sizes for label printers. @@ -6371,7 +6371,7 @@ * replace.el (query-replace, query-replace-regexp) (replace-string, replace-regexp, perform-replace): Add "word" - indicatiors to the prompt for word delimited replacements. + indicators to the prompt for word delimited replacements. * replace.el (read-regexp): Rename arg `default' to `default-value'. Doc fix. diff --git a/lisp/ChangeLog.7 b/lisp/ChangeLog.7 index 91b8d474224..83143f73360 100644 --- a/lisp/ChangeLog.7 +++ b/lisp/ChangeLog.7 @@ -14679,7 +14679,7 @@ * simple.el (current-word): Ignore text properties. * edebug.el (edebug-sit-for-seconds): New variable. - (edebug-display): Use that variable to control amt of time. + (edebug-display): Use that variable to control amount of time. 1997-06-22 Morten Welinder <terra@diku.dk> diff --git a/lisp/abbrev.el b/lisp/abbrev.el index 2ca8e25dac7..26c2b097929 100644 --- a/lisp/abbrev.el +++ b/lisp/abbrev.el @@ -501,7 +501,7 @@ PROPS is a list of properties." (defun abbrev-table-p (object) "Return non-nil if OBJECT is an abbrev table." (and (obarrayp object) - (numberp (ignore-error 'wrong-type-argument + (numberp (ignore-error wrong-type-argument (abbrev-table-get object :abbrev-table-modiff))))) (defun abbrev-table-empty-p (object &optional ignore-system) diff --git a/lisp/bindings.el b/lisp/bindings.el index a3f51ebb315..f2e0799f72b 100644 --- a/lisp/bindings.el +++ b/lisp/bindings.el @@ -1012,8 +1012,8 @@ if `inhibit-field-text-motion' is non-nil." ;; (define-key ctl-x-map "U" 'undo-only) (defvar-keymap undo-repeat-map :doc "Keymap to repeat undo key sequences \\`C-x u u'. Used in `repeat-mode'." + :repeat t "u" #'undo) -(put 'undo 'repeat-map 'undo-repeat-map) (define-key global-map '[(control ??)] 'undo-redo) (define-key global-map [?\C-\M-_] 'undo-redo) @@ -1033,12 +1033,10 @@ if `inhibit-field-text-motion' is non-nil." (defvar-keymap buffer-navigation-repeat-map :doc "Keymap to repeat `next-buffer' and `previous-buffer'. Used in `repeat-mode'." + :repeat t "<right>" #'next-buffer "<left>" #'previous-buffer) -(put 'next-buffer 'repeat-map 'buffer-navigation-repeat-map) -(put 'previous-buffer 'repeat-map 'buffer-navigation-repeat-map) - (let ((map minibuffer-local-map)) (define-key map "\en" 'next-history-element) (define-key map [next] 'next-history-element) @@ -1111,12 +1109,11 @@ if `inhibit-field-text-motion' is non-nil." (defvar-keymap next-error-repeat-map :doc "Keymap to repeat `next-error' key sequences. Used in `repeat-mode'." + :repeat t "n" #'next-error "M-n" #'next-error "p" #'previous-error "M-p" #'previous-error) -(put 'next-error 'repeat-map 'next-error-repeat-map) -(put 'previous-error 'repeat-map 'next-error-repeat-map) (defvar-keymap goto-map :doc "Keymap for navigation commands." @@ -1474,12 +1471,10 @@ if `inhibit-field-text-motion' is non-nil." (defvar-keymap page-navigation-repeat-map :doc "Keymap to repeat page navigation key sequences. Used in `repeat-mode'." + :repeat t "]" #'forward-page "[" #'backward-page) -(put 'forward-page 'repeat-map 'page-navigation-repeat-map) -(put 'backward-page 'repeat-map 'page-navigation-repeat-map) - (define-key ctl-x-map "\C-p" 'mark-page) (define-key ctl-x-map "l" 'count-lines-page) (define-key ctl-x-map "np" 'narrow-to-page) diff --git a/lisp/calendar/cal-dst.el b/lisp/calendar/cal-dst.el index 5f601f24d24..c8a65126a49 100644 --- a/lisp/calendar/cal-dst.el +++ b/lisp/calendar/cal-dst.el @@ -354,10 +354,10 @@ If the locale never uses daylight saving time, set this to 0." (if calendar-current-time-zone-cache (format-time-string "%z" 0 (* 60 (car calendar-current-time-zone-cache))) - "+0000") - (or (nth 2 calendar-current-time-zone-cache) "EST")) + "-0000") + (or (nth 2 calendar-current-time-zone-cache) "UTC")) "Abbreviated name of standard time zone at `calendar-location-name'. -For example, \"EST\" in New York City, \"PST\" for Los Angeles." +For example, \"-0500\" or \"EST\" in New York City." :type 'string :version "28.1" :set-after '(calendar-time-zone-style) @@ -368,10 +368,10 @@ For example, \"EST\" in New York City, \"PST\" for Los Angeles." (if calendar-current-time-zone-cache (format-time-string "%z" 0 (* 60 (cadr calendar-current-time-zone-cache))) - "+0000") - (or (nth 3 calendar-current-time-zone-cache) "EDT")) + "-0000") + (or (nth 3 calendar-current-time-zone-cache) "UTC")) "Abbreviated name of daylight saving time zone at `calendar-location-name'. -For example, \"EDT\" in New York City, \"PDT\" for Los Angeles." +For example, \"-0400\" or \"EDT\" in New York City." :type 'string :version "28.1" :set-after '(calendar-time-zone-style) diff --git a/lisp/calendar/diary-lib.el b/lisp/calendar/diary-lib.el index 9a2baf1e43c..cc1e7ec5f72 100644 --- a/lisp/calendar/diary-lib.el +++ b/lisp/calendar/diary-lib.el @@ -339,7 +339,7 @@ Returns a string using match elements 1-5, where: (t "\\1 \\2 \\3"))) ; MDY "\n \\4 %s, \\5"))) ;; TODO Sometimes the time is in a different time-zone to the one you -;; are in. Eg in PST, you might still get an email referring to: +;; are in. E.g., in Los Angeles, you might still get an email referring to: ;; "7:00 PM-8:00 PM. Greenwich Standard Time". ;; Note that it doesn't use a standard abbreviation for the timezone, ;; or anything helpful like that. diff --git a/lisp/calendar/solar.el b/lisp/calendar/solar.el index 8f501824bb0..0b5bc166530 100644 --- a/lisp/calendar/solar.el +++ b/lisp/calendar/solar.el @@ -839,12 +839,10 @@ This function is suitable for execution in an init file." "E" "W")))))) (calendar-standard-time-zone-name (if (< arg 16) calendar-standard-time-zone-name - (cond ((zerop calendar-time-zone) - (if (eq calendar-time-zone-style 'numeric) - "+0000" "UTC")) - ((< calendar-time-zone 0) - (format "UTC%dmin" calendar-time-zone)) - (t (format "UTC+%dmin" calendar-time-zone))))) + (if (and (zerop calendar-time-zone) + (not (eq calendar-time-zone-style 'numeric))) + "UTC" + (format-time-string "%z" 0 (* 60 calendar-time-zone))))) (calendar-daylight-savings-starts (if (< arg 16) calendar-daylight-savings-starts)) (calendar-daylight-savings-ends diff --git a/lisp/cedet/ChangeLog.1 b/lisp/cedet/ChangeLog.1 index 78275f4db3a..a3a1034e089 100644 --- a/lisp/cedet/ChangeLog.1 +++ b/lisp/cedet/ChangeLog.1 @@ -1446,7 +1446,7 @@ modes, and merge the tables together in :tables from :modetables. (srecode-make-mode-table): Init :modetables. (srecode-mode-table-find): Search in modetables. - (srecode-mode-table-new): Merge the differet files into the + (srecode-mode-table-new): Merge the different files into the modetables slot. 2012-10-01 David Engster <deng@randomsample.de> diff --git a/lisp/cedet/semantic/decorate/include.el b/lisp/cedet/semantic/decorate/include.el index fe510c371e3..26785298e6b 100644 --- a/lisp/cedet/semantic/decorate/include.el +++ b/lisp/cedet/semantic/decorate/include.el @@ -790,9 +790,7 @@ any decorated referring includes.") ;; This is a hack. Add in something better? (semanticdb-notify-references table (lambda (tab _me) - (semantic-decoration-unparsed-include-refrence-reset tab) - )) - )) + (semantic-decoration-unparsed-include-reference-reset tab))))) (cl-defmethod semanticdb-partial-synchronize ((cache semantic-decoration-unparsed-include-cache) new-tags) @@ -805,7 +803,7 @@ any decorated referring includes.") "Synchronize a CACHE with some NEW-TAGS." (semantic-reset cache)) -(defun semantic-decoration-unparsed-include-refrence-reset (table) +(defun semantic-decoration-unparsed-include-reference-reset (table) "Refresh any highlighting in buffers referred to by TABLE. If TABLE is not in a buffer, do nothing." ;; This cache removal may seem odd in that we are "creating one", but @@ -835,6 +833,8 @@ If TABLE is not in a buffer, do nothing." (semantic-decorate-add-decorations allinc) )))) +(define-obsolete-function-alias 'semantic-decoration-unparsed-include-refrence-reset + #'semantic-decoration-unparsed-include-reference-reset "30.1") (provide 'semantic/decorate/include) diff --git a/lisp/cedet/semantic/lex-spp.el b/lisp/cedet/semantic/lex-spp.el index 390c13ec98b..f3704f9a4d4 100644 --- a/lisp/cedet/semantic/lex-spp.el +++ b/lisp/cedet/semantic/lex-spp.el @@ -1243,7 +1243,7 @@ Finds the header file belonging to NAME, gets the macros from that file, and then merge the macros with our current symbol table." (when semantic-lex-spp-use-headers-flag - ;; @todo - do this someday, ok? + nil ; @todo - do this someday, ok? )) (defmacro define-lex-spp-include-analyzer (name doc regexp tokidx diff --git a/lisp/cedet/semantic/lex.el b/lisp/cedet/semantic/lex.el index 264b2027711..e4bce67c6f7 100644 --- a/lisp/cedet/semantic/lex.el +++ b/lisp/cedet/semantic/lex.el @@ -1108,7 +1108,7 @@ This can be done by using `semantic-lex-push-token'." (semantic-lex-analysis-bounds (cons (point) (point-max))) (semantic-lex-current-depth 0) (semantic-lex-maximum-depth semantic-lex-depth)) - (when ,condition ,@forms) + (when ,condition nil ,@forms) ; `nil' avoids an empty-body warning. semantic-lex-token-stream)))) (defmacro define-lex-regex-analyzer (name doc regexp &rest forms) diff --git a/lisp/comint.el b/lisp/comint.el index 7ba423e65de..77d213574f3 100644 --- a/lisp/comint.el +++ b/lisp/comint.el @@ -606,12 +606,10 @@ via PTYs.") (defvar-keymap comint-repeat-map :doc "Keymap to repeat comint key sequences. Used in `repeat-mode'." + :repeat t "C-n" #'comint-next-prompt "C-p" #'comint-previous-prompt) -(put #'comint-next-prompt 'repeat-map 'comint-repeat-map) -(put #'comint-previous-prompt 'repeat-map 'comint-repeat-map) - ;; Fixme: Is this still relevant? (defvar comint-ptyp t "Non-nil if communications via pty; false if by pipe. Buffer local. diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index 8af4618dbd1..65eb066a554 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -903,9 +903,9 @@ This also shows the saved values in the buffer." (defun custom-reset-standard-save-and-update () "Save settings and redraw after erasing customizations." (when (or (and custom-reset-standard-variables-list - (not (eq custom-reset-standard-variables-list '(t)))) + (not (equal custom-reset-standard-variables-list '(t)))) (and custom-reset-standard-faces-list - (not (eq custom-reset-standard-faces-list '(t))))) + (not (equal custom-reset-standard-faces-list '(t))))) ;; Save settings to file. (custom-save-all) ;; Set state of and redraw variables. diff --git a/lisp/desktop.el b/lisp/desktop.el index ef73bc596df..d55739bb6f8 100644 --- a/lisp/desktop.el +++ b/lisp/desktop.el @@ -828,7 +828,7 @@ is nil, ask the user where to save the desktop." ;; If we own it, we don't anymore. (when (eq (emacs-pid) (desktop-owner)) ;; Allow exiting Emacs even if we can't delete the desktop file. - (ignore-error 'file-error + (ignore-error file-error (desktop-release-lock)))) ;; ---------------------------------------------------------------------------- diff --git a/lisp/dired.el b/lisp/dired.el index 81e62f88cf1..f5d1b90abf4 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -4882,9 +4882,9 @@ Interactively with prefix argument, read FILE-NAME." (defvar-keymap dired-jump-map :doc "Keymap to repeat `dired-jump'. Used in `repeat-mode'." + :repeat t "j" #'dired-jump "C-j" #'dired-jump) -(put 'dired-jump 'repeat-map 'dired-jump-map) ;;; Miscellaneous commands diff --git a/lisp/elide-head.el b/lisp/elide-head.el index 75a3612df91..8a95082c15f 100644 --- a/lisp/elide-head.el +++ b/lisp/elide-head.el @@ -50,24 +50,41 @@ :group 'tools) (defcustom elide-head-headers-to-hide - `(;; GNU GPL - ("is free software[:;] you can redistribute it" . - ,(rx (or (seq "If not, see " (? "<") - "http" (? "s") "://www.gnu.org/licenses" - (? "/") (? ">") (? " ")) - (seq "Boston, MA " (? " ") - "0211" (or "1-1307" "0-1301") - (or " " ", ") "USA") - "675 Mass Ave, Cambridge, MA 02139, USA") - (? "."))) - ;; FreeBSD license / Modified BSD license (3-clause) - (,(rx (or "The Regents of the University of California. All rights reserved." - "Redistribution and use in source and binary")) - . "POSSIBILITY OF SUCH DAMAGE\\.") - ;; X11 and Expat - ("Permission is hereby granted, free of charge" . - ,(rx (or "authorization from the X Consortium." ; X11 - "THE USE OR OTHER DEALINGS IN THE SOFTWARE.")))) ; Expat + (rx-let ((delim + ;; A line break could be in a non-standard place, and the + ;; license could be in a comment. + (or + ;; Either just some spaces: + (+ " ") + ;; Or a newline and some comment starter: + (: (* (in " \t")) + "\n" + (* (in " \t")) + (* (or (syntax comment-start) (in ";#*-"))) + (* (in " \t")))))) + `(;; GNU GPL + ("is free software[:;] you can redistribute it" . + ,(rx (or (seq "If not, see " (? "<") + "http" (? "s") "://www.gnu.org/licenses" + (? "/") (? ">") (? " ")) + (seq "Boston," delim "MA" delim + (or "02111-1307" "02110-1301" "02111-1301") + (? ",") delim + "USA") + "675 Mass Ave, Cambridge, MA 02139, USA") + (? "."))) + ;; FreeBSD license / Modified BSD license (3-clause) + (,(rx (or "The Regents of the University of California. All rights reserved." + "Redistribution and use in source and binary")) + . "POSSIBILITY OF SUCH DAMAGE\\.") + ;; X11 and Expat + ("Permission is hereby granted, free of charge" . + ,(rx (or "authorization from the X Consortium." ; X11 + "THE USE OR OTHER DEALINGS IN THE SOFTWARE."))) ; Expat + ;; Apache + ("Licensed under the Apache License, Version 2.0" . + "limitations under the License.") + )) "Alist of regexps defining start and end of text to elide. The cars of elements of the list are searched for in order. Text is @@ -78,7 +95,7 @@ cdr. This affects `elide-head-mode'." :type '(alist :key-type (regexp :tag "Start regexp") :value-type (regexp :tag "End regexp")) - :version "29.1") + :version "30.1") (defvar-local elide-head-overlay nil) @@ -147,10 +164,11 @@ mode hooks." (defun elide-head (&optional arg) "Hide header material in buffer according to `elide-head-headers-to-hide'. -The header is made invisible with an overlay. With a prefix arg, show -an elided material again. +The header is made invisible with an overlay. With a prefix +argument ARG, show an elided material again. -This is suitable as an entry on `find-file-hook' or appropriate mode hooks." +This is suitable as an entry on `find-file-hook' or appropriate +mode hooks." (declare (obsolete elide-head-mode "29.1")) (interactive "P") (if arg diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 898dfffef63..ab35b0dde8f 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -410,7 +410,10 @@ for speeding up processing.") (`(condition-case ,var ,exp . ,clauses) `(,fn ,var ;Not evaluated. - ,(byte-optimize-form exp for-effect) + ,(byte-optimize-form exp + (if (assq :success clauses) + (null var) + for-effect)) ,@(mapcar (lambda (clause) (let ((byte-optimize--lexvars (and lexical-binding diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index b5e887db836..d909395e973 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -649,8 +649,8 @@ in `byte-compile-warning-types'; see the variable `byte-compile-warnings' for a fuller explanation of the warning types. The types that can be suppressed with this macro are `free-vars', `callargs', `redefine', `obsolete', -`interactive-only', `lexical', `mapcar', `constants' and -`suspicious'. +`interactive-only', `lexical', `mapcar', `constants', +`suspicious' and `empty-body'. For the `mapcar' case, only the `mapcar' function can be used in the symbol list. For `suspicious', only `set-buffer', `lsh' and `eq' diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 6067800759c..b5e121f0cd5 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -295,7 +295,8 @@ The information is logged to `byte-compile-log-buffer'." '(redefine callargs free-vars unresolved obsolete noruntime interactive-only make-local mapcar constants suspicious lexical lexical-dynamic - docstrings docstrings-non-ascii-quotes not-unused) + docstrings docstrings-non-ascii-quotes not-unused + empty-body) "The list of warning types used when `byte-compile-warnings' is t.") (defcustom byte-compile-warnings t "List of warnings that the byte-compiler should issue (t for almost all). @@ -326,6 +327,7 @@ Elements of the list may be: docstrings-non-ascii-quotes docstrings that have non-ASCII quotes. This depends on the `docstrings' warning type. suspicious constructs that usually don't do what the coder wanted. + empty-body body argument to a special form or macro is empty. If the list begins with `not', then the remaining elements specify warnings to suppress. For example, (not mapcar) will suppress warnings about mapcar. @@ -541,15 +543,19 @@ Return the compile-time value of FORM." ;; Later `internal--with-suppressed-warnings' binds it again, this ;; time in order to affect warnings emitted during the ;; compilation itself. - (let ((byte-compile--suppressed-warnings - (append warnings byte-compile--suppressed-warnings))) - ;; This function doesn't exist, but is just a placeholder - ;; symbol to hook up with the - ;; `byte-hunk-handler'/`byte-defop-compiler-1' machinery. - `(internal--with-suppressed-warnings - ',warnings - ,(macroexpand-all `(progn ,@body) - macroexpand-all-environment)))))) + (if body + (let ((byte-compile--suppressed-warnings + (append warnings byte-compile--suppressed-warnings))) + ;; This function doesn't exist, but is just a placeholder + ;; symbol to hook up with the + ;; `byte-hunk-handler'/`byte-defop-compiler-1' machinery. + `(internal--with-suppressed-warnings + ',warnings + ,(macroexpand-all `(progn ,@body) + macroexpand-all-environment))) + (macroexp-warn-and-return + "`with-suppressed-warnings' with empty body" + nil '(empty-body with-suppressed-warnings) t warnings))))) "The default macro-environment passed to macroexpand by the compiler. Placing a macro here will cause a macro to have different semantics when expanded by the compiler as when expanded by the interpreter.") @@ -4836,6 +4842,11 @@ binding slots have been popped." (dolist (clause (reverse clauses)) (let ((condition (nth 1 clause))) + (when (and (eq (car-safe condition) 'quote) + (cdr condition) (null (cddr condition))) + (byte-compile-warn-x + condition "`condition-case' condition should not be quoted: %S" + condition)) (unless (consp condition) (setq condition (list condition))) (dolist (c condition) (unless (and c (symbolp c)) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2c306d892c7..7fec370d474 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3716,7 +3716,7 @@ Prepare every function for final compilation and drive the C back-end." (if (zerop (call-process (expand-file-name invocation-name invocation-directory) - nil t t "-no-comp-spawn" "--batch" "-l" + nil t t "-no-comp-spawn" "-Q" "--batch" "-l" temp-file)) (progn (delete-file temp-file) @@ -4005,7 +4005,7 @@ display a message." :command (list (expand-file-name invocation-name invocation-directory) - "-no-comp-spawn" "--batch" + "-no-comp-spawn" "-Q" "--batch" "--eval" ;; Suppress Abort dialogs on MS-Windows "(setq w32-disable-abort-dialog t)" diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 67704bdb51c..9e792889c89 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -92,9 +92,9 @@ using, but only when you also use Edebug." ;;;###autoload (defcustom edebug-all-defs nil "If non-nil, evaluating defining forms instruments for Edebug. -This applies to `eval-defun', `eval-region', `eval-buffer', and -`eval-current-buffer'. `eval-region' is also called by -`eval-last-sexp', and `eval-print-last-sexp'. +This applies to `eval-defun', `eval-region' and `eval-buffer'. +`eval-region' is also called by `eval-last-sexp', and +`eval-print-last-sexp'. You can use the command `edebug-all-defs' to toggle the value of this variable. You may wish to make it local to each buffer with diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el index 49f2a1d6965..0614313809c 100644 --- a/lisp/emacs-lisp/ert-x.el +++ b/lisp/emacs-lisp/ert-x.el @@ -102,42 +102,35 @@ the name of the test and the result of NAME-FORM." (indent 1)) `(ert--call-with-test-buffer ,name-form (lambda () ,@body))) -(cl-defmacro ert-with-test-buffer-selected ((&key name) - &body body) - "Create a test buffer, switch to it, and run BODY. +(cl-defmacro ert-with-buffer-selected (buffer-or-name &body body) + "Display a buffer in a temporary selected window and run BODY. + +If BUFFER-OR-NAME is nil, the current buffer is used. -This extends `ert-with-test-buffer' by displaying the test -buffer (whose name is derived from NAME) in a temporary window. -The temporary window becomes the `selected-window' before BODY is -evaluated. The modification hooks `before-change-functions' and +The buffer is made the current buffer, and the temporary window +becomes the `selected-window', before BODY is evaluated. The +modification hooks `before-change-functions' and `after-change-functions' are not inhibited during the evaluation of BODY, which makes it easier to use `execute-kbd-macro' to simulate user interaction. The window configuration is restored before returning, even if BODY exits nonlocally. The return value is the last form in BODY." - (declare (debug ((":name" form) def-body)) - (indent 1)) - (let ((ret (make-symbol "ert--with-test-buffer-selected-ret"))) - `(save-window-excursion - (let (,ret) - (ert-with-test-buffer (:name ,name) - (with-current-buffer-window (current-buffer) - `(display-buffer-below-selected - (body-function - . ,(lambda (window) - (select-window window t) - ;; body-function is intended to initialize the - ;; contents of a temporary read-only buffer, so - ;; it is executed with some convenience - ;; changes. Undo those changes so that the - ;; test buffer behaves more like an ordinary - ;; buffer while the body executes. - (let ((inhibit-modification-hooks nil) - (inhibit-read-only nil) - (buffer-read-only nil)) - (setq ,ret (progn ,@body)))))) - nil)) - ,ret)))) + (declare (debug (form body)) (indent 1)) + `(save-window-excursion + (with-current-buffer (or ,buffer-or-name (current-buffer)) + (with-selected-window (display-buffer (current-buffer)) + ,@body)))) + +(cl-defmacro ert-with-test-buffer-selected ((&key name) &body body) + "Create a test buffer, switch to it, and run BODY. + +This combines `ert-with-test-buffer' and +`ert-with-buffer-selected'. The return value is the last form in +BODY." + (declare (debug ((":name" form) body)) (indent 1)) + `(ert-with-test-buffer (:name ,name) + (ert-with-buffer-selected (current-buffer) + ,@body))) ;;;###autoload (defun ert-kill-all-test-buffers () diff --git a/lisp/emacs-lisp/loaddefs-gen.el b/lisp/emacs-lisp/loaddefs-gen.el index 2dd04174f54..460d8eca586 100644 --- a/lisp/emacs-lisp/loaddefs-gen.el +++ b/lisp/emacs-lisp/loaddefs-gen.el @@ -608,7 +608,8 @@ instead of just updating them with the new/changed autoloads." (write-region (point-min) (point-max) output-file nil 'silent)) ;; We have some data, so generate the loaddef files. First ;; group per output file. - (dolist (fdefs (seq-group-by #'car defs)) + (dolist (fdefs (seq-group-by (lambda (x) (expand-file-name (car x))) + defs)) (let ((loaddefs-file (car fdefs)) hash) (with-temp-buffer diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index e1902ca8e31..6d089c27b7e 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -367,8 +367,8 @@ Assumes the caller has bound `macroexpand-all-environment'." (if (null body) (macroexp-unprogn (macroexp-warn-and-return - (format "Empty %s body" fun) - nil nil 'compile-only fun)) + (format "`%s' with empty body" fun) + nil (list 'empty-body fun) 'compile-only fun)) (macroexp--all-forms body)) (cdr form)) form))) diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 8f0eedd2f88..a9fbdfea210 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -131,7 +131,7 @@ the `clone' function." ((null spec) (package-vc-install name)) ((stringp spec) - (package-vc-install name nil spec)) + (package-vc-install name spec)) ((listp spec) (package-vc--archives-initialize) (package-vc--unpack (cadr pkg-descs) spec))))))) @@ -306,7 +306,9 @@ asynchronously." (directory (file-name-concat (or (package-desc-dir pkg-desc) (expand-file-name name package-user-dir)) - (plist-get pkg-spec :lisp-dir))) + (plist-get pkg-spec :lisp-dir) + (and-let* ((extras (package-desc-extras pkg-desc))) + (alist-get :lisp-dir extras)))) (file (or (plist-get pkg-spec :main-file) (expand-file-name (concat name ".el") @@ -406,99 +408,156 @@ otherwise it's assumed to be an Info file." (when clean-up (delete-file file)))) +(defun package-vc-install-dependencies (requirements) + "Install missing dependencies, and return missing ones. +The return value will be nil if everything was found, or a list +of (NAME VERSION) pairs of all packages that couldn't be found. + +REQUIREMENTS should be a list of additional requirements; each +element in this list should have the form (PACKAGE VERSION-LIST), +where PACKAGE is a package name and VERSION-LIST is the required +version of that package." + (let ((to-install '()) (missing '())) + (cl-labels ((search (pkg) + "Attempt to find all dependencies for PKG." + (cond + ((assq (car pkg) to-install)) ;inhibit cycles + ((package-installed-p (car pkg))) + ((let* ((pac package-archive-contents) + (desc (cadr (assoc (car pkg) pac)))) + (if desc + (let ((reqs (package-desc-reqs pkg))) + (push pkg to-install) + (mapc #'search reqs)) + (push pkg missing)))))) + (version-order (a b) + "Predicate to sort packages in order." + (version-list-< (cadr b) (cadr a))) + (duplicate-p (a b) + "Are A and B the same package?" + (eq (car a) (car b))) + (depends-on-p (target package) + "Does PACKAGE depend on TARGET?" + (or (eq target package) + (let* ((pac package-archive-contents) + (desc (cadr (assoc package pac)))) + (seq-some + (apply-partially #'depends-on-p target) + (package-desc-reqs desc))))) + (dependent-order (a b) + (or (not (depends-on-p (car b) (car a))) + (depends-on-p (car a) (car b))))) + (mapc #'search requirements) + (cl-callf sort to-install #'version-order) + (cl-callf seq-uniq to-install #'duplicate-p) + (cl-callf sort to-install #'dependent-order)) + (mapc #'package-install-from-archive to-install) + missing)) + (defun package-vc--unpack-1 (pkg-desc pkg-dir) "Prepare PKG-DESC that is already checked-out in PKG-DIR. 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." - ;; Remove any previous instance of PKG-DESC from `package-alist' - (let ((pkgs (assq (package-desc-name pkg-desc) package-alist))) - (when pkgs - (setf (cdr pkgs) (seq-remove #'package-vc-p (cdr pkgs))))) - - ;; In case the package was installed directly from source, the - ;; dependency list wasn't know beforehand, and they might have - ;; to be installed explicitly. - (let ((deps '())) - (dolist (file (directory-files pkg-dir t "\\.el\\'" t)) - (with-temp-buffer - (insert-file-contents file) - (when-let* ((require-lines (lm-header-multiline "package-requires"))) - (thread-last - (mapconcat #'identity require-lines " ") - package-read-from-string - package--prepare-dependencies - (nconc deps) - (setq deps))))) - (dolist (dep deps) - (cl-callf version-to-list (cadr dep))) - (package-download-transaction - (package-compute-transaction nil (delete-dups deps)))) - - (let ((default-directory (file-name-as-directory pkg-dir)) - (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)) - (extras (package-desc-extras pkg-desc)) - (lisp-dir (alist-get :lisp-dir extras))) - (package-generate-autoloads - name (file-name-concat pkg-dir lisp-dir)) - (when lisp-dir - (write-region - (with-temp-buffer - (insert ";; Autoload indirection for package-vc\n\n") - (prin1 `(load (expand-file-name - ,(file-name-concat lisp-dir auto-name) - (or (and load-file-name - (file-name-directory load-file-name)) - (car load-path)))) - (current-buffer)) - (buffer-string)) - nil (expand-file-name auto-name pkg-dir)))) - - ;; Generate package file - (package-vc--generate-description-file pkg-desc pkg-file) - - ;; Detect a manual - (when-let ((pkg-spec (package-vc--desc->spec pkg-desc)) - ((executable-find "install-info"))) - (dolist (doc-file (ensure-list (plist-get pkg-spec :doc))) - (package-vc--build-documentation pkg-desc doc-file)))) - - ;; Update package-alist. - (let ((new-desc (package-load-descriptor pkg-dir))) - ;; Activation has to be done before compilation, so that if we're - ;; upgrading and macros have changed we load the new definitions - ;; before compiling. - (when (package-activate-1 new-desc :reload :deps) - ;; FIXME: Compilation should be done as a separate, optional, step. - ;; E.g. for multi-package installs, we should first install all packages - ;; and then compile them. - (package--compile new-desc) - (when package-native-compile - (package--native-compile-async new-desc)) - ;; After compilation, load again any files loaded by - ;; `activate-1', so that we use the byte-compiled definitions. - (package--reload-previously-loaded new-desc))) - - ;; Mark package as selected - (package--save-selected-packages - (cons (package-desc-name pkg-desc) - package-selected-packages)) - (package--quickstart-maybe-refresh) - - ;; Confirm that the installation was successful - (let ((main-file (package-vc--main-file pkg-desc))) - (message "VC package `%s' installed (Version %s, Revision %S)." - (package-desc-name pkg-desc) - (lm-with-file main-file - (package-strip-rcs-id - (or (lm-header "package-version") - (lm-header "version")))) - (vc-working-revision main-file))) - t) + (let (missing) + ;; Remove any previous instance of PKG-DESC from `package-alist' + (let ((pkgs (assq (package-desc-name pkg-desc) package-alist))) + (when pkgs + (setf (cdr pkgs) (seq-remove #'package-vc-p (cdr pkgs))))) + + ;; In case the package was installed directly from source, the + ;; dependency list wasn't know beforehand, and they might have + ;; to be installed explicitly. + (let ((deps '())) + (dolist (file (directory-files pkg-dir t "\\.el\\'" t)) + (with-temp-buffer + (insert-file-contents file) + (when-let* ((require-lines (lm-header-multiline "package-requires"))) + (thread-last + (mapconcat #'identity require-lines " ") + package-read-from-string + package--prepare-dependencies + (nconc deps) + (setq deps))))) + (dolist (dep deps) + (cl-callf version-to-list (cadr dep))) + (setf missing (package-vc-install-dependencies (delete-dups deps))) + (setf missing (delq (assq (package-desc-name pkg-desc) + missing) + missing))) + + (let ((default-directory (file-name-as-directory pkg-dir)) + (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)) + (extras (package-desc-extras pkg-desc)) + (lisp-dir (alist-get :lisp-dir extras))) + (package-generate-autoloads + name (file-name-concat pkg-dir lisp-dir)) + (when lisp-dir + (write-region + (with-temp-buffer + (insert ";; Autoload indirection for package-vc\n\n") + (prin1 `(load (expand-file-name + ,(file-name-concat lisp-dir auto-name) + (or (and load-file-name + (file-name-directory load-file-name)) + (car load-path)))) + (current-buffer)) + (buffer-string)) + nil (expand-file-name auto-name pkg-dir)))) + + ;; Generate package file + (package-vc--generate-description-file pkg-desc pkg-file) + + ;; Detect a manual + (when-let ((pkg-spec (package-vc--desc->spec pkg-desc)) + ((executable-find "install-info"))) + (dolist (doc-file (ensure-list (plist-get pkg-spec :doc))) + (package-vc--build-documentation pkg-desc doc-file)))) + + ;; Update package-alist. + (let ((new-desc (package-load-descriptor pkg-dir))) + ;; Activation has to be done before compilation, so that if we're + ;; upgrading and macros have changed we load the new definitions + ;; before compiling. + (when (package-activate-1 new-desc :reload :deps) + ;; FIXME: Compilation should be done as a separate, optional, step. + ;; E.g. for multi-package installs, we should first install all packages + ;; and then compile them. + (package--compile new-desc) + (when package-native-compile + (package--native-compile-async new-desc)) + ;; After compilation, load again any files loaded by + ;; `activate-1', so that we use the byte-compiled definitions. + (package--reload-previously-loaded new-desc))) + + ;; Mark package as selected + (package--save-selected-packages + (cons (package-desc-name pkg-desc) + package-selected-packages)) + (package--quickstart-maybe-refresh) + + ;; Confirm that the installation was successful + (let ((main-file (package-vc--main-file pkg-desc))) + (message "VC package `%s' installed (Version %s, Revision %S).%s" + (package-desc-name pkg-desc) + (lm-with-file main-file + (package-strip-rcs-id + (or (lm-header "package-version") + (lm-header "version")))) + (vc-working-revision main-file) + (if missing + (format + " Failed to install the following dependencies: %s" + (mapconcat + (lambda (p) + (format "%s (%s)" (car p) (cadr p))) + missing ", ")) + ""))) + t)) (defun package-vc--guess-backend (url) "Guess the VC backend for URL. @@ -552,6 +611,23 @@ checkout. This overrides the `:branch' attribute in PKG-SPEC." (error "There already exists a checkout for %s" name))) (package-vc--clone pkg-desc pkg-spec pkg-dir rev) + ;; When nothing is specified about a `lisp-dir', then should + ;; heuristically check if there is a sub-directory with lisp + ;; files. These are conventionally just called "lisp" or "src". + ;; If this directory exists and contains non-zero number of lisp + ;; files, we will use that instead of `pkg-dir'. + (catch 'done + (dolist (name '("lisp" "src")) + (when-let* (((null lisp-dir)) + (dir (expand-file-name name pkg-dir)) + ((file-directory-p dir)) + ((directory-files dir nil "\\`[^.].+\\.el\\'" t 1))) + ;; We won't use `dir', since dir is an absolute path and we + ;; don't want `lisp-dir' to depend on the current location of + ;; the package installation, ie. to break if moved around the + ;; file system or between installations. + (throw 'done (setq lisp-dir name))))) + (when lisp-dir (push (cons :lisp-dir lisp-dir) (package-desc-extras pkg-desc))) @@ -661,7 +737,7 @@ If no such revision can be found, return nil." (line-number-at-pos nil t)))))))) ;;;###autoload -(defun package-vc-install (package &optional name rev backend) +(defun package-vc-install (package &optional rev backend name) "Fetch a PACKAGE and set it up for using with Emacs. If PACKAGE is a string containing an URL, download the package @@ -685,7 +761,9 @@ the package's repository; this is only possible if NAME-OR-URL is a URL, a string. If BACKEND is omitted or nil, the function uses `package-vc-heuristic-alist' to guess the backend. Note that by default, a VC package will be prioritized over a -regular package, but it will not remove a VC package." +regular package, but it will not remove a VC package. + +\(fn PACKAGE &optional REV BACKEND)" (interactive (progn ;; Initialize the package system to get the list of package @@ -694,8 +772,10 @@ regular package, but it will not remove a VC package." (let* ((name-or-url (package-vc--read-package-name "Fetch and install package: " t)) (name (file-name-base name-or-url))) - (list name-or-url (intern (string-remove-prefix "emacs-" name)) - (and current-prefix-arg :last-release))))) + (list name-or-url + (and current-prefix-arg :last-release) + nil + (intern (string-remove-prefix "emacs-" name)))))) (package-vc--archives-initialize) (cond ((null package) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 1cc978923e0..1ab70eb2fe9 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -2094,7 +2094,7 @@ if all the in-between dependencies are also in PACKAGE-LIST." (defun package-install-from-archive (pkg-desc) "Download and install a package defined by PKG-DESC." ;; This won't happen, unless the archive is doing something wrong. - (when (package-vc-p pkg-desc) + (when (eq (package-desc-kind pkg-desc) 'dir) (error "Can't install directory package from archive")) (let* ((location (package-archive-base pkg-desc)) (file (concat (package-desc-full-name pkg-desc) diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index 6704db3cc57..90f81d740f2 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -263,6 +263,12 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), :eval (stringp "a") :eval (stringp 'a) :eval "(stringp ?a)") + (string-or-null-p + :eval (string-or-null-p "a") + :eval (string-or-null-p nil)) + (char-or-string-p + :eval "(char-or-string-p ?a)" + :eval (char-or-string-p "a")) (string-empty-p :no-manual t :eval (string-empty-p "")) @@ -300,6 +306,9 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'), :eval (string-to-number "2.5e+03")) (number-to-string :eval (number-to-string 42)) + (char-uppercase-p + :eval "(char-uppercase-p ?A)" + :eval "(char-uppercase-p ?a)") "Data About Strings" (length :eval (length "foo") diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index 4896f4c2937..415f8db52ca 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -333,7 +333,10 @@ as the new values of the bound variables in the recursive invocation." ;;;###autoload (defun string-glyph-split (string) "Split STRING into a list of strings representing separate glyphs. -This takes into account combining characters and grapheme clusters." +This takes into account combining characters and grapheme clusters: +if compositions are enbaled, each sequence of characters composed +on display into a single grapheme cluster is treated as a single +indivisible unit." (let ((result nil) (start 0) comp) diff --git a/lisp/epa-ks.el b/lisp/epa-ks.el index bb64b61b8fa..668cdf9a618 100644 --- a/lisp/epa-ks.el +++ b/lisp/epa-ks.el @@ -135,9 +135,9 @@ Keys are marked using `epa-ks-mark-key-to-fetch'." keys)) (forward-line)) (when (yes-or-no-p (format "Proceed with fetching all %d key(s)? " - (length keys)))) - (dolist (id keys) - (epa-ks--fetch-key id)))) + (length keys))) + (dolist (id keys) + (epa-ks--fetch-key id))))) (tabulated-list-clear-all-tags)) (defun epa-ks--query-url (query exact) diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el index 43c5faad638..6820bf0d1a3 100644 --- a/lisp/erc/erc-backend.el +++ b/lisp/erc/erc-backend.el @@ -320,6 +320,15 @@ session when reconnecting. Once `erc-reuse-buffers' is retired and fully removed, modules can switch to leveraging the `permanent-local' property instead.") +(defvar erc--server-post-connect-hook '(erc-networks--warn-on-connect) + "Functions to run when a network connection is successfully opened. +Though internal, this complements `erc-connect-pre-hook' in that +it bookends the process rather than the logical connection, which +is the domain of `erc-before-connect' and `erc-after-connect'. +Note that unlike `erc-connect-pre-hook', this only runs in server +buffers, and it does so immediately before the first protocol +exchange.") + (defvar-local erc-server-timed-out nil "Non-nil if the IRC server failed to respond to a ping.") @@ -646,6 +655,7 @@ The current buffer is given by BUFFER." (cl-defmethod erc--register-connection () "Perform opening IRC protocol exchange with server." + (run-hooks 'erc--server-post-connect-hook) (erc-login)) (defvar erc--server-connect-dumb-ipv6-regexp diff --git a/lisp/erc/erc-compat.el b/lisp/erc/erc-compat.el index 77625398abd..864c5882cf2 100644 --- a/lisp/erc/erc-compat.el +++ b/lisp/erc/erc-compat.el @@ -261,7 +261,7 @@ If START or END is negative, it counts from the end." (when-let* ((s (plist-get e :secret)) (v (auth-source--obfuscate s))) (setf (plist-get e :secret) - (byte-compile (lambda () (auth-source--deobfuscate v))))) + (apply-partially #'auth-source--deobfuscate v))) (push e out))) rv))) @@ -391,11 +391,11 @@ If START or END is negative, it counts from the end." (cond ((fboundp 'browse-url-irc)) ; 29 ((boundp 'browse-url-default-handlers) ; 28 - (setf (alist-get "\\`irc6?s?://" browse-url-default-handlers - nil nil (lambda (a _) - (and (stringp a) - (string-match-p a "irc://localhost")))) - #'erc-compat--29-browse-url-irc)) + (add-to-list 'browse-url-default-handlers + '("\\`irc6?s?://" . erc-compat--29-browse-url-irc) + nil (lambda (_ a) + (and (stringp (car-safe a)) + (string-match-p (car a) "irc://localhost"))))) ((boundp 'browse-url-browser-function) ; 27 (require 'browse-url) (let ((existing browse-url-browser-function)) diff --git a/lisp/erc/erc-networks.el b/lisp/erc/erc-networks.el index 2e2d0930118..f05a98be16d 100644 --- a/lisp/erc/erc-networks.el +++ b/lisp/erc/erc-networks.el @@ -1472,14 +1472,16 @@ to be a false alarm. If `erc-reuse-buffers' is nil, let (t (rename-buffer (generate-new-buffer-name name))))) nil) -;; Soju v0.4.0 only sends ISUPPORT on upstream reconnect, so this -;; doesn't apply. ZNC 1.8.2, however, still sends the entire burst. -(defconst erc-networks--bouncer-targets '(*status bouncerserv) - "Case-mapped symbols matching known bouncer service-bot targets.") +;; Soju v0.4.0 sends ISUPPORT and nothing else on upstream reconnect, +;; so this actually doesn't apply. ZNC 1.8.2, however, still sends +;; the entire burst. +(defvar erc-networks--bouncer-targets '(*status bouncerserv) + "Symbols matching proxy-bot targets.") (defun erc-networks-on-MOTD-end (proc parsed) - "Call on-connect functions with server PROC and PARSED message. -This must run before `erc-server-connected' is set." + "Call on-connect functions with server PROC and PARSED message." + ;; This should normally run before `erc-server-connected' is set. + ;; However, bouncers and other proxies may interfere with that. (when erc-server-connected (unless (erc-buffer-filter (lambda () (and erc--target @@ -1502,6 +1504,18 @@ This must run before `erc-server-connected' is set." ((remove-hook 'erc-server-376-functions #'erc-networks-on-MOTD-end) (remove-hook 'erc-server-422-functions #'erc-networks-on-MOTD-end))) +(defun erc-networks--warn-on-connect () + "Emit warning when the `networks' module hasn't been loaded. +Ideally, do so upon opening the network process." + (unless (or erc--target erc-networks-mode) + (require 'info nil t) + (let ((m (concat "Required module `networks' not loaded. If this " + " was unexpected, please add it to `erc-modules'."))) + ;; Assume the server buffer has been marked as active. + (erc-display-error-notice + nil (concat m " See Info:\"(erc) Required Modules\" for more.")) + (lwarn 'erc :warning m)))) + (defun erc-ports-list (ports) "Return a list of PORTS. diff --git a/lisp/erc/erc-sasl.el b/lisp/erc/erc-sasl.el index 78d02a46381..23110d74b5e 100644 --- a/lisp/erc/erc-sasl.el +++ b/lisp/erc/erc-sasl.el @@ -435,7 +435,7 @@ Otherwise, expect it to disappear in subsequent versions.") (if (eq :user (alist-get 'user erc-sasl--options)) (erc-current-nick) erc-session-username))) - (erc-login)) + (cl-call-next-method)) (when erc-sasl--send-cap-ls (erc-server-send "CAP REQ :sasl")) (erc-server-send (format "AUTHENTICATE %s" m))) diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 6cfc39c4bda..16a0aba77b1 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -1607,7 +1607,8 @@ same manner." (when target ; compat (setq tgt-info (erc--target-from-string target))) (if tgt-info - (let* ((esid (erc-networks--id-symbol erc-networks--id)) + (let* ((esid (and erc-networks--id + (erc-networks--id-symbol erc-networks--id))) (name (if esid (erc-networks--reconcile-buffer-names tgt-info erc-networks--id) @@ -1765,8 +1766,7 @@ all channel buffers on all servers." ;; to, it was never realized. ;; ;; New library code should use the `erc--target' struct instead. -;; Third-party code can continue to use this until a getter for -;; `erc--target' (or whatever replaces it) is exported. +;; Third-party code can continue to use this and `erc-default-target'. (defvar-local erc-default-recipients nil "List of default recipients of the current buffer.") @@ -6012,13 +6012,14 @@ See also `erc-downcase'." ;; While `erc-default-target' happens to return nil in channel buffers ;; you've parted or from which you've been kicked, using it to detect ;; whether a channel is currently joined may become unreliable in the -;; future. For now, new code should consider using +;; future. For now, third-party code can use ;; ;; (erc-get-channel-user (erc-current-nick)) ;; -;; and expect a nicer option eventually. For retrieving a target -;; regardless of subscription or connection status, use replacements -;; based on `erc--target' instead. See also `erc--default-target'. +;; A predicate may be provided eventually. For retrieving a target's +;; name regardless of subscription or connection status, new library +;; code should use `erc--default-target'. Third-party code should +;; continue to use `erc-default-target'. (defun erc-default-target () "Return the current default target (as a character string) or nil if none." @@ -6760,7 +6761,8 @@ This should be a string with substitution variables recognized by If the name of the network is not available, then use the shortened server name instead." (if-let ((erc--target) - (name (if-let ((esid (erc-networks--id-symbol erc-networks--id))) + (name (if-let ((erc-networks--id) + (esid (erc-networks--id-symbol erc-networks--id))) (symbol-name esid) (erc-shorten-server-name (or erc-server-announced-name erc-session-server))))) diff --git a/lisp/eshell/em-elecslash.el b/lisp/eshell/em-elecslash.el index 091acb9a861..0ce3a4cc963 100644 --- a/lisp/eshell/em-elecslash.el +++ b/lisp/eshell/em-elecslash.el @@ -74,8 +74,9 @@ insertion." (command (save-excursion (eshell-bol) (skip-syntax-forward " ") - (thing-at-point 'sexp)))) - (if (and (file-remote-p default-directory) + (thing-at-point 'sexp))) + (prefix (file-remote-p default-directory))) + (if (and prefix ;; We can't formally parse the input. But if there is ;; one of these operators behind us, then looking at ;; the first command would not be sensible. So be @@ -93,14 +94,9 @@ insertion." (or eshell-prefer-lisp-functions (not (eshell-search-path command)))))))) (let ((map (make-sparse-keymap)) - (start (if tilde-before (1- (point)) (point))) - (localname - (tramp-file-name-localname - (tramp-dissect-file-name default-directory)))) + (start (if tilde-before (1- (point)) (point)))) (when tilde-before (delete-char -1)) - (insert - (substring default-directory 0 - (string-search localname default-directory))) + (insert prefix) (unless tilde-before (insert "/")) ;; Typing a second slash undoes the insertion, for when ;; you really do want to type a local absolute file name. diff --git a/lisp/eshell/em-prompt.el b/lisp/eshell/em-prompt.el index a8744de1dba..abb123bcff2 100644 --- a/lisp/eshell/em-prompt.el +++ b/lisp/eshell/em-prompt.el @@ -102,12 +102,10 @@ arriving, or after." (defvar-keymap eshell-prompt-repeat-map :doc "Keymap to repeat eshell-prompt key sequences. Used in `repeat-mode'." + :repeat t "C-n" #'eshell-next-prompt "C-p" #'eshell-previous-prompt) -(put #'eshell-next-prompt 'repeat-map 'eshell-prompt-repeat-map) -(put #'eshell-previous-prompt 'repeat-map 'eshell-prompt-repeat-map) - ;;; Functions: (define-minor-mode eshell-prompt-mode diff --git a/lisp/eshell/esh-cmd.el b/lisp/eshell/esh-cmd.el index 1fb84991120..39579335cf7 100644 --- a/lisp/eshell/esh-cmd.el +++ b/lisp/eshell/esh-cmd.el @@ -418,8 +418,11 @@ hooks should be run before and after the command." (eshell-separate-commands terms "[&;]" nil 'eshell--sep-terms)))) (let ((cmd commands)) (while cmd - (if (cdr cmd) - (setcar cmd `(eshell-commands ,(car cmd)))) + ;; Copy I/O handles so each full statement can manipulate them + ;; if they like. Steal the handles for the last command in + ;; the list; we won't use the originals again anyway. + (setcar cmd `(eshell-with-copied-handles + ,(car cmd) ,(not (cdr cmd)))) (setq cmd (cdr cmd)))) (if toplevel `(eshell-commands (progn @@ -788,16 +791,17 @@ this grossness will be made to disappear by using `call/cc'..." (defvar eshell-output-handle) ;Defined in esh-io.el. (defvar eshell-error-handle) ;Defined in esh-io.el. -(defmacro eshell-copy-handles (object) - "Duplicate current I/O handles, so OBJECT works with its own copy." +(defmacro eshell-with-copied-handles (object &optional steal-p) + "Duplicate current I/O handles, so OBJECT works with its own copy. +If STEAL-P is non-nil, these new handles will be stolen from the +current ones (see `eshell-duplicate-handles')." `(let ((eshell-current-handles - (eshell-create-handles - (car (aref eshell-current-handles - eshell-output-handle)) nil - (car (aref eshell-current-handles - eshell-error-handle)) nil))) + (eshell-duplicate-handles eshell-current-handles ,steal-p))) ,object)) +(define-obsolete-function-alias 'eshell-copy-handles + #'eshell-with-copied-handles "30.1") + (defmacro eshell-protect (object) "Protect I/O handles, so they aren't get closed after eval'ing OBJECT." `(progn @@ -808,7 +812,7 @@ this grossness will be made to disappear by using `call/cc'..." "Execute the commands in PIPELINE, connecting each to one another. This macro calls itself recursively, with NOTFIRST non-nil." (when (setq pipeline (cadr pipeline)) - `(eshell-copy-handles + `(eshell-with-copied-handles (progn ,(when (cdr pipeline) `(let ((nextproc @@ -833,7 +837,9 @@ This macro calls itself recursively, with NOTFIRST non-nil." (let ((proc ,(car pipeline))) (set headproc (or proc (symbol-value headproc))) (set tailproc (or (symbol-value tailproc) proc)) - proc)))))) + proc))) + ;; Steal handles if this is the last item in the pipeline. + ,(null (cdr pipeline))))) (defmacro eshell-do-pipelines-synchronously (pipeline) "Execute the commands in PIPELINE in sequence synchronously. @@ -880,11 +886,8 @@ This is used on systems where async subprocesses are not supported." (progn ,(if (fboundp 'make-process) `(eshell-do-pipelines ,pipeline) - `(let ((tail-handles (eshell-create-handles - (car (aref eshell-current-handles - ,eshell-output-handle)) nil - (car (aref eshell-current-handles - ,eshell-error-handle)) nil))) + `(let ((tail-handles (eshell-duplicate-handles + eshell-current-handles))) (eshell-do-pipelines-synchronously ,pipeline))) (eshell-process-identity (cons (symbol-value headproc) (symbol-value tailproc)))))) @@ -1024,7 +1027,9 @@ produced by `eshell-parse-command'." ;; We can just stick the new command at the end of the current ;; one, and everything will happen as it should. (setcdr (last (cdr eshell-current-command)) - (list `(let ((here (and (eobp) (point)))) + (list `(let ((here (and (eobp) (point))) + (eshell-command-body '(nil)) + (eshell-test-body '(nil))) ,(and input `(insert-and-inherit ,(concat input "\n"))) (if here diff --git a/lisp/eshell/esh-io.el b/lisp/eshell/esh-io.el index 4620565f857..90826a312b3 100644 --- a/lisp/eshell/esh-io.el +++ b/lisp/eshell/esh-io.el @@ -116,16 +116,22 @@ from executing while Emacs is redisplaying." :group 'eshell-io) (defcustom eshell-virtual-targets - '(("/dev/eshell" eshell-interactive-print nil) + '(;; The literal string "/dev/null" is intentional here. It just + ;; provides compatibility so that users can redirect to + ;; "/dev/null" no matter the actual value of `null-device'. + ("/dev/null" (lambda (_mode) (throw 'eshell-null-device t)) t) + ("/dev/eshell" eshell-interactive-print nil) ("/dev/kill" (lambda (mode) - (if (eq mode 'overwrite) - (kill-new "")) - 'eshell-kill-append) t) + (when (eq mode 'overwrite) + (kill-new "")) + #'eshell-kill-append) + t) ("/dev/clip" (lambda (mode) - (if (eq mode 'overwrite) - (let ((select-enable-clipboard t)) - (kill-new ""))) - 'eshell-clipboard-append) t)) + (when (eq mode 'overwrite) + (let ((select-enable-clipboard t)) + (kill-new ""))) + #'eshell-clipboard-append) + t)) "Map virtual devices name to Emacs Lisp functions. If the user specifies any of the filenames above as a redirection target, the function in the second element will be called. @@ -138,10 +144,8 @@ function. The output function is then called repeatedly with single strings, which represents successive pieces of the output of the command, until nil -is passed, meaning EOF. - -NOTE: /dev/null is handled specially as a virtual target, and should -not be added to this variable." +is passed, meaning EOF." + :version "30.1" :type '(repeat (list (string :tag "Target") function @@ -291,25 +295,58 @@ describing the mode, e.g. for using with `eshell-get-target'.") (defun eshell-create-handles (stdout output-mode &optional stderr error-mode) "Create a new set of file handles for a command. -The default location for standard output and standard error will go to -STDOUT and STDERR, respectively. -OUTPUT-MODE and ERROR-MODE are either `overwrite', `append' or `insert'; -a nil value of mode defaults to `insert'." +The default target for standard output and standard error will +go to STDOUT and STDERR, respectively. OUTPUT-MODE and +ERROR-MODE are either `overwrite', `append' or `insert'; a nil +value of mode defaults to `insert'. + +The result is a vector of file handles. Each handle is of the form: + + ((TARGETS . REF-COUNT) DEFAULT) + +TARGETS is a list of destinations for output. REF-COUNT is the +number of references to this handle (initially 1); see +`eshell-protect-handles' and `eshell-close-handles'. DEFAULT is +non-nil if handle has its initial default value (always t after +calling this function)." (let* ((handles (make-vector eshell-number-of-handles nil)) - (output-target (eshell-get-target stdout output-mode)) - (error-target (if stderr - (eshell-get-target stderr error-mode) - output-target))) - (aset handles eshell-output-handle (cons output-target 1)) - (aset handles eshell-error-handle (cons error-target 1)) + (output-target + (let ((target (eshell-get-target stdout output-mode))) + (cons (when target (list target)) 1))) + (error-target + (if stderr + (let ((target (eshell-get-target stderr error-mode))) + (cons (when target (list target)) 1)) + (cl-incf (cdr output-target)) + output-target))) + (aset handles eshell-output-handle (list output-target t)) + (aset handles eshell-error-handle (list error-target t)) handles)) +(defun eshell-duplicate-handles (handles &optional steal-p) + "Create a duplicate of the file handles in HANDLES. +This uses the targets of each handle in HANDLES, incrementing its +reference count by one (unless STEAL-P is non-nil). These +targets are shared between the original set of handles and the +new one, so the targets are only closed when the reference count +drops to 0 (see `eshell-close-handles'). + +This function also sets the DEFAULT field for each handle to +t (see `eshell-create-handles'). Unlike the targets, this value +is not shared with the original handles." + (let ((dup-handles (make-vector eshell-number-of-handles nil))) + (dotimes (idx eshell-number-of-handles) + (when-let ((handle (aref handles idx))) + (unless steal-p + (cl-incf (cdar handle))) + (aset dup-handles idx (list (car handle) t)))) + dup-handles)) + (defun eshell-protect-handles (handles) "Protect the handles in HANDLES from a being closed." (dotimes (idx eshell-number-of-handles) - (when (aref handles idx) - (setcdr (aref handles idx) - (1+ (cdr (aref handles idx)))))) + (when-let ((handle (aref handles idx))) + (cl-incf (cdar handle)))) handles) (defun eshell-close-handles (&optional exit-code result handles) @@ -327,42 +364,56 @@ the value already set in `eshell-last-command-result'." (when result (cl-assert (eq (car result) 'quote)) (setq eshell-last-command-result (cadr result))) - (let ((handles (or handles eshell-current-handles))) + (let ((handles (or handles eshell-current-handles)) + (succeeded (= eshell-last-command-status 0))) (dotimes (idx eshell-number-of-handles) - (when-let ((handle (aref handles idx))) - (setcdr handle (1- (cdr handle))) - (when (= (cdr handle) 0) - (dolist (target (ensure-list (car (aref handles idx)))) - (eshell-close-target target (= eshell-last-command-status 0))) - (setcar handle nil)))))) + (eshell-close-handle (aref handles idx) succeeded)))) + +(defun eshell-close-handle (handle status) + "Close a single HANDLE, taking refcounts into account. +This will pass STATUS to each target for the handle, which should +be a non-nil value on successful termination." + (when handle + (cl-assert (> (cdar handle) 0) + "Attempted to close a handle with 0 references") + (when (and (> (cdar handle) 0) + (= (cl-decf (cdar handle)) 0)) + (dolist (target (caar handle)) + (eshell-close-target target status)) + (setcar (car handle) nil)))) (defun eshell-set-output-handle (index mode &optional target handles) "Set handle INDEX for the current HANDLES to point to TARGET using MODE. -If HANDLES is nil, use `eshell-current-handles'." +If HANDLES is nil, use `eshell-current-handles'. + +If the handle is currently set to its default value (see +`eshell-create-handles'), this will overwrite the targets with +the new target. Otherwise, it will append the new target to the +current list of targets." (when target - (let ((handles (or handles eshell-current-handles))) - (if (and (stringp target) - (string= target (null-device))) - (aset handles index nil) - (let ((where (eshell-get-target target mode)) - (current (car (aref handles index)))) - (if (listp current) - (unless (member where current) - (setq current (append current (list where)))) - (setq current (list where))) - (if (not (aref handles index)) - (aset handles index (cons nil 1))) - (setcar (aref handles index) current)))))) + (let* ((handles (or handles eshell-current-handles)) + (handle (or (aref handles index) + (aset handles index (list (cons nil 1) nil)))) + (defaultp (cadr handle))) + (when defaultp + (cl-decf (cdar handle)) + (setcar handle (cons nil 1))) + (catch 'eshell-null-device + (let ((current (caar handle)) + (where (eshell-get-target target mode))) + (unless (member where current) + (setcar (car handle) (append current (list where)))))) + (setcar (cdr handle) nil)))) (defun eshell-copy-output-handle (index index-to-copy &optional handles) "Copy the handle INDEX-TO-COPY to INDEX for the current HANDLES. If HANDLES is nil, use `eshell-current-handles'." (let* ((handles (or handles eshell-current-handles)) (handle-to-copy (car (aref handles index-to-copy)))) - (setcar (aref handles index) - (if (listp handle-to-copy) - (copy-sequence handle-to-copy) - handle-to-copy)))) + (when handle-to-copy + (cl-incf (cdr handle-to-copy))) + (eshell-close-handle (aref handles index) nil) + (setcar (aref handles index) handle-to-copy))) (defun eshell-set-all-output-handles (mode &optional target handles) "Set output and error HANDLES to point to TARGET using MODE. @@ -493,9 +544,9 @@ INDEX is the handle index to check. If nil, check (let ((handles (or handles eshell-current-handles)) (index (or index eshell-output-handle))) (if (eq index 'all) - (and (eq (car (aref handles eshell-output-handle)) t) - (eq (car (aref handles eshell-error-handle)) t)) - (eq (car (aref handles index)) t)))) + (and (equal (caar (aref handles eshell-output-handle)) '(t)) + (equal (caar (aref handles eshell-error-handle)) '(t))) + (equal (caar (aref handles index)) '(t))))) (defvar eshell-print-queue nil) (defvar eshell-print-queue-count -1) @@ -602,15 +653,10 @@ Returns what was actually sent, or nil if nothing was sent." If HANDLE-INDEX is nil, output to `eshell-output-handle'. HANDLES is the set of file handles to use; if nil, use `eshell-current-handles'." - (let ((target (car (aref (or handles eshell-current-handles) - (or handle-index eshell-output-handle))))) - (if (listp target) - (while target - (eshell-output-object-to-target object (car target)) - (setq target (cdr target))) - (eshell-output-object-to-target object target) - ;; Explicitly return nil to match the list case above. - nil))) + (let ((targets (caar (aref (or handles eshell-current-handles) + (or handle-index eshell-output-handle))))) + (dolist (target targets) + (eshell-output-object-to-target object target)))) (provide 'esh-io) ;;; esh-io.el ends here diff --git a/lisp/eshell/esh-mode.el b/lisp/eshell/esh-mode.el index 4357a0e29a0..b3db0f6af45 100644 --- a/lisp/eshell/esh-mode.el +++ b/lisp/eshell/esh-mode.el @@ -282,12 +282,10 @@ This is used by `eshell-watch-for-password-prompt'." (defvar-keymap eshell-command-repeat-map :doc "Keymap to repeat eshell-command key sequences. Used in `repeat-mode'." + :repeat t "C-f" #'eshell-forward-argument "C-b" #'eshell-backward-argument) -(put #'eshell-forward-argument 'repeat-map 'eshell-command-repeat-map) -(put #'eshell-backward-argument 'repeat-map 'eshell-command-repeat-map) - ;;; User Functions: (defun eshell-kill-buffer-function () diff --git a/lisp/eshell/esh-proc.el b/lisp/eshell/esh-proc.el index 950922ea7f8..c56278aad02 100644 --- a/lisp/eshell/esh-proc.el +++ b/lisp/eshell/esh-proc.el @@ -467,7 +467,7 @@ PROC is the process that's exiting. STRING is the exit message." (if (process-get proc :eshell-busy) (run-at-time 0 nil finish-io) (when data - (ignore-error 'eshell-pipe-broken + (ignore-error eshell-pipe-broken (eshell-output-object data index handles))) (eshell-close-handles diff --git a/lisp/faces.el b/lisp/faces.el index c69339e2fdc..fe683e437f5 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -47,7 +47,8 @@ the terminal-initialization file to be loaded." ("vt400" . "vt200") ("vt420" . "vt200") ("alacritty" . "xterm") - ("foot" . "xterm")) + ("foot" . "xterm") + ("contour" . "xterm")) "Alist of terminal type aliases. Entries are of the form (TYPE . ALIAS), where both elements are strings. This means to treat a terminal of type TYPE as if it were of type ALIAS." @@ -689,6 +690,10 @@ be reset to `unspecified' when creating new frames, disregarding what the FACE's face spec says, call this function with FRAME set to t and the ATTRIBUTE's value set to `unspecified'. +Note that the ATTRIBUTE VALUE pairs are evaluated in the order +they are specified, except the `:family' and `:foundry' +attributes which are evaluated first. + The following attributes are recognized: `:family' diff --git a/lisp/files.el b/lisp/files.el index f352d3a9a7e..e729c007821 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -2850,7 +2850,7 @@ since only a single case-insensitive search through the alist is made." ("\\.emacs-places\\'" . lisp-data-mode) ("\\.el\\'" . emacs-lisp-mode) ("Project\\.ede\\'" . emacs-lisp-mode) - ("\\.\\(scm\\|stk\\|ss\\|sch\\)\\'" . scheme-mode) + ("\\.\\(scm\\|sls\\|sld\\|stk\\|ss\\|sch\\)\\'" . scheme-mode) ("\\.l\\'" . lisp-mode) ("\\.li?sp\\'" . lisp-mode) ("\\.[fF]\\'" . fortran-mode) @@ -6193,11 +6193,11 @@ instance of such commands." (rename-buffer (generate-new-buffer-name base-name)) (force-mode-line-update)))) -(defun files--ensure-directory (mkdir dir) - "Use function MKDIR to make directory DIR if it is not already a directory. +(defun files--ensure-directory (dir) + "Make directory DIR if it is not already a directory. Return non-nil if DIR is already a directory." (condition-case err - (funcall mkdir dir) + (make-directory-internal dir) (error (or (file-directory-p dir) (signal (car err) (cdr err)))))) @@ -6223,32 +6223,27 @@ Signal an error if unsuccessful." ;; If default-directory is a remote directory, ;; make sure we find its make-directory handler. (setq dir (expand-file-name dir)) - (let ((mkdir (if-let ((handler (find-file-name-handler dir 'make-directory))) - #'(lambda (dir) - ;; Use 'ignore' since the handler might be designed for - ;; Emacs 28-, so it might return an (undocumented) - ;; non-nil value, whereas the Emacs 29+ convention is - ;; to return nil here. - (ignore (funcall handler 'make-directory dir))) - #'make-directory-internal))) - (if (not parents) - (funcall mkdir dir) - (let ((dir (directory-file-name (expand-file-name dir))) - already-dir create-list parent) - (while (progn - (setq parent (directory-file-name - (file-name-directory dir))) - (condition-case () - (ignore (setq already-dir - (files--ensure-directory mkdir dir))) - (error - ;; Do not loop if root does not exist (Bug#2309). - (not (string= dir parent))))) - (setq create-list (cons dir create-list) - dir parent)) - (dolist (dir create-list) - (setq already-dir (files--ensure-directory mkdir dir))) - already-dir)))) + (let ((handler (find-file-name-handler dir 'make-directory))) + (if handler + (funcall handler 'make-directory dir parents) + (if (not parents) + (make-directory-internal dir) + (let ((dir (directory-file-name (expand-file-name dir))) + already-dir create-list parent) + (while (progn + (setq parent (directory-file-name + (file-name-directory dir))) + (condition-case () + (ignore (setq already-dir + (files--ensure-directory dir))) + (error + ;; Do not loop if root does not exist (Bug#2309). + (not (string= dir parent))))) + (setq create-list (cons dir create-list) + dir parent)) + (dolist (dir create-list) + (setq already-dir (files--ensure-directory dir))) + already-dir))))) (defun make-empty-file (filename &optional parents) "Create an empty file FILENAME. diff --git a/lisp/font-lock.el b/lisp/font-lock.el index bf9a179d6ae..831e603239b 100644 --- a/lisp/font-lock.el +++ b/lisp/font-lock.el @@ -2110,7 +2110,7 @@ For example, the declaration and use of fields in a struct." (defface font-lock-punctuation-face '((t nil)) - "Font Lock mode face used to highlight punctuation." + "Font Lock mode face used to highlight punctuation characters." :group 'font-lock-faces :version "29.1") @@ -2122,7 +2122,9 @@ For example, the declaration and use of fields in a struct." (defface font-lock-delimiter-face '((t :inherit font-lock-punctuation-face)) - "Font Lock mode face used to highlight delimiters." + "Font Lock mode face used to highlight delimiters. +What exactly is a delimiter depends on the major mode, but usually +these are characters like comma, colon, and semi-colon." :group 'font-lock-faces :version "29.1") @@ -2361,6 +2363,7 @@ in which C preprocessor directives are used, e.g. `asm-mode' and (define-obsolete-function-alias 'font-lock-after-fontify-buffer #'ignore "29.1") (define-obsolete-function-alias 'font-lock-after-unfontify-buffer #'ignore "29.1") +(define-obsolete-function-alias 'font-lock-fontify-syntactically-region #'font-lock-default-fontify-syntactically "29.1") (provide 'font-lock) diff --git a/lisp/frame.el b/lisp/frame.el index 400f8a44eea..e4cd2cd8ae2 100644 --- a/lisp/frame.el +++ b/lisp/frame.el @@ -1188,7 +1188,7 @@ e.g. (mapc \\='frame-set-background-mode (frame-list))." (defvar inhibit-frame-set-background-mode nil) -(defun frame--current-backround-mode (frame) +(defun frame--current-background-mode (frame) (let* ((frame-default-bg-mode (frame-terminal-default-bg-mode frame)) (bg-color (frame-parameter frame 'background-color)) (tty-type (tty-type frame)) @@ -1218,7 +1218,7 @@ If optional arg KEEP-FACE-SPECS is non-nil, don't recalculate face specs for the new background mode." (unless inhibit-frame-set-background-mode (let* ((bg-mode - (frame--current-backround-mode frame)) + (frame--current-background-mode frame)) (display-type (cond ((null (window-system frame)) (if (tty-display-color-p frame) 'color 'mono)) @@ -1297,7 +1297,7 @@ the `background-mode' terminal parameter." ;; :global t ;; :group 'faces ;; (when (eq dark-mode -;; (eq 'light (frame--current-backround-mode (selected-frame)))) +;; (eq 'light (frame--current-background-mode (selected-frame)))) ;; ;; FIXME: Change the face's SPEC instead? ;; (set-face-attribute 'default nil ;; :foreground (face-attribute 'default :background) @@ -3105,6 +3105,9 @@ If FRAME isn't maximized, show the title bar." frame 'undecorated (eq (alist-get 'fullscreen (frame-parameters frame)) 'maximized))) +(define-obsolete-function-alias 'frame--current-backround-mode + #'frame--current-background-mode "30.1") + (provide 'frame) ;;; frame.el ends here diff --git a/lisp/gnus/ChangeLog.3 b/lisp/gnus/ChangeLog.3 index 8c1073dc8db..bf64780799d 100644 --- a/lisp/gnus/ChangeLog.3 +++ b/lisp/gnus/ChangeLog.3 @@ -11763,7 +11763,7 @@ 2010-08-29 Lars Magne Ingebrigtsen <larsi@gnus.org> * gnus-start.el (gnus-dribble-read-file): Ensure that the directory - where the dribbel file lives exists. + where the dribble file lives exists. * message.el (message-send-mail-partially-limit): Change the default to nil, since most people don't want this. diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el index cf5ca628cff..c5cd4d7d6be 100644 --- a/lisp/gnus/gnus-registry.el +++ b/lisp/gnus/gnus-registry.el @@ -394,7 +394,7 @@ This is not required after changing `gnus-registry-cache-file'." (with-no-warnings (eieio-persistent-read file 'registry-db)) ;; Older EIEIO versions do not check the class name. - ('wrong-number-of-arguments + (wrong-number-of-arguments (eieio-persistent-read file))))) (gnus-message 5 "Reading Gnus registry from %s...done" file)) diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index e7d11b597b3..6c10a4ae976 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -3191,7 +3191,6 @@ Like `text-mode', but with these additional commands: (mail-abbrevs-setup)) ((message-mail-alias-type-p 'ecomplete) (ecomplete-setup))) - (add-hook 'completion-at-point-functions #'eudc-capf-complete -1 t) (add-hook 'completion-at-point-functions #'message-completion-function nil t) (unless buffer-file-name (message-set-auto-save-file-name)) diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el index ebd0adf2e25..dc86fe6db96 100644 --- a/lisp/gnus/mml.el +++ b/lisp/gnus/mml.el @@ -1484,10 +1484,12 @@ Ask for type, description or disposition according to (setq disposition (mml-minibuffer-read-disposition type nil file))) (mml-attach-file file type description disposition))))) -(defun mml-attach-buffer (buffer &optional type description disposition) +(defun mml-attach-buffer (buffer &optional type description disposition filename) "Attach a buffer to the outgoing MIME message. BUFFER is the name of the buffer to attach. See -`mml-attach-file' for details of operation." +`mml-attach-file' regarding TYPE, DESCRIPTION and DISPOSITION. +FILENAME is a suggested file name for the attachment should a +recipient wish to save a copy separate from the message." (interactive (let* ((buffer (read-buffer "Attach buffer: ")) (type (mml-minibuffer-read-type buffer "text/plain")) @@ -1497,9 +1499,10 @@ BUFFER is the name of the buffer to attach. See ;; If in the message header, attach at the end and leave point unchanged. (let ((head (unless (message-in-body-p) (point)))) (if head (goto-char (point-max))) - (mml-insert-empty-tag 'part 'type type 'buffer buffer - 'disposition disposition - 'description description) + (apply #'mml-insert-empty-tag + 'part 'type type 'buffer buffer + 'disposition disposition 'description description + (and filename `(filename ,filename))) ;; When using Mail mode, make sure it does the mime encoding ;; when you send the message. (or (eq mail-user-agent 'message-user-agent) diff --git a/lisp/gnus/nndiary.el b/lisp/gnus/nndiary.el index ab9c6dd74f9..e3fb5d8f872 100644 --- a/lisp/gnus/nndiary.el +++ b/lisp/gnus/nndiary.el @@ -339,8 +339,15 @@ all. This may very well take some time.") ;; for this header) or one list (specifying all the possible values for this ;; header). In the latter case, the list does NOT include the unspecified ;; spec (*). + ;; For time zone values, we have symbolic time zone names associated with ;; the (relative) number of seconds ahead GMT. + ;; The list of time zone values is obsolescent, and new code should + ;; not rely on it. Many of the time zone abbreviations are wrong; + ;; in particular, all single-letter abbreviations other than "Z" have + ;; been wrong since Internet RFC 2822 (2001). However, the + ;; abbreviations have not been changed due to backward compatibility + ;; concerns. ) (defsubst nndiary-schedule () diff --git a/lisp/gnus/nnml.el b/lisp/gnus/nnml.el index 40e4b9ea828..7aa445e6646 100644 --- a/lisp/gnus/nnml.el +++ b/lisp/gnus/nnml.el @@ -776,17 +776,22 @@ article number. This function is called narrowed to an article." (nnml--encode-headers headers) headers)))) +;; RFC2047-encode Subject and From, but leave invalid headers unencoded. (defun nnml--encode-headers (headers) (let ((subject (mail-header-subject headers)) (rfc2047-encoding-type 'mime)) (unless (string-match "\\`[[:ascii:]]*\\'" subject) - (setf (mail-header-subject headers) - (mail-encode-encoded-word-string subject t)))) + (let ((encoded-subject + (ignore-errors (mail-encode-encoded-word-string subject t)))) + (if encoded-subject + (setf (mail-header-subject headers) encoded-subject))))) (let ((from (mail-header-from headers)) (rfc2047-encoding-type 'address-mime)) (unless (string-match "\\`[[:ascii:]]*\\'" from) - (setf (mail-header-from headers) - (rfc2047-encode-string from t))))) + (let ((encoded-from + (ignore-errors (rfc2047-encode-string from t)))) + (if encoded-from + (setf (mail-header-from headers) encoded-from)))))) (defun nnml-get-nov-buffer (group &optional incrementalp) (let ((buffer (gnus-get-buffer-create diff --git a/lisp/help-fns.el b/lisp/help-fns.el index e29f763dabc..3307771ef68 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -2004,8 +2004,8 @@ variable with value KEYMAP." (mapatoms (lambda (symb) (when (and (boundp symb) (eq (symbol-value symb) keymap) - (not (eq symb 'keymap)) - (throw 'found-keymap symb))))) + (not (eq symb 'keymap))) + (throw 'found-keymap symb)))) nil))) ;; Follow aliasing. (or (ignore-errors (indirect-variable name)) name)))) diff --git a/lisp/help.el b/lisp/help.el index b709062cb27..d7fd4d555ea 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -76,6 +76,7 @@ buffer.") "C-n" #'view-emacs-news "C-o" #'describe-distribution "C-p" #'view-emacs-problems + "C-q" #'help-quick-toggle "C-s" #'search-forward-help-for-help "C-t" #'view-emacs-todo "C-w" #'describe-no-warranty @@ -116,7 +117,7 @@ buffer.") "v" #'describe-variable "w" #'where-is "x" #'describe-command - "q" #'help-quit-or-quick) + "q" #'help-quit) (define-key global-map (char-to-string help-char) 'help-command) (define-key global-map [help] 'help-command) @@ -243,7 +244,17 @@ buffer.") ;; ... and shrink it immediately. (fit-window-to-buffer)) (message - (substitute-command-keys "Toggle the quick help buffer using \\[help-quit-or-quick].")))) + (substitute-command-keys "Toggle the quick help buffer using \\[help-quick-toggle].")))) + +(defun help-quick-toggle () + "Toggle the quick-help window." + (interactive) + (if (and-let* ((window (get-buffer-window "*Quick Help*"))) + (quit-window t window)) + ;; Clear the message we may have gotten from `C-h' and then + ;; waiting before hitting `q'. + (message "") + (help-quick))) (defalias 'cheat-sheet #'help-quick) @@ -252,21 +263,6 @@ buffer.") (interactive) nil) -(defun help-quit-or-quick () - "Call `help-quit' or `help-quick' depending on the context." - (interactive) - (cond - (help-buffer-under-preparation - ;; FIXME: There should be a better way to detect if we are in the - ;; help command loop. - (help-quit)) - ((and-let* ((window (get-buffer-window "*Quick Help*"))) - (quit-window t window) - ;; Clear the message we may have gotten from `C-h' and then - ;; waiting before hitting `q'. - (message ""))) - ((help-quick)))) - (defvar help-return-method nil "What to do to \"exit\" the help buffer. This is a list @@ -416,7 +412,7 @@ Do not call this in the scope of `with-help-window'." ("describe-package" "Describe a specific Emacs package") "" ("help-with-tutorial" "Start the Emacs tutorial") - ("help-quick-or-quit" "Display the quick help buffer.") + ("help-quick-toggle" "Display the quick help buffer.") ("view-echo-area-messages" "Show recent messages (from echo area)") ("view-lossage" ,(format "Show last %d input keystrokes (lossage)" diff --git a/lisp/hi-lock.el b/lisp/hi-lock.el index a45e74eca26..bc631747e6d 100644 --- a/lisp/hi-lock.el +++ b/lisp/hi-lock.el @@ -569,24 +569,29 @@ the major mode specifies support for Font Lock." (when (and face-before face-after (not (eq face-before face-after))) (setq face-before nil)) (when (or face-after face-before) - (let* ((hi-text - (buffer-substring-no-properties - (if face-before - (or (previous-single-property-change (point) 'face) - (point-min)) - (point)) - (if face-after - (or (next-single-property-change (point) 'face) - (point-max)) - (point))))) + (let* ((beg (if face-before + (or (previous-single-property-change (point) 'face) + (point-min)) + (point))) + (end (if face-after + (or (next-single-property-change (point) 'face) + (point-max)) + (point)))) ;; Compute hi-lock patterns that match the ;; highlighted text at point. Use this later in ;; during completing-read. (dolist (hi-lock-pattern hi-lock-interactive-patterns) - (let ((regexp (or (car (rassq hi-lock-pattern hi-lock-interactive-lighters)) - (car hi-lock-pattern)))) - (if (string-match regexp hi-text) - (push regexp regexps))))))) + (let ((pattern (or (rassq hi-lock-pattern hi-lock-interactive-lighters) + (car hi-lock-pattern)))) + (cond + ((stringp pattern) + (when (string-match pattern (buffer-substring-no-properties beg end)) + (push pattern regexps))) + ((functionp (cadr pattern)) + (save-excursion + (goto-char beg) + (when (funcall (cadr pattern) end) + (push (car pattern) regexps)))))))))) regexps)) (defvar-local hi-lock--unused-faces nil diff --git a/lisp/htmlfontify.el b/lisp/htmlfontify.el index df4c6ab079c..32bf0bf4d44 100644 --- a/lisp/htmlfontify.el +++ b/lisp/htmlfontify.el @@ -1850,8 +1850,9 @@ Hardly bombproof, but good enough in the context in which it is being used." (defun hfy-text-p (srcdir file) "Is SRCDIR/FILE text? Use `hfy-istext-command' to determine this." - (let* ((cmd (format hfy-istext-command (expand-file-name file srcdir))) - (rsp (shell-command-to-string cmd))) + (let* ((cmd (format hfy-istext-command + (shell-quote-argument (expand-file-name file srcdir)))) + (rsp (shell-command-to-string cmd))) (string-match "text" rsp))) ;; open a file, check fontification, if fontified, write a fontified copy diff --git a/lisp/image-mode.el b/lisp/image-mode.el index bd208fbad46..10af8c6cab9 100644 --- a/lisp/image-mode.el +++ b/lisp/image-mode.el @@ -1086,7 +1086,7 @@ Otherwise, display the image by calling `image-mode'." (unwind-protect (progn (setq-local image-fit-to-window-lock t) - (ignore-error 'remote-file-error + (ignore-error remote-file-error (image-toggle-display-image))) (setq image-fit-to-window-lock nil))))))))))) diff --git a/lisp/indent.el b/lisp/indent.el index c7ec5c9a3ed..6b575a86b5e 100644 --- a/lisp/indent.el +++ b/lisp/indent.el @@ -784,7 +784,8 @@ If PREV is non-nil, return the previous one instead." (defun tab-to-tab-stop () "Insert spaces or tabs to next defined tab-stop column. The variable `tab-stop-list' is a list of columns at which there are tab stops. -Use \\[edit-tab-stops] to edit them interactively." +Use \\[edit-tab-stops] to edit them interactively. +Whether this inserts tabs or spaces depends on `indent-tabs-mode'." (interactive) (and abbrev-mode (= (char-syntax (preceding-char)) ?w) (expand-abbrev)) diff --git a/lisp/international/characters.el b/lisp/international/characters.el index 9dcae187f21..42344d499cf 100644 --- a/lisp/international/characters.el +++ b/lisp/international/characters.el @@ -184,7 +184,7 @@ with L, LRE, or LRO Unicode bidi character type.") (dolist (c '(chinese-cns11643-1 chinese-cns11643-2 chinese-cns11643-3 chinese-cns11643-4 chinese-cns11643-5 chinese-cns11643-6 - chinese-cns11643-7)) + chinese-cns11643-7 chinese-cns11643-15)) (map-charset-chars #'modify-category-entry c ?c) (if (eq c 'chinese-cns11643-1) (map-charset-chars #'modify-category-entry c ?C #x4421 #x7E7E) diff --git a/lisp/international/mule-conf.el b/lisp/international/mule-conf.el index 3f3ac6064ae..65ba2370fcf 100644 --- a/lisp/international/mule-conf.el +++ b/lisp/international/mule-conf.el @@ -1268,7 +1268,7 @@ :short-name "CNS11643-15" :long-name "CNS11643-15 (Chinese traditional)" :code-space [33 126 33 126] - :code-offset #x27A000 + :code-offset #x28083A ; Right after 'big5-hkscs. :unify-map "CNS-F") (unify-charset 'chinese-gb2312) diff --git a/lisp/isearch.el b/lisp/isearch.el index 6a17d18c45e..ba67cce841a 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el @@ -181,7 +181,9 @@ When t (by default), signal an error when no more matches are found. Then after repeating the search, wrap with `isearch-wrap-function'. When `no', wrap immediately after reaching the last match. When `no-ding', wrap immediately without flashing the screen. -When nil, never wrap, just stop at the last match." +When nil, never wrap, just stop at the last match. +With the values `no' and `no-ding' the search will try +to wrap around also on typing a character." :type '(choice (const :tag "Pause before wrapping" t) (const :tag "No pause before wrapping" no) (const :tag "No pause and no flashing" no-ding) @@ -880,6 +882,7 @@ matches literally, against one space. You can toggle the value of this variable by the command `isearch-toggle-lax-whitespace', usually bound to `M-s SPC' during isearch." :type 'boolean + :group 'isearch :version "25.1") (defvar isearch-regexp-lax-whitespace nil @@ -1179,6 +1182,7 @@ Each element of the list should be one of the symbols supported by `isearch-forward-thing-at-point' to yank the initial \"thing\" as text to the search string." :type '(repeat (symbol :tag "Thing symbol")) + :group 'isearch :version "28.1") (defun isearch-forward-thing-at-point () @@ -2525,10 +2529,11 @@ If no input items have been entered yet, just beep." (ding) (isearch-pop-state)) ;; When going back to the hidden match, reopen it and close other overlays. - (when (and (eq search-invisible 'open) isearch-hide-immediately) + (when (and (eq isearch-invisible 'open) isearch-hide-immediately) (if isearch-other-end - (isearch-range-invisible (min (point) isearch-other-end) - (max (point) isearch-other-end)) + (let ((search-invisible isearch-invisible)) + (isearch-range-invisible (min (point) isearch-other-end) + (max (point) isearch-other-end))) (isearch-close-unnecessary-overlays (point) (point)))) (isearch-update)) diff --git a/lisp/keymap.el b/lisp/keymap.el index b355f68aa2f..e93e3c5f3bc 100644 --- a/lisp/keymap.el +++ b/lisp/keymap.el @@ -625,7 +625,7 @@ command exists in this specific map, but it doesn't have the `(defvar ,variable-name (define-keymap ,@(nreverse opts) ,@defs) ,@(and doc (list doc))))) - (if repeat + (if props `(progn ,defvar-form ,@(nreverse props)) diff --git a/lisp/mail/rmailout.el b/lisp/mail/rmailout.el index c1371308d4f..18f980df975 100644 --- a/lisp/mail/rmailout.el +++ b/lisp/mail/rmailout.el @@ -327,15 +327,14 @@ Replaces the From line with a \"Mail-from\" header. Adds \"Date\" and "Date: \\2, \\4 \\3 \\9 \\5 " ;; The timezone could be matched by group 7 or group 10. - ;; If neither of them matched, assume EST, since only - ;; Easterners would be so sloppy. + ;; If neither matched, use "-0000" for an unknown zone. ;; It's a shame the substitution can't use "\\10". (cond ((/= (match-beginning 7) (match-end 7)) "\\7") ((/= (match-beginning 10) (match-end 10)) (buffer-substring (match-beginning 10) (match-end 10))) - (t "EST")) + (t "-0000")) "\n")) ;; Keep and reformat the sender if we don't ;; have a From: field. diff --git a/lisp/mail/rmailsum.el b/lisp/mail/rmailsum.el index d63e05f5fa2..20362d39d10 100644 --- a/lisp/mail/rmailsum.el +++ b/lisp/mail/rmailsum.el @@ -339,7 +339,7 @@ First element is ignored.") (split-string header "[ \f\t\n\r\v,;]+")))) (defun rmail-summary-fill-message-parents-and-descs-vectors () - "Fill parents and descendats vectors for messages. + "Fill parents and descendants vectors for messages. This populates `rmail-summary-message-parents-vector' and `rmail-summary-message-descendants-vector'." (with-current-buffer rmail-buffer diff --git a/lisp/mh-e/mh-search.el b/lisp/mh-e/mh-search.el index 058ea4499fd..1b28509dd12 100644 --- a/lisp/mh-e/mh-search.el +++ b/lisp/mh-e/mh-search.el @@ -292,7 +292,7 @@ folder containing the index search results." (cons folder msg))))) folder-results-map) - ;; Vist the results folder. + ;; Visit the results folder. (mh-visit-folder index-folder () (list folder-results-map origin-map)) (goto-char (point-min)) diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index a89f8191c09..2f9b902f082 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -1476,7 +1476,10 @@ when the buffer's text is already an exact match." (if (and (eq this-command last-command) completion-auto-help) (minibuffer-completion-help beg end)) (completion--done completion 'exact - (unless expect-exact + (unless (or expect-exact + (and completion-auto-select + (eq this-command last-command) + completion-auto-help)) "Complete, but not unique")))) (minibuffer--bitset completed t exact)))))))) diff --git a/lisp/net/ange-ftp.el b/lisp/net/ange-ftp.el index 9781ebf863a..f8e2858bc3f 100644 --- a/lisp/net/ange-ftp.el +++ b/lisp/net/ange-ftp.el @@ -4129,7 +4129,7 @@ directory, so that Emacs will know its current contents." (or (file-exists-p parent) (ange-ftp-make-directory parent parents)))) (if (file-exists-p dir) - (unless parents + (if parents t (signal 'file-already-exists (list "Cannot make directory: file already exists" dir))) @@ -4158,7 +4158,8 @@ directory, so that Emacs will know its current contents." (format "Could not make directory %s: %s" dir (cdr result)))) - (ange-ftp-add-file-entry dir t)) + (ange-ftp-add-file-entry dir t) + nil) (ange-ftp-real-make-directory dir))))) (defun ange-ftp-delete-directory (dir &optional recursive trash) diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 3799ef96e84..a8a985b8dea 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -2498,10 +2498,10 @@ Otherwise, the restored buffer will contain a prompt to do so by using (when (plist-get eww-data :url) (cl-case eww-restore-desktop ((t auto) (eww (plist-get eww-data :url))) - ((zerop (buffer-size)) - (let ((inhibit-read-only t)) - (insert (substitute-command-keys - eww-restore-reload-prompt))))))) + ((nil) (when (zerop (buffer-size)) + (let ((inhibit-read-only t)) + (insert (substitute-command-keys + eww-restore-reload-prompt)))))))) ;; . (current-buffer))) diff --git a/lisp/net/gnutls.el b/lisp/net/gnutls.el index 6e3845aec1a..9f14df08a79 100644 --- a/lisp/net/gnutls.el +++ b/lisp/net/gnutls.el @@ -128,10 +128,7 @@ key exchange is against man-in-the-middle attacks.) A value of nil says to use the default GnuTLS value. -The default value of this variable is such that virtually any -connection can be established, whether this connection can be -considered cryptographically \"safe\" or not. However, Emacs -network security is handled at a higher level via +Emacs network security is handled at a higher level via `open-network-stream' and the Network Security Manager. See Info node `(emacs) Network Security'." :type '(choice (const :tag "Use default value" nil) diff --git a/lisp/net/newst-backend.el b/lisp/net/newst-backend.el index af196ccecf9..2a87742fdf8 100644 --- a/lisp/net/newst-backend.el +++ b/lisp/net/newst-backend.el @@ -1623,7 +1623,7 @@ Sat, 07 Sep 2002 00:00:01 GMT ":\\([0-9]\\{2\\}\\)" ;; second "\\(:\\([0-9]\\{2\\}\\)\\)?" - ;; zone -- fixme + ;; zone "\\(\\s-+\\(" "UT\\|GMT\\|EST\\|EDT\\|CST\\|CDT\\|MST\\|MDT\\|PST\\|PDT" "\\|\\([-+]\\)\\([0-9]\\{2\\}\\)\\([0-9]\\{2\\}\\)" @@ -1642,16 +1642,26 @@ Sat, 07 Sep 2002 00:00:01 GMT (offset-hour (read (or (match-string 14 rfc822-string) "0"))) (offset-minute (read (or (match-string 15 rfc822-string) - "0"))) - ;;FIXME - ) + "0")))) (when zone (cond ((string= sign "+") (setq hour (- hour offset-hour)) (setq minute (- minute offset-minute))) ((string= sign "-") (setq hour (+ hour offset-hour)) - (setq minute (+ minute offset-minute))))) + (setq minute (+ minute offset-minute))) + ((or (string= zone "UT") (string= zone "GMT")) + nil) + ((string= zone "EDT") + (setq hour (+ hour 4))) + ((or (string= zone "EST") (string= zone "CDT")) + (setq hour (+ hour 5))) + ((or (string= zone "CST") (string= zone "MDT")) + (setq hour (+ hour 6))) + ((or (string= zone "MST") (string= zone "PDT")) + (setq hour (+ hour 7))) + ((string= zone "PST") + (setq hour (+ hour 8))))) (condition-case error-data (let ((i 1)) (dolist (m '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" diff --git a/lisp/net/soap-client.el b/lisp/net/soap-client.el index 5e7bdbe6c6a..6e9200e4656 100644 --- a/lisp/net/soap-client.el +++ b/lisp/net/soap-client.el @@ -1317,7 +1317,7 @@ See also `soap-wsdl-resolve-references'." "Validate VALUE against the basic type TYPE." (let* ((kind (soap-xs-basic-type-kind type))) (cl-case kind - ((anyType Array byte[]) + ((anyType Array byte\[\]) value) (t (let ((convert (get kind 'rng-xsd-convert))) diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 90020fbb1b6..5a025130ecf 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -411,20 +411,11 @@ Emacs dired can't find files." (defun tramp-adb-handle-make-directory (dir &optional parents) "Like `make-directory' for Tramp files." - (setq dir (expand-file-name dir)) - (with-parsed-tramp-file-name dir nil - (when (and (null parents) (file-exists-p dir)) - (tramp-error v 'file-already-exists dir)) - (when parents - (let ((par (expand-file-name ".." dir))) - (unless (file-directory-p par) - (make-directory par parents)))) - (tramp-flush-directory-properties v localname) - (unless (or (tramp-adb-send-command-and-check - v (format "mkdir -m %#o %s" - (default-file-modes) - (tramp-shell-quote-argument localname))) - (and parents (file-directory-p dir))) + (tramp-skeleton-make-directory dir parents + (unless (tramp-adb-send-command-and-check + v (format "mkdir -m %#o %s" + (default-file-modes) + (tramp-shell-quote-argument localname))) (tramp-error v 'file-error "Couldn't make directory %s" dir)))) (defun tramp-adb-handle-delete-directory (directory &optional recursive trash) diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el index 249b3fcd4d7..e6c0ebccbff 100644 --- a/lisp/net/tramp-crypt.el +++ b/lisp/net/tramp-crypt.el @@ -800,16 +800,9 @@ WILDCARD is not supported." (defun tramp-crypt-handle-make-directory (dir &optional parents) "Like `make-directory' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name dir) nil - (when (and (null parents) (file-exists-p dir)) - (tramp-error v 'file-already-exists dir)) + (tramp-skeleton-make-directory dir parents (let (tramp-crypt-enabled) - (make-directory (tramp-crypt-encrypt-file-name dir) parents)) - ;; When PARENTS is non-nil, DIR could be a chain of non-existent - ;; directories a/b/c/... Instead of checking, we simply flush the - ;; whole cache. - (tramp-flush-directory-properties - v (if parents "/" (file-name-directory localname))))) + (make-directory (tramp-crypt-encrypt-file-name dir) parents)))) (defun tramp-crypt-handle-rename-file (filename newname &optional ok-if-already-exists) diff --git a/lisp/net/tramp-fuse.el b/lisp/net/tramp-fuse.el index ea6b5a0622c..5176c6e9c48 100644 --- a/lisp/net/tramp-fuse.el +++ b/lisp/net/tramp-fuse.el @@ -127,14 +127,8 @@ (defun tramp-fuse-handle-make-directory (dir &optional parents) "Like `make-directory' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name dir) nil - (make-directory (tramp-fuse-local-file-name dir) parents) - ;; When PARENTS is non-nil, DIR could be a chain of non-existent - ;; directories a/b/c/... Instead of checking, we simply flush the - ;; whole file cache. - (tramp-flush-file-properties v localname) - (tramp-flush-directory-properties - v (if parents "/" (file-name-directory localname))))) + (tramp-skeleton-make-directory dir parents + (make-directory (tramp-fuse-local-file-name dir) parents))) ;; File name helper functions. diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index da7641774fb..66f4de989d0 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -1560,27 +1560,13 @@ If FILE-SYSTEM is non-nil, return file system attributes." (defun tramp-gvfs-handle-make-directory (dir &optional parents) "Like `make-directory' for Tramp files." - (setq dir (directory-file-name (expand-file-name dir))) - (with-parsed-tramp-file-name dir nil - (when (and (null parents) (file-exists-p dir)) - (tramp-error v 'file-already-exists dir)) - (tramp-flush-directory-properties v localname) + (tramp-skeleton-make-directory dir parents (save-match-data - (let ((ldir (file-name-directory dir))) - ;; Make missing directory parts. "gvfs-mkdir -p ..." does not - ;; work robust. - (when (and parents (not (file-directory-p ldir))) - (make-directory ldir parents)) - ;; Just do it. - (or (when-let ((mkdir-succeeded - (and - (tramp-gvfs-send-command - v "gvfs-mkdir" (tramp-gvfs-url-file-name dir)) - (tramp-gvfs-info dir)))) - (set-file-modes dir (default-file-modes)) - mkdir-succeeded) - (and parents (file-directory-p dir)) - (tramp-error v 'file-error "Couldn't make directory %s" dir)))))) + (if (and (tramp-gvfs-send-command + v "gvfs-mkdir" (tramp-gvfs-url-file-name dir)) + (tramp-gvfs-info dir)) + (set-file-modes dir (default-file-modes)) + (tramp-error v 'file-error "Couldn't make directory %s" dir))))) (defun tramp-gvfs-handle-rename-file (filename newname &optional ok-if-already-exists) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 6087f16431e..a5327e428ac 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -2559,19 +2559,10 @@ The method used must be an out-of-band method." (defun tramp-sh-handle-make-directory (dir &optional parents) "Like `make-directory' for Tramp files." - (setq dir (expand-file-name dir)) - (with-parsed-tramp-file-name dir nil - (when (and (null parents) (file-exists-p dir)) - (tramp-error v 'file-already-exists dir)) - ;; When PARENTS is non-nil, DIR could be a chain of non-existent - ;; directories a/b/c/... Instead of checking, we simply flush the - ;; whole cache. - (tramp-flush-directory-properties - v (if parents "/" (file-name-directory localname))) + (tramp-skeleton-make-directory dir parents (tramp-barf-unless-okay v (format "%s -m %#o %s" - (if parents "mkdir -p" "mkdir") - (default-file-modes) + "mkdir" (default-file-modes) (tramp-shell-quote-argument localname)) "Couldn't make directory %s" dir))) @@ -2829,7 +2820,7 @@ the result will be a local, non-Tramp, file name." (when (zerop (length name)) (setq name ".")) ;; On MS Windows, some special file names are not returned properly ;; by `file-name-absolute-p'. If `tramp-syntax' is `simplified', - ;; there could be the falso positive "/:". + ;; there could be the false positive "/:". (if (or (and (eq system-type 'windows-nt) (string-match-p (tramp-compat-rx bol (| (: alpha ":") (: (literal null-device) eol))) diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index cd73b9b8eca..b51f42deb45 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -1172,30 +1172,14 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (defun tramp-smb-handle-make-directory (dir &optional parents) "Like `make-directory' for Tramp files." - (setq dir (directory-file-name (expand-file-name dir))) - (unless (file-name-absolute-p dir) - (setq dir (expand-file-name dir default-directory))) - (with-parsed-tramp-file-name dir nil - (when (and (null parents) (file-exists-p dir)) - (tramp-error v 'file-already-exists dir)) - (let* ((ldir (file-name-directory dir))) - ;; Make missing directory parts. - (when (and parents - (tramp-smb-get-share v) - (not (file-directory-p ldir))) - (make-directory ldir parents)) - ;; Just do it. - (when (file-directory-p ldir) - (tramp-smb-send-command - v (if (tramp-smb-get-cifs-capabilities v) - (format "posix_mkdir %s %o" - (tramp-smb-shell-quote-localname v) (default-file-modes)) - (format "mkdir %s" (tramp-smb-shell-quote-localname v)))) - ;; We must also flush the cache of the directory, because - ;; `file-attributes' reads the values from there. - (tramp-flush-file-properties v localname)) - (unless (file-directory-p dir) - (tramp-error v 'file-error "Couldn't make directory %s" dir))))) + (tramp-skeleton-make-directory dir parents + (tramp-smb-send-command + v (if (tramp-smb-get-cifs-capabilities v) + (format "posix_mkdir %s %o" + (tramp-smb-shell-quote-localname v) (default-file-modes)) + (format "mkdir %s" (tramp-smb-shell-quote-localname v)))) + (unless (file-directory-p dir) + (tramp-error v 'file-error "Couldn't make directory %s" dir)))) ;; This is not used anymore. (defun tramp-smb-handle-make-directory-internal (directory) diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index fcc27dd8343..8774367cefe 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -626,18 +626,9 @@ the result will be a local, non-Tramp, file name." (defun tramp-sudoedit-handle-make-directory (dir &optional parents) "Like `make-directory' for Tramp files." - (setq dir (expand-file-name dir)) - (with-parsed-tramp-file-name dir nil - (when (and (null parents) (file-exists-p dir)) - (tramp-error v 'file-already-exists "Directory already exists %s" dir)) - ;; When PARENTS is non-nil, DIR could be a chain of non-existent - ;; directories a/b/c/... Instead of checking, we simply flush the - ;; whole cache. - (tramp-flush-directory-properties - v (if parents "/" (file-name-directory localname))) + (tramp-skeleton-make-directory dir parents (unless (tramp-sudoedit-send-command - v (if parents '("mkdir" "-p") "mkdir") - "-m" (format "%#o" (default-file-modes)) + v "mkdir" "-m" (format "%#o" (default-file-modes)) (tramp-compat-file-name-unquote localname)) (tramp-error v 'file-error "Couldn't make directory %s" dir)))) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index ca8963fbf54..acbd50dc0fb 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -3537,6 +3537,27 @@ BODY is the backend specific code." ;; Trigger the `file-missing' error. (signal 'error nil))))) +(defmacro tramp-skeleton-make-directory (dir &optional parents &rest body) + "Skeleton for `tramp-*-handle-make-directory'. +BODY is the backend specific code." + ;; Since Emacs 29.1, PARENTS isn't propagated to the handlers + ;; anymore. And the return values are specified since then as well. + (declare (indent 2) (debug t)) + `(let* ((dir (directory-file-name (expand-file-name ,dir))) + (par (file-name-directory dir))) + (with-parsed-tramp-file-name dir nil + (when (and (null ,parents) (file-exists-p dir)) + (tramp-error v 'file-already-exists dir)) + ;; Make missing directory parts. + (when ,parents + (unless (file-directory-p par) + (make-directory par ,parents))) + ;; Just do it. + (if (file-exists-p dir) t + (tramp-flush-file-properties v localname) + ,@body + nil)))) + (defmacro tramp-skeleton-set-file-modes-times-uid-gid (filename &rest body) "Skeleton for `tramp-*-set-file-{modes,times,uid-gid}'. @@ -5418,7 +5439,7 @@ Wait, until the connection buffer changes." ;; Hide message in buffer. (narrow-to-region (point-max) (point-max)) ;; Wait for new output. - (while (not (tramp-compat-ignore-error 'file-error + (while (not (tramp-compat-ignore-error file-error (tramp-wait-for-regexp proc 0.1 tramp-security-key-confirmed-regexp))) (when (tramp-check-for-regexp proc tramp-security-key-timeout-regexp) diff --git a/lisp/org/ChangeLog.1 b/lisp/org/ChangeLog.1 index 4f51c6a1ebb..e72526c3edc 100644 --- a/lisp/org/ChangeLog.1 +++ b/lisp/org/ChangeLog.1 @@ -10418,7 +10418,7 @@ * org.el (org-adaptive-fill-function): Remove occasional spurious space character when auto-filling. - * org.el (org-mode): Call external initalizers. Now both filling + * org.el (org-mode): Call external initializers. Now both filling code and comments code have their own independent part in org.el. (org-setup-filling): Rename from `org-set-autofill-regexps'. (org-setup-comments-handling): New function. @@ -15589,7 +15589,7 @@ * ob-python.el (org-babel-python-evaluate-session): Introduced a new local function for sending input with a slight delay to allow - pythong to re-draw the prompt. No longer removing newlines inside + python to re-draw the prompt. No longer removing newlines inside code block bodies (was due to a defective regexp). 2011-07-28 Bastien Guerry <bzg@gnu.org> @@ -17320,7 +17320,7 @@ * ob-lisp.el (org-babel-execute:lisp): Turn vectors into lists before reading by elisp. - (org-bable-lisp-vector-to-list): Stub of a vector->list function, + (org-babel-lisp-vector-to-list): Stub of a vector->list function, should be replaced with a cl-vector->el-vector function. 2011-07-28 Eric Schulte <schulte.eric@gmail.com> @@ -29935,7 +29935,7 @@ inserted at the correct position. * org-publish.el (org-publish-project-alist) - (org-publish-projects, org-publish-org-index): Change default anme + (org-publish-projects, org-publish-org-index): Change default name for the index of file names to "sitemap.org". * org-latex.el (org-export-latex-tables): diff --git a/lisp/org/ob-core.el b/lisp/org/ob-core.el index f69538f78c9..c2a3673752e 100644 --- a/lisp/org/ob-core.el +++ b/lisp/org/ob-core.el @@ -2464,7 +2464,11 @@ INFO may provide the values of these header arguments (in the (cons 'unordered (mapcar (lambda (e) - (list (if (stringp e) e (format "%S" e)))) + (cond + ((stringp e) (list e)) + ((listp e) + (mapcar (lambda (x) (format "%S" x)) e)) + (t (list (format "%S" e))))) (if (listp result) result (split-string result "\n" t)))) '(:splicep nil :istart "- " :iend "\n"))) @@ -3183,8 +3187,8 @@ situations in which is it not appropriate." (if (and (memq (string-to-char cell) '(?\( ?`)) (not (org-babel-confirm-evaluate ;; See `org-babel-get-src-block-info'. - (list "emacs-lisp" (format "%S" cell) - '((:eval . yes)) nil (format "%S" cell) + (list "emacs-lisp" cell + '((:eval . yes)) nil (format "%s" cell) nil nil)))) ;; Not allowed. (user-error "Evaluation of elisp code %S aborted." cell) diff --git a/lisp/org/ob-tangle.el b/lisp/org/ob-tangle.el index bd17bda32ba..fd6b6f3b943 100644 --- a/lisp/org/ob-tangle.el +++ b/lisp/org/ob-tangle.el @@ -500,7 +500,8 @@ The PARAMS are the 3rd element of the info for the same src block." (cl-letf (((symbol-function 'org-store-link-functions) (lambda () nil))) (org-store-link nil)))) - (bare (and (string-match org-link-bracket-re l) + (bare (and l + (string-match org-link-bracket-re l) (match-string 1 l)))) (when bare (if (and org-babel-tangle-use-relative-file-links diff --git a/lisp/org/oc-basic.el b/lisp/org/oc-basic.el index 3ef7a37e3b3..01e314bfdba 100644 --- a/lisp/org/oc-basic.el +++ b/lisp/org/oc-basic.el @@ -162,17 +162,17 @@ Return a hash table with citation references as keys and fields alist as values. (puthash (cdr (assq 'id item)) (mapcar (pcase-lambda (`(,field . ,value)) (pcase field - ('author - ;; Author is an array of objects, each - ;; of them designing a person. These - ;; objects may contain multiple - ;; properties, but for this basic - ;; processor, we'll focus on `given' and - ;; `family'. + ((or 'author 'editors) + ;; Author and editors are arrays of + ;; objects, each of them designing a + ;; person. These objects may contain + ;; multiple properties, but for this + ;; basic processor, we'll focus on + ;; `given' and `family'. ;; ;; For compatibility with BibTeX, add - ;; "and" between authors. - (cons 'author + ;; "and" between authors and editors. + (cons field (mapconcat (lambda (alist) (concat (alist-get 'family alist) diff --git a/lisp/org/org-element.el b/lisp/org/org-element.el index 71c242ea658..ace1cc1a984 100644 --- a/lisp/org/org-element.el +++ b/lisp/org/org-element.el @@ -1365,7 +1365,16 @@ Assume point is at beginning of the inline task." (priority (and (looking-at "\\[#.\\][ \t]*") (progn (goto-char (match-end 0)) (aref (match-string 0) 2)))) - (title-start (point)) + (commentedp + (and (let ((case-fold-search nil)) + (looking-at org-element-comment-string)) + (goto-char (match-end 0)) + (when (looking-at-p "\\(?:[ \t]\\|$\\)") + (point)))) + (title-start (prog1 (point) + (unless (or todo priority commentedp) + ;; Headline like "* :tag:" + (skip-chars-backward " \t")))) (tags (when (re-search-forward "[ \t]+\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$" (line-end-position) @@ -1375,6 +1384,7 @@ Assume point is at beginning of the inline task." (title-end (point)) (raw-value (org-trim (buffer-substring-no-properties title-start title-end))) + (archivedp (member org-element-archive-tag tags)) (task-end (save-excursion (end-of-line) (and (re-search-forward org-element-headline-re limit t) @@ -1410,7 +1420,9 @@ Assume point is at beginning of the inline task." :todo-keyword todo :todo-type todo-type :post-blank (1- (count-lines (or task-end begin) end)) - :post-affiliated begin) + :post-affiliated begin + :archivedp archivedp + :commentedp commentedp) time-props standard-props)))) (org-element-put-property @@ -7260,18 +7272,18 @@ Each element indicates the latest `org-element--cache-change-tic' when change did not contain gaps.") ;;;###autoload -(defun org-element-cache-reset (&optional all no-persistance) +(defun org-element-cache-reset (&optional all no-persistence) "Reset cache in current buffer. When optional argument ALL is non-nil, reset cache in all Org buffers. -When optional argument NO-PERSISTANCE is non-nil, do not try to update +When optional argument NO-PERSISTENCE is non-nil, do not try to update the cache persistence in the buffer." (interactive "P") (dolist (buffer (if all (buffer-list) (list (current-buffer)))) (org-with-base-buffer buffer (when (and org-element-use-cache (derived-mode-p 'org-mode)) ;; Only persist cache in file buffers. - (when (and (buffer-file-name) (not no-persistance)) + (when (and (buffer-file-name) (not no-persistence)) (when (not org-element-cache-persistent) (org-persist-unregister 'org-element--headline-cache (current-buffer)) (org-persist-unregister 'org-element--cache (current-buffer))) diff --git a/lisp/org/org-faces.el b/lisp/org/org-faces.el index 0effa13a1d6..b3ee17ccdf6 100644 --- a/lisp/org/org-faces.el +++ b/lisp/org/org-faces.el @@ -517,7 +517,7 @@ content of these blocks will still be treated as Org syntax." (defface org-agenda-structure-filter '((t (:inherit (org-warning org-agenda-structure)))) "Face used for the current type of task filter in the agenda. It inherits from `org-agenda-structure' so it can adapt to -it (e.g. if that is assigned a diffent font height or family)." +it (e.g. if that is assigned a different font height or family)." :group 'org-faces) (defface org-agenda-date '((t (:inherit org-agenda-structure))) diff --git a/lisp/org/org-fold-core.el b/lisp/org/org-fold-core.el index ffa689d4fa1..c4d78496e55 100644 --- a/lisp/org/org-fold-core.el +++ b/lisp/org/org-fold-core.el @@ -145,7 +145,7 @@ ;; All the folding specs can be specified by symbol representing their ;; name. However, this is not always convenient, especially if the -;; same spec can be used for fold different syntaxical structures. +;; same spec can be used for fold different syntactical structures. ;; Any folding spec can be additionally referenced by a symbol listed ;; in the spec's `:alias' folding spec property. For example, Org ;; mode's `org-fold-outline' folding spec can be referenced as any @@ -189,9 +189,9 @@ ;; all the processing related to buffer modifications. ;; The library also provides a way to unfold the text after some -;; destructive changes breaking syntaxical structure of the buffer. +;; destructive changes breaking syntactical structure of the buffer. ;; For example, Org mode automatically reveals folded drawers when the -;; drawer becomes syntaxically incorrect: +;; drawer becomes syntactically incorrect: ;; ------- before modification ------- ;; :DRAWER:<begin fold> ;; Some folded text inside drawer @@ -321,7 +321,7 @@ following symbols: functions relying on this package might not be able to unfold the edited text. For example, removed leading stars from a folded headline in Org mode will break visibility cycling since Org mode - will not be avare that the following folded text belonged to + will not be aware that the following folded text belonged to headline. - `ignore-modification-checks': Do not try to detect insertions in the diff --git a/lisp/org/org-persist.el b/lisp/org/org-persist.el index 6ccf357784e..60291e5187f 100644 --- a/lisp/org/org-persist.el +++ b/lisp/org/org-persist.el @@ -874,15 +874,21 @@ When IGNORE-RETURN is non-nil, just return t on success without calling When ASSOCIATED is non-nil, only save the matching data." (unless org-persist--index (org-persist--load-index)) (setq associated (org-persist--normalize-associated associated)) - (unless + (if (and (equal 1 (length org-persist--index)) ;; The single collection only contains a single container ;; in the container list. (equal 1 (length (plist-get (car org-persist--index) :container))) ;; The container is an `index' container. (eq 'index (caar (plist-get (car org-persist--index) :container))) - ;; No `org-persist-directory' exists yet. - (not (file-exists-p org-persist-directory))) + (or (not (file-exists-p org-persist-directory)) + (org-directory-empty-p org-persist-directory))) + ;; Do not write anything, and clear up `org-persist-directory' to reduce + ;; clutter. + (when (and (file-exists-p org-persist-directory) + (org-directory-empty-p org-persist-directory)) + (delete-directory org-persist-directory)) + ;; Write the data. (let (all-containers) (dolist (collection org-persist--index) (if associated @@ -963,6 +969,30 @@ Also, remove containers associated with non-existing files." (push collection new-index))))) (setq org-persist--index (nreverse new-index)))) +(defun org-persist-clear-storage-maybe () + "Clear `org-persist-directory' according to `org-persist--disable-when-emacs-Q'. + +When `org-persist--disable-when-emacs-Q' is non-nil and Emacs is called with -Q +command line argument, `org-persist-directory' is created in potentially public +system temporary directory. Remove everything upon existing Emacs in +such scenario." + (when (and org-persist--disable-when-emacs-Q + ;; FIXME: This is relying on undocumented fact that + ;; Emacs sets `user-init-file' to nil when loaded with + ;; "-Q" argument. + (not user-init-file) + (file-exists-p org-persist-directory)) + (delete-directory org-persist-directory 'recursive))) + +;; Point to temp directory when `org-persist--disable-when-emacs-Q' is set. +(when (and org-persist--disable-when-emacs-Q + ;; FIXME: This is relying on undocumented fact that + ;; Emacs sets `user-init-file' to nil when loaded with + ;; "-Q" argument. + (not user-init-file)) + (setq org-persist-directory + (make-temp-file "org-persist-" 'dir))) + ;; Automatically write the data, but only when we have write access. (let ((dir (directory-file-name (file-name-as-directory org-persist-directory)))) @@ -972,20 +1002,12 @@ Also, remove containers associated with non-existing files." (if (not (file-writable-p dir)) (message "Missing write access rights to org-persist-directory: %S" org-persist-directory) + (add-hook 'kill-emacs-hook #'org-persist-clear-storage-maybe) ; Run last. (add-hook 'kill-emacs-hook #'org-persist-write-all) ;; `org-persist-gc' should run before `org-persist-write-all'. ;; So we are adding the hook after `org-persist-write-all'. (add-hook 'kill-emacs-hook #'org-persist-gc))) -;; Point to temp directory when `org-persist--disable-when-emacs-Q' is set. -(if (and org-persist--disable-when-emacs-Q - ;; FIXME: This is relying on undocumented fact that - ;; Emacs sets `user-init-file' to nil when loaded with - ;; "-Q" argument. - (not user-init-file)) - (setq org-persist-directory - (make-temp-file "org-persist-" 'dir))) - (add-hook 'after-init-hook #'org-persist-load-all) (provide 'org-persist) diff --git a/lisp/org/org-version.el b/lisp/org/org-version.el index 8de0d1a4a97..a0016265f02 100644 --- a/lisp/org/org-version.el +++ b/lisp/org/org-version.el @@ -11,7 +11,7 @@ Inserted by installing Org mode or when a release is made." (defun org-git-version () "The Git version of Org mode. Inserted by installing Org or when a release is made." - (let ((org-git-version "release_9.6-49-g47d129")) + (let ((org-git-version "release_9.6-61-g63e073f")) org-git-version)) (provide 'org-version) diff --git a/lisp/org/org.el b/lisp/org/org.el index 6aa2a16219d..ab8b76b926a 100644 --- a/lisp/org/org.el +++ b/lisp/org/org.el @@ -20213,7 +20213,10 @@ interactive command with similar behavior." (defun org-back-to-heading (&optional invisible-ok) "Go back to beginning of heading." (beginning-of-line) - (or (org-at-heading-p (not invisible-ok)) + (or (and (org-at-heading-p (not invisible-ok)) + (not (and (featurep 'org-inlinetask) + (fboundp 'org-inlinetask-end-p) + (org-inlinetask-end-p)))) (if (org-element--cache-active-p) (let ((heading (org-element-lineage (org-element-at-point) '(headline inlinetask) diff --git a/lisp/org/ox-html.el b/lisp/org/ox-html.el index 86b10cbf785..19cdf4c5a26 100644 --- a/lisp/org/ox-html.el +++ b/lisp/org/ox-html.el @@ -3337,7 +3337,7 @@ INFO is a plist holding contextual information. See ((org-html-standalone-image-p destination info) (org-export-get-ordinal (org-element-map destination 'link #'identity info t) - info 'link 'org-html-standalone-image-p)) + info '(link) 'org-html-standalone-image-p)) (t (org-export-get-ordinal destination info nil counter-predicate)))) (desc diff --git a/lisp/outline.el b/lisp/outline.el index 53bfc4d556f..c2b33b4c58f 100644 --- a/lisp/outline.el +++ b/lisp/outline.el @@ -1868,6 +1868,7 @@ With a prefix argument, show headings up to that LEVEL." (defvar-keymap outline-navigation-repeat-map + :repeat t "C-b" #'outline-backward-same-level "b" #'outline-backward-same-level "C-f" #'outline-forward-same-level @@ -1879,14 +1880,8 @@ With a prefix argument, show headings up to that LEVEL." "C-u" #'outline-up-heading "u" #'outline-up-heading) -(dolist (command '(outline-backward-same-level - outline-forward-same-level - outline-next-visible-heading - outline-previous-visible-heading - outline-up-heading)) - (put command 'repeat-map 'outline-navigation-repeat-map)) - (defvar-keymap outline-editing-repeat-map + :repeat t "C-v" #'outline-move-subtree-down "v" #'outline-move-subtree-down "C-^" #'outline-move-subtree-up @@ -1896,12 +1891,6 @@ With a prefix argument, show headings up to that LEVEL." "C-<" #'outline-promote "<" #'outline-promote) -(dolist (command '(outline-move-subtree-down - outline-move-subtree-up - outline-demote - outline-promote)) - (put command 'repeat-map 'outline-editing-repeat-map)) - (provide 'outline) (provide 'noutline) diff --git a/lisp/pcomplete.el b/lisp/pcomplete.el index 4e3a88bbda8..2d3730e294a 100644 --- a/lisp/pcomplete.el +++ b/lisp/pcomplete.el @@ -645,13 +645,26 @@ parts of the list. The OFFSET argument is added to/taken away from the index that will be used. This is really only useful with `first' and `last', for -accessing absolute argument positions." - (nth (+ (pcase index - ('first 0) - ('last pcomplete-last) - (_ (- pcomplete-index (or index 0)))) - (or offset 0)) - pcomplete-args)) +accessing absolute argument positions. + +When the argument has been transformed into something that is not +a string by `pcomplete-parse-arguments-function', the text +representation of the argument, namely what the user actually +typed in, is returned, and the value of the argument is stored in +the pcomplete-arg-value text property of that string." + (let ((arg + (nth (+ (pcase index + ('first 0) + ('last pcomplete-last) + (_ (- pcomplete-index (or index 0)))) + (or offset 0)) + pcomplete-args))) + (if (stringp arg) + arg + (propertize + (buffer-substring (pcomplete-begin index offset) + (pcomplete-begin (1- (or index 0)) offset)) + 'pcomplete-arg-value arg)))) (defun pcomplete-begin (&optional index offset) "Return the beginning position of the INDEXth argument. diff --git a/lisp/progmodes/c-ts-mode.el b/lisp/progmodes/c-ts-mode.el index cf941236f82..50b951888ae 100644 --- a/lisp/progmodes/c-ts-mode.el +++ b/lisp/progmodes/c-ts-mode.el @@ -39,6 +39,8 @@ (declare-function treesit-node-child-by-field-name "treesit.c") (declare-function treesit-node-type "treesit.c") +;;; Custom variables + (defcustom c-ts-mode-indent-offset 2 "Number of spaces for each indentation step in `c-ts-mode'." :version "29.1" @@ -61,6 +63,8 @@ follows the form of `treesit-simple-indent-rules'." (function :tag "A function for user customized style" ignore)) :group 'c) +;;; Syntax table + (defvar c-ts-mode--syntax-table (let ((table (make-syntax-table))) ;; Taken from the cc-langs version @@ -83,13 +87,29 @@ follows the form of `treesit-simple-indent-rules'." table) "Syntax table for `c-ts-mode'.") -(defvar c++-ts-mode--syntax-table - (let ((table (make-syntax-table c-ts-mode--syntax-table))) - ;; Template delimiters. - (modify-syntax-entry ?< "(" table) - (modify-syntax-entry ?> ")" table) - table) - "Syntax table for `c++-ts-mode'.") +(defun c-ts-mode--syntax-propertize (beg end) + "Apply syntax text property to template delimiters between BEG and END. + +< 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 +appropriate text property to alter the syntax of template +delimiters < and >'s." + (goto-char beg) + (while (re-search-forward (rx (or "<" ">")) end t) + (pcase (treesit-node-type + (treesit-node-parent + (treesit-node-at (match-beginning 0)))) + ("template_argument_list" + (put-text-property (match-beginning 0) + (match-end 0) + 'syntax-table + (pcase (char-before) + (?< '(4 . ?>)) + (?> '(5 . ?<)))))))) + +;;; Indent (defun c-ts-mode--indent-styles (mode) "Indent rules supported by `c-ts-mode'. @@ -98,11 +118,13 @@ MODE is either `c' or `cpp'." `(((parent-is "translation_unit") parent-bol 0) ((node-is ")") parent 1) ((node-is "]") parent-bol 0) - ((node-is "}") (and parent parent-bol) 0) + ((node-is "}") c-ts-mode--bracket-children-anchor 0) ((node-is "else") parent-bol 0) ((node-is "case") parent-bol 0) ((node-is "preproc_arg") no-indent) - ((and (parent-is "comment") comment-end) comment-start -1) + ((and (parent-is "comment") c-ts-mode--looking-at-star) + c-ts-mode--comment-start-after-first-star -1) + ((parent-is "comment") prev-adaptive-prefix 0) ((node-is "labeled_statement") parent-bol 0) ((parent-is "labeled_statement") parent-bol c-ts-mode-indent-offset) ((match "preproc_ifdef" "compound_statement") point-min 0) @@ -111,7 +133,8 @@ MODE is either `c' or `cpp'." ((match "#endif" "preproc_if") point-min 0) ((match "preproc_function_def" "compound_statement") point-min 0) ((match "preproc_call" "compound_statement") point-min 0) - ((parent-is "compound_statement") (and parent parent-bol) c-ts-mode-indent-offset) + ((parent-is "compound_statement") + c-ts-mode--bracket-children-anchor c-ts-mode-indent-offset) ((parent-is "function_definition") parent-bol 0) ((parent-is "conditional_expression") first-sibling 0) ((parent-is "assignment_expression") parent-bol c-ts-mode-indent-offset) @@ -167,6 +190,39 @@ MODE is either `c' or `cpp'." ('linux (alist-get 'linux (c-ts-mode--indent-styles mode))))))) `((,mode ,@style)))) +(defun c-ts-mode--bracket-children-anchor (_n parent &rest _) + "This anchor is used for children of a compound_statement. +So anything inside a {} block. PARENT should be the +compound_statement. This anchor looks at the {, if itson its own +line, anchor at it, if it has stuff before it, anchor at the +beginning of grandparent." + (save-excursion + (goto-char (treesit-node-start parent)) + (let ((bol (line-beginning-position))) + (skip-chars-backward " \t") + (treesit-node-start + (if (< bol (point)) + (treesit-node-parent parent) + parent))))) + +(defun c-ts-mode--looking-at-star (&rest _) + "A tree-sitter simple indent matcher. +Matches if there is a \"*\" after point (ignoring whitespace in +between)." + (looking-at (rx (* (syntax whitespace)) "*"))) + +(defun c-ts-mode--comment-start-after-first-star (_n parent &rest _) + "A tree-sitter simple indent anchor. +Finds the \"/*\" and returns the point after the \"*\". +Assumes PARENT is a comment node." + (save-excursion + (goto-char (treesit-node-start parent)) + (if (looking-at (rx "/*")) + (match-end 0) + (point)))) + +;;; Font-lock + (defvar c-ts-mode--preproc-keywords '("#define" "#if" "#ifdef" "#ifndef" "#else" "#elif" "#endif" "#include") @@ -361,28 +417,34 @@ MODE is either `c' or `cpp'." @c-ts-mode--fontify-defun) (:match "^DEFUN$" @fn))))) -(defun c-ts-mode--fontify-declarator (node override start end &rest args) - "Fontify a declarator (whatever under the \"declarator\" field). -For NODE, OVERRIDE, START, END, and ARGS, see -`treesit-font-lock-rules'." +;;; Font-lock helpers + +(defun c-ts-mode--declarator-identifier (node) + "Return the identifier of the declarator node NODE." (pcase (treesit-node-type node) + ;; Recurse. ((or "attributed_declarator" "parenthesized_declarator") - (apply #'c-ts-mode--fontify-declarator - (treesit-node-child node 0 t) override start end args)) + (c-ts-mode--declarator-identifier (treesit-node-child node 0 t))) ("pointer_declarator" - (apply #'c-ts-mode--fontify-declarator - (treesit-node-child node -1) override start end args)) + (c-ts-mode--declarator-identifier (treesit-node-child node -1))) ((or "function_declarator" "array_declarator" "init_declarator") - (apply #'c-ts-mode--fontify-declarator - (treesit-node-child-by-field-name node "declarator") - override start end args)) + (c-ts-mode--declarator-identifier + (treesit-node-child-by-field-name node "declarator"))) + ;; Terminal case. ((or "identifier" "field_identifier") - (treesit-fontify-with-override - (treesit-node-start node) (treesit-node-end node) - (pcase (treesit-node-type (treesit-node-parent node)) - ("function_declarator" 'font-lock-function-name-face) - (_ 'font-lock-variable-name-face)) - override start end)))) + node))) + +(defun c-ts-mode--fontify-declarator (node override start end &rest _args) + "Fontify a declarator (whatever under the \"declarator\" field). +For NODE, OVERRIDE, START, END, and ARGS, see +`treesit-font-lock-rules'." + (let* ((identifier (c-ts-mode--declarator-identifier node)) + (face (pcase (treesit-node-type (treesit-node-parent identifier)) + ("function_declarator" 'font-lock-function-name-face) + (_ 'font-lock-variable-name-face)))) + (treesit-fontify-with-override + (treesit-node-start identifier) (treesit-node-end identifier) + face override start end))) (defun c-ts-mode--fontify-variable (node override start end &rest _) "Fontify an identifier node if it is a variable. @@ -453,94 +515,48 @@ For NODE, OVERRIDE, START, and END, see (t 'font-lock-warning-face)) override start end))) -(defun c-ts-mode--imenu-1 (node) - "Helper for `c-ts-mode--imenu'. -Find string representation for NODE and set marker, then recurse -the subtrees." - (let* ((ts-node (car node)) - (subtrees (mapcan #'c-ts-mode--imenu-1 (cdr node))) - (name (when ts-node - (treesit-node-text - (pcase (treesit-node-type ts-node) - ("function_definition" - (treesit-node-child-by-field-name - (treesit-node-child-by-field-name - ts-node "declarator") - "declarator")) - ("declaration" - (let ((child (treesit-node-child ts-node -1 t))) - (pcase (treesit-node-type child) - ("identifier" child) - (_ (treesit-node-child-by-field-name - child "declarator"))))) - ("struct_specifier" - (treesit-node-child-by-field-name - ts-node "name")))))) - (marker (when ts-node - (set-marker (make-marker) - (treesit-node-start ts-node))))) - (cond - ;; A struct_specifier could be inside a parameter list, another - ;; struct definition, a variable declaration, a function - ;; declaration. In those cases we don't include it. - ((string-match-p - (rx (or "parameter_declaration" "field_declaration" - "declaration" "function_definition")) - (or (treesit-node-type (treesit-node-parent ts-node)) - "")) - nil) - ;; Ignore function local variable declarations. - ((and (equal (treesit-node-type ts-node) "declaration") - (not (equal (treesit-node-type (treesit-node-parent ts-node)) - "translation_unit"))) - nil) - ((or (null ts-node) (null name)) subtrees) - (subtrees - `((,name ,(cons name marker) ,@subtrees))) - (t - `((,name . ,marker)))))) - -(defun c-ts-mode--imenu () - "Return Imenu alist for the current buffer." - (let* ((node (treesit-buffer-root-node)) - (func-tree (treesit-induce-sparse-tree - node "^function_definition$" nil 1000)) - (var-tree (treesit-induce-sparse-tree - node "^declaration$" nil 1000)) - (struct-tree (treesit-induce-sparse-tree - node "^struct_specifier$" nil 1000)) - (func-index (c-ts-mode--imenu-1 func-tree)) - (var-index (c-ts-mode--imenu-1 var-tree)) - (struct-index (c-ts-mode--imenu-1 struct-tree))) - (append - (when struct-index `(("Struct" . ,struct-index))) - (when var-index `(("Variable" . ,var-index))) - (when func-index `(("Function" . ,func-index)))))) - -(defun c-ts-mode--end-of-defun () - "`end-of-defun-function' of `c-ts-mode'." - ;; A struct/enum/union_specifier node doesn't include the ; at the - ;; end, so we manually skip it. - (treesit-end-of-defun) - (when (looking-at (rx (* " ") ";")) - (goto-char (match-end 0)) - ;; This part is copied from `end-of-defun'. - (unless (bolp) - (skip-chars-forward " \t") - (if (looking-at "\\s<\\|\n") - (forward-line 1))))) +;;; Imenu + +(defun c-ts-mode--defun-name (node) + "Return the name of the defun NODE. +Return nil if NODE is not a defun node or doesn't have a name." + (treesit-node-text + (pcase (treesit-node-type node) + ((or "function_definition" "declaration") + (c-ts-mode--declarator-identifier + (treesit-node-child-by-field-name node "declarator"))) + ((or "struct_specifier" "enum_specifier" + "union_specifier" "class_specifier") + (treesit-node-child-by-field-name node "name"))) + t)) + +;;; Defun navigation (defun c-ts-mode--defun-valid-p (node) - (if (string-match-p - (rx (or "struct_specifier" - "enum_specifier" - "union_specifier")) - (treesit-node-type node)) - (null - (treesit-node-top-level - node (rx (or "function_definition" - "type_definition")))) - t)) + "Return non-nil if NODE is a valid defun node. +Ie, NODE is not nested." + (not (or (and (member (treesit-node-type node) + '("struct_specifier" + "enum_specifier" + "union_specifier" + "declaration")) + ;; If NODE's type is one of the above, make sure it is + ;; top-level. + (treesit-node-top-level + node (rx (or "function_definition" + "type_definition" + "struct_specifier" + "enum_specifier" + "union_specifier" + "declaration")))) + + (and (equal (treesit-node-type node) "declaration") + ;; If NODE is a declaration, make sure it is not a + ;; function declaration. + (equal (treesit-node-type + (treesit-node-child-by-field-name + node "declarator")) + "function_declarator"))))) (defun c-ts-mode--defun-skipper () "Custom defun skipper for `c-ts-mode' and friends. @@ -556,15 +572,144 @@ the semicolon. This function skips the semicolon." `treesit-defun-type-regexp' defines what constructs to indent." (interactive "*") - (let ((orig-point (point-marker))) - ;; If `treesit-beginning-of-defun' returns nil, we are not in a - ;; defun, so don't indent anything. - (when (treesit-beginning-of-defun) - (let ((start (point))) - (treesit-end-of-defun) - (indent-region start (point)))) + (when-let ((orig-point (point-marker)) + (node (treesit-defun-at-point))) + (indent-region (treesit-node-start node) + (treesit-node-end node)) (goto-char orig-point))) +;;; Filling + +(defun c-ts-mode--fill-paragraph (&optional arg) + "Fillling function for `c-ts-mode'. +ARG is passed to `fill-paragraph'." + (interactive "*P") + (save-restriction + (widen) + (let* ((node (treesit-node-at (point))) + (start (treesit-node-start node)) + (end (treesit-node-end node)) + ;; Bind to nil to avoid infinite recursion. + (fill-paragraph-function nil) + (orig-point (point-marker)) + (start-marker nil) + (end-marker nil) + (end-len 0)) + (when (equal (treesit-node-type node) "comment") + ;; We mask "/*" and the space before "*/" like + ;; `c-fill-paragraph' does. + (atomic-change-group + ;; Mask "/*". + (goto-char start) + (when (looking-at (rx (* (syntax whitespace)) + (group "/") "*")) + (goto-char (match-beginning 1)) + (setq start-marker (point-marker)) + (replace-match " " nil nil nil 1)) + ;; Include whitespaces before /*. + (goto-char start) + (beginning-of-line) + (setq start (point)) + ;; Mask spaces before "*/" if it is attached at the end + ;; of a sentence rather than on its own line. + (goto-char end) + (when (looking-back (rx (not (syntax whitespace)) + (group (+ (syntax whitespace))) + "*/") + (line-beginning-position)) + (goto-char (match-beginning 1)) + (setq end-marker (point-marker)) + (setq end-len (- (match-end 1) (match-beginning 1))) + (replace-match (make-string end-len ?x) + nil nil nil 1)) + ;; If "*/" is on its own line, don't included it in the + ;; filling region. + (when (not end-marker) + (goto-char end) + (when (looking-back (rx "*/") 2) + (backward-char 2) + (skip-syntax-backward "-") + (setq end (point)))) + ;; Let `fill-paragraph' do its thing. + (goto-char orig-point) + (narrow-to-region start end) + (funcall #'fill-paragraph arg) + ;; Unmask. + (when start-marker + (goto-char start-marker) + (delete-char 1) + (insert "/")) + (when end-marker + (goto-char end-marker) + (delete-region (point) (+ end-len (point))) + (insert (make-string end-len ?\s)))) + (goto-char orig-point)) + ;; Return t so `fill-paragraph' doesn't attempt to fill by + ;; itself. + t))) + +(defun c-ts-mode-comment-setup () + "Set up local variables for C-like comment. + +Set up: + - `comment-start' + - `comment-end' + - `comment-start-skip' + - `comment-end-skip' + - `adaptive-fill-mode' + - `adaptive-fill-first-line-regexp' + - `paragraph-start' + - `paragraph-separate' + - `fill-paragraph-function'" + (setq-local comment-start "// ") + (setq-local comment-end "") + (setq-local comment-start-skip (rx (or (seq "/" (+ "/")) + (seq "/" (+ "*"))) + (* (syntax whitespace)))) + (setq-local comment-end-skip + (rx (* (syntax whitespace)) + (group (or (syntax comment-end) + (seq (+ "*") "/"))))) + (setq-local adaptive-fill-mode t) + ;; This matches (1) empty spaces (the default), (2) "//", (3) "*", + ;; but do not match "/*", because we don't want to use "/*" as + ;; prefix when filling. (Actually, it doesn't matter, because + ;; `comment-start-skip' matches "/*" which will cause + ;; `fill-context-prefix' to use "/*" as a prefix for filling, that's + ;; why we mask the "/*" in `c-ts-mode--fill-paragraph'.) + (setq-local adaptive-fill-regexp + (concat (rx (* (syntax whitespace)) + (group (or (seq "/" (+ "/")) (* "*")))) + adaptive-fill-regexp)) + ;; Note the missing * comparing to `adaptive-fill-regexp'. The + ;; reason for its absence is a bit convoluted to explain. Suffice + ;; to say that without it, filling a single line paragraph that + ;; starts with /* doesn't insert * at the beginning of each + ;; following line, and filling a multi-line paragraph whose first + ;; two lines start with * does insert * at the beginning of each + ;; following line. If you know how does adaptive filling works, you + ;; know what I mean. + (setq-local adaptive-fill-first-line-regexp + (rx bos + (seq (* (syntax whitespace)) + (group (seq "/" (+ "/"))) + (* (syntax whitespace))) + eos)) + ;; Same as `adaptive-fill-regexp'. + (setq-local paragraph-start + (rx (or (seq (* (syntax whitespace)) + (group (or (seq "/" (+ "/")) (* "*"))) + (* (syntax whitespace)) + ;; Add this eol so that in + ;; `fill-context-prefix', `paragraph-start' + ;; doesn't match the prefix. + eol) + "\f"))) + (setq-local paragraph-separate paragraph-start) + (setq-local fill-paragraph-function #'c-ts-mode--fill-paragraph)) + +;;; Modes + (defvar-keymap c-ts-mode-map :doc "Keymap for the C language with tree-sitter" :parent prog-mode-map @@ -587,6 +732,7 @@ the semicolon. This function skips the semicolon." "class_specifier")) #'c-ts-mode--defun-valid-p)) (setq-local treesit-defun-skipper #'c-ts-mode--defun-skipper) + (setq-local treesit-defun-name-function #'c-ts-mode--defun-name) ;; Nodes like struct/enum/union_specifier can appear in ;; function_definitions, so we need to find the top-level node. @@ -596,13 +742,25 @@ the semicolon. This function skips the semicolon." (when (eq c-ts-mode-indent-style 'linux) (setq-local indent-tabs-mode t)) + ;; Comment + (c-ts-mode-comment-setup) + ;; Electric (setq-local electric-indent-chars (append "{}():;," electric-indent-chars)) ;; Imenu. - (setq-local imenu-create-index-function #'c-ts-mode--imenu) - (setq-local which-func-functions nil) + (setq-local treesit-simple-imenu-settings + (let ((pred #'c-ts-mode--defun-valid-p)) + `(("Struct" ,(rx bos (or "struct" "enum" "union") + "_specifier" eos) + ,pred nil) + ("Variable" ,(rx bos "declaration" eos) ,pred nil) + ("Function" "\\`function_definition\\'" ,pred nil) + ("Class" ,(rx bos (or "class_specifier" + "function_definition") + eos) + ,pred nil)))) (setq-local treesit-font-lock-feature-list '(( comment definition) @@ -623,13 +781,6 @@ the semicolon. This function skips the semicolon." ;; Comments. (setq-local comment-start "/* ") (setq-local comment-end " */") - (setq-local comment-start-skip (rx (or (seq "/" (+ "/")) - (seq "/" (+ "*"))) - (* (syntax whitespace)))) - (setq-local comment-end-skip - (rx (* (syntax whitespace)) - (group (or (syntax comment-end) - (seq (+ "*") "/"))))) (setq-local treesit-simple-indent-rules (c-ts-mode--set-indent-style 'c)) @@ -637,37 +788,23 @@ the semicolon. This function skips the semicolon." ;; Font-lock. (setq-local treesit-font-lock-settings (c-ts-mode--font-lock-settings 'c)) - (treesit-major-mode-setup) - - ;; Override default value of end-of-defun-function set by - ;; `treesit-major-mode-setup'. - (setq-local end-of-defun-function #'c-ts-mode--end-of-defun)) + (treesit-major-mode-setup)) ;;;###autoload (define-derived-mode c++-ts-mode c-ts-base-mode "C++" "Major mode for editing C++, powered by tree-sitter." :group 'c++ - :syntax-table c++-ts-mode--syntax-table (unless (treesit-ready-p 'cpp) (error "Tree-sitter for C++ isn't available")) - ;; Comments. - (setq-local comment-start "// ") - (setq-local comment-end "") - (setq-local comment-start-skip (rx (or (seq "/" (+ "/")) - (seq "/" (+ "*"))) - (* (syntax whitespace)))) - (setq-local comment-end-skip - (rx (* (syntax whitespace)) - (group (or (syntax comment-end) - (seq (+ "*") "/"))))) - (setq-local treesit-text-type-regexp (regexp-opt '("comment" "raw_string_literal"))) (treesit-parser-create 'cpp) + (setq-local syntax-propertize-function + #'c-ts-mode--syntax-propertize) (setq-local treesit-simple-indent-rules (c-ts-mode--set-indent-style 'cpp)) @@ -675,11 +812,7 @@ the semicolon. This function skips the semicolon." ;; Font-lock. (setq-local treesit-font-lock-settings (c-ts-mode--font-lock-settings 'cpp)) - (treesit-major-mode-setup) - - ;; Override default value of end-of-defun-function set by - ;; `treesit-major-mode-setup'. - (setq-local end-of-defun-function #'c-ts-mode--end-of-defun)) + (treesit-major-mode-setup)) (provide 'c-ts-mode) diff --git a/lisp/progmodes/cc-engine.el b/lisp/progmodes/cc-engine.el index edb873f5a62..2198f3115a5 100644 --- a/lisp/progmodes/cc-engine.el +++ b/lisp/progmodes/cc-engine.el @@ -7757,7 +7757,7 @@ multi-line strings (but not C++, for example)." (1- (match-end 1)) ; 1- For the inserted ". eoll)))) - ;; ...and clear `syntax-table' text propertes from the + ;; ...and clear `syntax-table' text properties from the ;; following raw strings. (c-depropertize-ml-strings-in-region (point) (1+ eoll))) ;; Remove the temporary string delimiter. diff --git a/lisp/progmodes/csharp-mode.el b/lisp/progmodes/csharp-mode.el index 9e8b22c6aba..33a5f7046f1 100644 --- a/lisp/progmodes/csharp-mode.el +++ b/lisp/progmodes/csharp-mode.el @@ -34,6 +34,7 @@ (require 'cc-mode) (require 'cc-langs) (require 'treesit) +(require 'c-ts-mode) ; For comment indenting and filling. (eval-when-compile (require 'cc-fonts) @@ -42,6 +43,7 @@ (declare-function treesit-parser-create "treesit.c") (declare-function treesit-induce-sparse-tree "treesit.c") (declare-function treesit-node-start "treesit.c") +(declare-function treesit-node-type "treesit.c") (declare-function treesit-node-child-by-field-name "treesit.c") (defgroup csharp nil @@ -632,6 +634,9 @@ compilation and evaluation time conflicts." ((node-is "}") parent-bol 0) ((node-is ")") parent-bol 0) ((node-is "]") parent-bol 0) + ((and (parent-is "comment") c-ts-mode--looking-at-star) + c-ts-mode--comment-start-after-first-star -1) + ((parent-is "comment") prev-adaptive-prefix 0) ((parent-is "namespace_declaration") parent-bol 0) ((parent-is "class_declaration") parent-bol 0) ((parent-is "constructor_declaration") parent-bol 0) @@ -837,56 +842,21 @@ compilation and evaluation time conflicts." ;;;###autoload (add-to-list 'auto-mode-alist '("\\.cs\\'" . csharp-mode)) -(defun csharp-ts-mode--imenu-1 (node) - "Helper for `csharp-ts-mode--imenu'. -Find string representation for NODE and set marker, then recurse -the subtrees." - (let* ((ts-node (car node)) - (subtrees (mapcan #'csharp-ts-mode--imenu-1 (cdr node))) - (name (when ts-node - (or (treesit-node-text - (or (treesit-node-child-by-field-name - ts-node "name")) - t) - "Unnamed node"))) - (marker (when ts-node - (set-marker (make-marker) - (treesit-node-start ts-node))))) - (cond - ((null ts-node) subtrees) - (subtrees - `((,name ,(cons name marker) ,@subtrees))) - (t - `((,name . ,marker)))))) - -(defun csharp-ts-mode--imenu () - "Return Imenu alist for the current buffer." - (let* ((node (treesit-buffer-root-node)) - (class-tree (treesit-induce-sparse-tree - node "^class_declaration$" nil 1000)) - (interface-tree (treesit-induce-sparse-tree - node "^interface_declaration$" nil 1000)) - (enum-tree (treesit-induce-sparse-tree - node "^enum_declaration$" nil 1000)) - (struct-tree (treesit-induce-sparse-tree - node "^struct_declaration$" nil 1000)) - (record-tree (treesit-induce-sparse-tree - node "^record_declaration$" nil 1000)) - (method-tree (treesit-induce-sparse-tree - node "^method_declaration$" nil 1000)) - (class-index (csharp-ts-mode--imenu-1 class-tree)) - (interface-index (csharp-ts-mode--imenu-1 interface-tree)) - (enum-index (csharp-ts-mode--imenu-1 enum-tree)) - (record-index (csharp-ts-mode--imenu-1 record-tree)) - (struct-index (csharp-ts-mode--imenu-1 struct-tree)) - (method-index (csharp-ts-mode--imenu-1 method-tree))) - (append - (when class-index `(("Class" . ,class-index))) - (when interface-index `(("Interface" . ,interface-index))) - (when enum-index `(("Enum" . ,enum-index))) - (when record-index `(("Record" . ,record-index))) - (when struct-index `(("Struct" . ,struct-index))) - (when method-index `(("Method" . ,method-index)))))) +(defun csharp-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 "method_declaration" + "record_declaration" + "struct_declaration" + "enum_declaration" + "interface_declaration" + "class_declaration" + "class_declaration") + (treesit-node-text + (treesit-node-child-by-field-name + node "name") + t)))) ;;;###autoload (add-to-list 'auto-mode-alist '("\\.cs\\'" . csharp-mode)) @@ -916,15 +886,7 @@ Key bindings: (treesit-parser-create 'c-sharp) ;; Comments. - (setq-local comment-start "// ") - (setq-local comment-end "") - (setq-local comment-start-skip (rx (or (seq "/" (+ "/")) - (seq "/" (+ "*"))) - (* (syntax whitespace)))) - (setq-local comment-end-skip - (rx (* (syntax whitespace)) - (group (or (syntax comment-end) - (seq (+ "*") "/"))))) + (c-ts-mode-comment-setup) (setq-local treesit-text-type-regexp (regexp-opt '("comment" @@ -940,6 +902,7 @@ Key bindings: ;; Navigation. (setq-local treesit-defun-type-regexp "declaration") + (setq-local treesit-defun-name-function #'csharp-ts-mode--defun-name) ;; Font-lock. (setq-local treesit-font-lock-settings csharp-ts-mode--font-lock-settings) @@ -950,8 +913,14 @@ Key bindings: ( bracket delimiter))) ;; Imenu. - (setq-local imenu-create-index-function #'csharp-ts-mode--imenu) - (setq-local which-func-functions nil) ;; Piggyback on imenu + (setq-local treesit-simple-imenu-settings + '(("Class" "\\`class_declaration\\'" nil nil) + ("Interface" "\\`interface_declaration\\'" nil nil) + ("Enum" "\\`enum_declaration\\'" nil nil) + ("Record" "\\`record_declaration\\'" nil nil) + ("Struct" "\\`struct_declaration\\'" nil nil) + ("Method" "\\`method_declaration\\'" nil nil))) + (treesit-major-mode-setup)) (provide 'csharp-mode) diff --git a/lisp/progmodes/eglot.el b/lisp/progmodes/eglot.el index ce4ca4f3d92..15cb1b6fad0 100644 --- a/lisp/progmodes/eglot.el +++ b/lisp/progmodes/eglot.el @@ -190,6 +190,7 @@ chosen (interactively or automatically)." '("pylsp" "pyls" ("pyright-langserver" "--stdio") "jedi-language-server"))) ((js-json-mode json-mode json-ts-mode) . ,(eglot-alternatives '(("vscode-json-language-server" "--stdio") + ("vscode-json-languageserver" "--stdio") ("json-languageserver" "--stdio")))) ((js-mode js-ts-mode tsx-ts-mode typescript-ts-mode typescript-mode) . ("typescript-language-server" "--stdio")) @@ -907,6 +908,8 @@ PRESERVE-BUFFERS as in `eglot-shutdown', which see." do (with-demoted-errors "[eglot] shutdown all: %s" (cl-loop for s in ss do (eglot-shutdown s nil nil preserve-buffers))))) +(defvar eglot--servers-by-xrefed-file (make-hash-table :test 'equal)) + (defun eglot--on-shutdown (server) "Called by jsonrpc.el when SERVER is already dead." ;; Turn off `eglot--managed-mode' where appropriate. @@ -925,6 +928,9 @@ PRESERVE-BUFFERS as in `eglot-shutdown', which see." (setf (gethash (eglot--project server) eglot--servers-by-project) (delq server (gethash (eglot--project server) eglot--servers-by-project))) + (maphash (lambda (f s) + (when (eq s server) (remhash f eglot--servers-by-xrefed-file))) + eglot--servers-by-xrefed-file) (cond ((eglot--shutdown-requested server) t) ((not (eglot--inhibit-autoreconnect server)) @@ -1056,9 +1062,6 @@ be guessed." (put 'eglot-lsp-context 'variable-documentation "Dynamically non-nil when searching for projects in LSP context.") -(defvar eglot--servers-by-xrefed-file - (make-hash-table :test 'equal :weakness 'value)) - (defun eglot--current-project () "Return a project object for Eglot's LSP purposes. This relies on `project-current' and thus on diff --git a/lisp/progmodes/idlw-help.el b/lisp/progmodes/idlw-help.el index a19abf77e5f..51afb7e4850 100644 --- a/lisp/progmodes/idlw-help.el +++ b/lisp/progmodes/idlw-help.el @@ -269,7 +269,7 @@ Scrolling: SPC DEL RET Text Searches: Inside Topic: Use Emacs search functions Exit: [q]uit or mouse button 3 will kill the frame -When the hep text is a source file, the following commands are available +When the help text is a source file, the following commands are available Fontification: [F]ontify the buffer like source code Jump: [h] to function doclib header diff --git a/lisp/progmodes/java-ts-mode.el b/lisp/progmodes/java-ts-mode.el index bd6a8aa4743..215b5c16388 100644 --- a/lisp/progmodes/java-ts-mode.el +++ b/lisp/progmodes/java-ts-mode.el @@ -29,10 +29,12 @@ (require 'treesit) (eval-when-compile (require 'rx)) +(require 'c-ts-mode) ; For comment indent and filling. (declare-function treesit-parser-create "treesit.c") (declare-function treesit-induce-sparse-tree "treesit.c") (declare-function treesit-node-start "treesit.c") +(declare-function treesit-node-type "treesit.c") (declare-function treesit-node-child-by-field-name "treesit.c") (defcustom java-ts-mode-indent-offset 4 @@ -71,8 +73,9 @@ ((node-is "}") (and parent parent-bol) 0) ((node-is ")") parent-bol 0) ((node-is "]") parent-bol 0) - ((and (parent-is "comment") comment-end) comment-start -1) - ((parent-is "comment") comment-start-skip 0) + ((and (parent-is "comment") c-ts-mode--looking-at-star) + c-ts-mode--comment-start-after-first-star -1) + ((parent-is "comment") prev-adaptive-prefix 0) ((parent-is "text_block") no-indent) ((parent-is "class_body") parent-bol java-ts-mode-indent-offset) ((parent-is "interface_body") parent-bol java-ts-mode-indent-offset) @@ -248,52 +251,21 @@ '((["," ":" ";"]) @font-lock-delimiter-face)) "Tree-sitter font-lock settings for `java-ts-mode'.") -(defun java-ts-mode--imenu-1 (node) - "Helper for `java-ts-mode--imenu'. -Find string representation for NODE and set marker, then recurse -the subtrees." - (let* ((ts-node (car node)) - (subtrees (mapcan #'java-ts-mode--imenu-1 (cdr node))) - (name (when ts-node - (or (treesit-node-text - (or (treesit-node-child-by-field-name - ts-node "name")) - t) - "Unnamed node"))) - (marker (when ts-node - (set-marker (make-marker) - (treesit-node-start ts-node))))) - (cond - ((null ts-node) subtrees) - (subtrees - `((,name ,(cons name marker) ,@subtrees))) - (t - `((,name . ,marker)))))) - -(defun java-ts-mode--imenu () - "Return Imenu alist for the current buffer." - (let* ((node (treesit-buffer-root-node)) - (class-tree (treesit-induce-sparse-tree - node "^class_declaration$" nil 1000)) - (interface-tree (treesit-induce-sparse-tree - node "^interface_declaration$" nil 1000)) - (enum-tree (treesit-induce-sparse-tree - node "^enum_declaration$" nil 1000)) - (record-tree (treesit-induce-sparse-tree - node "^record_declaration$" nil 1000)) - (method-tree (treesit-induce-sparse-tree - node "^method_declaration$" nil 1000)) - (class-index (java-ts-mode--imenu-1 class-tree)) - (interface-index (java-ts-mode--imenu-1 interface-tree)) - (enum-index (java-ts-mode--imenu-1 enum-tree)) - (record-index (java-ts-mode--imenu-1 record-tree)) - (method-index (java-ts-mode--imenu-1 method-tree))) - (append - (when class-index `(("Class" . ,class-index))) - (when interface-index `(("Interface" . ,interface-index))) - (when enum-index `(("Enum" . ,enum-index))) - (when record-index `(("Record" . ,record-index))) - (when method-index `(("Method" . ,method-index)))))) +(defun java-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 "method_declaration" + "class_declaration" + "record_declaration" + "interface_declaration" + "enum_declaration" + "import_declaration" + "package_declaration" + "module_declaration") + (treesit-node-text + (treesit-node-child-by-field-name node "name") + t)))) ;;;###autoload (define-derived-mode java-ts-mode prog-mode "Java" @@ -307,15 +279,7 @@ the subtrees." (treesit-parser-create 'java) ;; Comments. - (setq-local comment-start "// ") - (setq-local comment-end "") - (setq-local comment-start-skip (rx (or (seq "/" (+ "/")) - (seq "/" (+ "*"))) - (* (syntax whitespace)))) - (setq-local comment-end-skip - (rx (* (syntax whitespace)) - (group (or (syntax comment-end) - (seq (+ "*") "/"))))) + (c-ts-mode-comment-setup) (setq-local treesit-text-type-regexp (regexp-opt '("line_comment" @@ -339,6 +303,7 @@ the subtrees." "import_declaration" "package_declaration" "module_declaration"))) + (setq-local treesit-defun-name-function #'java-ts-mode--defun-name) ;; Font-lock. (setq-local treesit-font-lock-settings java-ts-mode--font-lock-settings) @@ -349,8 +314,11 @@ the subtrees." ( bracket delimiter operator))) ;; Imenu. - (setq-local imenu-create-index-function #'java-ts-mode--imenu) - (setq-local which-func-functions nil) ;; Piggyback on imenu + (setq-local treesit-simple-imenu-settings + '(("Class" "\\`class_declaration\\'" nil nil) + ("Interface" "\\`interface_declaration\\'" nil nil) + ("Enum" "\\`record_declaration\\'" nil nil) + ("Method" "\\`method_declaration\\'" nil nil))) (treesit-major-mode-setup)) (provide 'java-ts-mode) diff --git a/lisp/progmodes/js.el b/lisp/progmodes/js.el index cbcca81baaa..9c26c52df94 100644 --- a/lisp/progmodes/js.el +++ b/lisp/progmodes/js.el @@ -54,6 +54,7 @@ (require 'json) (require 'prog-mode) (require 'treesit) +(require 'c-ts-mode) ; For comment indent and filling. (eval-when-compile (require 'cl-lib) @@ -73,6 +74,8 @@ (declare-function treesit-node-start "treesit.c") (declare-function treesit-node-end "treesit.c") (declare-function treesit-node-type "treesit.c") +(declare-function treesit-query-compile "treesit.c") +(declare-function treesit-query-capture "treesit.c") ;;; Constants @@ -3425,9 +3428,9 @@ This function is intended for use in `after-change-functions'." ((node-is ")") parent-bol 0) ((node-is "]") parent-bol 0) ((node-is ">") parent-bol 0) - ((parent-is "comment") comment-start 0) - ((and (parent-is "comment") comment-end) comment-start -1) - ((parent-is "comment") comment-start-skip 0) + ((and (parent-is "comment") c-ts-mode--looking-at-star) + c-ts-mode--comment-start-after-first-star -1) + ((parent-is "comment") prev-adaptive-prefix 0) ((parent-is "ternary_expression") parent-bol js-indent-level) ((parent-is "member_expression") parent-bol js-indent-level) ((node-is ,switch-case) parent-bol 0) @@ -3478,36 +3481,35 @@ This function is intended for use in `after-change-functions'." (treesit-font-lock-rules :language 'javascript - :override t :feature 'comment - `((comment) @font-lock-comment-face) + '((comment) @font-lock-comment-face) :language 'javascript - :override t :feature 'constant - `(((identifier) @font-lock-constant-face + '(((identifier) @font-lock-constant-face (:match "^[A-Z_][A-Z_\\d]*$" @font-lock-constant-face)) [(true) (false) (null)] @font-lock-constant-face) :language 'javascript - :override t :feature 'keyword `([,@js--treesit-keywords] @font-lock-keyword-face [(this) (super)] @font-lock-keyword-face) :language 'javascript - :override t :feature 'string - `((regex pattern: (regex_pattern)) @font-lock-string-face - (string) @font-lock-string-face - (template_string) @js--fontify-template-string - (template_substitution ["${" "}"] @font-lock-builtin-face)) + '((regex pattern: (regex_pattern)) @font-lock-string-face + (string) @font-lock-string-face) :language 'javascript + :feature 'string-interpolation :override t - :feature 'declaration - `((function + '((template_string) @js--fontify-template-string + (template_substitution ["${" "}"] @font-lock-delimiter-face)) + + :language 'javascript + :feature 'definition + '((function name: (identifier) @font-lock-function-name-face) (class_declaration @@ -3534,24 +3536,10 @@ This function is intended for use in `after-change-functions'." value: (array (number) (function)))) :language 'javascript - :override t - :feature 'identifier - `((new_expression - constructor: (identifier) @font-lock-type-face) - - (for_in_statement - left: (identifier) @font-lock-variable-name-face) - - (arrow_function - parameter: (identifier) @font-lock-variable-name-face)) - - :language 'javascript - :override t :feature 'property - ;; This needs to be before function-name feature, because methods - ;; can be both property and function-name, and we want them in - ;; function-name face. - `((property_identifier) @font-lock-property-face + '(((property_identifier) @font-lock-property-face + (:pred js--treesit-property-not-function-p + @font-lock-property-face)) (pair value: (identifier) @font-lock-variable-name-face) @@ -3560,36 +3548,27 @@ This function is intended for use in `after-change-functions'." ((shorthand_property_identifier_pattern) @font-lock-property-face)) :language 'javascript - :override t - :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)]) - - (call_expression + :feature 'assignment + '((assignment_expression + left: (_) @js--treesit-fontify-assignment-lhs)) + + :language 'javascript + :feature 'function + '((call_expression function: [(identifier) @font-lock-function-name-face (member_expression property: (property_identifier) @font-lock-function-name-face)]) - - (assignment_expression - left: [(identifier) @font-lock-variable-name-face - (member_expression - property: (property_identifier) @font-lock-variable-name-face)])) - - :language 'javascript - :override t - :feature 'pattern - `((pair_pattern key: (property_identifier) @font-lock-variable-name-face) - (array_pattern (identifier) @font-lock-variable-name-face)) + (method_definition + name: (property_identifier) @font-lock-function-name-face) + (function_declaration + name: (identifier) @font-lock-function-name-face) + (function + name: (identifier) @font-lock-function-name-face)) :language 'javascript - :override t :feature 'jsx - `( - (jsx_opening_element + '((jsx_opening_element [(nested_identifier (identifier)) (identifier)] @font-lock-function-name-face) @@ -3607,7 +3586,7 @@ This function is intended for use in `after-change-functions'." :language 'javascript :feature 'number - `((number) @font-lock-number-face + '((number) @font-lock-number-face ((identifier) @font-lock-number-face (:match "^\\(:?NaN\\|Infinity\\)$" @font-lock-number-face))) @@ -3656,91 +3635,50 @@ OVERRIDE is the override flag described in (setq font-beg (treesit-node-end child) child (treesit-node-next-sibling child))))) -(defun js-treesit-current-defun () - "Return name of surrounding function. -This function can be used as a value in `which-func-functions'" - (let ((node (treesit-node-at (point))) - (name-list ())) - (cl-loop while node - if (pcase (treesit-node-type node) - ("function_declaration" t) - ("method_definition" t) - ("class_declaration" t) - ("variable_declarator" t) - (_ nil)) - do (push (treesit-node-text - (treesit-node-child-by-field-name node "name") - t) - name-list) - do (setq node (treesit-node-parent node)) - finally return (string-join name-list ".")))) - -(defun js--treesit-imenu-1 (node) - "Given a sparse tree, create an imenu alist. - -NODE is the root node of the tree returned by -`treesit-induce-sparse-tree' (not a tree-sitter node, its car is -a tree-sitter node). Walk that tree and return an imenu alist. - -Return a list of ENTRY where - -ENTRY := (NAME . MARKER) - | (NAME . ((JUMP-LABEL . MARKER) - ENTRY - ...) - -NAME is the function/class's name, JUMP-LABEL is like \"*function -definition*\"." - (let* ((ts-node (car node)) - (children (cdr node)) - (subtrees (mapcan #'js--treesit-imenu-1 - children)) - (type (pcase (treesit-node-type ts-node) - ("lexical_declaration" 'variable) - ("class_declaration" 'class) - ("method_definition" 'method) - ("function_declaration" 'function))) - ;; The root of the tree could have a nil ts-node. - (name (when ts-node - (let ((ts-node-1 - (if (eq type 'variable) - (treesit-search-subtree - ts-node "variable_declarator" nil nil 1) - ts-node))) - (treesit-node-text - (treesit-node-child-by-field-name - ts-node-1 "name") - t)))) - (marker (when ts-node - (set-marker (make-marker) - (treesit-node-start ts-node))))) - (cond - ((null ts-node) - subtrees) - ;; Don't included non-top-level variable declarations. - ((and (eq type 'variable) - (treesit-node-top-level ts-node)) - nil) - (subtrees - `((,name - ,(cons "" marker) - ,@subtrees))) - (t (list (cons name marker)))))) - -(defun js--treesit-imenu () - "Return Imenu alist for the current buffer." - (let* ((node (treesit-buffer-root-node)) - (class-tree (treesit-induce-sparse-tree - node (rx (or "class_declaration" - "method_definition")) - nil 1000)) - (func-tree (treesit-induce-sparse-tree - node "function_declaration" nil 1000)) - (var-tree (treesit-induce-sparse-tree - node "lexical_declaration" nil 1000))) - `(("Class" . ,(js--treesit-imenu-1 class-tree)) - ("Variable" . ,(js--treesit-imenu-1 var-tree)) - ("Function" . ,(js--treesit-imenu-1 func-tree))))) +(defun js--treesit-property-not-function-p (node) + "Check that NODE, a property_identifier, is not used as a function." + (not (equal (treesit-node-type + (treesit-node-parent ; Maybe call_expression. + (treesit-node-parent ; Maybe member_expression. + node))) + "call_expression"))) + +(defvar js--treesit-lhs-identifier-query + (when (treesit-available-p) + (treesit-query-compile 'javascript '((identifier) @id + (property_identifier) @id))) + "Query that captures identifier and query_identifier.") + +(defun js--treesit-fontify-assignment-lhs (node override start end &rest _) + "Fontify the lhs NODE of an assignment_expression. +For OVERRIDE, START, END, see `treesit-font-lock-rules'." + (dolist (node (treesit-query-capture + node js--treesit-lhs-identifier-query nil nil t)) + (treesit-fontify-with-override + (treesit-node-start node) (treesit-node-end node) + (pcase (treesit-node-type node) + ("identifier" 'font-lock-variable-name-face) + ("property_identifier" 'font-lock-property-face)) + override start end))) + +(defun js--treesit-defun-name (node) + "Return the defun name of NODE. +Return nil if there is no name or if NODE is not a defun node." + (treesit-node-text + (treesit-node-child-by-field-name + (pcase (treesit-node-type node) + ("lexical_declaration" + (treesit-search-subtree node "variable_declarator" nil nil 1)) + ((or "function_declaration" "method_definition" "class_declaration") + node)) + "name") + t)) + +(defun js--treesit-valid-imenu-entry (node) + "Return nil if NODE is a non-top-level \"lexical_declaration\"." + (pcase (treesit-node-type node) + ("lexical_declaration" (treesit-node-top-level node)) + (_ t))) ;;; Main Function @@ -3853,15 +3791,7 @@ Currently there are `js-mode' and `js-ts-mode'." ;; Which-func. (setq-local which-func-imenu-joiner-function #'js--which-func-joiner) ;; Comment. - (setq-local comment-start "// ") - (setq-local comment-end "") - (setq-local comment-start-skip (rx (or (seq "/" (+ "/")) - (seq "/" (+ "*"))) - (* (syntax whitespace)))) - (setq-local comment-end-skip - (rx (* (syntax whitespace)) - (group (or (syntax comment-end) - (seq (+ "*") "/"))))) + (c-ts-mode-comment-setup) (setq-local comment-multi-line t) (setq-local treesit-text-type-regexp @@ -3885,19 +3815,25 @@ Currently there are `js-mode' and `js-ts-mode'." "method_definition" "function_declaration" "lexical_declaration"))) + (setq-local treesit-defun-name-function #'js--treesit-defun-name) ;; Fontification. (setq-local treesit-font-lock-settings js--treesit-font-lock-settings) (setq-local treesit-font-lock-feature-list - '(( comment declaration) + '(( comment definition) ( keyword string) - ( constant escape-sequence expression - identifier jsx number pattern property) - ( bracket delimiter operator))) + ( assignment constant escape-sequence jsx number + pattern) + ( bracket delimiter function operator property + string-interpolation))) ;; Imenu - (setq-local imenu-create-index-function - #'js--treesit-imenu) - ;; Which-func (use imenu). - (setq-local which-func-functions nil) + (setq-local treesit-simple-imenu-settings + `(("Function" "\\`function_declaration\\'" nil nil) + ("Variable" "\\`lexical_declaration\\'" + js--treesit-valid-imenu-entry nil) + ("Class" ,(rx bos (or "class_declaration" + "method_definition") + eos) + nil nil))) (treesit-major-mode-setup))) ;;;###autoload diff --git a/lisp/progmodes/json-ts-mode.el b/lisp/progmodes/json-ts-mode.el index 6c2f3805872..adba2f820fa 100644 --- a/lisp/progmodes/json-ts-mode.el +++ b/lisp/progmodes/json-ts-mode.el @@ -33,6 +33,7 @@ (declare-function treesit-parser-create "treesit.c") (declare-function treesit-induce-sparse-tree "treesit.c") (declare-function treesit-node-start "treesit.c") +(declare-function treesit-node-type "treesit.c") (declare-function treesit-node-child-by-field-name "treesit.c") @@ -107,33 +108,16 @@ '((ERROR) @font-lock-warning-face)) "Font-lock settings for JSON.") -(defun json-ts-mode--imenu-1 (node) - "Helper for `json-ts-mode--imenu'. -Find string representation for NODE and set marker, then recurse -the subtrees." - (let* ((ts-node (car node)) - (subtrees (mapcan #'json-ts-mode--imenu-1 (cdr node))) - (name (when ts-node - (treesit-node-text - (treesit-node-child-by-field-name - ts-node "key") - t))) - (marker (when ts-node - (set-marker (make-marker) - (treesit-node-start ts-node))))) - (cond - ((null ts-node) subtrees) - (subtrees - `((,name ,(cons name marker) ,@subtrees))) - (t - `((,name . ,marker)))))) - -(defun json-ts-mode--imenu () - "Return Imenu alist for the current buffer." - (let* ((node (treesit-buffer-root-node)) - (tree (treesit-induce-sparse-tree - node "pair" nil 1000))) - (json-ts-mode--imenu-1 tree))) +(defun json-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 "pair" "object") + (string-trim (treesit-node-text + (treesit-node-child-by-field-name + node "key") + t) + "\"" "\"")))) ;;;###autoload (define-derived-mode json-ts-mode prog-mode "JSON" @@ -161,6 +145,7 @@ the subtrees." ;; Navigation. (setq-local treesit-defun-type-regexp (rx (or "pair" "object"))) + (setq-local treesit-defun-name-function #'json-ts-mode--defun-name) ;; Font-lock. (setq-local treesit-font-lock-settings json-ts-mode--font-lock-settings) @@ -170,8 +155,8 @@ the subtrees." (bracket delimiter error))) ;; Imenu. - (setq-local imenu-create-index-function #'json-ts-mode--imenu) - (setq-local which-func-functions nil) ;; Piggyback on imenu + (setq-local treesit-simple-imenu-settings + '((nil "\\`pair\\'" nil nil))) (treesit-major-mode-setup)) diff --git a/lisp/progmodes/prog-mode.el b/lisp/progmodes/prog-mode.el index aa37a4ac865..2e0cb6cd25c 100644 --- a/lisp/progmodes/prog-mode.el +++ b/lisp/progmodes/prog-mode.el @@ -164,10 +164,8 @@ or follows point." (treesit-node-type (treesit-node-at (point))))))) (if (or treesit-text-node (nth 8 (syntax-ppss)) - (re-search-forward comment-start-skip (line-end-position) t)) - (if (memq fill-paragraph-function '(t nil)) - (lisp-fill-paragraph argument) - (funcall fill-paragraph-function argument)) + (re-search-forward "\\s-*\\s<" (line-end-position) t)) + (fill-paragraph argument (region-active-p)) (beginning-of-defun) (let ((start (point))) (end-of-defun) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 559da6dd649..c2633798473 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -1040,12 +1040,14 @@ by the user at will." (setq substrings (cons "./" substrings)))) (new-collection (project--file-completion-table substrings)) (abbr-cpd (abbreviate-file-name common-parent-directory)) + (abbr-cpd-length (length abbr-cpd)) (relname (cl-letf ((history-add-new-input nil) ((symbol-value hist) (mapcan (lambda (s) (and (string-prefix-p abbr-cpd s) - (list (substring s (length abbr-cpd))))) + (not (eq abbr-cpd-length (length s))) + (list (substring s abbr-cpd-length)))) (symbol-value hist)))) (project--completing-read-strict prompt new-collection diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index bdc9e6fa78c..07f86d31551 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -1080,7 +1080,6 @@ fontified." :feature 'string :language 'python - :override t '((string) @python--treesit-fontify-string) :feature 'string-interpolation @@ -1097,9 +1096,7 @@ fontified." :feature 'function :language 'python - '((function_definition - name: (identifier) @font-lock-function-name-face) - (call function: (identifier) @font-lock-function-name-face) + '((call function: (identifier) @font-lock-function-name-face) (call function: (attribute attribute: (identifier) @font-lock-function-name-face))) @@ -1130,7 +1127,7 @@ fontified." @font-lock-variable-name-face) (assignment left: (attribute attribute: (identifier) - @font-lock-variable-name-face)) + @font-lock-property-face)) (pattern_list (identifier) @font-lock-variable-name-face) (tuple_pattern (identifier) @@ -1162,12 +1159,10 @@ fontified." :feature 'number :language 'python - :override t '([(integer) (float)] @font-lock-number-face) :feature 'property :language 'python - :override t '((attribute attribute: (identifier) @font-lock-property-face) (class_definition @@ -1178,20 +1173,44 @@ fontified." :feature 'operator :language 'python - :override t `([,@python--treesit-operators] @font-lock-operator-face) :feature 'bracket :language 'python - :override t '(["(" ")" "[" "]" "{" "}"] @font-lock-bracket-face) :feature 'delimiter :language 'python - :override t - '(["," "." ":" ";" (ellipsis)] @font-lock-delimiter-face)) + '(["," "." ":" ";" (ellipsis)] @font-lock-delimiter-face) + + :feature 'variable + :language 'python + '((identifier) @python--treesit-fontify-variable)) "Tree-sitter font-lock settings.") +(defun python--treesit-variable-p (node) + "Check whether NODE is a variable. +NODE's type should be \"identifier\"." + ;; An identifier can be a function/class name, a property, or a + ;; variables. This funtion filters out function/class names and + ;; properties. + (pcase (treesit-node-type (treesit-node-parent node)) + ((or "function_definition" "class_definition") nil) + ("attribute" + (pcase (treesit-node-field-name node) + ("object" t) + (_ nil))) + (_ t))) + +(defun python--treesit-fontify-variable (node override start end &rest _) + "Fontify an identifier node if it is a variable. +For NODE, OVERRIDE, START, END, and ARGS, see +`treesit-font-lock-rules'." + (when (python--treesit-variable-p node) + (treesit-fontify-with-override + (treesit-node-start node) (treesit-node-end node) + 'font-lock-variable-name-face override start end))) + ;;; Indentation @@ -4540,7 +4559,7 @@ Commands that must finish the tracking session are listed in (when (and python-pdbtrack-tracked-buffer ;; Empty input is sent by C-d or `comint-send-eof' (or (string-empty-p input) - ;; "n some text" is "n" command for pdb. Split input and get firs part + ;; "n some text" is "n" command for pdb. Split input and get first part (let* ((command (car (split-string (string-trim input) " ")))) (setq python-pdbtrack-prev-command-continue (or (member command python-pdbtrack-continue-command) @@ -5448,6 +5467,16 @@ To this: ;;; Tree-sitter imenu +(defun python--treesit-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_definition" "class_definition") + (treesit-node-text + (treesit-node-child-by-field-name + node "name") + t)))) + (defun python--imenu-treesit-create-index-1 (node) "Given a sparse tree, create an imenu alist. @@ -5473,9 +5502,8 @@ definition*\"." ("class_definition" 'class))) ;; The root of the tree could have a nil ts-node. (name (when ts-node - (treesit-node-text - (treesit-node-child-by-field-name - ts-node "name") t))) + (or (treesit-defun-name ts-node) + "Anonymous"))) (marker (when ts-node (set-marker (make-marker) (treesit-node-start ts-node))))) @@ -6637,12 +6665,14 @@ implementations: `python-mode' and `python-ts-mode'." ( keyword string type) ( assignment builtin constant decorator escape-sequence number property string-interpolation ) - ( function bracket delimiter operator))) + ( bracket delimiter function operator variable))) (setq-local treesit-font-lock-settings python--treesit-settings) (setq-local imenu-create-index-function #'python-imenu-treesit-create-index) (setq-local treesit-defun-type-regexp (rx (or "function" "class") "_definition")) + (setq-local treesit-defun-name-function + #'python--treesit-defun-name) (treesit-major-mode-setup) (when python-indent-guess-indent-offset diff --git a/lisp/progmodes/ruby-mode.el b/lisp/progmodes/ruby-mode.el index fa51597697f..a4aa61905e4 100644 --- a/lisp/progmodes/ruby-mode.el +++ b/lisp/progmodes/ruby-mode.el @@ -212,7 +212,7 @@ It should match the part after \"def\" and until \"=\".") :safe 'booleanp) (defcustom ruby-indent-level 2 - "Indentation of Ruby statements." + "Number of spaces for each indentation step in `ruby-mode'." :type 'integer :safe 'integerp) @@ -268,6 +268,23 @@ Only has effect when `ruby-use-smie' is t." :safe 'booleanp :version "24.4") +(defcustom ruby-method-params-indent t + "Indentation of multiline method parameters. + +When t, the parameters list is indented to the method name. + +When a number, indent the parameters list this many columns +against the beginning of the method (the \"def\" keyword). + +The value nil means the same as 0. + +Only has effect when `ruby-use-smie' is t." + :type '(choice (const :tag "Indent to the method name" t) + (number :tag "Indent specified number of columns against def") + (const :tag "Indent to def" nil)) + :safe (lambda (val) (or (memq val '(t nil)) (numberp val))) + :version "29.1") + (defcustom ruby-deep-arglist t "Deep indent lists in parenthesis when non-nil. Also ignores spaces after parenthesis when `space'. @@ -660,9 +677,12 @@ This only affects the output of the command `ruby-toggle-block'." (unless (or (eolp) (forward-comment 1)) (cons 'column (current-column))))) ('(:before . " @ ") - (save-excursion - (skip-chars-forward " \t") - (cons 'column (current-column)))) + (if (or (eq ruby-method-params-indent t) + (not (smie-rule-parent-p "def" "def="))) + (save-excursion + (skip-chars-forward " \t") + (cons 'column (current-column))) + (smie-rule-parent (or ruby-method-params-indent 0)))) ('(:before . "do") (ruby-smie--indent-to-stmt)) ('(:before . ".") (if (smie-rule-sibling-p) @@ -1879,7 +1899,7 @@ or `gem' statement around point." (setq feature-name (read-string "Feature name: " init)))) (let ((out (substring - (shell-command-to-string (concat "gem which " feature-name)) + (shell-command-to-string (concat "gem which " (shell-quote-argument feature-name))) 0 -1))) (if (string-match-p "\\`ERROR" out) (user-error "%s" out) diff --git a/lisp/progmodes/rust-ts-mode.el b/lisp/progmodes/rust-ts-mode.el index 8b2ed191019..d03dffe628e 100644 --- a/lisp/progmodes/rust-ts-mode.el +++ b/lisp/progmodes/rust-ts-mode.el @@ -29,6 +29,7 @@ (require 'treesit) (eval-when-compile (require 'rx)) +(require 'c-ts-mode) ; For comment indent and filling. (declare-function treesit-parser-create "treesit.c") (declare-function treesit-induce-sparse-tree "treesit.c") @@ -70,6 +71,9 @@ ((node-is ")") parent-bol 0) ((node-is "]") parent-bol 0) ((node-is "}") (and parent parent-bol) 0) + ((and (parent-is "comment") c-ts-mode--looking-at-star) + c-ts-mode--comment-start-after-first-star -1) + ((parent-is "comment") prev-adaptive-prefix 0) ((parent-is "arguments") parent-bol rust-ts-mode-indent-offset) ((parent-is "await_expression") parent-bol rust-ts-mode-indent-offset) ((parent-is "array_expression") parent-bol rust-ts-mode-indent-offset) @@ -244,78 +248,32 @@ '((ERROR) @font-lock-warning-face)) "Tree-sitter font-lock settings for `rust-ts-mode'.") -(defun rust-ts-mode--imenu () - "Return Imenu alist for the current buffer." - (let* ((node (treesit-buffer-root-node)) - (enum-tree (treesit-induce-sparse-tree - node "enum_item" nil)) - (enum-index (rust-ts-mode--imenu-1 enum-tree)) - (func-tree (treesit-induce-sparse-tree - node "function_item" nil)) - (func-index (rust-ts-mode--imenu-1 func-tree)) - (impl-tree (treesit-induce-sparse-tree - node "impl_item" nil)) - (impl-index (rust-ts-mode--imenu-1 impl-tree)) - (mod-tree (treesit-induce-sparse-tree - node "mod_item" nil)) - (mod-index (rust-ts-mode--imenu-1 mod-tree)) - (struct-tree (treesit-induce-sparse-tree - node "struct_item" nil)) - (struct-index (rust-ts-mode--imenu-1 struct-tree)) - (type-tree (treesit-induce-sparse-tree - node "type_item" nil)) - (type-index (rust-ts-mode--imenu-1 type-tree))) - (append - (when mod-index `(("Module" . ,mod-index))) - (when enum-index `(("Enum" . ,enum-index))) - (when impl-index `(("Impl" . ,impl-index))) - (when type-index `(("Type" . ,type-index))) - (when struct-index `(("Struct" . ,struct-index))) - (when func-index `(("Fn" . ,func-index)))))) - -(defun rust-ts-mode--imenu-1 (node) - "Helper for `rust-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 #'rust-ts-mode--imenu-1 - children)) - (name (when ts-node - (pcase (treesit-node-type ts-node) - ("enum_item" - (treesit-node-text - (treesit-node-child-by-field-name ts-node "name") t)) - ("function_item" - (treesit-node-text - (treesit-node-child-by-field-name ts-node "name") t)) - ("impl_item" - (let ((trait-node (treesit-node-child-by-field-name ts-node "trait"))) - (concat - (treesit-node-text - trait-node t) - (when trait-node - " for ") - (treesit-node-text - (treesit-node-child-by-field-name ts-node "type") t)))) - ("mod_item" - (treesit-node-text - (treesit-node-child-by-field-name ts-node "name") t)) - ("struct_item" - (treesit-node-text - (treesit-node-child-by-field-name ts-node "name") t)) - ("type_item" - (treesit-node-text - (treesit-node-child-by-field-name ts-node "name") 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 rust-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) + ("enum_item" + (treesit-node-text + (treesit-node-child-by-field-name node "name") t)) + ("function_item" + (treesit-node-text + (treesit-node-child-by-field-name node "name") t)) + ("impl_item" + (let ((trait-node (treesit-node-child-by-field-name node "trait"))) + (concat + (treesit-node-text trait-node t) + (when trait-node " for ") + (treesit-node-text + (treesit-node-child-by-field-name node "type") t)))) + ("mod_item" + (treesit-node-text + (treesit-node-child-by-field-name node "name") t)) + ("struct_item" + (treesit-node-text + (treesit-node-child-by-field-name node "name") t)) + ("type_item" + (treesit-node-text + (treesit-node-child-by-field-name node "name") t)))) ;;;###autoload (add-to-list 'auto-mode-alist '("\\.rs\\'" . rust-ts-mode)) @@ -330,15 +288,7 @@ the subtrees." (treesit-parser-create 'rust) ;; Comments. - (setq-local comment-start "// ") - (setq-local comment-end "") - (setq-local comment-start-skip (rx (or (seq "/" (+ "/")) - (seq "/" (+ "*"))) - (* (syntax whitespace)))) - (setq-local comment-end-skip - (rx (* (syntax whitespace)) - (group (or (syntax comment-end) - (seq (+ "*") "/"))))) + (c-ts-mode-comment-setup) ;; Font-lock. (setq-local treesit-font-lock-settings rust-ts-mode--font-lock-settings) @@ -350,8 +300,13 @@ the subtrees." ( bracket delimiter error operator))) ;; Imenu. - (setq-local imenu-create-index-function #'rust-ts-mode--imenu) - (setq-local which-func-functions nil) + (setq-local treesit-simple-imenu-settings + `(("Module" "\\`mod_item\\'" nil nil) + ("Enum" "\\`enum_item\\'" nil nil) + ("Impl" "\\`impl_item\\'" nil nil) + ("Type" "\\`type_item\\'" nil nil) + ("Struct" "\\`struct_item\\'" nil nil) + ("Fn" "\\`function_item\\'" nil nil))) ;; Indent. (setq-local indent-tabs-mode nil @@ -363,6 +318,7 @@ the subtrees." "function_item" "impl_item" "struct_item"))) + (setq-local treesit-defun-name-function #'rust-ts-mode--defun-name) (treesit-major-mode-setup))) diff --git a/lisp/progmodes/scheme.el b/lisp/progmodes/scheme.el index 8454f24356a..f45d7992524 100644 --- a/lisp/progmodes/scheme.el +++ b/lisp/progmodes/scheme.el @@ -115,7 +115,8 @@ (defvar scheme-imenu-generic-expression `((nil - ,(rx bol "(define" + ,(rx bol (zero-or-more space) + "(define" (zero-or-one "*") (zero-or-one "-public") (one-or-more space) @@ -123,36 +124,41 @@ (group (one-or-more (or word (syntax symbol))))) 1) ("Methods" - ,(rx bol "(define-" + ,(rx bol (zero-or-more space) + "(define-" (or "generic" "method" "accessor") (one-or-more space) (zero-or-one "(") (group (one-or-more (or word (syntax symbol))))) 1) ("Classes" - ,(rx bol "(define-class" + ,(rx bol (zero-or-more space) + "(define-class" (one-or-more space) (zero-or-one "(") (group (one-or-more (or word (syntax symbol))))) 1) ("Records" - ,(rx bol "(define-record-type" + ,(rx bol (zero-or-more space) + "(define-record-type" (zero-or-one "*") (one-or-more space) (group (one-or-more (or word (syntax symbol))))) 1) ("Conditions" - ,(rx bol "(define-condition-type" + ,(rx bol (zero-or-more space) + "(define-condition-type" (one-or-more space) (group (one-or-more (or word (syntax symbol))))) 1) ("Modules" - ,(rx bol "(define-module" + ,(rx bol (zero-or-more space) + "(define-module" (one-or-more space) (group "(" (one-or-more any) ")")) 1) ("Macros" - ,(rx bol "(" + ,(rx bol (zero-or-more space) "(" (or (and "defmacro" (zero-or-one "*") (zero-or-one "-public")) diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el index 3f995d17b5a..d12ade36af3 100644 --- a/lisp/progmodes/sh-script.el +++ b/lisp/progmodes/sh-script.el @@ -150,6 +150,8 @@ (require 'executable) (require 'treesit) +(declare-function treesit-parser-create "treesit.c") + (autoload 'comint-completion-at-point "comint") (autoload 'comint-filename-completion "comint") (autoload 'comint-send-string "comint") diff --git a/lisp/progmodes/typescript-ts-mode.el b/lisp/progmodes/typescript-ts-mode.el index 6ba1b9b12c0..05ddc0e7a94 100644 --- a/lisp/progmodes/typescript-ts-mode.el +++ b/lisp/progmodes/typescript-ts-mode.el @@ -30,6 +30,7 @@ (require 'treesit) (require 'js) (eval-when-compile (require 'rx)) +(require 'c-ts-mode) ; For comment indent and filling. (declare-function treesit-parser-create "treesit.c") @@ -73,8 +74,9 @@ Argument LANGUAGE is either `typescript' or `tsx'." ((node-is ")") parent-bol 0) ((node-is "]") parent-bol 0) ((node-is ">") parent-bol 0) - ((and (parent-is "comment") comment-end) comment-start -1) - ((parent-is "comment") comment-start-skip 0) + ((and (parent-is "comment") c-ts-mode--looking-at-star) + c-ts-mode--comment-start-after-first-star -1) + ((parent-is "comment") prev-adaptive-prefix 0) ((parent-is "ternary_expression") parent-bol typescript-ts-mode-indent-offset) ((parent-is "member_expression") parent-bol typescript-ts-mode-indent-offset) ((parent-is "named_imports") parent-bol typescript-ts-mode-indent-offset) @@ -331,18 +333,12 @@ Argument LANGUAGE is either `typescript' or `tsx'." :syntax-table typescript-ts-mode--syntax-table ;; Comments. - (setq-local comment-start "// ") - (setq-local comment-end "") - (setq-local comment-start-skip "\\(?://+\\|/\\*+\\)\\s *") - (setq-local comment-end-skip - (rx (* (syntax whitespace)) - (group (or (syntax comment-end) - (seq (+ "*") "/"))))) + (c-ts-mode-comment-setup) + (setq-local treesit-defun-prefer-top-level t) (setq-local treesit-text-type-regexp (regexp-opt '("comment" "template_string"))) - (setq-local treesit-defun-prefer-top-level t) ;; Electric (setq-local electric-indent-chars @@ -354,11 +350,17 @@ Argument LANGUAGE is either `typescript' or `tsx'." "method_definition" "function_declaration" "lexical_declaration"))) - ;; Imenu. - (setq-local imenu-create-index-function #'js--treesit-imenu) - - ;; Which-func (use imenu). - (setq-local which-func-functions nil)) + (setq-local treesit-defun-name-function #'js--treesit-defun-name) + + ;; Imenu (same as in `js-ts-mode'). + (setq-local treesit-simple-imenu-settings + `(("Function" "\\`function_declaration\\'" nil nil) + ("Variable" "\\`lexical_declaration\\'" + js--treesit-valid-imenu-entry nil) + ("Class" ,(rx bos (or "class_declaration" + "method_definition") + eos) + nil nil)))) ;;;###autoload (define-derived-mode typescript-ts-mode typescript-ts-base-mode "TypeScript" diff --git a/lisp/repeat.el b/lisp/repeat.el index 33e8d98ce33..e382239fc86 100644 --- a/lisp/repeat.el +++ b/lisp/repeat.el @@ -368,6 +368,13 @@ This property can override the value of this variable." (defcustom repeat-keep-prefix nil "Whether to keep the prefix arg of the previous command when repeating." :type 'boolean + :initialize #'custom-initialize-default + :set (lambda (sym val) + (set-default sym val) + (when repeat-mode + (if repeat-keep-prefix + (add-hook 'pre-command-hook 'repeat-pre-hook) + (remove-hook 'pre-command-hook 'repeat-pre-hook)))) :group 'repeat :version "28.1") @@ -392,7 +399,8 @@ but the property value is `t', then check the last key." (defcustom repeat-echo-function #'repeat-echo-message "Function to display a hint about available keys. Function is called after every repeatable command with one argument: -a repeating map, or nil after deactivating the transient repeating mode." +a repeating map, or nil after deactivating the transient repeating mode. +You can use `add-function' for multiple functions simultaneously." :type '(choice (const :tag "Show hints in the echo area" repeat-echo-message) (const :tag "Show indicator in the mode line" @@ -419,7 +427,11 @@ When Repeat mode is enabled, and the command symbol has the property named See `describe-repeat-maps' for a list of all repeatable commands." :global t :group 'repeat (if (not repeat-mode) - (remove-hook 'post-command-hook 'repeat-post-hook) + (progn + (remove-hook 'pre-command-hook 'repeat-pre-hook) + (remove-hook 'post-command-hook 'repeat-post-hook)) + (when repeat-keep-prefix + (add-hook 'pre-command-hook 'repeat-pre-hook)) (add-hook 'post-command-hook 'repeat-post-hook) (let* ((keymaps nil) (commands (all-completions @@ -431,15 +443,21 @@ See `describe-repeat-maps' for a list of all repeatable commands." (length commands) (length (delete-dups keymaps)))))) -(defvar repeat--prev-mb '(0) - "Previous minibuffer state.") - (defun repeat--command-property (property) (or (and (symbolp this-command) (get this-command property)) (and (symbolp real-this-command) (get real-this-command property)))) +(defun repeat-get-map () + "Return a transient map for keys repeatable after the current command." + (when repeat-mode + (let ((rep-map (or repeat-map (repeat--command-property 'repeat-map)))) + (when rep-map + (when (and (symbolp rep-map) (boundp rep-map)) + (setq rep-map (symbol-value rep-map))) + rep-map)))) + (defun repeat-check-key (key map) "Check if the last key is suitable to activate the repeating MAP." (let* ((prop (repeat--command-property 'repeat-check-key)) @@ -449,50 +467,61 @@ See `describe-repeat-maps' for a list of all repeatable commands." ;; Try without modifiers: (lookup-key map (vector (event-basic-type key)))))) +(defvar repeat--prev-mb '(0) + "Previous minibuffer state.") + +(defun repeat-check-map (map) + "Decides whether MAP can be used for the next command." + (and map + ;; Detect changes in the minibuffer state to allow repetitions + ;; in the same minibuffer, but not when the minibuffer is activated + ;; in the middle of repeating sequence (bug#47566). + (or (< (minibuffer-depth) (car repeat--prev-mb)) + (eq current-minibuffer-command (cdr repeat--prev-mb))) + (repeat-check-key last-command-event map) + t)) + +(defun repeat-pre-hook () + "Function run before commands to handle repeatable keys." + (when (and repeat-mode repeat-keep-prefix repeat-in-progress + (not prefix-arg) current-prefix-arg) + (let ((map (repeat-get-map))) + ;; Only when repeat-post-hook will activate the same map + (when (repeat-check-map map) + ;; Optimize to use less logic in the function `repeat-get-map' + ;; for the next call: when called again from `repeat-post-hook' + ;; it will use the variable `repeat-map'. + (setq repeat-map map) + ;; Preserve universal argument + (setq prefix-arg current-prefix-arg))))) + (defun repeat-post-hook () "Function run after commands to set transient keymap for repeatable keys." (let ((was-in-progress repeat-in-progress)) (setq repeat-in-progress nil) - (when repeat-mode - (let ((rep-map (or repeat-map (repeat--command-property 'repeat-map)))) - (when rep-map - (when (and (symbolp rep-map) (boundp rep-map)) - (setq rep-map (symbol-value rep-map))) - (let ((map (copy-keymap rep-map))) - - (when (and - ;; Detect changes in the minibuffer state to allow repetitions - ;; in the same minibuffer, but not when the minibuffer is activated - ;; in the middle of repeating sequence (bug#47566). - (or (< (minibuffer-depth) (car repeat--prev-mb)) - (eq current-minibuffer-command (cdr repeat--prev-mb))) - (or (not repeat-keep-prefix) prefix-arg) - (repeat-check-key last-command-event map)) - - ;; Messaging - (unless prefix-arg - (funcall repeat-echo-function map)) - - ;; Adding an exit key - (when repeat-exit-key - (define-key map (if (key-valid-p repeat-exit-key) - (kbd repeat-exit-key) - repeat-exit-key) - 'ignore)) - - (when (and repeat-keep-prefix (not prefix-arg)) - (setq prefix-arg current-prefix-arg)) - - (setq repeat-in-progress t) - (let ((exitfun (set-transient-map map))) - (repeat--exit) - (setq repeat-exit-function exitfun) - - (let* ((prop (repeat--command-property 'repeat-exit-timeout)) - (timeout (unless (eq prop 'no) (or prop repeat-exit-timeout)))) - (when timeout - (setq repeat-exit-timer - (run-with-idle-timer timeout nil #'repeat-exit)))))))))) + (let ((map (repeat-get-map))) + (when (repeat-check-map map) + ;; Messaging + (funcall repeat-echo-function map) + + ;; Adding an exit key + (when repeat-exit-key + (setq map (copy-keymap map)) + (define-key map (if (key-valid-p repeat-exit-key) + (kbd repeat-exit-key) + repeat-exit-key) + 'ignore)) + + (setq repeat-in-progress t) + (repeat--exit) + (let ((exitfun (set-transient-map map))) + (setq repeat-exit-function exitfun) + + (let* ((prop (repeat--command-property 'repeat-exit-timeout)) + (timeout (unless (eq prop 'no) (or prop repeat-exit-timeout)))) + (when timeout + (setq repeat-exit-timer + (run-with-idle-timer timeout nil #'repeat-exit))))))) (setq repeat-map nil) (setq repeat--prev-mb (cons (minibuffer-depth) current-minibuffer-command)) @@ -582,6 +611,7 @@ Used in `repeat-mode'." (push s (alist-get (get s 'repeat-map) keymaps))))) (with-help-window (help-buffer) (with-current-buffer standard-output + (setq-local outline-regexp "[*]+") (insert "A list of keymaps used by commands with the symbol property `repeat-map'.\n") (dolist (keymap (sort keymaps (lambda (a b) diff --git a/lisp/replace.el b/lisp/replace.el index 302cb65543b..cebe779ae4c 100644 --- a/lisp/replace.el +++ b/lisp/replace.el @@ -1692,7 +1692,7 @@ contents of the line; it normally shows the line number. \(For multiline matches, the prefix column shows the line number for the first line and whitespace for the rest of the lines.\) If this face will display the same as the default face, the prefix -column will not be highlighted speciall." +column will not be highlighted specially." :type 'face :group 'matching :version "24.4") diff --git a/lisp/server.el b/lisp/server.el index 8f4ca4cbc6c..8bd622346e7 100644 --- a/lisp/server.el +++ b/lisp/server.el @@ -1502,7 +1502,7 @@ so don't mark these buffers specially, just visit them normally." minibuffer-auto-raise)) (filen (car file)) (obuf (get-file-buffer filen))) - (add-to-history 'file-name-history filen) + (file-name-history--add filen) (if (null obuf) (progn (run-hooks 'pre-command-hook) diff --git a/lisp/shell.el b/lisp/shell.el index dadbdcbc034..727f2aa0dd7 100644 --- a/lisp/shell.el +++ b/lisp/shell.el @@ -395,12 +395,10 @@ Useful for shells like zsh that has this feature." (defvar-keymap shell-repeat-map :doc "Keymap to repeat shell key sequences. Used in `repeat-mode'." + :repeat t "C-f" #'shell-forward-command "C-b" #'shell-backward-command) -(put #'shell-forward-command 'repeat-map 'shell-repeat-map) -(put #'shell-backward-command 'repeat-map 'shell-repeat-map) - (defcustom shell-mode-hook '() "Hook for customizing Shell mode." :type 'hook diff --git a/lisp/simple.el b/lisp/simple.el index f85428ca740..cf0845853a2 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -8438,6 +8438,43 @@ are interchanged." (interactive "*p") (transpose-subr 'forward-word arg)) +(defvar transpose-sexps-function + (lambda (arg) + ;; Here we should try to simulate the behavior of + ;; (cons (progn (forward-sexp x) (point)) + ;; (progn (forward-sexp (- x)) (point))) + ;; Except that we don't want to rely on the second forward-sexp + ;; putting us back to where we want to be, since forward-sexp-function + ;; might do funny things like infix-precedence. + (if (if (> arg 0) + (looking-at "\\sw\\|\\s_") + (and (not (bobp)) + (save-excursion + (forward-char -1) + (looking-at "\\sw\\|\\s_")))) + ;; Jumping over a symbol. We might be inside it, mind you. + (progn (funcall (if (> arg 0) + #'skip-syntax-backward #'skip-syntax-forward) + "w_") + (cons (save-excursion (forward-sexp arg) (point)) (point))) + ;; Otherwise, we're between sexps. Take a step back before jumping + ;; to make sure we'll obey the same precedence no matter which + ;; direction we're going. + (funcall (if (> arg 0) #'skip-syntax-backward #'skip-syntax-forward) + " .") + (cons (save-excursion (forward-sexp arg) (point)) + (progn (while (or (forward-comment (if (> arg 0) 1 -1)) + (not (zerop (funcall (if (> arg 0) + #'skip-syntax-forward + #'skip-syntax-backward) + "."))))) + (point))))) + "If non-nil, `transpose-sexps' delegates to this function. + +This function takes one argument ARG, a number. Its expected +return value is a position pair, which is a cons (BEG . END), +where BEG and END are buffer positions.") + (defun transpose-sexps (arg &optional interactive) "Like \\[transpose-chars] (`transpose-chars'), but applies to sexps. Unlike `transpose-words', point must be between the two sexps and not @@ -8453,38 +8490,7 @@ report errors as appropriate for this kind of usage." (condition-case nil (transpose-sexps arg nil) (scan-error (user-error "Not between two complete sexps"))) - (transpose-subr - (lambda (arg) - ;; Here we should try to simulate the behavior of - ;; (cons (progn (forward-sexp x) (point)) - ;; (progn (forward-sexp (- x)) (point))) - ;; Except that we don't want to rely on the second forward-sexp - ;; putting us back to where we want to be, since forward-sexp-function - ;; might do funny things like infix-precedence. - (if (if (> arg 0) - (looking-at "\\sw\\|\\s_") - (and (not (bobp)) - (save-excursion - (forward-char -1) - (looking-at "\\sw\\|\\s_")))) - ;; Jumping over a symbol. We might be inside it, mind you. - (progn (funcall (if (> arg 0) - 'skip-syntax-backward 'skip-syntax-forward) - "w_") - (cons (save-excursion (forward-sexp arg) (point)) (point))) - ;; Otherwise, we're between sexps. Take a step back before jumping - ;; to make sure we'll obey the same precedence no matter which - ;; direction we're going. - (funcall (if (> arg 0) 'skip-syntax-backward 'skip-syntax-forward) - " .") - (cons (save-excursion (forward-sexp arg) (point)) - (progn (while (or (forward-comment (if (> arg 0) 1 -1)) - (not (zerop (funcall (if (> arg 0) - 'skip-syntax-forward - 'skip-syntax-backward) - "."))))) - (point))))) - arg 'special))) + (transpose-subr transpose-sexps-function arg 'special))) (defun transpose-lines (arg) "Exchange current line and previous line, leaving point after both. @@ -8509,13 +8515,15 @@ With argument 0, interchanges line point is in with line mark is in." ;; FIXME document SPECIAL. (defun transpose-subr (mover arg &optional special) "Subroutine to do the work of transposing objects. -Works for lines, sentences, paragraphs, etc. MOVER is a function that -moves forward by units of the given object (e.g. `forward-sentence', -`forward-paragraph'). If ARG is zero, exchanges the current object -with the one containing mark. If ARG is an integer, moves the -current object past ARG following (if ARG is positive) or -preceding (if ARG is negative) objects, leaving point after the -current object." +Works for lines, sentences, paragraphs, etc. MOVER is a function +that moves forward by units of the given +object (e.g. `forward-sentence', `forward-paragraph'), or a +function calculating a cons of buffer positions. + + If ARG is zero, exchanges the current object with the one +containing mark. If ARG is an integer, moves the current object +past ARG following (if ARG is positive) or preceding (if ARG is +negative) objects, leaving point after the current object." (let ((aux (if special mover (lambda (x) (cons (progn (funcall mover x) (point)) @@ -8542,6 +8550,8 @@ current object." (goto-char (+ (car pos2) (- (cdr pos1) (car pos1)))))))) (defun transpose-subr-1 (pos1 pos2) + (unless (and pos1 pos2) + (error "Don't have two things to transpose")) (when (> (car pos1) (cdr pos1)) (setq pos1 (cons (cdr pos1) (car pos1)))) (when (> (car pos2) (cdr pos2)) (setq pos2 (cons (cdr pos2) (car pos2)))) (when (> (car pos1) (car pos2)) @@ -10053,6 +10063,8 @@ PREFIX is the string that represents this modifier in an event type symbol." event-type (cons event-type (cdr event))))))) +;; This is what makes "C-x @" followed by [hsmaSc] work even though +;; you won't find any (define-key ctl-x-map "@" ...) binding. (define-key function-key-map [?\C-x ?@ ?h] 'event-apply-hyper-modifier) (define-key function-key-map [?\C-x ?@ ?s] 'event-apply-super-modifier) (define-key function-key-map [?\C-x ?@ ?m] 'event-apply-meta-modifier) diff --git a/lisp/sort.el b/lisp/sort.el index d04f075abd1..b66d6453d21 100644 --- a/lisp/sort.el +++ b/lisp/sort.el @@ -86,7 +86,7 @@ second key. If PREDICATE is nil, comparison is done with `<' if the keys are numbers, with `compare-buffer-substrings' if the keys are cons cells (the car and cdr of each cons cell are taken as start and end positions), and with `string<' otherwise." - ;; Heuristically try to avoid messages if sorting a small amt of text. + ;; Heuristically try to avoid messages if sorting a small amount of text. (let ((messages (> (- (point-max) (point-min)) 50000))) (save-excursion (if messages (message "Finding sort keys...")) diff --git a/lisp/startup.el b/lisp/startup.el index 6270de2ace6..5a383630774 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -2921,7 +2921,7 @@ nil default-directory" name) (when (looking-at "#!") (forward-line)) (let (value form) - (while (ignore-error 'end-of-file + (while (ignore-error end-of-file (setq form (read (current-buffer)))) (setq value (eval form t))) (kill-emacs (if (numberp value) diff --git a/lisp/subr.el b/lisp/subr.el index e142eaa8104..69e6198e1bd 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -280,14 +280,20 @@ change the list." When COND yields non-nil, eval BODY forms sequentially and return value of last one, or nil if there are none." (declare (indent 1) (debug t)) - (list 'if cond (cons 'progn body))) + (if body + (list 'if cond (cons 'progn body)) + (macroexp-warn-and-return "`when' with empty body" + cond '(empty-body when) t))) (defmacro unless (cond &rest body) "If COND yields nil, do BODY, else return nil. When COND yields nil, eval BODY forms sequentially and return value of last one, or nil if there are none." (declare (indent 1) (debug t)) - (cons 'if (cons cond (cons nil body)))) + (if body + (cons 'if (cons cond (cons nil body))) + (macroexp-warn-and-return "`unless' with empty body" + cond '(empty-body unless) t))) (defsubst subr-primitive-p (object) "Return t if OBJECT is a built-in primitive function." @@ -380,9 +386,23 @@ without silencing all errors." "Execute BODY; if the error CONDITION occurs, return nil. Otherwise, return result of last form in BODY. -CONDITION can also be a list of error conditions." +CONDITION can also be a list of error conditions. +The CONDITION argument is not evaluated. Do not quote it." (declare (debug t) (indent 1)) - `(condition-case nil (progn ,@body) (,condition nil))) + (cond + ((and (eq (car-safe condition) 'quote) + (cdr condition) (null (cddr condition))) + (macroexp-warn-and-return + (format "`ignore-error' condition argument should not be quoted: %S" + condition) + `(condition-case nil (progn ,@body) (,(cadr condition) nil)) + nil t condition)) + (body + `(condition-case nil (progn ,@body) (,condition nil))) + (t + (macroexp-warn-and-return "`ignore-error' with empty body" + nil '(empty-body ignore-error) t condition)))) + ;;;; Basic Lisp functions. @@ -1576,16 +1596,18 @@ in the current Emacs session, then this function may return nil." ;; Use `window-point' for the case when the current buffer ;; is temporarily switched to some other buffer (bug#50256) (let* ((pos (window-point)) - (posn (posn-at-point pos))) - (if (null posn) ;; `pos' is "out of sight". - (list (selected-window) pos '(0 . 0) 0) - ;; If `pos' is inside a chunk of text hidden by an `invisible' - ;; or `display' property, `posn-at-point' returns the position - ;; that *is* visible, whereas `event--posn-at-point' is used - ;; when we have a keyboard event, whose position is `point' even - ;; if that position is invisible. - (setf (nth 5 posn) pos) - posn))) + (posn (posn-at-point pos (if (minibufferp (current-buffer)) + (minibuffer-window))))) + (cond ((null posn) ;; `pos' is "out of sight". + (setq posn (list (selected-window) pos '(0 . 0) 0))) + ;; If `pos' is inside a chunk of text hidden by an `invisible' + ;; or `display' property, `posn-at-point' returns the position + ;; that *is* visible, whereas `event--posn-at-point' is used + ;; when we have a keyboard event, whose position is `point' even + ;; if that position is invisible. + ((> (length posn) 5) + (setf (nth 5 posn) pos))) + posn)) (defun event-start (event) "Return the starting position of EVENT. @@ -4848,6 +4870,7 @@ but that should be robust in the unexpected case that an error is signaled." (declare (debug t) (indent 1)) (let* ((err (make-symbol "err")) (orig-body body) + (orig-format format) (format (if (and (stringp format) body) format (prog1 "Error: %S" (if format (push format body))))) @@ -4858,7 +4881,9 @@ but that should be robust in the unexpected case that an error is signaled." (if (eq orig-body body) exp ;; The use without `format' is obsolete, let's warn when we bump ;; into any such remaining uses. - (macroexp-warn-and-return "Missing format argument" exp nil nil format)))) + (macroexp-warn-and-return + "Missing format argument in `with-demote-errors'" exp nil nil + orig-format)))) (defmacro combine-after-change-calls (&rest body) "Execute BODY, but don't call the after-change functions till the end. @@ -6084,14 +6109,8 @@ command is called from a keyboard macro?" ;; Skip special forms (from non-compiled code). (and frame (null (car frame))) ;; Skip also `interactive-p' (because we don't want to know if - ;; interactive-p was called interactively but if it's caller was) - ;; and `byte-code' (idem; this appears in subexpressions of things - ;; like condition-case, which are wrapped in a separate bytecode - ;; chunk). - ;; FIXME: For lexical-binding code, this is much worse, - ;; because the frames look like "byte-code -> funcall -> #[...]", - ;; which is not a reliable signature. - (memq (nth 1 frame) '(interactive-p 'byte-code)) + ;; interactive-p was called interactively but if it's caller was). + (eq (nth 1 frame) 'interactive-p) ;; Skip package-specific stack-frames. (let ((skip (run-hook-with-args-until-success 'called-interactively-p-functions @@ -6909,11 +6928,8 @@ sentence (see Info node `(elisp) Documentation Tips')." (defun json-available-p () "Return non-nil if Emacs has libjansson support." - (and (fboundp 'json-serialize) - (condition-case nil - (json-serialize t) - (:success t) - (json-unavailable nil)))) + (and (fboundp 'json--available-p) + (json--available-p))) (defun ensure-list (object) "Return OBJECT as a list. diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el index 065116d5129..7433f5c8e51 100644 --- a/lisp/tab-bar.el +++ b/lisp/tab-bar.el @@ -1029,7 +1029,7 @@ This variable has effect only when `tab-bar-auto-width' is non-nil." :initialize #'custom-initialize-default :set (lambda (sym val) (set-default sym val) - (setq tab-bar--fixed-width-hash nil)) + (setq tab-bar--auto-width-hash nil)) :group 'tab-bar :version "29.1") @@ -1048,17 +1048,17 @@ tab bar might wrap to the second line when it shouldn't.") tab-bar-tab-group-inactive) "Resize tabs only with these faces.") -(defvar tab-bar--fixed-width-hash nil +(defvar tab-bar--auto-width-hash nil "Memoization table for `tab-bar-auto-width'.") (defun tab-bar-auto-width (items) "Return tab-bar items with resized tab names." - (unless tab-bar--fixed-width-hash - (define-hash-table-test 'tab-bar--fixed-width-hash-test + (unless tab-bar--auto-width-hash + (define-hash-table-test 'tab-bar--auto-width-hash-test #'equal-including-properties #'sxhash-equal-including-properties) - (setq tab-bar--fixed-width-hash - (make-hash-table :test 'tab-bar--fixed-width-hash-test))) + (setq tab-bar--auto-width-hash + (make-hash-table :test 'tab-bar--auto-width-hash-test))) (let ((tabs nil) ;; list of resizable tabs (non-tabs "") ;; concatenated names of non-resizable tabs (width 0)) ;; resize tab names to this width @@ -1086,7 +1086,7 @@ tab bar might wrap to the second line when it shouldn't.") (setf (nth 2 item) (with-memoization (gethash (list (selected-frame) width (nth 2 item)) - tab-bar--fixed-width-hash) + tab-bar--auto-width-hash) (let* ((name (nth 2 item)) (len (length name)) (close-p (get-text-property (1- len) 'close-tab name)) @@ -1116,7 +1116,8 @@ tab bar might wrap to the second line when it shouldn't.") (del-pos2 (if close-p -1 nil))) (while continue (setq name (concat (substring name 0 del-pos1) - (substring name del-pos2))) + (and del-pos2 + (substring name del-pos2)))) (setq curr-width (string-pixel-width name)) (if (and (> curr-width width) (< curr-width prev-width)) @@ -2654,18 +2655,16 @@ When `switch-to-buffer-obey-display-actions' is non-nil, (defvar-keymap tab-bar-switch-repeat-map :doc "Keymap to repeat tab switch key sequences \\`C-x t o o O'. Used in `repeat-mode'." + :repeat t "o" #'tab-next "O" #'tab-previous) -(put 'tab-next 'repeat-map 'tab-bar-switch-repeat-map) -(put 'tab-previous 'repeat-map 'tab-bar-switch-repeat-map) (defvar-keymap tab-bar-move-repeat-map :doc "Keymap to repeat tab move key sequences \\`C-x t m m M'. Used in `repeat-mode'." + :repeat t "m" #'tab-move "M" #'tab-bar-move-tab-backward) -(put 'tab-move 'repeat-map 'tab-bar-move-repeat-map) -(put 'tab-bar-move-tab-backward 'repeat-map 'tab-bar-move-repeat-map) (provide 'tab-bar) diff --git a/lisp/tab-line.el b/lisp/tab-line.el index c4e4a688720..30612728bde 100644 --- a/lisp/tab-line.el +++ b/lisp/tab-line.el @@ -572,9 +572,14 @@ For use in `tab-line-tab-face-functions'." (defvar tab-line-auto-hscroll) -(defun tab-line-cache-key-default (_tabs) +(defun tab-line-cache-key-default (tabs) "Return default list of cache keys." (list + tabs + ;; handle buffer renames + (buffer-name (window-buffer)) + ;; handle tab-line scrolling + (window-parameter nil 'tab-line-hscroll) ;; for setting face 'tab-line-tab-current' (mode-line-window-selected-p) ;; for `tab-line-tab-face-modified' @@ -591,12 +596,7 @@ of cache keys. You can use `add-function' to add more cache keys.") (defun tab-line-format () "Format for displaying the tab line of the selected window." (let* ((tabs (funcall tab-line-tabs-function)) - (cache-key (append (list tabs - ;; handle buffer renames - (buffer-name (window-buffer)) - ;; handle tab-line scrolling - (window-parameter nil 'tab-line-hscroll)) - (funcall tab-line-cache-key-function tabs))) + (cache-key (funcall tab-line-cache-key-function tabs)) (cache (window-parameter nil 'tab-line-cache))) ;; Enable auto-hscroll again after it was disabled on manual scrolling. ;; The moment to enable it is when the window-buffer was updated. diff --git a/lisp/textmodes/bibtex.el b/lisp/textmodes/bibtex.el index f4b557f443f..23909742889 100644 --- a/lisp/textmodes/bibtex.el +++ b/lisp/textmodes/bibtex.el @@ -1822,8 +1822,9 @@ Initialized by `bibtex-set-dialect'.") 1 '(11)))) (defvar bibtex-font-lock-keywords - ;; entry type and reference key - `((,bibtex-any-entry-maybe-empty-head + `(("\\$[^$\n]+\\$" . font-lock-string-face) ; bug#50202 + ;; entry type and reference key + (,bibtex-any-entry-maybe-empty-head (,bibtex-type-in-head font-lock-function-name-face) (,bibtex-key-in-head font-lock-constant-face nil t)) ;; optional field names (treated as comments) @@ -3631,8 +3632,11 @@ if that value is non-nil. (setq-local fill-paragraph-function #'bibtex-fill-field) (setq-local font-lock-defaults '(bibtex-font-lock-keywords - nil t ((?$ . "\"") - ;; Mathematical expressions should be fontified as strings + nil t ((?$ . ".") + ;; Mathematical expressions should be fontified + ;; as strings. Yet `$' may also appear in certain + ;; fields like `URL' when it does not delimit + ;; a math expression (bug#50202). (?\" . ".") ;; Quotes are field delimiters and quote-delimited ;; entries should be fontified in the same way as @@ -4079,11 +4083,19 @@ INIT is surrounded by field delimiters, unless NODELIM is non-nil." If inside an entry, move to the beginning of it, otherwise move to the beginning of the previous entry. If point is ahead of all BibTeX entries move point to the beginning of buffer. Return the new location of point." + ;; This command is similar to `beginning-of-defun', but with historical + ;; differences. + ;; - It does not move point to the previous entry if point is already + ;; at the beginning of an entry + ;; - It does not take an optional ARG that moves backward to the beginning + ;; of a defun ARG times. + ;; - It returns point and the code relies on this. (interactive) - (skip-chars-forward " \t") - (if (looking-at "@") - (forward-char)) - (re-search-backward "^[ \t]*@" nil 'move) + (beginning-of-line) + ;; `bibtex-any-valid-entry-type' would fail if users "disable" + ;; an entry by chosing an invalid entry type. + (or (looking-at bibtex-any-entry-maybe-empty-head) + (re-search-backward bibtex-any-entry-maybe-empty-head nil 'move)) (point)) (defun bibtex-end-of-entry () diff --git a/lisp/textmodes/css-mode.el b/lisp/textmodes/css-mode.el index 822097a86d8..e8d97259489 100644 --- a/lisp/textmodes/css-mode.el +++ b/lisp/textmodes/css-mode.el @@ -1412,39 +1412,18 @@ for determining whether point is within a selector." '((ERROR) @error)) "Tree-sitter font-lock settings for `css-ts-mode'.") -(defun css--treesit-imenu-1 (node) - "Helper for `css--treesit-imenu'. -Find string representation for NODE and set marker, then recurse -the subtrees." - (let* ((ts-node (car node)) - (subtrees (mapcan #'css--treesit-imenu-1 (cdr node))) - (name (when ts-node - (pcase (treesit-node-type ts-node) - ("rule_set" (treesit-node-text - (treesit-node-child ts-node 0) t)) - ("media_statement" - (let ((block (treesit-node-child ts-node -1))) - (string-trim - (buffer-substring-no-properties - (treesit-node-start ts-node) - (treesit-node-start block)))))))) - (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 css--treesit-imenu () - "Return Imenu alist for the current buffer." - (let* ((node (treesit-buffer-root-node)) - (tree (treesit-induce-sparse-tree - node (rx (or "rule_set" "media_statement")) - nil 1000))) - (css--treesit-imenu-1 tree))) +(defun css--treesit-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) + ("rule_set" (treesit-node-text + (treesit-node-child node 0) t)) + ("media_statement" + (let ((block (treesit-node-child node -1))) + (string-trim + (buffer-substring-no-properties + (treesit-node-start node) + (treesit-node-start block))))))) ;;; Completion @@ -1825,23 +1804,29 @@ can also be used to fill comments. :syntax-table css-mode-syntax-table (when (treesit-ready-p 'css) ;; Borrowed from `css-mode'. + (setq-local syntax-propertize-function + css-syntax-propertize-function) (add-hook 'completion-at-point-functions #'css-completion-at-point nil 'local) (setq-local fill-paragraph-function #'css-fill-paragraph) (setq-local adaptive-fill-function #'css-adaptive-fill) - (setq-local add-log-current-defun-function #'css-current-defun-name) + ;; `css--fontify-region' first calls the default function, which + ;; will call tree-sitter's function, then it fontifies colors. + (setq-local font-lock-fontify-region-function #'css--fontify-region) ;; Tree-sitter specific setup. (treesit-parser-create 'css) (setq-local treesit-simple-indent-rules css--treesit-indent-rules) (setq-local treesit-defun-type-regexp "rule_set") + (setq-local treesit-defun-name-function #'css--treesit-defun-name) (setq-local treesit-font-lock-settings css--treesit-settings) (setq-local treesit-font-lock-feature-list '((selector comment query keyword) (property constant string) (error variable function operator bracket))) - (setq-local imenu-create-index-function #'css--treesit-imenu) - (setq-local which-func-functions nil) + (setq-local treesit-simple-imenu-settings + `(( nil ,(rx bos (or "rule_set" "media_statement") eos) + nil nil))) (treesit-major-mode-setup))) ;;;###autoload diff --git a/lisp/textmodes/reftex-vars.el b/lisp/textmodes/reftex-vars.el index ee94cc5d693..51dedddf3a5 100644 --- a/lisp/textmodes/reftex-vars.el +++ b/lisp/textmodes/reftex-vars.el @@ -2096,8 +2096,8 @@ may require a restart of Emacs in order to become effective." (defcustom reftex-allow-detached-macro-args nil "Non-nil means, allow arguments of macros to be detached by whitespace. -When this is t, `aaa' will be considered as argument of \\bb in the following -construct: \\bbb [xxx] {aaa}." +When this is t, `aaa' will be considered as argument of \\bbb in +the following construct: \\bbb [xxx] {aaa}." :group 'reftex-miscellaneous-configurations :type 'boolean) diff --git a/lisp/textmodes/toml-ts-mode.el b/lisp/textmodes/toml-ts-mode.el index bca6a5e81ad..cbdc758d4b3 100644 --- a/lisp/textmodes/toml-ts-mode.el +++ b/lisp/textmodes/toml-ts-mode.el @@ -32,6 +32,8 @@ (declare-function treesit-parser-create "treesit.c") (declare-function treesit-induce-sparse-tree "treesit.c") (declare-function treesit-node-start "treesit.c") +(declare-function treesit-node-type "treesit.c") +(declare-function treesit-node-child "treesit.c") (declare-function treesit-node-child-by-field-name "treesit.c") (defcustom toml-ts-mode-indent-offset 2 @@ -107,43 +109,13 @@ '((ERROR) @font-lock-warning-face)) "Font-lock settings for TOML.") -(defun toml-ts-mode--get-table-name (node) - "Obtains the header-name for the associated tree-sitter `NODE'." - (if node - (treesit-node-text - (car (cdr (treesit-node-children node)))) - "Root table")) - -(defun toml-ts-mode--imenu-1 (node) - "Helper for `toml-ts-mode--imenu'. -Find string representation for NODE and set marker, then recurse -the subtrees." - (let* ((ts-node (car node)) - (subtrees (mapcan #'toml-ts-mode--imenu-1 (cdr node))) - (name (toml-ts-mode--get-table-name ts-node)) - (marker (when ts-node - (set-marker (make-marker) - (treesit-node-start ts-node))))) - (cond - ((null ts-node) subtrees) - (subtrees - `((,name ,(cons name marker) ,@subtrees))) - (t - `((,name . ,marker)))))) - -(defun toml-ts-mode--imenu () - "Return Imenu alist for the current buffer." - (let* ((node (treesit-buffer-root-node)) - (table-tree (treesit-induce-sparse-tree - node "^table$" nil 1000)) - (table-array-tree (treesit-induce-sparse-tree - node "^table_array_element$" nil 1000)) - (table-index (toml-ts-mode--imenu-1 table-tree)) - (table-array-index (toml-ts-mode--imenu-1 table-array-tree))) - (append - (when table-index `(("Headers" . ,table-index))) - (when table-array-index `(("Arrays" . ,table-array-index)))))) - +(defun toml-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 "table" "table_array_element") + (or (treesit-node-text (treesit-node-child node 1) t) + "Root table")))) ;;;###autoload (add-to-list 'auto-mode-alist '("\\.toml\\'" . toml-ts-mode)) @@ -167,6 +139,7 @@ the subtrees." ;; Navigation. (setq-local treesit-defun-type-regexp (rx (or "table" "table_array_element"))) + (setq-local treesit-defun-name-function #'toml-ts-mode--defun-name) ;; Font-lock. (setq-local treesit-font-lock-settings toml-ts-mode--font-lock-settings) @@ -177,8 +150,9 @@ the subtrees." (delimiter error))) ;; Imenu. - (setq-local imenu-create-index-function #'toml-ts-mode--imenu) - (setq-local which-func-functions nil) ;; Piggyback on imenu + (setq-local treesit-simple-imenu-settings + '(("Header" "\\`table\\'" nil nil) + ("Array" "\\`table_array_element\\'" nil nil))) (treesit-major-mode-setup))) diff --git a/lisp/treesit.el b/lisp/treesit.el index 1f366807ce2..4af555fb8e6 100644 --- a/lisp/treesit.el +++ b/lisp/treesit.el @@ -2,6 +2,10 @@ ;; Copyright (C) 2021-2022 Free Software Foundation, Inc. +;; Maintainer: 付禹安 (Yuan Fu) <casouri@gmail.com> +;; Keywords: treesit, tree-sitter, languages +;; Package: emacs + ;; This file is part of GNU Emacs. ;; GNU Emacs is free software: you can redistribute it and/or modify @@ -141,6 +145,9 @@ parser in `treesit-parser-list', or nil if there is no parser." ;;; Node API supplement +(define-error 'treesit-no-parser "No available parser for this buffer" + 'treesit-error) + (defun treesit-node-buffer (node) "Return the buffer in which NODE belongs." (treesit-parser-buffer @@ -168,13 +175,14 @@ before POS. Return nil if no leaf node can be returned. If NAMED is non-nil, only look for named nodes. -If PARSER-OR-LANG is nil, use the first parser in -`treesit-parser-list'; if PARSER-OR-LANG is a parser, use -that parser; if PARSER-OR-LANG is a language, find a parser using -that language in the current buffer, and use that." +If PARSER-OR-LANG is a parser, use that parser; if PARSER-OR-LANG +is a language, find the first parser for that language in the +current buffer, or create one if none exists; If PARSER-OR-LANG +is nil, try to guess the language at POS using `treesit-language-at'." (let* ((root (if (treesit-parser-p parser-or-lang) (treesit-parser-root-node parser-or-lang) - (treesit-buffer-root-node parser-or-lang))) + (treesit-buffer-root-node + (or parser-or-lang (treesit-language-at pos))))) (node root) (node-before root) (pos-1 (max (1- pos) (point-min))) @@ -216,43 +224,51 @@ to use `treesit-node-at' instead. Return nil if none was found. If NAMED is non-nil, only look for named node. -If PARSER-OR-LANG is nil, use the first parser in -`treesit-parser-list'; if PARSER-OR-LANG is a parser, use -that parser; if PARSER-OR-LANG is a language, find a parser using -that language in the current buffer, and use that." +If PARSER-OR-LANG is a parser, use that parser; if PARSER-OR-LANG +is a language, find the first parser for that language in the +current buffer, or create one if none exists; If PARSER-OR-LANG +is nil, try to guess the language at BEG using `treesit-language-at'." (let ((root (if (treesit-parser-p parser-or-lang) (treesit-parser-root-node parser-or-lang) - (treesit-buffer-root-node parser-or-lang)))) + (treesit-buffer-root-node + (or parser-or-lang (treesit-language-at beg)))))) (treesit-node-descendant-for-range root beg (or end beg) named))) -(defun treesit-node-top-level (node &optional type) +(defun treesit-node-top-level (node &optional pred include-node) "Return the top-level equivalent of NODE. + Specifically, return the highest parent of NODE that has the same type as it. If no such parent exists, return nil. -If TYPE is non-nil, match each parent's type with TYPE as a -regexp, rather than using NODE's type." - (let ((type (or type (treesit-node-type node))) +If PRED is non-nil, match each parent's type with PRED as a +regexp, rather than using NODE's type. PRED can also be a +function that takes the node as an argument, and return +non-nil/nil for match/no match. + +If INCLUDE-NODE is non-nil, return NODE if it satisfies PRED." + (let ((pred (or pred (treesit-node-type node))) (result nil)) - (cl-loop for cursor = (treesit-node-parent node) + (cl-loop for cursor = (if include-node node + (treesit-node-parent node)) then (treesit-node-parent cursor) while cursor - if (string-match-p type (treesit-node-type cursor)) + if (if (stringp pred) + (string-match-p pred (treesit-node-type cursor)) + (funcall pred cursor)) do (setq result cursor)) result)) (defun treesit-buffer-root-node (&optional language) "Return the root node of the current buffer. -Use the first parser in `treesit-parser-list'. -If optional argument LANGUAGE is non-nil, use the first parser -for LANGUAGE." +Use the first parser in the parser list if LANGUAGE is omitted. +If LANGUAGE is non-nil, use the first parser for LANGUAGE in the +parser list, or create one if none exists." (if-let ((parser - (or (if language - (treesit-parser-create language) - (or (car (treesit-parser-list)) - (signal 'treesit-error - '("Buffer has no parser"))))))) + (if language + (treesit-parser-create language) + (or (car (treesit-parser-list)) + (signal 'treesit-no-parser (list (current-buffer))))))) (treesit-parser-root-node parser))) (defun treesit-filter-child (node pred &optional named) @@ -282,11 +298,16 @@ properties." (treesit-node-start node) (treesit-node-end node)))))) -(defun treesit-parent-until (node pred) +(defun treesit-parent-until (node pred &optional include-node) "Return the closest parent of NODE that satisfies PRED. + Return nil if none was found. PRED should be a function that -takes one argument, the parent node." - (let ((node (treesit-node-parent node))) +takes one argument, the parent node, and return non-nil/nil for +match/no match. + +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))) (setq node (treesit-node-parent node))) node)) @@ -301,8 +322,6 @@ takes one argument, the parent node." node (treesit-node-parent node))) last)) -(defalias 'treesit-traverse-parent #'treesit-parent-until) - (defun treesit-node-children (node &optional named) "Return a list of NODE's children. If NAMED is non-nil, collect named child only." @@ -859,7 +878,7 @@ LIMIT is the recursion limit, which defaults to 100." (push child result)) (setq child (treesit-node-next-sibling child))) ;; If NODE has no child, keep NODE. - (or result node))) + (or result (list node)))) (defsubst treesit--node-length (node) "Return the length of the text of NODE." @@ -1107,6 +1126,22 @@ See `treesit-simple-indent-presets'.") (re-search-forward comment-start-skip) (skip-syntax-backward "-") (point)))) + (cons 'prev-adaptive-prefix + (lambda (_n parent &rest _) + (save-excursion + (re-search-backward + (rx (not (or " " "\t" "\n"))) nil t) + (beginning-of-line) + (and (>= (point) (treesit-node-start parent)) + ;; `adaptive-fill-regexp' will not match "/*", + ;; so we need to also try `comment-start-skip'. + (or (and adaptive-fill-regexp + (looking-at adaptive-fill-regexp) + (> (- (match-end 0) (match-beginning 0)) 0) + (match-end 0)) + (and comment-start-skip + (looking-at comment-start-skip) + (match-end 0))))))) ;; TODO: Document. (cons 'grand-parent (lambda (_n parent &rest _) @@ -1183,7 +1218,7 @@ no-node \(n-p-gp NODE-TYPE PARENT-TYPE GRANDPARENT-TYPE) - Checks that NODE, its parent, and its grandparent's type. + Checks for NODE's, its parent's, and its grandparent's type. \(query QUERY) @@ -1229,7 +1264,14 @@ comment-start Goes to the position that `comment-start-skip' would return, skips whitespace backwards, and returns the resulting - position. Assumes PARENT is a comment node.") + position. Assumes PARENT is a comment node. + +prev-adaptive-prefix + + Goes to the beginning of previous non-empty line, and tries + to match `adaptive-fill-regexp'. If it matches, return the + end of the match, otherwise return nil. This is useful for a + `indent-relative'-like indent behavior for block comments.") (defun treesit--simple-indent-eval (exp) "Evaluate EXP. @@ -1555,7 +1597,61 @@ BACKWARD and ALL are the same as in `treesit-search-forward'." (goto-char current-pos))) node)) -;;; Navigation +(defun treesit-transpose-sexps (&optional arg) + "Tree-sitter `transpose-sexps' function. +Arg is the same as in `transpose-sexps'. + +Locate the node closest to POINT, and transpose that node with +its sibling node ARG nodes away. + +Return a pair of positions as described by +`transpose-sexps-function' for use in `transpose-subr' and +friends." + (let* ((parent (treesit-node-parent (treesit-node-at (point)))) + (child (treesit-node-child parent 0 t))) + (named-let loop ((prev child) + (next (treesit-node-next-sibling child t))) + (when (and prev next) + (if (< (point) (treesit-node-end next)) + (if (= arg -1) + (cons (treesit-node-start prev) + (treesit-node-end prev)) + (when-let ((n (treesit-node-child + parent (+ arg (treesit-node-index prev t)) t))) + (cons (treesit-node-end n) + (treesit-node-start n)))) + (loop (treesit-node-next-sibling prev t) + (treesit-node-next-sibling next t))))))) + +;;; Navigation, defun, things +;; +;; Emacs lets you define "things" by a regexp that matches the type of +;; a node, and here are some functions that lets you find the "things" +;; at/around point, navigate backward/forward a "thing", etc. +;; +;; The most obvious "thing" is a defun, and there are thin wrappers +;; around thing functions for defun for convenience. +;; +;; We have more command-like functions like: +;; - treesit-beginning-of-thing/defun +;; - treesit-end-of-thing/defun +;; - treesit-thing/defun-at-point +;; +;; And more generic functions like: +;; - treesit--things-around +;; - treesit--top-level-thing +;; - treesit--navigate-thing +;; +;; There are also some defun-specific functions, like +;; treesit-defun-name, treesit-add-log-current-defun. +;; +;; TODO: I'm not entirely sure how would this go, so I only documented +;; the "defun" functions and didn't document any "thing" functions. +;; We should also document `treesit-block-type-regexp' and support it +;; in major modes if we can meaningfully intergrate hideshow: I tried +;; and failed, we need SomeOne that understands hideshow to look at +;; it. (BTW, hideshow should use its own +;; `treesit-hideshow-block-type-regexp'.) (defvar-local treesit-defun-type-regexp nil "A regexp that matches the node type of defun nodes. @@ -1563,12 +1659,15 @@ For example, \"(function|class)_definition\". Sometimes not all nodes matched by the regexp are valid defuns. In that case, set this variable to a cons cell of the -form (REGEXP . FILTER), where FILTER is a function that takes a +form (REGEXP . PRED), where PRED is a function that takes a node (the matched node) and returns t if node is valid, or nil for invalid node. This is used by `treesit-beginning-of-defun' and friends.") +(defvar-local treesit-block-type-regexp nil + "Like `treesit-defun-type-regexp', but for blocks.") + (defvar-local treesit-defun-tactic 'nested "Determines how does Emacs treat nested defuns. If the value is `top-level', Emacs only moves across top-level @@ -1583,6 +1682,58 @@ newline after a defun, or the beginning of a defun. 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.") + +(defvar-local treesit-add-log-defun-delimiter "." + "The delimiter used to connect several defun names. +This is used in `treesit-add-log-current-defun'.") + +(defsubst treesit--thing-unpack-pattern (pattern) + "Unpack PATTERN in the shape of `treesit-defun-type-regexp'. + +Basically, + + (unpack REGEXP) = (REGEXP . nil) + (unpack (REGEXP . PRED)) = (REGEXP . PRED)" + (if (consp pattern) + pattern + (cons pattern nil))) + +(defun treesit-beginning-of-thing (pattern &optional arg) + "Like `beginning-of-defun', but generalized into things. + +PATTERN is like `treesit-defun-type-regexp', ARG +is the same as in `beginning-of-defun'. + +Return non-nil if successfully moved, nil otherwise." + (pcase-let* ((arg (or arg 1)) + (`(,regexp . ,pred) (treesit--thing-unpack-pattern + pattern)) + (dest (treesit--navigate-thing + (point) (- arg) 'beg regexp pred))) + (when dest + (goto-char dest)))) + +(defun treesit-end-of-thing (pattern &optional arg) + "Like `end-of-defun', but generalized into things. + +PATTERN is like `treesit-defun-type-regexp', ARG is the same as +in `end-of-defun'. + +Return non-nil if successfully moved, nil otherwise." + (pcase-let* ((arg (or arg 1)) + (`(,regexp . ,pred) (treesit--thing-unpack-pattern + pattern)) + (dest (treesit--navigate-thing + (point) arg 'end regexp pred))) + (when dest + (goto-char dest)))) + (defun treesit-beginning-of-defun (&optional arg) "Move backward to the beginning of a defun. @@ -1595,9 +1746,7 @@ This is a tree-sitter equivalent of `beginning-of-defun'. Behavior of this function depends on `treesit-defun-type-regexp' and `treesit-defun-skipper'." (interactive "^p") - (when-let* ((arg (or arg 1)) - (dest (treesit--navigate-defun (point) (- arg) 'beg))) - (goto-char dest) + (when (treesit-beginning-of-thing treesit-defun-type-regexp arg) (when treesit-defun-skipper (funcall treesit-defun-skipper)) t)) @@ -1612,9 +1761,7 @@ This is a tree-sitter equivalent of `end-of-defun'. Behavior of this function depends on `treesit-defun-type-regexp' and `treesit-defun-skipper'." (interactive "^p\nd") - (when-let* ((arg (or arg 1)) - (dest (treesit--navigate-defun (point) arg 'end))) - (goto-char dest) + (when (treesit-end-of-thing treesit-defun-type-regexp arg) (when treesit-defun-skipper (funcall treesit-defun-skipper)))) @@ -1632,13 +1779,17 @@ comments and multiline string literals. For example, This function tries to move to the beginning of a line, either by moving to the empty newline after a defun, or to the beginning of the current line if the beginning of the defun is indented." - (cond ((and (looking-at (rx (* (or " " "\\t")) "\n")) - (not (looking-at (rx bol)))) - (goto-char (match-end 0))) - ((save-excursion - (skip-chars-backward " \t") - (eq (point) (line-beginning-position))) - (goto-char (line-beginning-position))))) + ;; Moving forward, point at the end of a line and not already on an + ;; empty line: go to BOL of the next line (which hopefully is an + ;; empty line). + (cond ((and (looking-at (rx (* (or " " "\t")) "\n")) + (not (bolp))) + (forward-line 1)) + ;; Moving backward, but there are some whitespace (and only + ;; whitespace) between point and BOL: go back to BOL. + ((looking-back (rx (+ (or " " "\t"))) + (line-beginning-position)) + (beginning-of-line)))) ;; prev-sibling: ;; 1. end-of-node before pos @@ -1651,85 +1802,77 @@ the current line if the beginning of the defun is indented." ;; parent: ;; 1. node covers pos ;; 2. smallest such node -(defun treesit--defuns-around (pos regexp &optional pred) - "Return the previous, next, and parent defun around POS. +(defun treesit--things-around (pos regexp &optional pred) + "Return the previous, next, and parent thing around POS. Return a list of (PREV NEXT PARENT), where PREV and NEXT are -previous and next sibling defuns around POS, and PARENT is the -parent defun surrounding POS. All of three could be nil if no -sound defun exists. +previous and next sibling things around POS, and PARENT is the +parent thing surrounding POS. All of three could be nil if no +sound things exists. -REGEXP and PRED are the same as in `treesit-defun-type-regexp'." +REGEXP and PRED are the same as in `treesit-thing-at-point'." (let* ((node (treesit-node-at pos)) - ;; NODE-BEFORE/AFTER = NODE when POS is completely in NODE, - ;; but if not, that means point could be in between two - ;; defun, in that case we want to use a node that's actually - ;; before/after point. - (node-before (if (>= (treesit-node-start node) pos) - (treesit-search-forward-goto node "" t t t) - node)) - (node-after (if (<= (treesit-node-end node) pos) - (treesit-search-forward-goto node "" nil nil t) - node)) - (result (list nil nil nil)) - (pred (or pred (lambda (_) t)))) + (result (list nil nil nil))) ;; 1. Find previous and next sibling defuns. (cl-loop for idx from 0 to 1 - for node in (list node-before node-after) for backward in '(t nil) + ;; Make sure we go in the right direction, and the defun we find + ;; doesn't cover POS. for pos-pred in (list (lambda (n) (<= (treesit-node-end n) pos)) (lambda (n) (>= (treesit-node-start n) pos))) - ;; If point is inside a defun, our process below will never - ;; return a next/prev sibling outside of that defun, effectively - ;; any prev/next sibling is locked inside the smallest defun - ;; covering point, which is the correct behavior. That's because - ;; when there exists a defun that covers point, - ;; `treesit-search-forward' will first reach that defun, after - ;; that we only go upwards in the tree, so other defuns outside - ;; of the covering defun is never reached. (Don't use - ;; `treesit-search-forward-goto' as it breaks when NODE-AFTER is - ;; the last token of a parent defun: it will skip the parent - ;; defun because it wants to ensure progress.) - do (cl-loop for cursor = (when node - (save-excursion - (treesit-search-forward - node regexp backward backward))) - then (treesit-node-parent cursor) - while cursor - if (and (string-match-p - regexp (treesit-node-type cursor)) - (funcall pred cursor) - (funcall pos-pred cursor)) - do (setf (nth idx result) cursor))) + ;; We repeatedly find next defun candidate with + ;; `treesit-search-forward', and check if it is a valid defun, + ;; until the node we find covers POS, meaning we've gone through + ;; every possible sibling defuns. But there is a catch: + ;; `treesit-search-forward' searches bottom-up, so for each + ;; candidate we need to go up the tree and find the top-most + ;; valid sibling, this defun will be at the same level as POS. + ;; Don't use `treesit-search-forward-goto', it skips nodes in + ;; order to enforce progress. + when node + do (let ((cursor node) + (iter-pred (lambda (node) + (and (string-match-p + regexp (treesit-node-type node)) + (or (null pred) (funcall pred node)) + (funcall pos-pred node))))) + ;; Find the node just before/after POS to start searching. + (save-excursion + (while (and cursor (not (funcall pos-pred cursor))) + (setq cursor (treesit-search-forward-goto + cursor "" backward backward t)))) + ;; Keep searching until we run out of candidates. + (while (and cursor + (funcall pos-pred cursor) + (null (nth idx result))) + (setf (nth idx result) + (treesit-node-top-level cursor iter-pred t)) + (setq cursor (treesit-search-forward + cursor regexp backward backward))))) ;; 2. Find the parent defun. - (setf (nth 2 result) - (cl-loop for cursor = (or (nth 0 result) - (nth 1 result) - node) - then (treesit-node-parent cursor) - while cursor - if (and (string-match-p - regexp (treesit-node-type cursor)) - (funcall pred cursor) - (not (member cursor result))) - return cursor)) + (let ((cursor (or (nth 0 result) (nth 1 result) node)) + (iter-pred (lambda (node) + (and (string-match-p + regexp (treesit-node-type node)) + (or (null pred) (funcall pred node)) + (not (treesit-node-eq node (nth 0 result))) + (not (treesit-node-eq node (nth 1 result))) + (< (treesit-node-start node) + pos + (treesit-node-end node)))))) + (setf (nth 2 result) + (treesit-parent-until cursor iter-pred))) result)) -(defun treesit--top-level-defun (node regexp &optional pred) - "Return the top-level parent defun of NODE. -REGEXP and PRED are the same as in `treesit-defun-type-regexp'." - (let* ((pred (or pred (lambda (_) t)))) - ;; `treesit-search-forward-goto' will make sure the matched node - ;; is before POS. - (cl-loop for cursor = node - then (treesit-node-parent cursor) - while cursor - if (and (string-match-p - regexp (treesit-node-type cursor)) - (funcall pred cursor)) - do (setq node cursor)) - node)) +(defun treesit--top-level-thing (node regexp &optional pred) + "Return the top-level parent thing of NODE. +REGEXP and PRED are the same as in `treesit-thing-at-point'." + (treesit-node-top-level + node (lambda (node) + (and (string-match-p regexp (treesit-node-type node)) + (or (null pred) (funcall pred node)))) + t)) ;; The basic idea for nested defun navigation is that we first try to ;; move across sibling defuns in the same level, if no more siblings @@ -1758,25 +1901,23 @@ REGEXP and PRED are the same as in `treesit-defun-type-regexp'." ;; -> Obviously we don't want to go to parent's end, instead, we ;; want to go to parent's prev-sibling's end. Again, we recurse ;; in the function to do that. -(defun treesit--navigate-defun (pos arg side &optional recursing) - "Navigate defun ARG steps from POS. +(defun treesit--navigate-thing (pos arg side regexp &optional pred recursing) + "Navigate thing ARG steps from POS. If ARG is positive, move forward that many steps, if negative, move backward. If SIDE is `beg', stop at the beginning of a -defun, if SIDE is `end', stop at the end. +thing, if SIDE is `end', stop at the end. This function doesn't actually move point, it just returns the -position it would move to. If there aren't enough defuns to move +position it would move to. If there aren't enough things to move across, return nil. +REGEXP and PRED are the same as in `treesit-thing-at-point'. + RECURSING is an internal parameter, if non-nil, it means this function is called recursively." (pcase-let* ((counter (abs arg)) - (`(,regexp . ,pred) - (if (consp treesit-defun-type-regexp) - treesit-defun-type-regexp - (cons treesit-defun-type-regexp nil))) ;; Move POS to the beg/end of NODE. If NODE is nil, terminate. ;; Return the position we moved to. (advance (lambda (node) @@ -1790,13 +1931,13 @@ function is called recursively." (while (> counter 0) (pcase-let ((`(,prev ,next ,parent) - (treesit--defuns-around pos regexp pred))) + (treesit--things-around pos regexp pred))) ;; When PARENT is nil, nested and top-level are the same, if ;; there is a PARENT, make PARENT to be the top-level parent ;; and pretend there is no nested PREV and NEXT. (when (and (eq treesit-defun-tactic 'top-level) parent) - (setq parent (treesit--top-level-defun + (setq parent (treesit--top-level-thing parent regexp pred) prev nil next nil)) @@ -1817,9 +1958,9 @@ function is called recursively." ;; (recursing) until we got out of the parents until ;; (1) there is a next sibling defun, or (2) no more ;; parents [2]. - (setq pos (or (treesit--navigate-defun + (setq pos (or (treesit--navigate-thing (treesit-node-end (or next parent)) - 1 'beg t) + 1 'beg regexp pred t) (throw 'term nil))) ;; Normal case. (setq pos (funcall advance (or next parent)))) @@ -1829,9 +1970,9 @@ function is called recursively." (parent t) (t nil))) ;; Special case: go to prev end-of-defun. - (setq pos (or (treesit--navigate-defun + (setq pos (or (treesit--navigate-thing (treesit-node-start (or prev parent)) - -1 'end t) + -1 'end regexp pred t) (throw 'term nil))) ;; Normal case. (setq pos (funcall advance (or prev parent))))) @@ -1840,6 +1981,158 @@ function is called recursively." ;; Counter equal to 0 means we successfully stepped ARG steps. (if (eq counter 0) pos nil))) +;; TODO: In corporate into thing-at-point. +(defun treesit-thing-at-point (pattern tactic) + "Return the thing node at point or nil if none is found. + +\"Thing\" is defined by PATTERN, which can be either a string +REGEXP or a cons cell (REGEXP . PRED): if a node's type matches +REGEXP, it is a thing. The \"thing\" could be further restricted +by PRED: if non-nil, PRED should be a function that takes a node +and returns t if the node is a \"thing\", and nil if not. + +Return the top-level defun if TACTIC is `top-level', return the +immediate parent thing if TACTIC is `nested'." + (pcase-let* ((`(,regexp . ,pred) + (treesit--thing-unpack-pattern pattern)) + (`(,_ ,next ,parent) + (treesit--things-around (point) regexp pred)) + ;; If point is at the beginning of a thing, we + ;; prioritize that thing over the parent in nested + ;; mode. + (node (or (and (eq (treesit-node-start next) (point)) + next) + parent))) + (if (eq tactic 'top-level) + (treesit--top-level-thing node regexp pred) + node))) + +(defun treesit-defun-at-point () + "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'. + +Return nil if `treesit-defun-type-regexp' is not set." + (when treesit-defun-type-regexp + (treesit-thing-at-point + treesit-defun-type-regexp treesit-defun-tactic))) + +(defun treesit-defun-name (node) + "Return the defun name of NODE. + +Return nil if there is no name, or if NODE is not a defun node, +or if NODE is nil. + +If `treesit-defun-name-function' is nil, always return nil." + (when treesit-defun-name-function + (funcall treesit-defun-name-function node))) + +(defun treesit-add-log-current-defun () + "Return the name of the defun at point. + +Used for `add-log-current-defun-function'. + +The delimiter between nested defun names is controlled by +`treesit-add-log-defun-delimiter'." + (let ((node (treesit-defun-at-point)) + (name nil)) + (while node + (when-let ((new-name (treesit-defun-name node))) + (if name + (setq name (concat new-name + treesit-add-log-defun-delimiter + name)) + (setq name new-name))) + (setq node (treesit-node-parent node))) + name)) + +;;; Imenu + +(defvar treesit-simple-imenu-settings nil + "Settings that configure `treesit-simple-imenu'. + +It should be a list of (CATEGORY REGEXP PRED NAME-FN). + +CATEGORY is the name of a category, like \"Function\", \"Class\", +etc. REGEXP should be a regexp matching the type of nodes that +belong to CATEGORY. PRED should be either nil or a function +that takes a node an the argument. It should return non-nil if +the node is a valid node for CATEGORY, or nil if not. + +CATEGORY could also be nil. In that case the entries matched by +REGEXP and PRED are not grouped under CATEGORY. + +NAME-FN should be either nil or a function that takes a defun +node and returns the name of that defun node. If NAME-FN is nil, +`treesit-defun-name' is used. + +`treesit-major-mode-setup' automatically sets up Imenu if this +variable is non-nil.") + +(defun treesit--simple-imenu-1 (node pred name-fn) + "Given a sparse tree, create an Imenu index. + +NODE is a node in the tree returned by +`treesit-induce-sparse-tree' (not a tree-sitter node, its car is +a tree-sitter node). Walk that tree and return an Imenu index. + +Return a list of entries where each ENTRY has the form: + +ENTRY := (NAME . MARKER) + | (NAME . ((\" \" . MARKER) + ENTRY + ...) + +PRED and NAME-FN are the same as described in +`treesit-simple-imenu-settings'. NAME-FN computes NAME in an +ENTRY. MARKER marks the start of each tree-sitter node." + (let* ((ts-node (car node)) + (children (cdr node)) + (subtrees (mapcan (lambda (node) + (treesit--simple-imenu-1 node pred name-fn)) + children)) + ;; The root of the tree could have a nil ts-node. + (name (when ts-node + (or (if name-fn + (funcall name-fn ts-node) + (treesit-defun-name ts-node)) + "Anonymous"))) + (marker (when ts-node + (set-marker (make-marker) + (treesit-node-start ts-node))))) + (cond + ;; The tree-sitter node in the root node of the tree returned by + ;; `treesit-induce-sparse-tree' is often nil. + ((null ts-node) + subtrees) + ;; This tree-sitter node is not a valid entry, skip it. + ((and pred (not (funcall pred ts-node))) + subtrees) + ;; Non-leaf node, return a (list of) subgroup. + (subtrees + `((,name + ,(cons " " marker) + ,@subtrees))) + ;; Leaf node, return a (list of) plain index entry. + (t (list (cons name marker)))))) + +(defun treesit-simple-imenu () + "Return an Imenu index for the current buffer." + (let ((root (treesit-buffer-root-node))) + (mapcan (lambda (setting) + (pcase-let ((`(,category ,regexp ,pred ,name-fn) + setting)) + (when-let* ((tree (treesit-induce-sparse-tree + root regexp)) + (index (treesit--simple-imenu-1 + tree pred name-fn))) + (if category + (list (cons category index)) + index)))) + treesit-simple-imenu-settings))) + ;;; Activating tree-sitter (defun treesit-ready-p (language &optional quiet) @@ -1897,6 +2190,11 @@ If `treesit-simple-indent-rules' is non-nil, setup indentation. If `treesit-defun-type-regexp' is non-nil, setup `beginning/end-of-defun' functions. +If `treesit-defun-name-function' is non-nil, setup +`add-log-current-defun'. + +If `treesit-simple-imenu-settings' is non-nil, setup Imenu. + Make sure necessary parsers are created for the current buffer before calling this function." ;; Font-lock. @@ -1924,7 +2222,27 @@ before calling this function." (keymap-set (current-local-map) "<remap> <beginning-of-defun>" #'treesit-beginning-of-defun) (keymap-set (current-local-map) "<remap> <end-of-defun>" - #'treesit-end-of-defun))) + #'treesit-end-of-defun) + ;; `end-of-defun' will not work completely correctly in nested + ;; defuns due to its implementation. However, many lisp programs + ;; use `beginning/end-of-defun', so we should still set + ;; `beginning/end-of-defun-function' so they still mostly work. + ;; This is also what `cc-mode' does: rebind user commands and set + ;; the variables. In future we should update `end-of-defun' to + ;; work with nested defuns. + (setq-local beginning-of-defun-function #'treesit-beginning-of-defun) + (setq-local end-of-defun-function #'treesit-end-of-defun)) + ;; Defun name. + (when treesit-defun-name-function + (setq-local add-log-current-defun-function + #'treesit-add-log-current-defun)) + + (setq-local transpose-sexps-function #'treesit-transpose-sexps) + + ;; Imenu. + (when treesit-simple-imenu-settings + (setq-local imenu-create-index-function + #'treesit-simple-imenu))) ;;; Debugging diff --git a/lisp/url/url-future.el b/lisp/url/url-future.el index 56787f7c5ec..737eea32c6a 100644 --- a/lisp/url/url-future.el +++ b/lisp/url/url-future.el @@ -53,7 +53,7 @@ (define-inline url-future-errored-p (url-future) (inline-quote (eq (url-future-status ,url-future) 'error))) -(define-inline url-future-cancelled-p (url-future) +(define-inline url-future-canceled-p (url-future) (inline-quote (eq (url-future-status ,url-future) 'cancel))) (defun url-future-finish (url-future &optional status) @@ -96,5 +96,8 @@ (signal 'error 'url-future-already-done) (url-future-finish url-future 'cancel))) +(define-obsolete-function-alias 'url-future-cancelled-p + #'url-future-canceled-p "30.1") + (provide 'url-future) ;;; url-future.el ends here diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index 357ce001b3c..b80337eb742 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -272,8 +272,7 @@ and hunk-based syntax highlighting otherwise as a fallback." (defcustom diff-minor-mode-prefix "\C-c=" "Prefix key for `diff-minor-mode' commands." - :type '(choice (string "ESC") - (string "\C-c=") string)) + :type '(choice (string "\e") (string "\C-c=") string)) (defvar-keymap diff-minor-mode-map :doc "Keymap for `diff-minor-mode'. See also `diff-mode-shared-map'." diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 9f27f759d35..671be66bbef 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -1020,40 +1020,67 @@ It is based on `log-edit-mode', and has Git-specific extensions." ;; message. Handle also remote files. (if (eq system-type 'windows-nt) (let ((default-directory (file-name-directory file1))) - (make-nearby-temp-file "git-msg"))))) + (make-nearby-temp-file "git-msg")))) + to-stash) (when vc-git-patch-string (unless (zerop (vc-git-command nil t nil "diff" "--cached" "--quiet")) - ;; Check that all staged changes also exist in the patch. - ;; This is needed to allow adding/removing files that are - ;; currently staged to the index. So remove the whole file diff - ;; from the patch because commit will take it from the index. + ;; Check that what's already staged is compatible with what + ;; we want to commit (bug#60126). + ;; + ;; 1. If the changes to a file in the index are identical to + ;; the changes to that file we want to commit, remove the + ;; changes from our patch, and let the commit take them + ;; from the index. This is necessary for adding and + ;; removing files to work. + ;; + ;; 2. If the changes to a file in the index are different to + ;; changes to that file we want to commit, then we have to + ;; unstage the changes or abort. + ;; + ;; 3. If there are changes to a file in the index but we don't + ;; want to commit any changes to that file, we need to + ;; stash those changes before committing. (with-temp-buffer (vc-git-command (current-buffer) t nil "diff" "--cached") (goto-char (point-min)) - (let ((pos (point)) file-diff file-beg) + (let ((pos (point)) file-name file-header file-diff file-beg) (while (not (eobp)) + (when (and (looking-at "^diff --git a/\\(.+\\) b/\\(.+\\)") + (string= (match-string 1) (match-string 2))) + (setq file-name (match-string 1))) (forward-line 1) ; skip current "diff --git" line + (setq file-header (buffer-substring pos (point))) (search-forward "diff --git" nil 'move) (move-beginning-of-line 1) (setq file-diff (buffer-substring pos (point))) - (if (and (setq file-beg (string-search - file-diff vc-git-patch-string)) - ;; Check that file diff ends with an empty string - ;; or the beginning of the next file diff. - (string-match-p "\\`\\'\\|\\`diff --git" - (substring - vc-git-patch-string - (+ file-beg (length file-diff))))) - (setq vc-git-patch-string - (string-replace file-diff "" vc-git-patch-string)) - (user-error "Index not empty")) + (cond ((and (setq file-beg (string-search + file-diff vc-git-patch-string)) + ;; Check that file diff ends with an empty string + ;; or the beginning of the next file diff. + (string-match-p "\\`\\'\\|\\`diff --git" + (substring + vc-git-patch-string + (+ file-beg (length file-diff))))) + (setq vc-git-patch-string + (string-replace file-diff "" vc-git-patch-string))) + ((string-match (format "^%s" (regexp-quote file-header)) + vc-git-patch-string) + (if (and file-name + (yes-or-no-p + (format "Unstage already-staged changes to %s?" + file-name))) + (vc-git-command nil 0 file-name "reset" "-q" "--") + (user-error "Index not empty"))) + (t (push file-name to-stash))) (setq pos (point)))))) - (let ((patch-file (make-nearby-temp-file "git-patch"))) - (with-temp-file patch-file - (insert vc-git-patch-string)) - (unwind-protect - (vc-git-command nil 0 patch-file "apply" "--cached") - (delete-file patch-file)))) + (unless (string-empty-p vc-git-patch-string) + (let ((patch-file (make-nearby-temp-file "git-patch"))) + (with-temp-file patch-file + (insert vc-git-patch-string)) + (unwind-protect + (vc-git-command nil 0 patch-file "apply" "--cached") + (delete-file patch-file)))) + (when to-stash (vc-git--stash-staged-changes files))) (cl-flet ((boolean-arg-fn (argument) (lambda (value) (when (equal value "yes") (list argument))))) @@ -1079,7 +1106,58 @@ It is based on `log-edit-mode', and has Git-specific extensions." args) (unless vc-git-patch-string (if only (list "--only" "--") '("-a")))))) - (if (and msg-file (file-exists-p msg-file)) (delete-file msg-file)))) + (if (and msg-file (file-exists-p msg-file)) (delete-file msg-file)) + (when to-stash + (let ((cached (make-nearby-temp-file "git-cached"))) + (unwind-protect + (progn (with-temp-file cached + (vc-git-command t 0 nil "stash" "show" "-p")) + (vc-git-command nil 0 cached "apply" "--cached")) + (delete-file cached)) + (vc-git-command nil 0 nil "stash" "drop"))))) + +(defun vc-git--stash-staged-changes (files) + "Stash only the staged changes to FILES." + ;; This is necessary because even if you pass a list of file names + ;; to 'git stash push', it will stash any and all staged changes. + (unless (zerop + (vc-git-command nil t files "diff" "--cached" "--quiet")) + (cl-flet + ((git-string (&rest args) + (string-trim-right + (with-output-to-string + (apply #'vc-git-command standard-output 0 nil args))))) + (let ((cached (make-nearby-temp-file "git-cached")) + (message "Previously staged changes") + tree) + ;; Use a temporary index to create a tree object corresponding + ;; to the staged changes to FILES. + (unwind-protect + (progn + (with-temp-file cached + (vc-git-command t 0 files "diff" "--cached" "--")) + (let* ((index (make-nearby-temp-file "git-index")) + (process-environment + (cons (format "GIT_INDEX_FILE=%s" index) + process-environment))) + (unwind-protect + (progn + (vc-git-command nil 0 nil "read-tree" "HEAD") + (vc-git-command nil 0 cached "apply" "--cached") + (setq tree (git-string "write-tree"))) + (delete-file index)))) + (delete-file cached)) + ;; Prepare stash commit object, which has a special structure. + (let* ((tree-commit (git-string "commit-tree" "-m" message + "-p" "HEAD" tree)) + (stash-commit (git-string "commit-tree" "-m" message + "-p" "HEAD" "-p" tree-commit + tree))) + ;; Push the new stash entry. + (vc-git-command nil 0 nil "update-ref" "--create-reflog" + "-m" message "refs/stash" stash-commit) + ;; Unstage the changes we've now stashed. + (vc-git-command nil 0 files "reset" "--")))))) (defun vc-git-find-revision (file rev buffer) (let* (process-file-side-effects diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index 690c907c77e..130214b840a 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -3369,7 +3369,7 @@ If nil, no default will be used. This option may be set locally." (declare-function message--name-table "message" (orig-string)) (declare-function mml-attach-buffer "mml" - (buffer &optional type description disposition)) + (buffer &optional type description disposition filename)) (declare-function log-view-get-marked "log-view" ()) (defun vc-default-prepare-patch (_backend rev) @@ -3410,6 +3410,19 @@ of the current file." (and-let* ((file (buffer-file-name))) (vc-working-revision file))))) +(defun vc--subject-to-file-name (subject) + "Generate a file name for a patch with subject line SUBJECT." + (let* ((stripped + (replace-regexp-in-string "\\`\\[.*PATCH.*\\]\\s-*" "" + subject)) + (truncated (if (length> stripped 50) + (substring stripped 0 50) + stripped))) + (concat + (string-trim (replace-regexp-in-string "\\W" "-" truncated) + "-+" "-+") + ".patch"))) + ;;;###autoload (defun vc-prepare-patch (addressee subject revisions) "Compose an Email sending patches for REVISIONS to ADDRESSEE. @@ -3420,7 +3433,7 @@ revision, with SUBJECT derived from each revision subject. When invoked with a numerical prefix argument, use the last N revisions. When invoked interactively in a Log View buffer with -marked revisions, use those these." +marked revisions, use those." (interactive (let ((revs (vc-prepare-patch-prompt-revisions)) to) (require 'message) @@ -3466,11 +3479,17 @@ marked revisions, use those these." (rfc822-goto-eoh) (forward-line) (save-excursion - (dolist (patch patches) - (mml-attach-buffer (buffer-name (plist-get patch :buffer)) - "text/x-patch" - (plist-get patch :subject) - "attachment"))) + (let ((i 0)) + (dolist (patch patches) + (let* ((patch-subject (plist-get patch :subject)) + (filename + (vc--subject-to-file-name patch-subject))) + (mml-attach-buffer + (buffer-name (plist-get patch :buffer)) + "text/x-patch" + patch-subject + "attachment" + (format "%04d-%s" (cl-incf i) filename)))))) (open-line 2))))) (defun vc-default-responsible-p (_backend _file) diff --git a/lisp/whitespace.el b/lisp/whitespace.el index 25ea07e9db7..558be1841ab 100644 --- a/lisp/whitespace.el +++ b/lisp/whitespace.el @@ -2093,6 +2093,17 @@ resultant list will be returned." t)) +(defun whitespace--clone () + "Hook function run after `make-indirect-buffer' and `clone-buffer'." + (when (whitespace-style-face-p) + (setq-local whitespace-bob-marker + (copy-marker (marker-position whitespace-bob-marker) + (marker-insertion-type whitespace-bob-marker))) + (setq-local whitespace-eob-marker + (copy-marker (marker-position whitespace-eob-marker) + (marker-insertion-type whitespace-eob-marker))))) + + (defun whitespace-color-on () "Turn on color visualization." (when (whitespace-style-face-p) @@ -2111,6 +2122,8 @@ resultant list will be returned." ;; The -1 ensures that it runs before any ;; `font-lock-mode' hook functions. -1 t) + (add-hook 'clone-buffer-hook #'whitespace--clone nil t) + (add-hook 'clone-indirect-buffer-hook #'whitespace--clone nil t) ;; Add whitespace-mode color into font lock. (setq whitespace-font-lock-keywords @@ -2204,6 +2217,8 @@ resultant list will be returned." (remove-hook 'before-change-functions #'whitespace-buffer-changed t) (remove-hook 'after-change-functions #'whitespace--update-bob-eob t) + (remove-hook 'clone-buffer-hook #'whitespace--clone t) + (remove-hook 'clone-indirect-buffer-hook #'whitespace--clone t) (font-lock-remove-keywords nil whitespace-font-lock-keywords) (font-lock-flush))) @@ -2268,10 +2283,11 @@ Highlighting those lines can be distracting.)" (save-excursion (goto-char whitespace-point) (line-beginning-position))))) (when (= p 1) - ;; See the comment in `whitespace--update-bob-eob' for why this - ;; text property is added here. - (put-text-property 1 whitespace-bob-marker - 'font-lock-multiline t)) + (with-silent-modifications + ;; See the comment in `whitespace--update-bob-eob' for why + ;; this text property is added here. + (put-text-property 1 whitespace-bob-marker + 'font-lock-multiline t))) (when (< p e) (set-match-data (list p e)) (goto-char e)))) @@ -2292,10 +2308,11 @@ about to start typing, and if they do, that line and previous empty lines will no longer be EoB empty lines. Highlighting those lines can be distracting.)" (when (= limit (1+ (buffer-size))) - ;; See the comment in `whitespace--update-bob-eob' for why this - ;; text property is added here. - (put-text-property whitespace-eob-marker limit - 'font-lock-multiline t)) + (with-silent-modifications + ;; See the comment in `whitespace--update-bob-eob' for why this + ;; text property is added here. + (put-text-property whitespace-eob-marker limit + 'font-lock-multiline t))) (let ((b (max (point) whitespace-eob-marker whitespace-bob-marker ; See comment in the bob func. (save-excursion (goto-char whitespace-point) @@ -2437,8 +2454,9 @@ purposes)." (save-match-data (when (looking-at whitespace-empty-at-bob-regexp) (set-marker whitespace-bob-marker (match-end 1)) - (put-text-property (match-beginning 1) (match-end 1) - 'font-lock-multiline t)))) + (with-silent-modifications + (put-text-property (match-beginning 1) (match-end 1) + 'font-lock-multiline t))))) (when (or (null end) (>= end (save-excursion (goto-char whitespace-eob-marker) @@ -2451,8 +2469,9 @@ purposes)." (when (whitespace--looking-back whitespace-empty-at-eob-regexp) (set-marker whitespace-eob-marker (match-beginning 1)) - (put-text-property (match-beginning 1) (match-end 1) - 'font-lock-multiline t))))))))) + (with-silent-modifications + (put-text-property (match-beginning 1) (match-end 1) + 'font-lock-multiline t)))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/lisp/window.el b/lisp/window.el index a4a84218818..5dd5b808831 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -10561,26 +10561,23 @@ displaying that processes's buffer." (defvar-keymap other-window-repeat-map :doc "Keymap to repeat `other-window' key sequences. Used in `repeat-mode'." + :repeat t "o" #'other-window "O" (lambda () (interactive) (setq repeat-map 'other-window-repeat-map) (other-window -1))) -(put 'other-window 'repeat-map 'other-window-repeat-map) (defvar-keymap resize-window-repeat-map :doc "Keymap to repeat window resizing commands. Used in `repeat-mode'." + :repeat t ;; Standard keys: "^" #'enlarge-window "}" #'enlarge-window-horizontally "{" #'shrink-window-horizontally ;; Additional keys: "v" #'shrink-window) -(put 'enlarge-window 'repeat-map 'resize-window-repeat-map) -(put 'enlarge-window-horizontally 'repeat-map 'resize-window-repeat-map) -(put 'shrink-window-horizontally 'repeat-map 'resize-window-repeat-map) -(put 'shrink-window 'repeat-map 'resize-window-repeat-map) (defvar-keymap window-prefix-map :doc "Keymap for subcommands of \\`C-x w'." diff --git a/lisp/winner.el b/lisp/winner.el index c8354b18bec..aed57aa0371 100644 --- a/lisp/winner.el +++ b/lisp/winner.el @@ -330,12 +330,10 @@ You may want to include buffer names such as *Help*, *Apropos*, (defvar-keymap winner-repeat-map :doc "Keymap to repeat winner key sequences. Used in `repeat-mode'." + :repeat t "<left>" #'winner-undo "<right>" #'winner-redo) -(put #'winner-undo 'repeat-map 'winner-repeat-map) -(put #'winner-redo 'repeat-map 'winner-repeat-map) - ;;;###autoload (define-minor-mode winner-mode |