From b58fd1eab9e7a07711b63f5ce67d518972efaba9 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 16 Jan 2021 16:32:00 +0200 Subject: ; * lisp/language/cham.el: Fix copy-paste mistake in comment. --- lisp/language/cham.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/language/cham.el b/lisp/language/cham.el index 4749f2e8db4..be1a6b4f4c1 100644 --- a/lisp/language/cham.el +++ b/lisp/language/cham.el @@ -23,7 +23,7 @@ ;;; Commentary: -;; Tai Viet is being included in the Unicode at the range U+AA80..U+AADF. +;; Cham script is included in the Unicode at the range U+AA00..U+AA5F. ;;; Code: -- cgit v1.2.3 From 849fe71de7b041c21cb776c7428c39e0ce67df14 Mon Sep 17 00:00:00 2001 From: Fabrice Bauzac Date: Mon, 18 Jan 2021 23:02:21 +0100 Subject: Sort Ibuffer filename/process column as displayed * lisp/ibuf-ext.el (ibuffer-do-sort-by-filename/process): Use the same function for sorting and for displaying the filename/process (Bug#45800). Copyright-paperwork-exempt: yes --- lisp/ibuf-ext.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'lisp') diff --git a/lisp/ibuf-ext.el b/lisp/ibuf-ext.el index ed5c9c02115..44574abd46a 100644 --- a/lisp/ibuf-ext.el +++ b/lisp/ibuf-ext.el @@ -1497,10 +1497,10 @@ Ordering is lexicographic." (string-lessp ;; FIXME: For now just compare the file name and the process name ;; (if it exists). Is there a better way to do this? - (or (buffer-file-name (car a)) + (or (with-current-buffer (car a) (ibuffer-buffer-file-name)) (let ((pr-a (get-buffer-process (car a)))) (and (processp pr-a) (process-name pr-a)))) - (or (buffer-file-name (car b)) + (or (with-current-buffer (car b) (ibuffer-buffer-file-name)) (let ((pr-b (get-buffer-process (car b)))) (and (processp pr-b) (process-name pr-b)))))) -- cgit v1.2.3 From f30cf07ecba8f4316b268b7ad57705a0aa16d660 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 20 Jan 2021 16:58:09 +0100 Subject: Make symbol-at-point return nil if there's no symbols in the buffer * lisp/thingatpt.el (thing-at-point--beginning-of-symbol): Special op that errors out when there's no symbols in the buffer before point (bug#14234). (symbol): Use it. --- lisp/thingatpt.el | 9 +++++++++ test/lisp/thingatpt-tests.el | 1 - 2 files changed, 9 insertions(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/thingatpt.el b/lisp/thingatpt.el index d3ba941fcc2..67d4092d407 100644 --- a/lisp/thingatpt.el +++ b/lisp/thingatpt.el @@ -218,6 +218,15 @@ The bounds of THING are determined by `bounds-of-thing-at-point'." (put 'sexp 'beginning-op 'thing-at-point--beginning-of-sexp) +;; Symbols + +(put 'symbol 'beginning-op 'thing-at-point--beginning-of-symbol) + +(defun thing-at-point--beginning-of-symbol () + "Move point to the beginning of the current symbol." + (and (re-search-backward "\\(\\sw\\|\\s_\\)+") + (skip-syntax-backward "w_"))) + ;; Lists (put 'list 'bounds-of-thing-at-point 'thing-at-point-bounds-of-list-at-point) diff --git a/test/lisp/thingatpt-tests.el b/test/lisp/thingatpt-tests.el index 8eec853d461..62a27f09cbd 100644 --- a/test/lisp/thingatpt-tests.el +++ b/test/lisp/thingatpt-tests.el @@ -185,7 +185,6 @@ position to retrieve THING.") (should (eq (symbol-at-point) 'bar)))) (ert-deftest test-symbol-thing-3 () - :expected-result :failed ; FIXME bug#14234 (with-temp-buffer (insert "`[[`(") (goto-char 2) -- cgit v1.2.3 From cad2c4b14a98d24d6cba4089bd48340899dcff52 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 20 Jan 2021 17:25:40 +0100 Subject: Tweak tty-find-type to allow TERM=screen.xterm * lisp/faces.el (tty-find-type): Allow TERM=screen.xterm to find term/screen.el (bug#45824). --- lisp/faces.el | 2 +- test/lisp/faces-tests.el | 8 ++++++++ 2 files changed, 9 insertions(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/faces.el b/lisp/faces.el index 4e98338432f..d654b1f0e2a 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -2199,7 +2199,7 @@ the above example." (not (funcall pred type))) ;; Strip off last hyphen and what follows, then try again (setq type - (if (setq hyphend (string-match-p "[-_][^-_]+$" type)) + (if (setq hyphend (string-match-p "[-_.][^-_.]+$" type)) (substring type 0 hyphend) nil)))) type) diff --git a/test/lisp/faces-tests.el b/test/lisp/faces-tests.el index 6e77259fe1b..c0db9c9de17 100644 --- a/test/lisp/faces-tests.el +++ b/test/lisp/faces-tests.el @@ -217,5 +217,13 @@ )) ) +(ert-deftest test-tty-find-type () + (let ((pred (lambda (string) + (locate-library (concat "term/" string ".el"))))) + (should (tty-find-type pred "cygwin")) + (should (tty-find-type pred "cygwin-foo")) + (should (equal (tty-find-type pred "xterm") "xterm")) + (should (equal (tty-find-type pred "screen.xterm") "screen")))) + (provide 'faces-tests) ;;; faces-tests.el ends here -- cgit v1.2.3 From 72d4522b05c81ba9400603963db55e47c6d836ce Mon Sep 17 00:00:00 2001 From: Gabriel do Nascimento Ribeiro Date: Wed, 20 Jan 2021 17:45:08 +0100 Subject: Add option remember-diary-regexp * lisp/textmodes/remember.el (remember-diary-extract-entries): Use it (bug#45808). (remember-diary-regexp): New variable. --- etc/NEWS | 3 +++ lisp/textmodes/remember.el | 12 +++++++++--- 2 files changed, 12 insertions(+), 3 deletions(-) (limited to 'lisp') diff --git a/etc/NEWS b/etc/NEWS index 7a012b48912..a0e1e3b2a18 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1557,6 +1557,9 @@ that makes it a valid button. ** Miscellaneous +--- +*** New user option 'remember-diary-regexp'. + *** New function 'buffer-line-statistics'. This function returns some statistics about the line lengths in a buffer. diff --git a/lisp/textmodes/remember.el b/lisp/textmodes/remember.el index 98d3a3856ea..92706e38073 100644 --- a/lisp/textmodes/remember.el +++ b/lisp/textmodes/remember.el @@ -159,7 +159,8 @@ ;; ;; This should be before other entries that may return t ;; (add-to-list 'remember-handler-functions 'remember-diary-extract-entries) ;; -;; This module recognizes entries of the form +;; This module recognizes entries of the form (defined by +;; `remember-diary-regexp') ;; ;; DIARY: .... ;; @@ -532,13 +533,18 @@ If this is nil, then `diary-file' will be used instead." (autoload 'diary-make-entry "diary-lib") +(defcustom remember-diary-regexp "^DIARY:\\s-*\\(.+\\)" + "Regexp to extract diary entries." + :type 'regexp + :version "28.1") + ;;;###autoload (defun remember-diary-extract-entries () - "Extract diary entries from the region." + "Extract diary entries from the region based on `remember-diary-regexp'." (save-excursion (goto-char (point-min)) (let (list) - (while (re-search-forward "^DIARY:\\s-*\\(.+\\)" nil t) + (while (re-search-forward remember-diary-regexp nil t) (push (remember-diary-convert-entry (match-string 1)) list)) (when list (diary-make-entry (mapconcat 'identity list "\n") -- cgit v1.2.3 From edf6350e7ffd51f93fd84df3e0f9734e337cd51c Mon Sep 17 00:00:00 2001 From: Gabriel do Nascimento Ribeiro Date: Wed, 20 Jan 2021 17:53:04 +0100 Subject: Add option remember-text-format-function * lisp/textmodes/remember.el (remember-text-format-function): New variable (bug#45809). (remember-append-to-file): Use it. --- etc/NEWS | 3 +++ lisp/textmodes/remember.el | 17 ++++++++++++++--- 2 files changed, 17 insertions(+), 3 deletions(-) (limited to 'lisp') diff --git a/etc/NEWS b/etc/NEWS index a0e1e3b2a18..c8cbce1882a 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1560,6 +1560,9 @@ that makes it a valid button. --- *** New user option 'remember-diary-regexp'. +--- +*** New user option 'remember-text-format-function'. + *** New function 'buffer-line-statistics'. This function returns some statistics about the line lengths in a buffer. diff --git a/lisp/textmodes/remember.el b/lisp/textmodes/remember.el index 92706e38073..6c94f8d03c8 100644 --- a/lisp/textmodes/remember.el +++ b/lisp/textmodes/remember.el @@ -411,13 +411,24 @@ The default emulates `current-time-string' for backward compatibility." :group 'remember :version "27.1") +(defcustom remember-text-format-function nil + "The function to format the remembered text. +The function receives the remembered text as argument and should +return the text to be remembered." + :type 'function + :group 'remember + :version "28.1") + (defun remember-append-to-file () "Remember, with description DESC, the given TEXT." (let* ((text (buffer-string)) (desc (remember-buffer-desc)) - (remember-text (concat "\n" remember-leader-text - (format-time-string remember-time-format) - " (" desc ")\n\n" text + (remember-text (concat "\n" + (if remember-text-format-function + (funcall remember-text-format-function text) + (concat remember-leader-text + (format-time-string remember-time-format) + " (" desc ")\n\n" text)) (save-excursion (goto-char (point-max)) (if (bolp) nil "\n")))) (buf (find-buffer-visiting remember-data-file))) -- cgit v1.2.3 From 38173af10df67cb36521cdcc2f1f42103d67de98 Mon Sep 17 00:00:00 2001 From: Gabriel do Nascimento Ribeiro Date: Wed, 20 Jan 2021 17:54:43 +0100 Subject: Respect remember-save-after-remembering on remember-diary-extract-entries * lisp/textmodes/remember.el (remember-diary-extract-entries): Save automatically if `remember-save-after-remembering' is non-nil (bug#45811). --- lisp/textmodes/remember.el | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/textmodes/remember.el b/lisp/textmodes/remember.el index 6c94f8d03c8..7f107977d53 100644 --- a/lisp/textmodes/remember.el +++ b/lisp/textmodes/remember.el @@ -559,7 +559,10 @@ If this is nil, then `diary-file' will be used instead." (push (remember-diary-convert-entry (match-string 1)) list)) (when list (diary-make-entry (mapconcat 'identity list "\n") - nil remember-diary-file)) + nil remember-diary-file) + (when remember-save-after-remembering + (with-current-buffer (find-buffer-visiting diary-file) + (save-buffer)))) nil))) ;; Continue processing ;;; Internal Functions: -- cgit v1.2.3 From bd423b869978f33bea8d399684f02b0b5b53da43 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Wed, 20 Jan 2021 18:51:52 +0100 Subject: Fix environment handling in tramp-handle-make-process * lisp/net/tramp.el (tramp-test-message): Add `tramp-suppress-trace' property. (tramp-handle-make-process): Handle also 'tramp-remote-process-environment'. --- lisp/net/tramp.el | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) (limited to 'lisp') diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 2816c58fe7f..7b34a748822 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -1990,6 +1990,8 @@ the resulting error message." (tramp-dissect-file-name default-directory) 0 fmt-string arguments) (apply #'message fmt-string arguments))) +(put #'tramp-test-message 'tramp-suppress-trace t) + ;; This function provides traces in case of errors not triggered by ;; Tramp functions. (defun tramp-signal-hook-function (error-symbol data) @@ -3801,15 +3803,20 @@ It does not support `:stderr'." (get-buffer-create buffer) ;; BUFFER can be nil. We use a temporary buffer. (generate-new-buffer tramp-temp-buffer-name))) - ;; We use as environment the difference to toplevel - ;; `process-environment'. (env (mapcar (lambda (elt) - (unless - (member - elt (default-toplevel-value 'process-environment)) - (when (string-match-p "=" elt) elt))) - process-environment)) + (when (string-match-p "=" elt) elt)) + tramp-remote-process-environment)) + ;; We use as environment the difference to toplevel + ;; `process-environment'. + (env (dolist (elt process-environment env) + (when + (and + (string-match-p "=" elt) + (not + (member + elt (default-toplevel-value 'process-environment)))) + (setq env (cons elt env))))) (env (setenv-internal env "INSIDE_EMACS" (concat (or (getenv "INSIDE_EMACS") emacs-version) -- cgit v1.2.3 From 7fe7efe0bbb00a541df1da68ca4cb4af14441fe1 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 20 Jan 2021 18:52:17 +0100 Subject: cua-toggle-global-mark doc string clarification * lisp/emulation/cua-gmrk.el (cua-toggle-global-mark): Clarify that also inserted characters are affected (bug#8083). --- lisp/emulation/cua-gmrk.el | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) (limited to 'lisp') diff --git a/lisp/emulation/cua-gmrk.el b/lisp/emulation/cua-gmrk.el index 195bba1f317..6f6b9fce130 100644 --- a/lisp/emulation/cua-gmrk.el +++ b/lisp/emulation/cua-gmrk.el @@ -87,9 +87,11 @@ (defun cua-toggle-global-mark (stay) "Set or cancel the global marker. -When the global marker is set, CUA cut and copy commands will automatically -insert the deleted or copied text before the global marker, even when the -global marker is in another buffer. +When the global marker is set, CUA cut and copy commands will +automatically insert the inserted, deleted or copied text before +the global marker, even when the global marker is in another +buffer. + If the global marker isn't set, set the global marker at point in the current buffer. Otherwise jump to the global marker position and cancel it. With prefix argument, don't jump to global mark when canceling it." -- cgit v1.2.3 From 434057ad925cad3ebcae1802fab60733ae5decae Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 20 Jan 2021 19:42:21 +0100 Subject: Fix footnote-mode problem when reopening an old file * lisp/mail/footnote.el (footnote--regenerate-alist): New function (bug#7258). (footnote-mode): Use it to restore footnotes after opening an old file with footnotes. --- lisp/mail/footnote.el | 27 ++++++++++++++++++++++++++- 1 file changed, 26 insertions(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/mail/footnote.el b/lisp/mail/footnote.el index ea109eec12a..9c1a738035e 100644 --- a/lisp/mail/footnote.el +++ b/lisp/mail/footnote.el @@ -910,7 +910,32 @@ play around with the following keys: (unless (assoc bullet-regexp filladapt-token-table) (setq filladapt-token-table (append filladapt-token-table - (list (list bullet-regexp 'bullet))))))))) + (list (list bullet-regexp 'bullet))))))) + (footnote--regenerate-alist))) + +(defun footnote--regenerate-alist () + (save-excursion + (goto-char (point-min)) + (if (not (re-search-forward footnote-section-tag-regexp nil t)) + (error "No footnote section in this buffer") + (setq footnote--markers-alist + (cl-loop + with start-of-footnotes = (match-beginning 0) + with regexp = (footnote--current-regexp) + for (note text) in + (cl-loop for pos = (re-search-forward regexp nil t) + while pos + collect (list (match-string 1) + (copy-marker (match-beginning 0) t))) + do (goto-char (point-min)) + collect (cl-list* + (string-to-number note) + text + (cl-loop + for pos = (re-search-forward regexp start-of-footnotes t) + while pos + when (equal note (match-string 1)) + collect (copy-marker (match-beginning 0) t)))))))) (provide 'footnote) -- cgit v1.2.3 From 09bfb12edc57ace138090861e335366d8f1cc4b2 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 20 Jan 2021 13:54:11 -0500 Subject: * lisp/emacs-lisp/byte-opt.el (byte-optimize-lapcode): Re-indent --- lisp/emacs-lisp/byte-opt.el | 914 ++++++++++++++++++++++---------------------- 1 file changed, 457 insertions(+), 457 deletions(-) (limited to 'lisp') diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index f29f85b9650..6d1f4179ce1 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1561,467 +1561,467 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; You may notice that sequences like "dup varset discard" are ;; optimized but sequences like "dup varset TAG1: discard" are not. ;; You may be tempted to change this; resist that temptation. - (cond ;; - ;; pop --> - ;; ...including: - ;; const-X pop --> - ;; varref-X pop --> - ;; dup pop --> - ;; - ((and (eq 'byte-discard (car lap1)) - (memq (car lap0) side-effect-free)) - (setq keep-going t) - (setq tmp (aref byte-stack+-info (symbol-value (car lap0)))) - (setq rest (cdr rest)) - (cond ((= tmp 1) - (byte-compile-log-lap - " %s discard\t-->\t" lap0) - (setq lap (delq lap0 (delq lap1 lap)))) - ((= tmp 0) - (byte-compile-log-lap - " %s discard\t-->\t discard" lap0) - (setq lap (delq lap0 lap))) - ((= tmp -1) - (byte-compile-log-lap - " %s discard\t-->\tdiscard discard" lap0) - (setcar lap0 'byte-discard) - (setcdr lap0 0)) - ((error "Optimizer error: too much on the stack")))) - ;; - ;; goto*-X X: --> X: - ;; - ((and (memq (car lap0) byte-goto-ops) - (eq (cdr lap0) lap1)) - (cond ((eq (car lap0) 'byte-goto) - (setq lap (delq lap0 lap)) - (setq tmp "")) - ((memq (car lap0) byte-goto-always-pop-ops) - (setcar lap0 (setq tmp 'byte-discard)) - (setcdr lap0 0)) - ((error "Depth conflict at tag %d" (nth 2 lap0)))) - (and (memq byte-optimize-log '(t byte)) - (byte-compile-log " (goto %s) %s:\t-->\t%s %s:" - (nth 1 lap1) (nth 1 lap1) - tmp (nth 1 lap1))) - (setq keep-going t)) - ;; - ;; varset-X varref-X --> dup varset-X - ;; varbind-X varref-X --> dup varbind-X - ;; const/dup varset-X varref-X --> const/dup varset-X const/dup - ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup - ;; The latter two can enable other optimizations. - ;; - ;; For lexical variables, we could do the same - ;; stack-set-X+1 stack-ref-X --> dup stack-set-X+2 - ;; but this is a very minor gain, since dup is stack-ref-0, - ;; i.e. it's only better if X>5, and even then it comes - ;; at the cost of an extra stack slot. Let's not bother. - ((and (eq 'byte-varref (car lap2)) - (eq (cdr lap1) (cdr lap2)) - (memq (car lap1) '(byte-varset byte-varbind))) - (if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars)) - (not (eq (car lap0) 'byte-constant))) - nil - (setq keep-going t) - (if (memq (car lap0) '(byte-constant byte-dup)) - (progn - (setq tmp (if (or (not tmp) - (macroexp--const-symbol-p - (car (cdr lap0)))) - (cdr lap0) - (byte-compile-get-constant t))) - (byte-compile-log-lap " %s %s %s\t-->\t%s %s %s" - lap0 lap1 lap2 lap0 lap1 - (cons (car lap0) tmp)) - (setcar lap2 (car lap0)) - (setcdr lap2 tmp)) - (byte-compile-log-lap " %s %s\t-->\tdup %s" lap1 lap2 lap1) - (setcar lap2 (car lap1)) - (setcar lap1 'byte-dup) - (setcdr lap1 0) - ;; The stack depth gets locally increased, so we will - ;; increase maxdepth in case depth = maxdepth here. - ;; This can cause the third argument to byte-code to - ;; be larger than necessary. - (setq add-depth 1)))) - ;; - ;; dup varset-X discard --> varset-X - ;; dup varbind-X discard --> varbind-X - ;; dup stack-set-X discard --> stack-set-X-1 - ;; (the varbind variant can emerge from other optimizations) - ;; - ((and (eq 'byte-dup (car lap0)) - (eq 'byte-discard (car lap2)) - (memq (car lap1) '(byte-varset byte-varbind - byte-stack-set))) - (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1) - (setq keep-going t - rest (cdr rest)) - (if (eq 'byte-stack-set (car lap1)) (cl-decf (cdr lap1))) - (setq lap (delq lap0 (delq lap2 lap)))) - ;; - ;; not goto-X-if-nil --> goto-X-if-non-nil - ;; not goto-X-if-non-nil --> goto-X-if-nil - ;; - ;; it is wrong to do the same thing for the -else-pop variants. - ;; - ((and (eq 'byte-not (car lap0)) - (memq (car lap1) '(byte-goto-if-nil byte-goto-if-not-nil))) - (byte-compile-log-lap " not %s\t-->\t%s" - lap1 - (cons - (if (eq (car lap1) 'byte-goto-if-nil) - 'byte-goto-if-not-nil - 'byte-goto-if-nil) - (cdr lap1))) - (setcar lap1 (if (eq (car lap1) 'byte-goto-if-nil) - 'byte-goto-if-not-nil - 'byte-goto-if-nil)) - (setq lap (delq lap0 lap)) - (setq keep-going t)) - ;; - ;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X: - ;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X: - ;; - ;; it is wrong to do the same thing for the -else-pop variants. - ;; - ((and (memq (car lap0) - '(byte-goto-if-nil byte-goto-if-not-nil)) ; gotoX - (eq 'byte-goto (car lap1)) ; gotoY - (eq (cdr lap0) lap2)) ; TAG X - (let ((inverse (if (eq 'byte-goto-if-nil (car lap0)) - 'byte-goto-if-not-nil 'byte-goto-if-nil))) - (byte-compile-log-lap " %s %s %s:\t-->\t%s %s:" - lap0 lap1 lap2 - (cons inverse (cdr lap1)) lap2) - (setq lap (delq lap0 lap)) - (setcar lap1 inverse) - (setq keep-going t))) - ;; - ;; const goto-if-* --> whatever - ;; - ((and (eq 'byte-constant (car lap0)) - (memq (car lap1) byte-conditional-ops) - ;; If the `byte-constant's cdr is not a cons cell, it has - ;; to be an index into the constant pool); even though - ;; it'll be a constant, that constant is not known yet - ;; (it's typically a free variable of a closure, so will - ;; only be known when the closure will be built at - ;; run-time). - (consp (cdr lap0))) - (cond ((if (memq (car lap1) '(byte-goto-if-nil - byte-goto-if-nil-else-pop)) - (car (cdr lap0)) - (not (car (cdr lap0)))) - (byte-compile-log-lap " %s %s\t-->\t" - lap0 lap1) - (setq rest (cdr rest) - lap (delq lap0 (delq lap1 lap)))) - (t - (byte-compile-log-lap " %s %s\t-->\t%s" - lap0 lap1 - (cons 'byte-goto (cdr lap1))) - (when (memq (car lap1) byte-goto-always-pop-ops) - (setq lap (delq lap0 lap))) - (setcar lap1 'byte-goto))) - (setq keep-going t)) - ;; - ;; varref-X varref-X --> varref-X dup - ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup - ;; stackref-X [dup ...] stackref-X+N --> stackref-X [dup ...] dup - ;; We don't optimize the const-X variations on this here, - ;; because that would inhibit some goto optimizations; we - ;; optimize the const-X case after all other optimizations. - ;; - ((and (memq (car lap0) '(byte-varref byte-stack-ref)) - (progn - (setq tmp (cdr rest)) - (setq tmp2 0) - (while (eq (car (car tmp)) 'byte-dup) - (setq tmp2 (1+ tmp2)) - (setq tmp (cdr tmp))) - t) - (eq (if (eq 'byte-stack-ref (car lap0)) - (+ tmp2 1 (cdr lap0)) - (cdr lap0)) - (cdr (car tmp))) - (eq (car lap0) (car (car tmp)))) - (if (memq byte-optimize-log '(t byte)) - (let ((str "")) - (setq tmp2 (cdr rest)) - (while (not (eq tmp tmp2)) - (setq tmp2 (cdr tmp2) - str (concat str " dup"))) - (byte-compile-log-lap " %s%s %s\t-->\t%s%s dup" - lap0 str lap0 lap0 str))) - (setq keep-going t) - (setcar (car tmp) 'byte-dup) - (setcdr (car tmp) 0) - (setq rest tmp)) - ;; - ;; TAG1: TAG2: --> TAG1: - ;; (and other references to TAG2 are replaced with TAG1) - ;; - ((and (eq (car lap0) 'TAG) - (eq (car lap1) 'TAG)) - (and (memq byte-optimize-log '(t byte)) - (byte-compile-log " adjacent tags %d and %d merged" - (nth 1 lap1) (nth 1 lap0))) - (setq tmp3 lap) - (while (setq tmp2 (rassq lap0 tmp3)) - (setcdr tmp2 lap1) - (setq tmp3 (cdr (memq tmp2 tmp3)))) - (setq lap (delq lap0 lap) - keep-going t) - ;; replace references to tag in jump tables, if any - (dolist (table byte-compile-jump-tables) - (maphash #'(lambda (value tag) - (when (equal tag lap0) - (puthash value lap1 table))) - table))) - ;; - ;; unused-TAG: --> - ;; - ((and (eq 'TAG (car lap0)) - (not (rassq lap0 lap)) - ;; make sure this tag isn't used in a jump-table - (cl-loop for table in byte-compile-jump-tables - when (member lap0 (hash-table-values table)) - return nil finally return t)) - (and (memq byte-optimize-log '(t byte)) - (byte-compile-log " unused tag %d removed" (nth 1 lap0))) - (setq lap (delq lap0 lap) - keep-going t)) - ;; - ;; goto ... --> goto - ;; return ... --> return - ;; (unless a jump-table is being used, where deleting may affect - ;; other valid case bodies) - ;; - ((and (memq (car lap0) '(byte-goto byte-return)) - (not (memq (car lap1) '(TAG nil))) - ;; FIXME: Instead of deferring simply when jump-tables are - ;; being used, keep a list of tags used for switch tags and - ;; use them instead (see `byte-compile-inline-lapcode'). - (not byte-compile-jump-tables)) - (setq tmp rest) - (let ((i 0) - (opt-p (memq byte-optimize-log '(t lap))) - str deleted) - (while (and (setq tmp (cdr tmp)) - (not (eq 'TAG (car (car tmp))))) - (if opt-p (setq deleted (cons (car tmp) deleted) - str (concat str " %s") - i (1+ i)))) - (if opt-p - (let ((tagstr - (if (eq 'TAG (car (car tmp))) - (format "%d:" (car (cdr (car tmp)))) - (or (car tmp) "")))) - (if (< i 6) - (apply 'byte-compile-log-lap-1 - (concat " %s" str - " %s\t-->\t%s %s") - lap0 - (nconc (nreverse deleted) - (list tagstr lap0 tagstr))) - (byte-compile-log-lap - " %s <%d unreachable op%s> %s\t-->\t%s %s" - lap0 i (if (= i 1) "" "s") - tagstr lap0 tagstr)))) - (rplacd rest tmp)) - (setq keep-going t)) - ;; - ;; unbind --> unbind - ;; (this may enable other optimizations.) - ;; - ((and (eq 'byte-unbind (car lap1)) - (memq (car lap0) byte-after-unbind-ops)) - (byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0) - (setcar rest lap1) - (setcar (cdr rest) lap0) - (setq keep-going t)) - ;; - ;; varbind-X unbind-N --> discard unbind-(N-1) - ;; save-excursion unbind-N --> unbind-(N-1) - ;; save-restriction unbind-N --> unbind-(N-1) - ;; - ((and (eq 'byte-unbind (car lap1)) - (memq (car lap0) '(byte-varbind byte-save-excursion - byte-save-restriction)) - (< 0 (cdr lap1))) - (if (zerop (setcdr lap1 (1- (cdr lap1)))) - (delq lap1 rest)) - (if (eq (car lap0) 'byte-varbind) - (setcar rest (cons 'byte-discard 0)) + (cond + ;; pop --> + ;; ...including: + ;; const-X pop --> + ;; varref-X pop --> + ;; dup pop --> + ;; + ((and (eq 'byte-discard (car lap1)) + (memq (car lap0) side-effect-free)) + (setq keep-going t) + (setq tmp (aref byte-stack+-info (symbol-value (car lap0)))) + (setq rest (cdr rest)) + (cond ((= tmp 1) + (byte-compile-log-lap + " %s discard\t-->\t" lap0) + (setq lap (delq lap0 (delq lap1 lap)))) + ((= tmp 0) + (byte-compile-log-lap + " %s discard\t-->\t discard" lap0) (setq lap (delq lap0 lap))) - (byte-compile-log-lap " %s %s\t-->\t%s %s" - lap0 (cons (car lap1) (1+ (cdr lap1))) - (if (eq (car lap0) 'byte-varbind) - (car rest) - (car (cdr rest))) - (if (and (/= 0 (cdr lap1)) - (eq (car lap0) 'byte-varbind)) - (car (cdr rest)) - "")) - (setq keep-going t)) - ;; - ;; goto*-X ... X: goto-Y --> goto*-Y - ;; goto-X ... X: return --> return - ;; - ((and (memq (car lap0) byte-goto-ops) - (memq (car (setq tmp (nth 1 (memq (cdr lap0) lap)))) - '(byte-goto byte-return))) - (cond ((and (not (eq tmp lap0)) - (or (eq (car lap0) 'byte-goto) - (eq (car tmp) 'byte-goto))) - (byte-compile-log-lap " %s [%s]\t-->\t%s" - (car lap0) tmp tmp) - (if (eq (car tmp) 'byte-return) - (setcar lap0 'byte-return)) - (setcdr lap0 (cdr tmp)) - (setq keep-going t)))) - ;; - ;; goto-*-else-pop X ... X: goto-if-* --> whatever - ;; goto-*-else-pop X ... X: discard --> whatever - ;; - ((and (memq (car lap0) '(byte-goto-if-nil-else-pop - byte-goto-if-not-nil-else-pop)) - (memq (car (car (setq tmp (cdr (memq (cdr lap0) lap))))) - (eval-when-compile - (cons 'byte-discard byte-conditional-ops))) - (not (eq lap0 (car tmp)))) - (setq tmp2 (car tmp)) - (setq tmp3 (assq (car lap0) '((byte-goto-if-nil-else-pop - byte-goto-if-nil) - (byte-goto-if-not-nil-else-pop - byte-goto-if-not-nil)))) - (if (memq (car tmp2) tmp3) - (progn (setcar lap0 (car tmp2)) - (setcdr lap0 (cdr tmp2)) - (byte-compile-log-lap " %s-else-pop [%s]\t-->\t%s" - (car lap0) tmp2 lap0)) - ;; Get rid of the -else-pop's and jump one step further. + ((= tmp -1) + (byte-compile-log-lap + " %s discard\t-->\tdiscard discard" lap0) + (setcar lap0 'byte-discard) + (setcdr lap0 0)) + ((error "Optimizer error: too much on the stack")))) + ;; + ;; goto*-X X: --> X: + ;; + ((and (memq (car lap0) byte-goto-ops) + (eq (cdr lap0) lap1)) + (cond ((eq (car lap0) 'byte-goto) + (setq lap (delq lap0 lap)) + (setq tmp "")) + ((memq (car lap0) byte-goto-always-pop-ops) + (setcar lap0 (setq tmp 'byte-discard)) + (setcdr lap0 0)) + ((error "Depth conflict at tag %d" (nth 2 lap0)))) + (and (memq byte-optimize-log '(t byte)) + (byte-compile-log " (goto %s) %s:\t-->\t%s %s:" + (nth 1 lap1) (nth 1 lap1) + tmp (nth 1 lap1))) + (setq keep-going t)) + ;; + ;; varset-X varref-X --> dup varset-X + ;; varbind-X varref-X --> dup varbind-X + ;; const/dup varset-X varref-X --> const/dup varset-X const/dup + ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup + ;; The latter two can enable other optimizations. + ;; + ;; For lexical variables, we could do the same + ;; stack-set-X+1 stack-ref-X --> dup stack-set-X+2 + ;; but this is a very minor gain, since dup is stack-ref-0, + ;; i.e. it's only better if X>5, and even then it comes + ;; at the cost of an extra stack slot. Let's not bother. + ((and (eq 'byte-varref (car lap2)) + (eq (cdr lap1) (cdr lap2)) + (memq (car lap1) '(byte-varset byte-varbind))) + (if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars)) + (not (eq (car lap0) 'byte-constant))) + nil + (setq keep-going t) + (if (memq (car lap0) '(byte-constant byte-dup)) + (progn + (setq tmp (if (or (not tmp) + (macroexp--const-symbol-p + (car (cdr lap0)))) + (cdr lap0) + (byte-compile-get-constant t))) + (byte-compile-log-lap " %s %s %s\t-->\t%s %s %s" + lap0 lap1 lap2 lap0 lap1 + (cons (car lap0) tmp)) + (setcar lap2 (car lap0)) + (setcdr lap2 tmp)) + (byte-compile-log-lap " %s %s\t-->\tdup %s" lap1 lap2 lap1) + (setcar lap2 (car lap1)) + (setcar lap1 'byte-dup) + (setcdr lap1 0) + ;; The stack depth gets locally increased, so we will + ;; increase maxdepth in case depth = maxdepth here. + ;; This can cause the third argument to byte-code to + ;; be larger than necessary. + (setq add-depth 1)))) + ;; + ;; dup varset-X discard --> varset-X + ;; dup varbind-X discard --> varbind-X + ;; dup stack-set-X discard --> stack-set-X-1 + ;; (the varbind variant can emerge from other optimizations) + ;; + ((and (eq 'byte-dup (car lap0)) + (eq 'byte-discard (car lap2)) + (memq (car lap1) '(byte-varset byte-varbind + byte-stack-set))) + (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1) + (setq keep-going t + rest (cdr rest)) + (if (eq 'byte-stack-set (car lap1)) (cl-decf (cdr lap1))) + (setq lap (delq lap0 (delq lap2 lap)))) + ;; + ;; not goto-X-if-nil --> goto-X-if-non-nil + ;; not goto-X-if-non-nil --> goto-X-if-nil + ;; + ;; it is wrong to do the same thing for the -else-pop variants. + ;; + ((and (eq 'byte-not (car lap0)) + (memq (car lap1) '(byte-goto-if-nil byte-goto-if-not-nil))) + (byte-compile-log-lap " not %s\t-->\t%s" + lap1 + (cons + (if (eq (car lap1) 'byte-goto-if-nil) + 'byte-goto-if-not-nil + 'byte-goto-if-nil) + (cdr lap1))) + (setcar lap1 (if (eq (car lap1) 'byte-goto-if-nil) + 'byte-goto-if-not-nil + 'byte-goto-if-nil)) + (setq lap (delq lap0 lap)) + (setq keep-going t)) + ;; + ;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X: + ;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X: + ;; + ;; it is wrong to do the same thing for the -else-pop variants. + ;; + ((and (memq (car lap0) + '(byte-goto-if-nil byte-goto-if-not-nil)) ; gotoX + (eq 'byte-goto (car lap1)) ; gotoY + (eq (cdr lap0) lap2)) ; TAG X + (let ((inverse (if (eq 'byte-goto-if-nil (car lap0)) + 'byte-goto-if-not-nil 'byte-goto-if-nil))) + (byte-compile-log-lap " %s %s %s:\t-->\t%s %s:" + lap0 lap1 lap2 + (cons inverse (cdr lap1)) lap2) + (setq lap (delq lap0 lap)) + (setcar lap1 inverse) + (setq keep-going t))) + ;; + ;; const goto-if-* --> whatever + ;; + ((and (eq 'byte-constant (car lap0)) + (memq (car lap1) byte-conditional-ops) + ;; If the `byte-constant's cdr is not a cons cell, it has + ;; to be an index into the constant pool); even though + ;; it'll be a constant, that constant is not known yet + ;; (it's typically a free variable of a closure, so will + ;; only be known when the closure will be built at + ;; run-time). + (consp (cdr lap0))) + (cond ((if (memq (car lap1) '(byte-goto-if-nil + byte-goto-if-nil-else-pop)) + (car (cdr lap0)) + (not (car (cdr lap0)))) + (byte-compile-log-lap " %s %s\t-->\t" + lap0 lap1) + (setq rest (cdr rest) + lap (delq lap0 (delq lap1 lap)))) + (t + (byte-compile-log-lap " %s %s\t-->\t%s" + lap0 lap1 + (cons 'byte-goto (cdr lap1))) + (when (memq (car lap1) byte-goto-always-pop-ops) + (setq lap (delq lap0 lap))) + (setcar lap1 'byte-goto))) + (setq keep-going t)) + ;; + ;; varref-X varref-X --> varref-X dup + ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup + ;; stackref-X [dup ...] stackref-X+N --> stackref-X [dup ...] dup + ;; We don't optimize the const-X variations on this here, + ;; because that would inhibit some goto optimizations; we + ;; optimize the const-X case after all other optimizations. + ;; + ((and (memq (car lap0) '(byte-varref byte-stack-ref)) + (progn + (setq tmp (cdr rest)) + (setq tmp2 0) + (while (eq (car (car tmp)) 'byte-dup) + (setq tmp2 (1+ tmp2)) + (setq tmp (cdr tmp))) + t) + (eq (if (eq 'byte-stack-ref (car lap0)) + (+ tmp2 1 (cdr lap0)) + (cdr lap0)) + (cdr (car tmp))) + (eq (car lap0) (car (car tmp)))) + (if (memq byte-optimize-log '(t byte)) + (let ((str "")) + (setq tmp2 (cdr rest)) + (while (not (eq tmp tmp2)) + (setq tmp2 (cdr tmp2) + str (concat str " dup"))) + (byte-compile-log-lap " %s%s %s\t-->\t%s%s dup" + lap0 str lap0 lap0 str))) + (setq keep-going t) + (setcar (car tmp) 'byte-dup) + (setcdr (car tmp) 0) + (setq rest tmp)) + ;; + ;; TAG1: TAG2: --> TAG1: + ;; (and other references to TAG2 are replaced with TAG1) + ;; + ((and (eq (car lap0) 'TAG) + (eq (car lap1) 'TAG)) + (and (memq byte-optimize-log '(t byte)) + (byte-compile-log " adjacent tags %d and %d merged" + (nth 1 lap1) (nth 1 lap0))) + (setq tmp3 lap) + (while (setq tmp2 (rassq lap0 tmp3)) + (setcdr tmp2 lap1) + (setq tmp3 (cdr (memq tmp2 tmp3)))) + (setq lap (delq lap0 lap) + keep-going t) + ;; replace references to tag in jump tables, if any + (dolist (table byte-compile-jump-tables) + (maphash #'(lambda (value tag) + (when (equal tag lap0) + (puthash value lap1 table))) + table))) + ;; + ;; unused-TAG: --> + ;; + ((and (eq 'TAG (car lap0)) + (not (rassq lap0 lap)) + ;; make sure this tag isn't used in a jump-table + (cl-loop for table in byte-compile-jump-tables + when (member lap0 (hash-table-values table)) + return nil finally return t)) + (and (memq byte-optimize-log '(t byte)) + (byte-compile-log " unused tag %d removed" (nth 1 lap0))) + (setq lap (delq lap0 lap) + keep-going t)) + ;; + ;; goto ... --> goto + ;; return ... --> return + ;; (unless a jump-table is being used, where deleting may affect + ;; other valid case bodies) + ;; + ((and (memq (car lap0) '(byte-goto byte-return)) + (not (memq (car lap1) '(TAG nil))) + ;; FIXME: Instead of deferring simply when jump-tables are + ;; being used, keep a list of tags used for switch tags and + ;; use them instead (see `byte-compile-inline-lapcode'). + (not byte-compile-jump-tables)) + (setq tmp rest) + (let ((i 0) + (opt-p (memq byte-optimize-log '(t lap))) + str deleted) + (while (and (setq tmp (cdr tmp)) + (not (eq 'TAG (car (car tmp))))) + (if opt-p (setq deleted (cons (car tmp) deleted) + str (concat str " %s") + i (1+ i)))) + (if opt-p + (let ((tagstr + (if (eq 'TAG (car (car tmp))) + (format "%d:" (car (cdr (car tmp)))) + (or (car tmp) "")))) + (if (< i 6) + (apply 'byte-compile-log-lap-1 + (concat " %s" str + " %s\t-->\t%s %s") + lap0 + (nconc (nreverse deleted) + (list tagstr lap0 tagstr))) + (byte-compile-log-lap + " %s <%d unreachable op%s> %s\t-->\t%s %s" + lap0 i (if (= i 1) "" "s") + tagstr lap0 tagstr)))) + (rplacd rest tmp)) + (setq keep-going t)) + ;; + ;; unbind --> unbind + ;; (this may enable other optimizations.) + ;; + ((and (eq 'byte-unbind (car lap1)) + (memq (car lap0) byte-after-unbind-ops)) + (byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0) + (setcar rest lap1) + (setcar (cdr rest) lap0) + (setq keep-going t)) + ;; + ;; varbind-X unbind-N --> discard unbind-(N-1) + ;; save-excursion unbind-N --> unbind-(N-1) + ;; save-restriction unbind-N --> unbind-(N-1) + ;; + ((and (eq 'byte-unbind (car lap1)) + (memq (car lap0) '(byte-varbind byte-save-excursion + byte-save-restriction)) + (< 0 (cdr lap1))) + (if (zerop (setcdr lap1 (1- (cdr lap1)))) + (delq lap1 rest)) + (if (eq (car lap0) 'byte-varbind) + (setcar rest (cons 'byte-discard 0)) + (setq lap (delq lap0 lap))) + (byte-compile-log-lap " %s %s\t-->\t%s %s" + lap0 (cons (car lap1) (1+ (cdr lap1))) + (if (eq (car lap0) 'byte-varbind) + (car rest) + (car (cdr rest))) + (if (and (/= 0 (cdr lap1)) + (eq (car lap0) 'byte-varbind)) + (car (cdr rest)) + "")) + (setq keep-going t)) + ;; + ;; goto*-X ... X: goto-Y --> goto*-Y + ;; goto-X ... X: return --> return + ;; + ((and (memq (car lap0) byte-goto-ops) + (memq (car (setq tmp (nth 1 (memq (cdr lap0) lap)))) + '(byte-goto byte-return))) + (cond ((and (not (eq tmp lap0)) + (or (eq (car lap0) 'byte-goto) + (eq (car tmp) 'byte-goto))) + (byte-compile-log-lap " %s [%s]\t-->\t%s" + (car lap0) tmp tmp) + (if (eq (car tmp) 'byte-return) + (setcar lap0 'byte-return)) + (setcdr lap0 (cdr tmp)) + (setq keep-going t)))) + ;; + ;; goto-*-else-pop X ... X: goto-if-* --> whatever + ;; goto-*-else-pop X ... X: discard --> whatever + ;; + ((and (memq (car lap0) '(byte-goto-if-nil-else-pop + byte-goto-if-not-nil-else-pop)) + (memq (car (car (setq tmp (cdr (memq (cdr lap0) lap))))) + (eval-when-compile + (cons 'byte-discard byte-conditional-ops))) + (not (eq lap0 (car tmp)))) + (setq tmp2 (car tmp)) + (setq tmp3 (assq (car lap0) '((byte-goto-if-nil-else-pop + byte-goto-if-nil) + (byte-goto-if-not-nil-else-pop + byte-goto-if-not-nil)))) + (if (memq (car tmp2) tmp3) + (progn (setcar lap0 (car tmp2)) + (setcdr lap0 (cdr tmp2)) + (byte-compile-log-lap " %s-else-pop [%s]\t-->\t%s" + (car lap0) tmp2 lap0)) + ;; Get rid of the -else-pop's and jump one step further. + (or (eq 'TAG (car (nth 1 tmp))) + (setcdr tmp (cons (byte-compile-make-tag) + (cdr tmp)))) + (byte-compile-log-lap " %s [%s]\t-->\t%s " + (car lap0) tmp2 (nth 1 tmp3)) + (setcar lap0 (nth 1 tmp3)) + (setcdr lap0 (nth 1 tmp))) + (setq keep-going t)) + ;; + ;; const goto-X ... X: goto-if-* --> whatever + ;; const goto-X ... X: discard --> whatever + ;; + ((and (eq (car lap0) 'byte-constant) + (eq (car lap1) 'byte-goto) + (memq (car (car (setq tmp (cdr (memq (cdr lap1) lap))))) + (eval-when-compile + (cons 'byte-discard byte-conditional-ops))) + (not (eq lap1 (car tmp)))) + (setq tmp2 (car tmp)) + (cond ((when (consp (cdr lap0)) + (memq (car tmp2) + (if (null (car (cdr lap0))) + '(byte-goto-if-nil byte-goto-if-nil-else-pop) + '(byte-goto-if-not-nil + byte-goto-if-not-nil-else-pop)))) + (byte-compile-log-lap " %s goto [%s]\t-->\t%s %s" + lap0 tmp2 lap0 tmp2) + (setcar lap1 (car tmp2)) + (setcdr lap1 (cdr tmp2)) + ;; Let next step fix the (const,goto-if*) sequence. + (setq rest (cons nil rest)) + (setq keep-going t)) + ((or (consp (cdr lap0)) + (eq (car tmp2) 'byte-discard)) + ;; Jump one step further + (byte-compile-log-lap + " %s goto [%s]\t-->\t goto " + lap0 tmp2) (or (eq 'TAG (car (nth 1 tmp))) (setcdr tmp (cons (byte-compile-make-tag) (cdr tmp)))) - (byte-compile-log-lap " %s [%s]\t-->\t%s " - (car lap0) tmp2 (nth 1 tmp3)) - (setcar lap0 (nth 1 tmp3)) - (setcdr lap0 (nth 1 tmp))) - (setq keep-going t)) - ;; - ;; const goto-X ... X: goto-if-* --> whatever - ;; const goto-X ... X: discard --> whatever - ;; - ((and (eq (car lap0) 'byte-constant) - (eq (car lap1) 'byte-goto) - (memq (car (car (setq tmp (cdr (memq (cdr lap1) lap))))) - (eval-when-compile - (cons 'byte-discard byte-conditional-ops))) - (not (eq lap1 (car tmp)))) - (setq tmp2 (car tmp)) - (cond ((when (consp (cdr lap0)) - (memq (car tmp2) - (if (null (car (cdr lap0))) - '(byte-goto-if-nil byte-goto-if-nil-else-pop) - '(byte-goto-if-not-nil - byte-goto-if-not-nil-else-pop)))) - (byte-compile-log-lap " %s goto [%s]\t-->\t%s %s" - lap0 tmp2 lap0 tmp2) - (setcar lap1 (car tmp2)) - (setcdr lap1 (cdr tmp2)) - ;; Let next step fix the (const,goto-if*) sequence. - (setq rest (cons nil rest)) - (setq keep-going t)) - ((or (consp (cdr lap0)) - (eq (car tmp2) 'byte-discard)) - ;; Jump one step further - (byte-compile-log-lap - " %s goto [%s]\t-->\t goto " - lap0 tmp2) - (or (eq 'TAG (car (nth 1 tmp))) - (setcdr tmp (cons (byte-compile-make-tag) - (cdr tmp)))) - (setcdr lap1 (car (cdr tmp))) - (setq lap (delq lap0 lap)) - (setq keep-going t)))) - ;; - ;; X: varref-Y ... varset-Y goto-X --> - ;; X: varref-Y Z: ... dup varset-Y goto-Z - ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.) - ;; (This is so usual for while loops that it is worth handling). - ;; - ;; Here again, we could do it for stack-ref/stack-set, but - ;; that's replacing a stack-ref-Y with a stack-ref-0, which - ;; is a very minor improvement (if any), at the cost of - ;; more stack use and more byte-code. Let's not do it. - ;; - ((and (eq (car lap1) 'byte-varset) - (eq (car lap2) 'byte-goto) - (not (memq (cdr lap2) rest)) ;Backwards jump - (eq (car (car (setq tmp (cdr (memq (cdr lap2) lap))))) - 'byte-varref) - (eq (cdr (car tmp)) (cdr lap1)) - (not (memq (car (cdr lap1)) byte-boolean-vars))) - ;;(byte-compile-log-lap " Pulled %s to end of loop" (car tmp)) - (let ((newtag (byte-compile-make-tag))) - (byte-compile-log-lap - " %s: %s ... %s %s\t-->\t%s: %s %s: ... %s %s %s" - (nth 1 (cdr lap2)) (car tmp) - lap1 lap2 - (nth 1 (cdr lap2)) (car tmp) - (nth 1 newtag) 'byte-dup lap1 - (cons 'byte-goto newtag) - ) - (setcdr rest (cons (cons 'byte-dup 0) (cdr rest))) - (setcdr tmp (cons (setcdr lap2 newtag) (cdr tmp)))) - (setq add-depth 1) - (setq keep-going t)) - ;; - ;; goto-X Y: ... X: goto-if*-Y --> goto-if-not-*-X+1 Y: - ;; (This can pull the loop test to the end of the loop) - ;; - ((and (eq (car lap0) 'byte-goto) - (eq (car lap1) 'TAG) - (eq lap1 - (cdr (car (setq tmp (cdr (memq (cdr lap0) lap)))))) - (memq (car (car tmp)) - '(byte-goto byte-goto-if-nil byte-goto-if-not-nil - byte-goto-if-nil-else-pop))) -;; (byte-compile-log-lap " %s %s, %s %s --> moved conditional" -;; lap0 lap1 (cdr lap0) (car tmp)) - (let ((newtag (byte-compile-make-tag))) - (byte-compile-log-lap - "%s %s: ... %s: %s\t-->\t%s ... %s:" - lap0 (nth 1 lap1) (nth 1 (cdr lap0)) (car tmp) - (cons (cdr (assq (car (car tmp)) - '((byte-goto-if-nil . byte-goto-if-not-nil) - (byte-goto-if-not-nil . byte-goto-if-nil) - (byte-goto-if-nil-else-pop . - byte-goto-if-not-nil-else-pop) - (byte-goto-if-not-nil-else-pop . - byte-goto-if-nil-else-pop)))) - newtag) - - (nth 1 newtag) - ) - (setcdr tmp (cons (setcdr lap0 newtag) (cdr tmp))) - (if (eq (car (car tmp)) 'byte-goto-if-nil-else-pop) - ;; We can handle this case but not the -if-not-nil case, - ;; because we won't know which non-nil constant to push. - (setcdr rest (cons (cons 'byte-constant - (byte-compile-get-constant nil)) - (cdr rest)))) - (setcar lap0 (nth 1 (memq (car (car tmp)) - '(byte-goto-if-nil-else-pop - byte-goto-if-not-nil - byte-goto-if-nil - byte-goto-if-not-nil - byte-goto byte-goto)))) - ) - (setq keep-going t)) - ) + (setcdr lap1 (car (cdr tmp))) + (setq lap (delq lap0 lap)) + (setq keep-going t)))) + ;; + ;; X: varref-Y ... varset-Y goto-X --> + ;; X: varref-Y Z: ... dup varset-Y goto-Z + ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.) + ;; (This is so usual for while loops that it is worth handling). + ;; + ;; Here again, we could do it for stack-ref/stack-set, but + ;; that's replacing a stack-ref-Y with a stack-ref-0, which + ;; is a very minor improvement (if any), at the cost of + ;; more stack use and more byte-code. Let's not do it. + ;; + ((and (eq (car lap1) 'byte-varset) + (eq (car lap2) 'byte-goto) + (not (memq (cdr lap2) rest)) ;Backwards jump + (eq (car (car (setq tmp (cdr (memq (cdr lap2) lap))))) + 'byte-varref) + (eq (cdr (car tmp)) (cdr lap1)) + (not (memq (car (cdr lap1)) byte-boolean-vars))) + ;;(byte-compile-log-lap " Pulled %s to end of loop" (car tmp)) + (let ((newtag (byte-compile-make-tag))) + (byte-compile-log-lap + " %s: %s ... %s %s\t-->\t%s: %s %s: ... %s %s %s" + (nth 1 (cdr lap2)) (car tmp) + lap1 lap2 + (nth 1 (cdr lap2)) (car tmp) + (nth 1 newtag) 'byte-dup lap1 + (cons 'byte-goto newtag) + ) + (setcdr rest (cons (cons 'byte-dup 0) (cdr rest))) + (setcdr tmp (cons (setcdr lap2 newtag) (cdr tmp)))) + (setq add-depth 1) + (setq keep-going t)) + ;; + ;; goto-X Y: ... X: goto-if*-Y --> goto-if-not-*-X+1 Y: + ;; (This can pull the loop test to the end of the loop) + ;; + ((and (eq (car lap0) 'byte-goto) + (eq (car lap1) 'TAG) + (eq lap1 + (cdr (car (setq tmp (cdr (memq (cdr lap0) lap)))))) + (memq (car (car tmp)) + '(byte-goto byte-goto-if-nil byte-goto-if-not-nil + byte-goto-if-nil-else-pop))) + ;; (byte-compile-log-lap " %s %s, %s %s --> moved conditional" + ;; lap0 lap1 (cdr lap0) (car tmp)) + (let ((newtag (byte-compile-make-tag))) + (byte-compile-log-lap + "%s %s: ... %s: %s\t-->\t%s ... %s:" + lap0 (nth 1 lap1) (nth 1 (cdr lap0)) (car tmp) + (cons (cdr (assq (car (car tmp)) + '((byte-goto-if-nil . byte-goto-if-not-nil) + (byte-goto-if-not-nil . byte-goto-if-nil) + (byte-goto-if-nil-else-pop . + byte-goto-if-not-nil-else-pop) + (byte-goto-if-not-nil-else-pop . + byte-goto-if-nil-else-pop)))) + newtag) + + (nth 1 newtag) + ) + (setcdr tmp (cons (setcdr lap0 newtag) (cdr tmp))) + (if (eq (car (car tmp)) 'byte-goto-if-nil-else-pop) + ;; We can handle this case but not the -if-not-nil case, + ;; because we won't know which non-nil constant to push. + (setcdr rest (cons (cons 'byte-constant + (byte-compile-get-constant nil)) + (cdr rest)))) + (setcar lap0 (nth 1 (memq (car (car tmp)) + '(byte-goto-if-nil-else-pop + byte-goto-if-not-nil + byte-goto-if-nil + byte-goto-if-not-nil + byte-goto byte-goto)))) + ) + (setq keep-going t)) + ) (setq rest (cdr rest))) ) ;; Cleanup stage: -- cgit v1.2.3 From 4dfebf25c743d4ba4506919b58591f74debfb334 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 20 Jan 2021 13:59:58 -0500 Subject: * lisp/emacs-lisp/byte-opt.el (byte-optimize-lapcode): Move some opts. This moves two optimizations from the final pass to the main loop. Both may enable further optimizations (and the second can be applied repeatedly but "from the end", so the loop in the final pass only gets to apply it once). --- lisp/emacs-lisp/byte-opt.el | 99 +++++++++++++++++++++++---------------------- 1 file changed, 50 insertions(+), 49 deletions(-) (limited to 'lisp') diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 6d1f4179ce1..620bd91b646 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -2021,6 +2021,56 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." byte-goto byte-goto)))) ) (setq keep-going t)) + + ;; + ;; stack-set-M [discard/discardN ...] --> discardN-preserve-tos + ;; stack-set-M [discard/discardN ...] --> discardN + ;; + ((and (eq (car lap0) 'byte-stack-set) + (memq (car lap1) '(byte-discard byte-discardN)) + (progn + ;; See if enough discard operations follow to expose or + ;; destroy the value stored by the stack-set. + (setq tmp (cdr rest)) + (setq tmp2 (1- (cdr lap0))) + (setq tmp3 0) + (while (memq (car (car tmp)) '(byte-discard byte-discardN)) + (setq tmp3 + (+ tmp3 (if (eq (car (car tmp)) 'byte-discard) + 1 + (cdr (car tmp))))) + (setq tmp (cdr tmp))) + (>= tmp3 tmp2))) + ;; Do the optimization. + (setq lap (delq lap0 lap)) + (setcar lap1 + (if (= tmp2 tmp3) + ;; The value stored is the new TOS, so pop one more + ;; value (to get rid of the old value) using the + ;; TOS-preserving discard operator. + 'byte-discardN-preserve-tos + ;; Otherwise, the value stored is lost, so just use a + ;; normal discard. + 'byte-discardN)) + (setcdr lap1 (1+ tmp3)) + (setcdr (cdr rest) tmp) + (byte-compile-log-lap " %s [discard/discardN]...\t-->\t%s" + lap0 lap1)) + ;; + ;; discardN-preserve-tos return --> return + ;; dup return --> return + ;; stack-set-N return --> return ; where N is TOS-1 + ;; + ((and (eq (car lap1) 'byte-return) + (or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup)) + (and (eq (car lap0) 'byte-stack-set) + (= (cdr lap0) 1)))) + (setq keep-going t) + ;; The byte-code interpreter will pop the stack for us, so + ;; we can just leave stuff on it. + (setq lap (delq lap0 lap)) + (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 lap1)) + ) (setq rest (cdr rest))) ) @@ -2084,41 +2134,6 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (setq lap (delq lap0 lap)) (setcdr lap1 (+ (cdr lap1) (cdr lap0)))) - ;; - ;; stack-set-M [discard/discardN ...] --> discardN-preserve-tos - ;; stack-set-M [discard/discardN ...] --> discardN - ;; - ((and (eq (car lap0) 'byte-stack-set) - (memq (car lap1) '(byte-discard byte-discardN)) - (progn - ;; See if enough discard operations follow to expose or - ;; destroy the value stored by the stack-set. - (setq tmp (cdr rest)) - (setq tmp2 (1- (cdr lap0))) - (setq tmp3 0) - (while (memq (car (car tmp)) '(byte-discard byte-discardN)) - (setq tmp3 - (+ tmp3 (if (eq (car (car tmp)) 'byte-discard) - 1 - (cdr (car tmp))))) - (setq tmp (cdr tmp))) - (>= tmp3 tmp2))) - ;; Do the optimization. - (setq lap (delq lap0 lap)) - (setcar lap1 - (if (= tmp2 tmp3) - ;; The value stored is the new TOS, so pop one more - ;; value (to get rid of the old value) using the - ;; TOS-preserving discard operator. - 'byte-discardN-preserve-tos - ;; Otherwise, the value stored is lost, so just use a - ;; normal discard. - 'byte-discardN)) - (setcdr lap1 (1+ tmp3)) - (setcdr (cdr rest) tmp) - (byte-compile-log-lap " %s [discard/discardN]...\t-->\t%s" - lap0 lap1)) - ;; ;; discard/discardN/discardN-preserve-tos-X discard/discardN-Y --> ;; discardN-(X+Y) @@ -2146,20 +2161,6 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (setq lap (delq lap0 lap)) (setcdr lap1 (+ (cdr lap0) (cdr lap1))) (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 (car rest))) - - ;; - ;; discardN-preserve-tos return --> return - ;; dup return --> return - ;; stack-set-N return --> return ; where N is TOS-1 - ;; - ((and (eq (car lap1) 'byte-return) - (or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup)) - (and (eq (car lap0) 'byte-stack-set) - (= (cdr lap0) 1)))) - ;; The byte-code interpreter will pop the stack for us, so - ;; we can just leave stuff on it. - (setq lap (delq lap0 lap)) - (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 lap1)) ) (setq rest (cdr rest))) (setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth))) -- cgit v1.2.3 From 66439d31ad2a63753d29e4582b76b36b9363d96b Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 20 Jan 2021 14:08:35 -0500 Subject: * lisp/emacs-lisp/byte-opt.el (byte-optimize-lapcode): Add 2 new opts This introduces two new optimizations. They're designed for code like (while (let (...) (if ... (progn blabla t) (progn blabla nil))) ...) and they allow the elimination of the test internal to `while` since we can immediately know when we return `t` or `nil` what the result of the test will be. `cl-labels` tends to generate this kind of code when it applies the tail-call optimization. --- lisp/emacs-lisp/byte-opt.el | 31 +++++++++++++++++++++++++++++++ 1 file changed, 31 insertions(+) (limited to 'lisp') diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 620bd91b646..cfa407019a7 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -2056,6 +2056,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (setcdr (cdr rest) tmp) (byte-compile-log-lap " %s [discard/discardN]...\t-->\t%s" lap0 lap1)) + ;; ;; discardN-preserve-tos return --> return ;; dup return --> return @@ -2071,6 +2072,36 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (setq lap (delq lap0 lap)) (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 lap1)) + ;; + ;; goto-X ... X: discard ==> discard goto-Y ... X: discard Y: + ;; + ((and (eq (car lap0) 'byte-goto) + (setq tmp (cdr (memq (cdr lap0) lap))) + (memq (caar tmp) '(byte-discard byte-discardN + byte-discardN-preserve-tos))) + (byte-compile-log-lap + " goto-X .. X: \t-->\t%s goto-X.. X: %s Y:" + (car tmp) (car tmp)) + (setq keep-going t) + (let* ((newtag (byte-compile-make-tag)) + ;; Make a copy, since we sometimes modify insts in-place! + (newdiscard (cons (caar tmp) (cdar tmp))) + (newjmp (cons (car lap0) newtag))) + (push newtag (cdr tmp)) ;Push new tag after the discard. + (setcar rest newdiscard) + (push newjmp (cdr rest)))) + + ;; + ;; const discardN-preserve-tos ==> discardN const + ;; + ((and (eq (car lap0) 'byte-constant) + (eq (car lap1) 'byte-discardN-preserve-tos)) + (setq keep-going t) + (let ((newdiscard (cons 'byte-discardN (cdr lap1)))) + (byte-compile-log-lap + " %s %s\t-->\t%s %s" lap0 lap1 newdiscard lap0) + (setf (car rest) newdiscard) + (setf (cadr rest) lap0))) ) (setq rest (cdr rest))) ) -- cgit v1.2.3 From 0d3635536d4ed8ada6946e98e7d9f03fa443bc36 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 20 Jan 2021 14:12:50 -0500 Subject: * lisp/emacs-lisp/subr-x.el (named-let): New macro --- etc/NEWS | 12 +++++++----- lisp/emacs-lisp/subr-x.el | 22 ++++++++++++++++++++++ 2 files changed, 29 insertions(+), 5 deletions(-) (limited to 'lisp') diff --git a/etc/NEWS b/etc/NEWS index c8cbce1882a..59b13998cfa 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1554,6 +1554,13 @@ buttons in it. This function takes a string and returns a string propertized in a way that makes it a valid button. +** subr-x ++++ +*** A number of new string manipulation functions have been added. +'string-clean-whitespace', 'string-fill', 'string-limit', +'string-lines', 'string-pad' and 'string-chop-newline'. + +*** New macro `named-let` that provides Scheme's "named let" looping construct ** Miscellaneous @@ -1593,11 +1600,6 @@ length to a number). *** New user option 'authinfo-hide-elements'. This can be set to nil to inhibit hiding passwords in ".authinfo" files. -+++ -*** A number of new string manipulation functions have been added. -'string-clean-whitespace', 'string-fill', 'string-limit', -'string-lines', 'string-pad' and 'string-chop-newline'. - +++ *** New variable 'current-minibuffer-command'. This is like 'this-command', but it is bound recursively when entering diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index b90227da42f..a4514454c0b 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -389,6 +389,28 @@ it makes no sense to convert it to a string using (set-buffer source-buffer) (replace-buffer-contents tmp-buffer max-secs max-costs))))))))) +(defmacro named-let (name bindings &rest body) + "Looping construct taken from Scheme. +Like `let', bind variables in BINDINGS and then evaluate BODY, +but with the twist that BODY can evaluate itself recursively by +calling NAME, where the arguments passed to NAME are used +as the new values of the bound variables in the recursive invocation." + (declare (indent 2) (debug (symbolp (&rest (symbolp form)) body))) + (require 'cl-lib) + (let ((fargs (mapcar (lambda (b) (if (consp b) (car b) b)) bindings)) + (aargs (mapcar (lambda (b) (if (consp b) (cadr b))) bindings))) + ;; According to the Scheme semantics of named let, `name' is not in scope + ;; while evaluating the expressions in `bindings', and for this reason, the + ;; "initial" function call below needs to be outside of the `cl-labels'. + ;; When the "self-tco" eliminates all recursive calls, the `cl-labels' + ;; expands to a lambda which the byte-compiler then combines with the + ;; funcall to make a `let' so we end up with a plain `while' loop and no + ;; remaining `lambda' at all. + `(funcall + (cl-labels ((,name ,fargs . ,body)) #',name) + . ,aargs))) + + (provide 'subr-x) ;;; subr-x.el ends here -- cgit v1.2.3 From 5065698c81dcf241fc234c78bffea54af4203892 Mon Sep 17 00:00:00 2001 From: Juri Linkov Date: Wed, 20 Jan 2021 21:19:23 +0200 Subject: Move the ‘declare’ form before the interactive spec in 10 functions. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * lisp/emacs-lisp/package.el (package-menu-hide-package): * lisp/font-lock.el (font-lock-debug-fontify): * lisp/image.el (image-jpeg-p): * lisp/mail/flow-fill.el (fill-flowed-test): * lisp/mh-e/mh-speed.el (mh-speed-toggle, mh-speed-view): * lisp/progmodes/project.el (project-async-shell-command) (project-shell-command, project-compile): * lisp/progmodes/sh-script.el (sh-assignment): Fix special forms to follow in this order: docstring, declare, interactive. --- lisp/emacs-lisp/package.el | 2 +- lisp/font-lock.el | 2 +- lisp/image.el | 2 +- lisp/mail/flow-fill.el | 2 +- lisp/mh-e/mh-speed.el | 4 ++-- lisp/progmodes/project.el | 6 +++--- lisp/progmodes/sh-script.el | 2 +- 7 files changed, 10 insertions(+), 10 deletions(-) (limited to 'lisp') diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 453e86c7831..90b7b88d58a 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -3260,9 +3260,9 @@ To unhide a package, type `\\[customize-variable] RET package-hidden-regexps'. Type \\[package-menu-toggle-hiding] to toggle package hiding." + (declare (interactive-only "change `package-hidden-regexps' instead.")) (interactive) (package--ensure-package-menu-mode) - (declare (interactive-only "change `package-hidden-regexps' instead.")) (let* ((name (when (derived-mode-p 'package-menu-mode) (concat "\\`" (regexp-quote (symbol-name (package-desc-name (tabulated-list-get-id)))) diff --git a/lisp/font-lock.el b/lisp/font-lock.el index a51434c38c9..a9fc69d419a 100644 --- a/lisp/font-lock.el +++ b/lisp/font-lock.el @@ -1104,8 +1104,8 @@ Called with two arguments BEG and END.") "Reinitialize the font-lock machinery and (re-)fontify the buffer. This functions is a convenience functions when developing font locking for a mode, and is not meant to be called from lisp functions." - (interactive) (declare (interactive-only t)) + (interactive) ;; Make font-lock recalculate all the mode-specific data. (setq font-lock-major-mode nil) ;; Make the syntax machinery discard all information. diff --git a/lisp/image.el b/lisp/image.el index 814035594b6..6955a90de77 100644 --- a/lisp/image.el +++ b/lisp/image.el @@ -264,9 +264,9 @@ compatibility with versions of Emacs that lack the variable ;; Used to be in image-type-header-regexps, but now not used anywhere ;; (since 2009-08-28). (defun image-jpeg-p (data) - (declare (obsolete "It is unused inside Emacs and will be removed." "27.1")) "Value is non-nil if DATA, a string, consists of JFIF image data. We accept the tag Exif because that is the same format." + (declare (obsolete "It is unused inside Emacs and will be removed." "27.1")) (setq data (ignore-errors (string-to-unibyte data))) (when (and data (string-match-p "\\`\xff\xd8" data)) (catch 'jfif diff --git a/lisp/mail/flow-fill.el b/lisp/mail/flow-fill.el index e93ba547a89..0fab1b21b47 100644 --- a/lisp/mail/flow-fill.el +++ b/lisp/mail/flow-fill.el @@ -174,8 +174,8 @@ lines." (defvar fill-flowed-encode-tests) (defun fill-flowed-test () - (interactive "") (declare (obsolete nil "27.1")) + (interactive "") (user-error (concat "This function is obsolete. Please see " "test/lisp/mail/flow-fill-tests.el " "in the Emacs source tree"))) diff --git a/lisp/mh-e/mh-speed.el b/lisp/mh-e/mh-speed.el index 35d5884b16c..00b96804174 100644 --- a/lisp/mh-e/mh-speed.el +++ b/lisp/mh-e/mh-speed.el @@ -128,8 +128,8 @@ With non-nil FORCE, the update is always carried out." (defun mh-speed-toggle (&rest ignored) "Toggle the display of child folders in the speedbar. The optional arguments from speedbar are IGNORED." - (interactive) (declare (ignore args)) + (interactive) (beginning-of-line) (let ((parent (get-text-property (point) 'mh-folder)) (kids-p (get-text-property (point) 'mh-children-p)) @@ -167,8 +167,8 @@ The optional arguments from speedbar are IGNORED." (defun mh-speed-view (&rest ignored) "Visits the selected folder just as if you had used \\\\[mh-visit-folder]. The optional arguments from speedbar are IGNORED." - (interactive) (declare (ignore args)) + (interactive) (let* ((folder (get-text-property (mh-line-beginning-position) 'mh-folder)) (range (and (stringp folder) (mh-read-range "Scan" folder t nil nil diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 18124227d1b..768cd58ae44 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -928,16 +928,16 @@ if one already exists." ;;;###autoload (defun project-async-shell-command () "Run `async-shell-command' in the current project's root directory." - (interactive) (declare (interactive-only async-shell-command)) + (interactive) (let ((default-directory (project-root (project-current t)))) (call-interactively #'async-shell-command))) ;;;###autoload (defun project-shell-command () "Run `shell-command' in the current project's root directory." - (interactive) (declare (interactive-only shell-command)) + (interactive) (let ((default-directory (project-root (project-current t)))) (call-interactively #'shell-command))) @@ -974,8 +974,8 @@ loop using the command \\[fileloop-continue]." ;;;###autoload (defun project-compile () "Run `compile' in the project root." - (interactive) (declare (interactive-only compile)) + (interactive) (let ((default-directory (project-root (project-current t)))) (call-interactively #'compile))) diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el index d3692d47205..cc045a1b2d1 100644 --- a/lisp/progmodes/sh-script.el +++ b/lisp/progmodes/sh-script.el @@ -2927,8 +2927,8 @@ option followed by a colon `:' if the option accepts an argument." (put 'sh-assignment 'delete-selection t) (defun sh-assignment (arg) "Remember preceding identifier for future completion and do self-insert." - (interactive "p") (declare (obsolete nil "27.1")) + (interactive "p") (self-insert-command arg) (sh--assignment-collect)) -- cgit v1.2.3 From 93141d581330d94e7eec9f114def2bec15f87866 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 20 Jan 2021 21:46:30 +0100 Subject: Always send Lisp words to checkdoc-ispell-init * lisp/emacs-lisp/checkdoc.el (checkdoc-ispell-init): Always send the Lisp words to the process (bug#6221). This allows an existing ispell process to be correctly initialised. --- lisp/emacs-lisp/checkdoc.el | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) (limited to 'lisp') diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index 2e204ff7aea..aae807b8c18 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -2106,12 +2106,14 @@ nil." (unless ispell-process (condition-case nil (progn - (ispell-set-spellchecker-params) ; Initialize variables and dict alists. - (ispell-accept-buffer-local-defs) ; Use the correct dictionary. - ;; This code copied in part from ispell.el Emacs 19.34 - (dolist (w checkdoc-ispell-lisp-words) - (process-send-string ispell-process (concat "@" w "\n")))) - (error (setq checkdoc-spellcheck-documentation-flag nil))))) + ;; Initialize variables and dict alists. + (ispell-set-spellchecker-params) + ;; Use the correct dictionary. + (ispell-accept-buffer-local-defs)) + (error (setq checkdoc-spellcheck-documentation-flag nil)))) + ;; This code copied in part from ispell.el Emacs 19.34 + (dolist (w checkdoc-ispell-lisp-words) + (process-send-string ispell-process (concat "@" w "\n")))) (defun checkdoc-ispell-docstring-engine (end &optional take-notes) "Run the Ispell tools on the doc string between point and END. -- cgit v1.2.3 From 1a6ed932d9d9779419f403e32e911f86657cb9f7 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 20 Jan 2021 22:11:38 +0100 Subject: Revert "Always send Lisp words to checkdoc-ispell-init" This reverts commit 93141d581330d94e7eec9f114def2bec15f87866. This would make checkdoc words be used in other flyspell buffers. --- lisp/emacs-lisp/checkdoc.el | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) (limited to 'lisp') diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index aae807b8c18..2e204ff7aea 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -2106,14 +2106,12 @@ nil." (unless ispell-process (condition-case nil (progn - ;; Initialize variables and dict alists. - (ispell-set-spellchecker-params) - ;; Use the correct dictionary. - (ispell-accept-buffer-local-defs)) - (error (setq checkdoc-spellcheck-documentation-flag nil)))) - ;; This code copied in part from ispell.el Emacs 19.34 - (dolist (w checkdoc-ispell-lisp-words) - (process-send-string ispell-process (concat "@" w "\n")))) + (ispell-set-spellchecker-params) ; Initialize variables and dict alists. + (ispell-accept-buffer-local-defs) ; Use the correct dictionary. + ;; This code copied in part from ispell.el Emacs 19.34 + (dolist (w checkdoc-ispell-lisp-words) + (process-send-string ispell-process (concat "@" w "\n")))) + (error (setq checkdoc-spellcheck-documentation-flag nil))))) (defun checkdoc-ispell-docstring-engine (end &optional take-notes) "Run the Ispell tools on the doc string between point and END. -- cgit v1.2.3 From 61b716bd3034ac50829ef66399c14113a903f82a Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 20 Jan 2021 22:15:38 +0100 Subject: checkdoc-spellcheck-documentation-flag doc string improvement * lisp/emacs-lisp/checkdoc.el (checkdoc-spellcheck-documentation-flag): Mention `ispell-kill-ispell' (bug#6221). --- lisp/emacs-lisp/checkdoc.el | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index 2e204ff7aea..76638ec13b1 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -241,7 +241,12 @@ system. Possible values are: defun - Spell-check when style checking a single defun. buffer - Spell-check when style checking the whole buffer. interactive - Spell-check during any interactive check. - t - Always spell-check." + t - Always spell-check. + +There is a list of Lisp-specific words which checkdoc will +install into Ispell on the fly, but only if Ispell is not already +running. Use `ispell-kill-ispell' to make checkdoc restart it +with these words enabled." :type '(choice (const nil) (const defun) (const buffer) -- cgit v1.2.3 From 0df23b73e4718937bcaddf9008ad8ef9ca3a2413 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 20 Jan 2021 23:30:53 +0100 Subject: Fix recent remember-diary-extract-entries change * lisp/textmodes/remember.el (remember-diary-extract-entries): Use `remember-diary-file' over `diary-file'. --- lisp/textmodes/remember.el | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/textmodes/remember.el b/lisp/textmodes/remember.el index 7f107977d53..811a265118c 100644 --- a/lisp/textmodes/remember.el +++ b/lisp/textmodes/remember.el @@ -549,6 +549,8 @@ If this is nil, then `diary-file' will be used instead." :type 'regexp :version "28.1") +(defvar diary-file) + ;;;###autoload (defun remember-diary-extract-entries () "Extract diary entries from the region based on `remember-diary-regexp'." @@ -561,7 +563,8 @@ If this is nil, then `diary-file' will be used instead." (diary-make-entry (mapconcat 'identity list "\n") nil remember-diary-file) (when remember-save-after-remembering - (with-current-buffer (find-buffer-visiting diary-file) + (with-current-buffer (find-buffer-visiting (or remember-diary-file + diary-file)) (save-buffer)))) nil))) ;; Continue processing -- cgit v1.2.3 From b9511362f5fe4dc772cb2b65afeb051a7443f2a4 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 20 Jan 2021 20:17:11 -0500 Subject: * lisp/emacs-lisp/bytecomp.el (byte-compile--declare-var): Fix warning Make sure the "declared after first use" is under the control of the `lexical` option. --- lisp/emacs-lisp/bytecomp.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 360da6b6ba6..9429d6a0d5d 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2505,7 +2505,8 @@ list that represents a doc string reference. (when (memq sym byte-compile-lexical-variables) (setq byte-compile-lexical-variables (delq sym byte-compile-lexical-variables)) - (byte-compile-warn "Variable `%S' declared after its first use" sym)) + (when (byte-compile-warning-enabled-p 'lexical sym) + (byte-compile-warn "Variable `%S' declared after its first use" sym))) (push sym byte-compile-bound-variables) (push sym byte-compile--seen-defvars)) -- cgit v1.2.3 From d8a9828b3b7c5d80ecc57089e0c93c4dfa6837b7 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 20 Jan 2021 23:00:57 -0500 Subject: * lisp/calendar/calendar.el (calendar-read-sexp): New function (calendar-read): Mark as obsolete. (calendar-read-date): Use it. Add `default-date` argument. Provide defaults for the month and day (fixes bug#32105). --- lisp/calendar/calendar.el | 57 ++++++++++++++++++++++++++++++++++------------- 1 file changed, 41 insertions(+), 16 deletions(-) (limited to 'lisp') diff --git a/lisp/calendar/calendar.el b/lisp/calendar/calendar.el index 21cea212e18..3f9fe1c9d8f 100644 --- a/lisp/calendar/calendar.el +++ b/lisp/calendar/calendar.el @@ -112,6 +112,8 @@ ;;; Code: +(eval-when-compile (require 'subr-x)) + (load "cal-loaddefs" nil t) ;; Calendar has historically relied heavily on dynamic scoping. @@ -1459,7 +1461,7 @@ Optional integers MON and YR are used instead of today's date." Inserts STRING so that it ends at INDENT. STRING is either a literal string, or a sexp to evaluate to return such. Truncates STRING to length TRUNCATE, and ensures a trailing space." - (if (not (ignore-errors (stringp (setq string (eval string))))) + (if (not (ignore-errors (stringp (setq string (eval string t))))) (calendar-move-to-column indent) (if (> (string-width string) truncate) (setq string (truncate-string-to-width string truncate))) @@ -1526,7 +1528,7 @@ first INDENT characters on the line." (format (format "%%%dd" calendar-day-digit-width) day) 'mouse-face 'highlight 'help-echo (calendar-dlet* ((day day) (month month) (year year)) - (eval calendar-date-echo-text)) + (eval calendar-date-echo-text t)) ;; 'date property prevents intermonth text confusing re-searches. ;; (Tried intangible, it did not really work.) 'date t) @@ -2054,23 +2056,40 @@ With argument ARG, jump to mark, pop it, and put point at end of ring." (error "%s not available in the calendar" (global-key-binding (this-command-keys)))) +(defun calendar-read-sexp (prompt predicate &optional default &rest args) + "Return an object read from the minibuffer. +Passes PROMPT, DEFAULT, and ARGS to `format-prompt' to build +the actual prompt. PREDICATE is called with a single value (the object +the user entered) and it should return non-nil if that value is a valid choice. +DEFAULT is the default value to use." + (unless (stringp default) (setq default (format "%S" default))) + (named-let query () + ;; The call to `read-from-minibuffer' is copied from `read-minibuffer', + ;; except it's changed to use the DEFAULT arg instead of INITIAL-CONTENTS. + (let ((value (read-from-minibuffer + (apply #'format-prompt prompt default args) + nil minibuffer-local-map t 'minibuffer-history default))) + (if (funcall predicate value) + value + (query))))) + (defun calendar-read (prompt acceptable &optional initial-contents) "Return an object read from the minibuffer. Prompt with the string PROMPT and use the function ACCEPTABLE to decide if entered item is acceptable. If non-nil, optional third arg INITIAL-CONTENTS is a string to insert in the minibuffer before reading." + (declare (obsolete calendar-read-sexp "28.1")) (let ((value (read-minibuffer prompt initial-contents))) (while (not (funcall acceptable value)) (setq value (read-minibuffer prompt initial-contents))) value)) - (defun calendar-customized-p (symbol) "Return non-nil if SYMBOL has been customized." (and (default-boundp symbol) (let ((standard (get symbol 'standard-value))) (and standard - (not (equal (eval (car standard)) (default-value symbol))))))) + (not (equal (eval (car standard) t) (default-value symbol))))))) (defun calendar-abbrev-construct (full &optional maxlen) "From sequence FULL, return a vector of abbreviations. @@ -2284,32 +2303,38 @@ arguments SEQUENCES." (append (list sequence) sequences)) (reverse alist))) -(defun calendar-read-date (&optional noday) +(defun calendar-read-date (&optional noday default-date) "Prompt for Gregorian date. Return a list (month day year). If optional NODAY is t, does not ask for day, but just returns \(month 1 year); if NODAY is any other non-nil value the value returned is (month year)." - (let* ((year (calendar-read - "Year (>0): " - (lambda (x) (> x 0)) - (number-to-string (calendar-extract-year - (calendar-current-date))))) + (unless default-date (setq default-date (calendar-current-date))) + (let* ((defyear (calendar-extract-year default-date)) + (year (calendar-read-sexp "Year (>0)" + (lambda (x) (> x 0)) + defyear)) (month-array calendar-month-name-array) + (defmon (aref month-array (1- (calendar-extract-month default-date)))) (completion-ignore-case t) (month (cdr (assoc-string - (completing-read - "Month name: " - (mapcar #'list (append month-array nil)) - nil t) + (completing-read + (format-prompt "Month name" defmon) + (append month-array nil) + nil t nil nil defmon) (calendar-make-alist month-array 1) t))) + (defday (calendar-extract-day default-date)) (last (calendar-last-day-of-month month year))) (if noday (if (eq noday t) (list month 1 year) (list month year)) (list month - (calendar-read (format "Day (1-%d): " last) - (lambda (x) (and (< 0 x) (<= x last)))) + (calendar-read-sexp "Day (1-%d)" + (lambda (x) (and (< 0 x) (<= x last))) + ;; Don't offer today's day as default + ;; if it's not valid for the chosen + ;; month/year. + (if (<= defday last) defday) last) year)))) (defun calendar-interval (mon1 yr1 mon2 yr2) -- cgit v1.2.3 From 0f65baa03b54dc95b24b765bc91370354743a449 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 20 Jan 2021 23:08:25 -0500 Subject: * lisp/calendar/cal-french.el (calendar-french-accents-p): Obsolete function Always assume accented letters can be used (calendar-french-month-name-array) (calendar-french-special-days-array): Use the accented names. (calendar-french-multibyte-month-name-array) (calendar-french-multibyte-special-days-array): Make those vars obsolete aliases. (calendar-french-month-name-array, calendar-french-day-name-array) (calendar-french-special-days-array): Mark functions as obsolete. (calendar-french-date-string, calendar-french-goto-date): Always use the text with accents. --- lisp/calendar/cal-french.el | 59 +++++++++++++++++---------------------------- 1 file changed, 22 insertions(+), 37 deletions(-) (limited to 'lisp') diff --git a/lisp/calendar/cal-french.el b/lisp/calendar/cal-french.el index e759b5dad95..c8ab6c41d8b 100644 --- a/lisp/calendar/cal-french.el +++ b/lisp/calendar/cal-french.el @@ -35,54 +35,45 @@ (defconst calendar-french-epoch (calendar-absolute-from-gregorian '(9 22 1792)) "Absolute date of start of French Revolutionary calendar = Sept 22, 1792.") -(defconst calendar-french-month-name-array - ["Vende'miaire" "Brumaire" "Frimaire" "Nivo^se" "Pluvio^se" "Vento^se" - "Germinal" "Flore'al" "Prairial" "Messidor" "Thermidor" "Fructidor"] - "Array of month names in the French calendar.") +(define-obsolete-variable-alias 'calendar-french-multibyte-month-name-array + 'calendar-french-month-name-array "28.1") -(defconst calendar-french-multibyte-month-name-array +(defconst calendar-french-month-name-array ["Vendémiaire" "Brumaire" "Frimaire" "Nivôse" "Pluviôse" "Ventôse" "Germinal" "Floréal" "Prairial" "Messidor" "Thermidor" "Fructidor"] - "Array of multibyte month names in the French calendar.") + "Array of month names in the French calendar.") (defconst calendar-french-day-name-array ["Primidi" "Duodi" "Tridi" "Quartidi" "Quintidi" "Sextidi" "Septidi" "Octidi" "Nonidi" "Decadi"] "Array of day names in the French calendar.") -(defconst calendar-french-special-days-array - ["de la Vertu" "du Ge'nie" "du Travail" "de la Raison" "des Re'compenses" - "de la Re'volution"] - "Array of special day names in the French calendar.") +(define-obsolete-variable-alias 'calendar-french-multibyte-special-days-array + 'calendar-french-special-days-array "28.1") -(defconst calendar-french-multibyte-special-days-array +(defconst calendar-french-special-days-array ["de la Vertu" "du Génie" "du Travail" "de la Raison" "des Récompenses" "de la Révolution"] - "Array of multibyte special day names in the French calendar.") + "Array of special day names in the French calendar.") (defun calendar-french-accents-p () - "Return non-nil if diacritical marks are available." - (and (or window-system - (terminal-coding-system)) - (or enable-multibyte-characters - (and (char-table-p standard-display-table) - (equal (aref standard-display-table 161) [161]))))) + (declare (obsolete nil "28.1")) + t) (defun calendar-french-month-name-array () "Return the array of month names, depending on whether accents are available." - (if (calendar-french-accents-p) - calendar-french-multibyte-month-name-array - calendar-french-month-name-array)) + (declare (obsolete "use the variable of the same name instead" "28.1")) + calendar-french-month-name-array) (defun calendar-french-day-name-array () "Return the array of day names." + (declare (obsolete "use the variable of the same name instead" "28.1")) calendar-french-day-name-array) (defun calendar-french-special-days-array () "Return the special day names, depending on whether accents are available." - (if (calendar-french-accents-p) - calendar-french-multibyte-special-days-array - calendar-french-special-days-array)) + (declare (obsolete "use the variable of the same name instead" "28.1")) + calendar-french-special-days-array) (defun calendar-french-leap-year-p (year) "True if YEAR is a leap year on the French Revolutionary calendar. @@ -171,17 +162,13 @@ Defaults to today's date if DATE is not given." (d (calendar-extract-day french-date))) (cond ((< y 1) "") - ((= m 13) (format (if (calendar-french-accents-p) - "Jour %s de l'Année %d de la Révolution" - "Jour %s de l'Anne'e %d de la Re'volution") - (aref (calendar-french-special-days-array) (1- d)) + ((= m 13) (format "Jour %s de l'Année %d de la Révolution" + (aref calendar-french-special-days-array (1- d)) y)) (t (format - (if (calendar-french-accents-p) - "%d %s an %d de la Révolution" - "%d %s an %d de la Re'volution") + "%d %s an %d de la Révolution" d - (aref (calendar-french-month-name-array) (1- m)) + (aref calendar-french-month-name-array (1- m)) y))))) ;;;###cal-autoload @@ -198,13 +185,11 @@ Defaults to today's date if DATE is not given." "Move cursor to French Revolutionary date DATE. Echo French Revolutionary date unless NOECHO is non-nil." (interactive - (let* ((months (calendar-french-month-name-array)) - (special-days (calendar-french-special-days-array)) + (let* ((months calendar-french-month-name-array) + (special-days calendar-french-special-days-array) (year (progn (calendar-read - (if (calendar-french-accents-p) - "Année de la Révolution (>0): " - "Anne'e de la Re'volution (>0): ") + "Année de la Révolution (>0): " (lambda (x) (> x 0)) (number-to-string (calendar-extract-year -- cgit v1.2.3 From 0c93d0d072d6030c57bb8ab9e7b90686ed79af15 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 20 Jan 2021 23:14:25 -0500 Subject: Use `calendar-read-sexp` instead of the now obsolete `calendar-read` * lisp/calendar/diary-lib.el (diary-insert-cyclic-entry): * lisp/calendar/cal-persia.el (calendar-persian-read-date): * lisp/calendar/cal-move.el (calendar-goto-day-of-year): * lisp/calendar/cal-mayan.el (calendar-mayan-read-haab-date) (calendar-mayan-read-tzolkin-date): * lisp/calendar/cal-julian.el (calendar-julian-goto-date) (calendar-astro-goto-day-number): * lisp/calendar/cal-iso.el (calendar-iso-read-date): * lisp/calendar/cal-islam.el (calendar-islamic-read-date): * lisp/calendar/cal-hebrew.el (calendar-hebrew-read-date) (calendar-hebrew-list-yahrzeits): * lisp/calendar/cal-french.el (calendar-french-goto-date): * lisp/calendar/cal-coptic.el (calendar-coptic-read-date): * lisp/calendar/cal-china.el (calendar-chinese-goto-date): * lisp/calendar/cal-bahai.el (calendar-bahai-read-date): * lisp/calendar/holidays.el (list-holidays): Use `calendar-read-sexp`. --- lisp/calendar/cal-bahai.el | 15 +++++++------ lisp/calendar/cal-china.el | 20 ++++++++++-------- lisp/calendar/cal-coptic.el | 23 +++++++++++--------- lisp/calendar/cal-french.el | 17 +++++++-------- lisp/calendar/cal-hebrew.el | 51 ++++++++++++++++++++++++--------------------- lisp/calendar/cal-islam.el | 19 +++++++++-------- lisp/calendar/cal-iso.el | 19 +++++++++-------- lisp/calendar/cal-julian.el | 26 +++++++++++------------ lisp/calendar/cal-mayan.el | 8 +++---- lisp/calendar/cal-move.el | 15 ++++++------- lisp/calendar/cal-persia.el | 21 ++++++++++--------- lisp/calendar/diary-lib.el | 4 ++-- lisp/calendar/holidays.el | 15 +++++++------ 13 files changed, 131 insertions(+), 122 deletions(-) (limited to 'lisp') diff --git a/lisp/calendar/cal-bahai.el b/lisp/calendar/cal-bahai.el index 22e4cdbcd52..16176e37b4a 100644 --- a/lisp/calendar/cal-bahai.el +++ b/lisp/calendar/cal-bahai.el @@ -153,13 +153,12 @@ Defaults to today's date if DATE is not given." "Interactively read the arguments for a Bahá’í date command. Reads a year, month and day." (let* ((today (calendar-current-date)) - (year (calendar-read - "Bahá’í calendar year (not 0): " + (year (calendar-read-sexp + "Bahá’í calendar year (not 0)" (lambda (x) (not (zerop x))) - (number-to-string - (calendar-extract-year - (calendar-bahai-from-absolute - (calendar-absolute-from-gregorian today)))))) + (calendar-extract-year + (calendar-bahai-from-absolute + (calendar-absolute-from-gregorian today))))) (completion-ignore-case t) (month (cdr (assoc (completing-read @@ -169,8 +168,8 @@ Reads a year, month and day." nil t) (calendar-make-alist calendar-bahai-month-name-array 1)))) - (day (calendar-read "Bahá’í calendar day (1-19): " - (lambda (x) (and (< 0 x) (<= x 19)))))) + (day (calendar-read-sexp "Bahá’í calendar day (1-19)" + (lambda (x) (and (< 0 x) (<= x 19)))))) (list (list month day year)))) ;;;###cal-autoload diff --git a/lisp/calendar/cal-china.el b/lisp/calendar/cal-china.el index 7e5d0c46e11..dd69d849df1 100644 --- a/lisp/calendar/cal-china.el +++ b/lisp/calendar/cal-china.el @@ -602,14 +602,14 @@ Echo Chinese date unless NOECHO is non-nil." (interactive (let* ((c (calendar-chinese-from-absolute (calendar-absolute-from-gregorian (calendar-current-date)))) - (cycle (calendar-read - "Chinese calendar cycle number (>44): " + (cycle (calendar-read-sexp + "Chinese calendar cycle number (>44)" (lambda (x) (> x 44)) - (number-to-string (car c)))) - (year (calendar-read - "Year in Chinese cycle (1..60): " + (car c))) + (year (calendar-read-sexp + "Year in Chinese cycle (1..60)" (lambda (x) (and (<= 1 x) (<= x 60))) - (number-to-string (cadr c)))) + (cadr c))) (month-list (calendar-chinese-months-to-alist (calendar-chinese-months cycle year))) (month (cdr (assoc @@ -624,9 +624,11 @@ Echo Chinese date unless NOECHO is non-nil." (list cycle year month 1)))))) 30 29)) - (day (calendar-read - (format "Chinese calendar day (1-%d): " last) - (lambda (x) (and (<= 1 x) (<= x last)))))) + (day (calendar-read-sexp + "Chinese calendar day (1-%d)" + (lambda (x) (and (<= 1 x) (<= x last))) + nil + last))) (list (list cycle year month day)))) (calendar-goto-date (calendar-gregorian-from-absolute (calendar-chinese-to-absolute date))) diff --git a/lisp/calendar/cal-coptic.el b/lisp/calendar/cal-coptic.el index 3461f3259b9..2a0e7d81e0c 100644 --- a/lisp/calendar/cal-coptic.el +++ b/lisp/calendar/cal-coptic.el @@ -136,13 +136,13 @@ Defaults to today's date if DATE is not given." "Interactively read the arguments for a Coptic date command. Reads a year, month, and day." (let* ((today (calendar-current-date)) - (year (calendar-read - (format "%s calendar year (>0): " calendar-coptic-name) + (year (calendar-read-sexp + "%s calendar year (>0)" (lambda (x) (> x 0)) - (number-to-string - (calendar-extract-year - (calendar-coptic-from-absolute - (calendar-absolute-from-gregorian today)))))) + (calendar-extract-year + (calendar-coptic-from-absolute + (calendar-absolute-from-gregorian today))) + calendar-coptic-name)) (completion-ignore-case t) (month (cdr (assoc-string (completing-read @@ -151,11 +151,14 @@ Reads a year, month, and day." (append calendar-coptic-month-name-array nil)) nil t) (calendar-make-alist calendar-coptic-month-name-array - 1) t))) + 1) + t))) (last (calendar-coptic-last-day-of-month month year)) - (day (calendar-read - (format "%s calendar day (1-%d): " calendar-coptic-name last) - (lambda (x) (and (< 0 x) (<= x last)))))) + (day (calendar-read-sexp + "%s calendar day (1-%d)" + (lambda (x) (and (< 0 x) (<= x last))) + nil + calendar-coptic-name last))) (list (list month day year)))) ;;;###cal-autoload diff --git a/lisp/calendar/cal-french.el b/lisp/calendar/cal-french.el index c8ab6c41d8b..07c41c00bfe 100644 --- a/lisp/calendar/cal-french.el +++ b/lisp/calendar/cal-french.el @@ -188,14 +188,13 @@ Echo French Revolutionary date unless NOECHO is non-nil." (let* ((months calendar-french-month-name-array) (special-days calendar-french-special-days-array) (year (progn - (calendar-read - "Année de la Révolution (>0): " + (calendar-read-sexp + "Année de la Révolution (>0)" (lambda (x) (> x 0)) - (number-to-string - (calendar-extract-year - (calendar-french-from-absolute - (calendar-absolute-from-gregorian - (calendar-current-date)))))))) + (calendar-extract-year + (calendar-french-from-absolute + (calendar-absolute-from-gregorian + (calendar-current-date))))))) (month-list (mapcar 'list (append months @@ -219,8 +218,8 @@ Echo French Revolutionary date unless NOECHO is non-nil." (calendar-make-alist month-list 1 'car) t))) (day (if (> month 12) (- month 12) - (calendar-read - "Jour (1-30): " + (calendar-read-sexp + "Jour (1-30)" (lambda (x) (and (<= 1 x) (<= x 30)))))) (month (if (> month 12) 13 month))) (list (list month day year)))) diff --git a/lisp/calendar/cal-hebrew.el b/lisp/calendar/cal-hebrew.el index bcc80f0877b..a835f9b430e 100644 --- a/lisp/calendar/cal-hebrew.el +++ b/lisp/calendar/cal-hebrew.el @@ -225,13 +225,12 @@ Driven by the variable `calendar-date-display-form'." "Interactively read the arguments for a Hebrew date command. Reads a year, month, and day." (let* ((today (calendar-current-date)) - (year (calendar-read - "Hebrew calendar year (>3760): " + (year (calendar-read-sexp + "Hebrew calendar year (>3760)" (lambda (x) (> x 3760)) - (number-to-string - (calendar-extract-year - (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian today)))))) + (calendar-extract-year + (calendar-hebrew-from-absolute + (calendar-absolute-from-gregorian today))))) (month-array (if (calendar-hebrew-leap-year-p year) calendar-hebrew-month-name-array-leap-year calendar-hebrew-month-name-array-common-year)) @@ -258,10 +257,11 @@ Reads a year, month, and day." (last (calendar-hebrew-last-day-of-month month year)) (first (if (and (= year 3761) (= month 10)) 18 1)) - (day (calendar-read - (format "Hebrew calendar day (%d-%d): " - first last) - (lambda (x) (and (<= first x) (<= x last)))))) + (day (calendar-read-sexp + "Hebrew calendar day (%d-%d)" + (lambda (x) (and (<= first x) (<= x last))) + nil + first last))) (list (list month day year)))) ;;;###cal-autoload @@ -681,10 +681,10 @@ from the cursor position." (if (equal (current-buffer) (get-buffer calendar-buffer)) (calendar-cursor-to-date t) (let* ((today (calendar-current-date)) - (year (calendar-read - "Year of death (>0): " + (year (calendar-read-sexp + "Year of death (>0)" (lambda (x) (> x 0)) - (number-to-string (calendar-extract-year today)))) + (calendar-extract-year today))) (month-array calendar-month-name-array) (completion-ignore-case t) (month (cdr (assoc-string @@ -694,20 +694,23 @@ from the cursor position." nil t) (calendar-make-alist month-array 1) t))) (last (calendar-last-day-of-month month year)) - (day (calendar-read - (format "Day of death (1-%d): " last) - (lambda (x) (and (< 0 x) (<= x last)))))) + (day (calendar-read-sexp + "Day of death (1-%d)" + (lambda (x) (and (< 0 x) (<= x last))) + nil + last))) (list month day year)))) (death-year (calendar-extract-year death-date)) - (start-year (calendar-read - (format "Starting year of Yahrzeit table (>%d): " - death-year) + (start-year (calendar-read-sexp + "Starting year of Yahrzeit table (>%d)" (lambda (x) (> x death-year)) - (number-to-string (1+ death-year)))) - (end-year (calendar-read - (format "Ending year of Yahrzeit table (>=%d): " - start-year) - (lambda (x) (>= x start-year))))) + (1+ death-year) + death-year)) + (end-year (calendar-read-sexp + "Ending year of Yahrzeit table (>=%d)" + (lambda (x) (>= x start-year)) + nil + start-year))) (list death-date start-year end-year))) (message "Computing Yahrzeits...") (let* ((h-date (calendar-hebrew-from-absolute diff --git a/lisp/calendar/cal-islam.el b/lisp/calendar/cal-islam.el index d256310ba6c..4082ed43e5d 100644 --- a/lisp/calendar/cal-islam.el +++ b/lisp/calendar/cal-islam.el @@ -143,13 +143,12 @@ Driven by the variable `calendar-date-display-form'." "Interactively read the arguments for an Islamic date command. Reads a year, month, and day." (let* ((today (calendar-current-date)) - (year (calendar-read - "Islamic calendar year (>0): " + (year (calendar-read-sexp + "Islamic calendar year (>0)" (lambda (x) (> x 0)) - (number-to-string - (calendar-extract-year - (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian today)))))) + (calendar-extract-year + (calendar-islamic-from-absolute + (calendar-absolute-from-gregorian today))))) (month-array calendar-islamic-month-name-array) (completion-ignore-case t) (month (cdr (assoc-string @@ -159,9 +158,11 @@ Reads a year, month, and day." nil t) (calendar-make-alist month-array 1) t))) (last (calendar-islamic-last-day-of-month month year)) - (day (calendar-read - (format "Islamic calendar day (1-%d): " last) - (lambda (x) (and (< 0 x) (<= x last)))))) + (day (calendar-read-sexp + "Islamic calendar day (1-%d)" + (lambda (x) (and (< 0 x) (<= x last))) + nil + last))) (list (list month day year)))) ;;;###cal-autoload diff --git a/lisp/calendar/cal-iso.el b/lisp/calendar/cal-iso.el index 956433e4a20..a247b2d15a9 100644 --- a/lisp/calendar/cal-iso.el +++ b/lisp/calendar/cal-iso.el @@ -92,22 +92,23 @@ date Sunday, December 31, 1 BC." "Interactively read the arguments for an ISO date command. Reads a year and week, and if DAYFLAG is non-nil a day (otherwise taken to be 1)." - (let* ((year (calendar-read - "ISO calendar year (>0): " + (let* ((year (calendar-read-sexp + "ISO calendar year (>0)" (lambda (x) (> x 0)) - (number-to-string (calendar-extract-year - (calendar-current-date))))) + (calendar-extract-year (calendar-current-date)))) (no-weeks (calendar-extract-month (calendar-iso-from-absolute (1- (calendar-dayname-on-or-before 1 (calendar-absolute-from-gregorian (list 1 4 (1+ year)))))))) - (week (calendar-read - (format "ISO calendar week (1-%d): " no-weeks) - (lambda (x) (and (> x 0) (<= x no-weeks))))) - (day (if dayflag (calendar-read - "ISO day (1-7): " + (week (calendar-read-sexp + "ISO calendar week (1-%d)" + (lambda (x) (and (> x 0) (<= x no-weeks))) + nil + no-weeks)) + (day (if dayflag (calendar-read-sexp + "ISO day (1-7)" (lambda (x) (and (<= 1 x) (<= x 7)))) 1))) (list (list week day year)))) diff --git a/lisp/calendar/cal-julian.el b/lisp/calendar/cal-julian.el index 235b4d00900..47880a4e974 100644 --- a/lisp/calendar/cal-julian.el +++ b/lisp/calendar/cal-julian.el @@ -95,14 +95,13 @@ Driven by the variable `calendar-date-display-form'." "Move cursor to Julian DATE; echo Julian date unless NOECHO is non-nil." (interactive (let* ((today (calendar-current-date)) - (year (calendar-read - "Julian calendar year (>0): " + (year (calendar-read-sexp + "Julian calendar year (>0)" (lambda (x) (> x 0)) - (number-to-string - (calendar-extract-year - (calendar-julian-from-absolute - (calendar-absolute-from-gregorian - today)))))) + (calendar-extract-year + (calendar-julian-from-absolute + (calendar-absolute-from-gregorian + today))))) (month-array calendar-month-name-array) (completion-ignore-case t) (month (cdr (assoc-string @@ -115,12 +114,13 @@ Driven by the variable `calendar-date-display-form'." (if (and (zerop (% year 4)) (= month 2)) 29 (aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month)))) - (day (calendar-read - (format "Julian calendar day (%d-%d): " - (if (and (= year 1) (= month 1)) 3 1) last) + (day (calendar-read-sexp + "Julian calendar day (%d-%d)" (lambda (x) (and (< (if (and (= year 1) (= month 1)) 2 0) x) - (<= x last)))))) + (<= x last))) + nil + (if (and (= year 1) (= month 1)) 3 1) last))) (list (list month day year)))) (calendar-goto-date (calendar-gregorian-from-absolute (calendar-julian-to-absolute date))) @@ -173,8 +173,8 @@ Defaults to today's date if DATE is not given." (defun calendar-astro-goto-day-number (daynumber &optional noecho) "Move cursor to astronomical (Julian) DAYNUMBER. Echo astronomical (Julian) day number unless NOECHO is non-nil." - (interactive (list (calendar-read - "Astronomical (Julian) day number (>1721425): " + (interactive (list (calendar-read-sexp + "Astronomical (Julian) day number (>1721425)" (lambda (x) (> x 1721425))))) (calendar-goto-date (calendar-gregorian-from-absolute diff --git a/lisp/calendar/cal-mayan.el b/lisp/calendar/cal-mayan.el index 8d894ebd986..e3533e7b1d6 100644 --- a/lisp/calendar/cal-mayan.el +++ b/lisp/calendar/cal-mayan.el @@ -135,8 +135,8 @@ but some use 1137140. Using 1232041 gives you Spinden's correlation; using (defun calendar-mayan-read-haab-date () "Prompt for a Mayan haab date." (let* ((completion-ignore-case t) - (haab-day (calendar-read - "Haab kin (0-19): " + (haab-day (calendar-read-sexp + "Haab kin (0-19)" (lambda (x) (and (>= x 0) (< x 20))))) (haab-month-list (append calendar-mayan-haab-month-name-array (and (< haab-day 5) '("Uayeb")))) @@ -151,8 +151,8 @@ but some use 1137140. Using 1232041 gives you Spinden's correlation; using (defun calendar-mayan-read-tzolkin-date () "Prompt for a Mayan tzolkin date." (let* ((completion-ignore-case t) - (tzolkin-count (calendar-read - "Tzolkin kin (1-13): " + (tzolkin-count (calendar-read-sexp + "Tzolkin kin (1-13)" (lambda (x) (and (> x 0) (< x 14))))) (tzolkin-name-list (append calendar-mayan-tzolkin-names-array nil)) (tzolkin-name (cdr diff --git a/lisp/calendar/cal-move.el b/lisp/calendar/cal-move.el index 710ce37ccbf..c2b5d618ea0 100644 --- a/lisp/calendar/cal-move.el +++ b/lisp/calendar/cal-move.el @@ -386,15 +386,16 @@ Moves forward if ARG is negative." "Move cursor to YEAR, DAY number; echo DAY/YEAR unless NOECHO is non-nil. Negative DAY counts backward from end of year." (interactive - (let* ((year (calendar-read - "Year (>0): " + (let* ((year (calendar-read-sexp + "Year (>0)" (lambda (x) (> x 0)) - (number-to-string (calendar-extract-year - (calendar-current-date))))) + (calendar-extract-year (calendar-current-date)))) (last (if (calendar-leap-year-p year) 366 365)) - (day (calendar-read - (format "Day number (+/- 1-%d): " last) - (lambda (x) (and (<= 1 (abs x)) (<= (abs x) last)))))) + (day (calendar-read-sexp + "Day number (+/- 1-%d)" + (lambda (x) (and (<= 1 (abs x)) (<= (abs x) last))) + nil + last))) (list year day))) (calendar-goto-date (calendar-gregorian-from-absolute diff --git a/lisp/calendar/cal-persia.el b/lisp/calendar/cal-persia.el index a9c99fedbdb..21085284ac8 100644 --- a/lisp/calendar/cal-persia.el +++ b/lisp/calendar/cal-persia.el @@ -157,14 +157,13 @@ Gregorian date Sunday, December 31, 1 BC." (defun calendar-persian-read-date () "Interactively read the arguments for a Persian date command. Reads a year, month, and day." - (let* ((year (calendar-read - "Persian calendar year (not 0): " + (let* ((year (calendar-read-sexp + "Persian calendar year (not 0)" (lambda (x) (not (zerop x))) - (number-to-string - (calendar-extract-year - (calendar-persian-from-absolute - (calendar-absolute-from-gregorian - (calendar-current-date))))))) + (calendar-extract-year + (calendar-persian-from-absolute + (calendar-absolute-from-gregorian + (calendar-current-date)))))) (completion-ignore-case t) (month (cdr (assoc (completing-read @@ -175,9 +174,11 @@ Reads a year, month, and day." (calendar-make-alist calendar-persian-month-name-array 1)))) (last (calendar-persian-last-day-of-month month year)) - (day (calendar-read - (format "Persian calendar day (1-%d): " last) - (lambda (x) (and (< 0 x) (<= x last)))))) + (day (calendar-read-sexp + "Persian calendar day (1-%d)" + (lambda (x) (and (< 0 x) (<= x last))) + nil + last))) (list (list month day year)))) ;;;###cal-autoload diff --git a/lisp/calendar/diary-lib.el b/lisp/calendar/diary-lib.el index aad70161f9f..4efa3669967 100644 --- a/lisp/calendar/diary-lib.el +++ b/lisp/calendar/diary-lib.el @@ -2221,8 +2221,8 @@ Prefix argument ARG makes the entry nonmarking." (diary-make-entry (format "%s(diary-cyclic %d %s)" diary-sexp-entry-symbol - (calendar-read "Repeat every how many days: " - (lambda (x) (> x 0))) + (calendar-read-sexp "Repeat every how many days" + (lambda (x) (> x 0))) (calendar-date-string (calendar-cursor-to-date t) nil t)) arg))) diff --git a/lisp/calendar/holidays.el b/lisp/calendar/holidays.el index 932993beba0..4bc17de3067 100644 --- a/lisp/calendar/holidays.el +++ b/lisp/calendar/holidays.el @@ -423,16 +423,15 @@ of a holiday list. The optional LABEL is used to label the buffer created." (interactive - (let* ((start-year (calendar-read - "Starting year of holidays (>0): " + (let* ((start-year (calendar-read-sexp + "Starting year of holidays (>0)" (lambda (x) (> x 0)) - (number-to-string (calendar-extract-year - (calendar-current-date))))) - (end-year (calendar-read - (format "Ending year (inclusive) of holidays (>=%s): " - start-year) + (calendar-extract-year (calendar-current-date)))) + (end-year (calendar-read-sexp + "Ending year (inclusive) of holidays (>=%s)" (lambda (x) (>= x start-year)) - (number-to-string start-year))) + start-year + start-year)) (completion-ignore-case t) (lists (list -- cgit v1.2.3 From bacc24b5d0d708dd9ac34e314c2d3af25b311397 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 20 Jan 2021 23:45:18 -0500 Subject: Use `lexical-binding` in all the cal-*.el files * lisp/calendar/cal-bahai.el: Use lexical-binding. (calendar-bahai-date-string): Use `calendar-dlet*`. * lisp/calendar/cal-china.el: Use lexical-binding. (calendar-chinese-zodiac-sign-on-or-after) (calendar-chinese-new-moon-on-or-after): Declare `year`. (calendar-chinese-from-absolute-for-diary) (calendar-chinese-to-absolute-for-diary) (calendar-chinese-mark-date-pattern): Avoid dynbound var `date` as function argument. * lisp/calendar/cal-coptic.el: Use lexical-binding. (calendar-coptic-date-string): Use `calendar-dlet*`. (calendar-ethiopic-to-absolute, calendar-ethiopic-from-absolute) (calendar-ethiopic-date-string, calendar-ethiopic-goto-date): Avoid dynbound var `date` as function argument. * lisp/calendar/cal-french.el: Use lexical-binding. * lisp/calendar/cal-hebrew.el: Use lexical-binding. (holiday-hebrew-hanukkah): Don't use the third form in `dotimes`. * lisp/calendar/cal-islam.el: Use lexical-binding. (calendar-islamic-to-absolute): Comment out unused vars `month` and `day`. * lisp/calendar/cal-move.el: * lisp/calendar/cal-mayan.el: * lisp/calendar/cal-iso.el: Use lexical-binding. * lisp/calendar/cal-persia.el: Use lexical-binding. (calendar-persian-date-string): Use `calendar-dlet*`. * lisp/calendar/cal-html.el: Use lexical-binding. (cal-html-insert-minical): Comment out unused var `date`. (cal-html-cursor-month, cal-html-cursor-year): Mark `event` arg as unused. * lisp/calendar/cal-menu.el: Use lexical-binding. (diary-list-include-blanks): Declare var. * lisp/calendar/cal-x.el: Use lexical-binding. * lisp/calendar/cal-tex.el: Use lexical-binding. (diary-list-include-blanks): Declare var. (cal-tex-insert-days, cal-tex-cursor-week-iso, cal-tex-week-hours) (cal-tex-weekly-common, cal-tex-cursor-filofax-2week) (cal-tex-cursor-filofax-daily, cal-tex-daily-page): Declare `date` as dynbound for the benefit of `cal-tex-daily-string`. --- lisp/calendar/cal-bahai.el | 13 +++---- lisp/calendar/cal-china.el | 25 +++++++------ lisp/calendar/cal-coptic.el | 33 +++++++++--------- lisp/calendar/cal-french.el | 2 +- lisp/calendar/cal-hebrew.el | 17 ++++----- lisp/calendar/cal-html.el | 19 +++++----- lisp/calendar/cal-islam.el | 6 ++-- lisp/calendar/cal-iso.el | 2 +- lisp/calendar/cal-mayan.el | 2 +- lisp/calendar/cal-menu.el | 4 ++- lisp/calendar/cal-move.el | 2 +- lisp/calendar/cal-persia.el | 9 ++--- lisp/calendar/cal-tex.el | 85 +++++++++++++++++++++++++++------------------ lisp/calendar/cal-x.el | 2 +- 14 files changed, 125 insertions(+), 96 deletions(-) (limited to 'lisp') diff --git a/lisp/calendar/cal-bahai.el b/lisp/calendar/cal-bahai.el index 16176e37b4a..c2e4205c0bc 100644 --- a/lisp/calendar/cal-bahai.el +++ b/lisp/calendar/cal-bahai.el @@ -1,4 +1,4 @@ -;;; cal-bahai.el --- calendar functions for the Bahá’í calendar. +;;; cal-bahai.el --- calendar functions for the Bahá’í calendar. -*- lexical-binding: t; -*- ;; Copyright (C) 2001-2021 Free Software Foundation, Inc. @@ -124,9 +124,10 @@ Defaults to today's date if DATE is not given." (y (calendar-extract-year bahai-date))) (if (< y 1) "" ; pre-Bahai - (let* ((m (calendar-extract-month bahai-date)) - (d (calendar-extract-day bahai-date)) - (monthname (if (and (= m 19) + (let ((m (calendar-extract-month bahai-date)) + (d (calendar-extract-day bahai-date))) + (calendar-dlet* + ((monthname (if (and (= m 19) (<= d 0)) "Ayyám-i-Há" (aref calendar-bahai-month-name-array (1- m)))) @@ -137,8 +138,8 @@ Defaults to today's date if DATE is not given." (year (number-to-string y)) (month (number-to-string m)) dayname) - ;; Can't call calendar-date-string because of monthname oddity. - (mapconcat 'eval calendar-date-display-form ""))))) + ;; Can't call calendar-date-string because of monthname oddity. + (mapconcat #'eval calendar-date-display-form "")))))) ;;;###cal-autoload (defun calendar-bahai-print-date () diff --git a/lisp/calendar/cal-china.el b/lisp/calendar/cal-china.el index dd69d849df1..9a28984a7ab 100644 --- a/lisp/calendar/cal-china.el +++ b/lisp/calendar/cal-china.el @@ -1,4 +1,4 @@ -;;; cal-china.el --- calendar functions for the Chinese calendar +;;; cal-china.el --- calendar functions for the Chinese calendar -*- lexical-binding: t; -*- ;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc. @@ -185,7 +185,9 @@ N congruent to 1 gives the first name, N congruent to 2 gives the second name, (defun calendar-chinese-zodiac-sign-on-or-after (d) "Absolute date of first new Zodiac sign on or after absolute date D. The Zodiac signs begin when the sun's longitude is a multiple of 30 degrees." - (let* ((year (calendar-extract-year (calendar-gregorian-from-absolute d))) + (with-suppressed-warnings ((lexical year)) + (defvar year)) + (let* ((year (calendar-extract-year (calendar-gregorian-from-absolute d))) (calendar-time-zone (eval calendar-chinese-time-zone)) ; uses year (calendar-daylight-time-offset calendar-chinese-daylight-time-offset) @@ -207,6 +209,8 @@ The Zodiac signs begin when the sun's longitude is a multiple of 30 degrees." (defun calendar-chinese-new-moon-on-or-after (d) "Absolute date of first new moon on or after absolute date D." + (with-suppressed-warnings ((lexical year)) + (defvar year)) (let* ((year (calendar-extract-year (calendar-gregorian-from-absolute d))) (calendar-time-zone (eval calendar-chinese-time-zone)) (calendar-daylight-time-offset @@ -665,17 +669,17 @@ Echo Chinese date unless NOECHO is non-nil." ["正月" "二月" "三月" "四月" "五月" "六月" "七月" "八月" "九月" "十月" "冬月" "臘月"]) -;;; NOTE: In the diary the cycle and year of a Chinese date is -;;; combined using this formula: (+ (* cycle 100) year). +;; NOTE: In the diary the cycle and year of a Chinese date is +;; combined using this formula: (+ (* cycle 100) year). ;;; -;;; These two functions convert to and back from this representation. -(defun calendar-chinese-from-absolute-for-diary (date) - (pcase-let ((`(,c ,y ,m ,d) (calendar-chinese-from-absolute date))) +;; These two functions convert to and back from this representation. +(defun calendar-chinese-from-absolute-for-diary (thedate) + (pcase-let ((`(,c ,y ,m ,d) (calendar-chinese-from-absolute thedate))) ;; Note: For leap months M is a float. (list (floor m) d (+ (* c 100) y)))) -(defun calendar-chinese-to-absolute-for-diary (date &optional prefer-leap) - (pcase-let* ((`(,m ,d ,y) date) +(defun calendar-chinese-to-absolute-for-diary (thedate &optional prefer-leap) + (pcase-let* ((`(,m ,d ,y) thedate) (cycle (floor y 100)) (year (mod y 100)) (months (calendar-chinese-months cycle year)) @@ -693,7 +697,8 @@ Echo Chinese date unless NOECHO is non-nil." (unless (zerop month) (calendar-mark-1 month day year #'calendar-chinese-from-absolute-for-diary - (lambda (date) (calendar-chinese-to-absolute-for-diary date t)) + (lambda (thedate) + (calendar-chinese-to-absolute-for-diary thedate t)) color))) ;;;###cal-autoload diff --git a/lisp/calendar/cal-coptic.el b/lisp/calendar/cal-coptic.el index 2a0e7d81e0c..346585e1817 100644 --- a/lisp/calendar/cal-coptic.el +++ b/lisp/calendar/cal-coptic.el @@ -1,4 +1,4 @@ -;;; cal-coptic.el --- calendar functions for the Coptic/Ethiopic calendars +;;; cal-coptic.el --- calendar functions for the Coptic/Ethiopic calendars -*- lexical-binding: t; -*- ;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc. @@ -116,12 +116,13 @@ Defaults to today's date if DATE is not given." (m (calendar-extract-month coptic-date))) (if (< y 1) "" - (let ((monthname (aref calendar-coptic-month-name-array (1- m))) - (day (number-to-string (calendar-extract-day coptic-date))) - (dayname nil) - (month (number-to-string m)) - (year (number-to-string y))) - (mapconcat 'eval calendar-date-display-form ""))))) + (calendar-dlet* + ((monthname (aref calendar-coptic-month-name-array (1- m))) + (day (number-to-string (calendar-extract-day coptic-date))) + (dayname nil) + (month (number-to-string m)) + (year (number-to-string y))) + (mapconcat #'eval calendar-date-display-form ""))))) ;;;###cal-autoload (defun calendar-coptic-print-date () @@ -197,30 +198,30 @@ Echo Coptic date unless NOECHO is t." (defconst calendar-ethiopic-name "Ethiopic" "Used in some message strings.") -(defun calendar-ethiopic-to-absolute (date) +(defun calendar-ethiopic-to-absolute (thedate) "Compute absolute date from Ethiopic date DATE. The absolute date is the number of days elapsed since the (imaginary) Gregorian date Sunday, December 31, 1 BC." (let ((calendar-coptic-epoch calendar-ethiopic-epoch)) - (calendar-coptic-to-absolute date))) + (calendar-coptic-to-absolute thedate))) -(defun calendar-ethiopic-from-absolute (date) +(defun calendar-ethiopic-from-absolute (thedate) "Compute the Ethiopic equivalent for absolute date DATE. The result is a list of the form (MONTH DAY YEAR). The absolute date is the number of days elapsed since the imaginary Gregorian date Sunday, December 31, 1 BC." (let ((calendar-coptic-epoch calendar-ethiopic-epoch)) - (calendar-coptic-from-absolute date))) + (calendar-coptic-from-absolute thedate))) ;;;###cal-autoload -(defun calendar-ethiopic-date-string (&optional date) +(defun calendar-ethiopic-date-string (&optional thedate) "String of Ethiopic date of Gregorian DATE. Returns the empty string if DATE is pre-Ethiopic calendar. Defaults to today's date if DATE is not given." (let ((calendar-coptic-epoch calendar-ethiopic-epoch) (calendar-coptic-name calendar-ethiopic-name) (calendar-coptic-month-name-array calendar-ethiopic-month-name-array)) - (calendar-coptic-date-string date))) + (calendar-coptic-date-string thedate))) ;;;###cal-autoload (defun calendar-ethiopic-print-date () @@ -232,8 +233,8 @@ Defaults to today's date if DATE is not given." (call-interactively 'calendar-coptic-print-date))) ;;;###cal-autoload -(defun calendar-ethiopic-goto-date (date &optional noecho) - "Move cursor to Ethiopic date DATE. +(defun calendar-ethiopic-goto-date (thedate &optional noecho) + "Move cursor to Ethiopic date THEDATE. Echo Ethiopic date unless NOECHO is t." (interactive (let ((calendar-coptic-epoch calendar-ethiopic-epoch) @@ -241,7 +242,7 @@ Echo Ethiopic date unless NOECHO is t." (calendar-coptic-month-name-array calendar-ethiopic-month-name-array)) (calendar-coptic-read-date))) (calendar-goto-date (calendar-gregorian-from-absolute - (calendar-ethiopic-to-absolute date))) + (calendar-ethiopic-to-absolute thedate))) (or noecho (calendar-ethiopic-print-date))) ;; To be called from diary-list-sexp-entries, where DATE is bound. diff --git a/lisp/calendar/cal-french.el b/lisp/calendar/cal-french.el index 07c41c00bfe..639bae700cc 100644 --- a/lisp/calendar/cal-french.el +++ b/lisp/calendar/cal-french.el @@ -1,4 +1,4 @@ -;;; cal-french.el --- calendar functions for the French Revolutionary calendar +;;; cal-french.el --- calendar functions for the French Revolutionary calendar -*- lexical-binding: t; -*- ;; Copyright (C) 1988-1989, 1992, 1994-1995, 1997, 2001-2021 Free ;; Software Foundation, Inc. diff --git a/lisp/calendar/cal-hebrew.el b/lisp/calendar/cal-hebrew.el index a835f9b430e..50b4fc363bb 100644 --- a/lisp/calendar/cal-hebrew.el +++ b/lisp/calendar/cal-hebrew.el @@ -1,4 +1,4 @@ -;;; cal-hebrew.el --- calendar functions for the Hebrew calendar +;;; cal-hebrew.el --- calendar functions for the Hebrew calendar -*- lexical-binding: t; -*- ;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc. @@ -399,19 +399,20 @@ is non-nil." (list m (calendar-last-day-of-month m y) y)))))) (abs-h (calendar-hebrew-to-absolute (list 9 25 h-y))) (ord ["first" "second" "third" "fourth" "fifth" "sixth" - "seventh" "eighth"]) - han) + "seventh" "eighth"])) (holiday-filter-visible-calendar (if (or all calendar-hebrew-all-holidays-flag) (append (list (list (calendar-gregorian-from-absolute (1- abs-h)) "Erev Hanukkah")) - (dotimes (i 8 (nreverse han)) - (push (list - (calendar-gregorian-from-absolute (+ abs-h i)) - (format "Hanukkah (%s day)" (aref ord i))) - han))) + (let (han) + (dotimes (i 8) + (push (list + (calendar-gregorian-from-absolute (+ abs-h i)) + (format "Hanukkah (%s day)" (aref ord i))) + han)) + (nreverse han))) (list (list (calendar-gregorian-from-absolute abs-h) "Hanukkah"))))))) ;;;###holiday-autoload diff --git a/lisp/calendar/cal-html.el b/lisp/calendar/cal-html.el index 3d7cc938437..e5810c3f027 100644 --- a/lisp/calendar/cal-html.el +++ b/lisp/calendar/cal-html.el @@ -1,4 +1,4 @@ -;;; cal-html.el --- functions for printing HTML calendars +;;; cal-html.el --- functions for printing HTML calendars -*- lexical-binding: t; -*- ;; Copyright (C) 2002-2021 Free Software Foundation, Inc. @@ -250,7 +250,7 @@ Contains links to previous and next month and year, and current minical." calendar-week-start-day)) 7)) (monthpage-name (cal-html-monthpage-name month year)) - date) + ) ;; date ;; Start writing table. (insert (cal-html-comment "MINICAL") (cal-html-b-table "class=minical border=1 align=center")) @@ -276,7 +276,7 @@ Contains links to previous and next month and year, and current minical." (insert cal-html-e-tablerow-string cal-html-b-tablerow-string))) ;; End empty slots (for some browsers like konqueror). - (dotimes (i end-blank-days) + (dotimes (_ end-blank-days) (insert cal-html-b-tabledata-string cal-html-e-tabledata-string))) @@ -431,12 +431,11 @@ holidays in HOLIDAY-LIST." ;;; User commands. ;;;###cal-autoload -(defun cal-html-cursor-month (month year dir &optional event) +(defun cal-html-cursor-month (month year dir &optional _event) "Write an HTML calendar file for numeric MONTH of four-digit YEAR. The output directory DIR is created if necessary. Interactively, -MONTH and YEAR are taken from the calendar cursor position, or from -the position specified by EVENT. Note that any existing output files -are overwritten." +MONTH and YEAR are taken from the calendar cursor position. +Note that any existing output files are overwritten." (interactive (let* ((event last-nonmenu-event) (date (calendar-cursor-to-date t event)) (month (calendar-extract-month date)) @@ -446,11 +445,11 @@ are overwritten." (cal-html-one-month month year dir)) ;;;###cal-autoload -(defun cal-html-cursor-year (year dir &optional event) +(defun cal-html-cursor-year (year dir &optional _event) "Write HTML calendar files (index and monthly pages) for four-digit YEAR. The output directory DIR is created if necessary. Interactively, -YEAR is taken from the calendar cursor position, or from the position -specified by EVENT. Note that any existing output files are overwritten." +YEAR is taken from the calendar cursor position. +Note that any existing output files are overwritten." (interactive (let* ((event last-nonmenu-event) (year (calendar-extract-year (calendar-cursor-to-date t event)))) diff --git a/lisp/calendar/cal-islam.el b/lisp/calendar/cal-islam.el index 4082ed43e5d..45c6ffa7bd7 100644 --- a/lisp/calendar/cal-islam.el +++ b/lisp/calendar/cal-islam.el @@ -1,4 +1,4 @@ -;;; cal-islam.el --- calendar functions for the Islamic calendar +;;; cal-islam.el --- calendar functions for the Islamic calendar -*- lexical-binding: t; -*- ;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc. @@ -67,8 +67,8 @@ "Absolute date of Islamic DATE. The absolute date is the number of days elapsed since the (imaginary) Gregorian date Sunday, December 31, 1 BC." - (let* ((month (calendar-extract-month date)) - (day (calendar-extract-day date)) + (let* (;;(month (calendar-extract-month date)) + ;;(day (calendar-extract-day date)) (year (calendar-extract-year date)) (y (% year 30)) (leap-years-in-cycle (cond ((< y 3) 0) diff --git a/lisp/calendar/cal-iso.el b/lisp/calendar/cal-iso.el index a247b2d15a9..90f57c25e9d 100644 --- a/lisp/calendar/cal-iso.el +++ b/lisp/calendar/cal-iso.el @@ -1,4 +1,4 @@ -;;; cal-iso.el --- calendar functions for the ISO calendar +;;; cal-iso.el --- calendar functions for the ISO calendar -*- lexical-binding: t; -*- ;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc. diff --git a/lisp/calendar/cal-mayan.el b/lisp/calendar/cal-mayan.el index e3533e7b1d6..9a221921130 100644 --- a/lisp/calendar/cal-mayan.el +++ b/lisp/calendar/cal-mayan.el @@ -1,4 +1,4 @@ -;;; cal-mayan.el --- calendar functions for the Mayan calendars +;;; cal-mayan.el --- calendar functions for the Mayan calendars -*- lexical-binding: t; -*- ;; Copyright (C) 1992-1993, 1995, 1997, 2001-2021 Free Software ;; Foundation, Inc. diff --git a/lisp/calendar/cal-menu.el b/lisp/calendar/cal-menu.el index a30c681a897..497f3329055 100644 --- a/lisp/calendar/cal-menu.el +++ b/lisp/calendar/cal-menu.el @@ -1,4 +1,4 @@ -;;; cal-menu.el --- calendar functions for menu bar and popup menu support +;;; cal-menu.el --- calendar functions for menu bar and popup menu support -*- lexical-binding: t; -*- ;; Copyright (C) 1994-1995, 2001-2021 Free Software Foundation, Inc. @@ -183,6 +183,8 @@ Signals an error if popups are unavailable." ;; Autoloaded in diary-lib. (declare-function calendar-check-holidays "holidays" (date)) +(defvar diary-list-include-blanks) + (defun calendar-mouse-view-diary-entries (&optional date diary event) "Pop up menu of diary entries for mouse-selected date. Use optional DATE and alternative file DIARY. EVENT is the event diff --git a/lisp/calendar/cal-move.el b/lisp/calendar/cal-move.el index c2b5d618ea0..9294362cb43 100644 --- a/lisp/calendar/cal-move.el +++ b/lisp/calendar/cal-move.el @@ -1,4 +1,4 @@ -;;; cal-move.el --- calendar functions for movement in the calendar +;;; cal-move.el --- calendar functions for movement in the calendar -*- lexical-binding: t; -*- ;; Copyright (C) 1995, 2001-2021 Free Software Foundation, Inc. diff --git a/lisp/calendar/cal-persia.el b/lisp/calendar/cal-persia.el index 21085284ac8..ca37d803224 100644 --- a/lisp/calendar/cal-persia.el +++ b/lisp/calendar/cal-persia.el @@ -1,4 +1,4 @@ -;;; cal-persia.el --- calendar functions for the Persian calendar +;;; cal-persia.el --- calendar functions for the Persian calendar -*- lexical-binding: t; -*- ;; Copyright (C) 1996-1997, 2001-2021 Free Software Foundation, Inc. @@ -139,13 +139,14 @@ Gregorian date Sunday, December 31, 1 BC." (calendar-absolute-from-gregorian (or date (calendar-current-date))))) (y (calendar-extract-year persian-date)) - (m (calendar-extract-month persian-date)) - (monthname (aref calendar-persian-month-name-array (1- m))) + (m (calendar-extract-month persian-date))) + (calendar-dlet* + ((monthname (aref calendar-persian-month-name-array (1- m))) (day (number-to-string (calendar-extract-day persian-date))) (year (number-to-string y)) (month (number-to-string m)) dayname) - (mapconcat 'eval calendar-date-display-form ""))) + (mapconcat #'eval calendar-date-display-form "")))) ;;;###cal-autoload (defun calendar-persian-print-date () diff --git a/lisp/calendar/cal-tex.el b/lisp/calendar/cal-tex.el index 9df9f4cbedf..f5932014dd9 100644 --- a/lisp/calendar/cal-tex.el +++ b/lisp/calendar/cal-tex.el @@ -1,4 +1,4 @@ -;;; cal-tex.el --- calendar functions for printing calendars with LaTeX +;;; cal-tex.el --- calendar functions for printing calendars with LaTeX -*- lexical-binding: t; -*- ;; Copyright (C) 1995, 2001-2021 Free Software Foundation, Inc. @@ -248,6 +248,8 @@ This definition is the heart of the calendar!") (autoload 'diary-list-entries "diary-lib") +(defvar diary-list-include-blanks) + (defun cal-tex-list-diary-entries (d1 d2) "Generate a list of all diary-entries from absolute date D1 to D2." (let (diary-list-include-blanks) @@ -591,6 +593,8 @@ indicates a buffer position to use instead of point." LaTeX commands are inserted for the days of the MONTH in YEAR. Diary entries on DIARY-LIST are included. Holidays on HOLIDAYS are included. Each day is formatted using format DAY-FORMAT." + (with-suppressed-warnings ((lexical date)) + (defvar date)) ;For `cal-tex-daily-string'. (let ((blank-days ; at start of month (mod (- (calendar-day-of-week (list month 1 year)) @@ -605,7 +609,7 @@ are included. Each day is formatted using format DAY-FORMAT." (insert (format day-format (cal-tex-month-name month) j)) (cal-tex-arg (cal-tex-latexify-list diary-list date)) (cal-tex-arg (cal-tex-latexify-list holidays date)) - (cal-tex-arg (eval cal-tex-daily-string)) + (cal-tex-arg (eval cal-tex-daily-string t)) (cal-tex-arg) (cal-tex-comment)) (when (and (zerop (mod (+ j blank-days) 7)) @@ -885,13 +889,15 @@ argument EVENT specifies a different buffer position." (interactive (list (prefix-numeric-value current-prefix-arg) last-nonmenu-event)) (or n (setq n 1)) + (with-suppressed-warnings ((lexical date)) + (defvar date)) ;For `cal-tex-daily-string'. (let* ((date (calendar-gregorian-from-absolute (calendar-dayname-on-or-before 1 (calendar-absolute-from-gregorian (calendar-cursor-to-date t event))))) (month (calendar-extract-month date)) - (year (calendar-extract-year date)) + ;; (year (calendar-extract-year date)) (day (calendar-extract-day date)) (d1 (calendar-absolute-from-gregorian date)) (d2 (+ (* 7 n) d1)) @@ -932,7 +938,7 @@ argument EVENT specifies a different buffer position." (insert ": ") (cal-tex-large-bf s)) (cal-tex-hfill) - (insert " " (eval cal-tex-daily-string)) + (insert " " (eval cal-tex-daily-string t)) (cal-tex-e-parbox) (cal-tex-nl) (cal-tex-noindent) @@ -951,7 +957,8 @@ argument EVENT specifies a different buffer position." (cal-tex-e-parbox "2cm") (cal-tex-nl) (setq month (calendar-extract-month date) - year (calendar-extract-year date))) + ;; year (calendar-extract-year date) + )) (cal-tex-e-parbox) (unless (= i (1- n)) (run-hooks 'cal-tex-week-hook) @@ -961,13 +968,16 @@ argument EVENT specifies a different buffer position." ;; TODO respect cal-tex-daily-start,end? ;; Using different numbers of hours will probably break some layouts. -(defun cal-tex-week-hours (date holidays height) - "Insert hourly entries for DATE with HOLIDAYS, with line height HEIGHT. +(defun cal-tex-week-hours (thedate holidays height) + "Insert hourly entries for THEDATE with HOLIDAYS, with line height HEIGHT. Uses the 24-hour clock if `cal-tex-24' is non-nil. Note that the hours shown are hard-coded to 8-12, 13-17." - (let ((month (calendar-extract-month date)) + (with-suppressed-warnings ((lexical date)) + (defvar date)) ;For `cal-tex-daily-string'. + (let ((date thedate) + (month (calendar-extract-month date)) (day (calendar-extract-day date)) - (year (calendar-extract-year date)) + ;; (year (calendar-extract-year date)) morning afternoon s) (cal-tex-comment "begin cal-tex-week-hours") (cal-tex-cmd "\\ \\\\[-.2cm]") @@ -983,7 +993,7 @@ shown are hard-coded to 8-12, 13-17." (insert ": ") (cal-tex-large-bf s)) (cal-tex-hfill) - (insert " " (eval cal-tex-daily-string)) + (insert " " (eval cal-tex-daily-string t)) (cal-tex-e-parbox) (cal-tex-nl "-.3cm") (cal-tex-rule "0pt" "6.8in" ".2mm") @@ -1088,14 +1098,16 @@ shown are hard-coded to 8-12, 13-17." (defun cal-tex-weekly-common (n event &optional filofax) "Common code for weekly calendars." (or n (setq n 1)) + (with-suppressed-warnings ((lexical date)) + (defvar date)) ;For `cal-tex-daily-string'. (let* ((date (calendar-gregorian-from-absolute (calendar-dayname-on-or-before 1 (calendar-absolute-from-gregorian (calendar-cursor-to-date t event))))) - (month (calendar-extract-month date)) - (year (calendar-extract-year date)) - (day (calendar-extract-day date)) + ;; (month (calendar-extract-month date)) + ;; (year (calendar-extract-year date)) + ;; (day (calendar-extract-day date)) (d1 (calendar-absolute-from-gregorian date)) (d2 (+ (* 7 n) d1)) (holidays (if cal-tex-holidays @@ -1161,7 +1173,7 @@ shown are hard-coded to 8-12, 13-17." (cal-tex-arg (number-to-string (calendar-extract-day date))) (cal-tex-arg (cal-tex-latexify-list diary-list date)) (cal-tex-arg (cal-tex-latexify-list holidays date)) - (cal-tex-arg (eval cal-tex-daily-string)) + (cal-tex-arg (eval cal-tex-daily-string t)) (insert "%\n") (setq date (cal-tex-incr-date date))) (insert "\\noindent\\rule{\\textwidth}{0.3pt}\\\\%\n") @@ -1258,14 +1270,16 @@ Optional EVENT indicates a buffer position to use instead of point." (interactive (list (prefix-numeric-value current-prefix-arg) last-nonmenu-event)) (or n (setq n 1)) + (with-suppressed-warnings ((lexical date)) + (defvar date)) ;For `cal-tex-daily-string'. (let* ((date (calendar-gregorian-from-absolute (calendar-dayname-on-or-before calendar-week-start-day (calendar-absolute-from-gregorian (calendar-cursor-to-date t event))))) - (month (calendar-extract-month date)) - (year (calendar-extract-year date)) - (day (calendar-extract-day date)) + ;; (month (calendar-extract-month date)) + ;; (year (calendar-extract-year date)) + ;; (day (calendar-extract-day date)) (d1 (calendar-absolute-from-gregorian date)) (d2 (+ (* 7 n) d1)) (holidays (if cal-tex-holidays @@ -1311,7 +1325,7 @@ Optional EVENT indicates a buffer position to use instead of point." (cal-tex-arg (number-to-string (calendar-extract-day date))) (cal-tex-arg (cal-tex-latexify-list diary-list date)) (cal-tex-arg (cal-tex-latexify-list holidays date)) - (cal-tex-arg (eval cal-tex-daily-string)) + (cal-tex-arg (eval cal-tex-daily-string t)) (insert "%\n") (setq date (cal-tex-incr-date date))) (unless (= i (1- n)) @@ -1342,14 +1356,16 @@ Optional EVENT indicates a buffer position to use instead of point." (interactive (list (prefix-numeric-value current-prefix-arg) last-nonmenu-event)) (or n (setq n 1)) + (with-suppressed-warnings ((lexical date)) + (defvar date)) ;For `cal-tex-daily-string'. (let* ((date (calendar-gregorian-from-absolute (calendar-dayname-on-or-before 1 (calendar-absolute-from-gregorian (calendar-cursor-to-date t event))))) - (month (calendar-extract-month date)) - (year (calendar-extract-year date)) - (day (calendar-extract-day date)) + ;; (month (calendar-extract-month date)) + ;; (year (calendar-extract-year date)) + ;; (day (calendar-extract-day date)) (d1 (calendar-absolute-from-gregorian date)) (d2 (+ (* 7 n) d1)) (holidays (if cal-tex-holidays @@ -1383,11 +1399,11 @@ Optional EVENT indicates a buffer position to use instead of point." "\\leftday"))) (cal-tex-arg (cal-tex-latexify-list diary-list date)) (cal-tex-arg (cal-tex-latexify-list holidays date "\\\\" t)) - (cal-tex-arg (eval cal-tex-daily-string)) + (cal-tex-arg (eval cal-tex-daily-string t)) (insert "%\n") - (if cal-tex-rules - (insert "\\linesfill\n") - (insert "\\vfill\\noindent\\rule{\\textwidth}{0.3pt}\\\\%\n")) + (insert (if cal-tex-rules + "\\linesfill\n" + "\\vfill\\noindent\\rule{\\textwidth}{0.3pt}\\\\%\n")) (cal-tex-newpage) (setq date (cal-tex-incr-date date))) (insert "%\n") @@ -1397,11 +1413,11 @@ Optional EVENT indicates a buffer position to use instead of point." (insert "\\weekend") (cal-tex-arg (cal-tex-latexify-list diary-list date)) (cal-tex-arg (cal-tex-latexify-list holidays date "\\\\" t)) - (cal-tex-arg (eval cal-tex-daily-string)) + (cal-tex-arg (eval cal-tex-daily-string t)) (insert "%\n") - (if cal-tex-rules - (insert "\\linesfill\n") - (insert "\\vfill")) + (insert (if cal-tex-rules + "\\linesfill\n" + "\\vfill")) (setq date (cal-tex-incr-date date))) (or cal-tex-rules (insert "\\noindent\\rule{\\textwidth}{0.3pt}\\\\%\n")) @@ -1442,12 +1458,15 @@ a buffer position to use instead of point." (cal-tex-end-document) (run-hooks 'cal-tex-hook))) -(defun cal-tex-daily-page (date) - "Make a calendar page for Gregorian DATE on 8.5 by 11 paper. +(defun cal-tex-daily-page (thedate) + "Make a calendar page for Gregorian THEDATE on 8.5 by 11 paper. Uses the 24-hour clock if `cal-tex-24' is non-nil. Produces hourly sections for the period specified by `cal-tex-daily-start' and `cal-tex-daily-end'." - (let ((month-name (cal-tex-month-name (calendar-extract-month date))) + (with-suppressed-warnings ((lexical date)) + (defvar date)) ;For `cal-tex-daily-string'. + (let ((date thedate) + (month-name (cal-tex-month-name (calendar-extract-month date))) (i (1- cal-tex-daily-start)) hour) (cal-tex-banner "cal-tex-daily-page") @@ -1459,7 +1478,7 @@ and `cal-tex-daily-end'." (cal-tex-bf month-name ) (cal-tex-e-parbox) (cal-tex-hspace "1cm") - (cal-tex-scriptsize (eval cal-tex-daily-string)) + (cal-tex-scriptsize (eval cal-tex-daily-string t)) (cal-tex-hspace "3.5cm") (cal-tex-e-makebox) (cal-tex-hfill) diff --git a/lisp/calendar/cal-x.el b/lisp/calendar/cal-x.el index 1c19a60db10..ca303ce39ae 100644 --- a/lisp/calendar/cal-x.el +++ b/lisp/calendar/cal-x.el @@ -1,4 +1,4 @@ -;;; cal-x.el --- calendar windows in dedicated frames +;;; cal-x.el --- calendar windows in dedicated frames -*- lexical-binding: t; -*- ;; Copyright (C) 1994-1995, 2001-2021 Free Software Foundation, Inc. -- cgit v1.2.3 From 8e7728a5bfaf99efd3fb9ea7dd42dabd11a00b5c Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 21 Jan 2021 12:45:24 +0100 Subject: Fix thinko in previous footnote.el change * lisp/mail/footnote.el (footnote--regenerate-alist): Don't error out when there's no footnotes. --- lisp/mail/footnote.el | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) (limited to 'lisp') diff --git a/lisp/mail/footnote.el b/lisp/mail/footnote.el index 9c1a738035e..995ae5f9160 100644 --- a/lisp/mail/footnote.el +++ b/lisp/mail/footnote.el @@ -916,8 +916,7 @@ play around with the following keys: (defun footnote--regenerate-alist () (save-excursion (goto-char (point-min)) - (if (not (re-search-forward footnote-section-tag-regexp nil t)) - (error "No footnote section in this buffer") + (when (re-search-forward footnote-section-tag-regexp nil t) (setq footnote--markers-alist (cl-loop with start-of-footnotes = (match-beginning 0) -- cgit v1.2.3 From b2d30fd6303a2461c591f0ace7eb2a43638bba21 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Thu, 21 Jan 2021 16:21:45 +0200 Subject: A better fix for 'kill-visual-line' * lisp/simple.el (kill-visual-line): Use the 6th element of the return value of 'posn-at-point', which provides the coordinates in terms or row and column, and is thus more reliable for deciding whether we moved to the next screen line. (Bug#45837) --- lisp/simple.el | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) (limited to 'lisp') diff --git a/lisp/simple.el b/lisp/simple.el index 37c0885dcc5..2c6e3916cd4 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -7338,10 +7338,7 @@ even beep.)" ;; of the kill before killing. (let ((opoint (point)) (kill-whole-line (and kill-whole-line (bolp))) - (orig-y (cdr (nth 2 (posn-at-point)))) - ;; FIXME: This tolerance should be zero! It isn't due to a - ;; bug in posn-at-point, see bug#45837. - (tol (/ (line-pixel-height) 2))) + (orig-vlnum (cdr (nth 6 (posn-at-point))))) (if arg (vertical-motion (prefix-numeric-value arg)) (end-of-visual-line 1) @@ -7352,8 +7349,8 @@ even beep.)" ;; end-of-visual-line didn't overshoot due to complications ;; like display or overlay strings, intangible text, etc.: ;; otherwise, we don't want to kill a character that's - ;; unrelated to the place where the visual line wrapped. - (and (< (abs (- (cdr (nth 2 (posn-at-point))) orig-y)) tol) + ;; unrelated to the place where the visual line wraps. + (and (= (cdr (nth 6 (posn-at-point))) orig-vlnum) ;; Make sure we delete the character where the line wraps ;; under visual-line-mode, be it whitespace or a ;; character whose category set allows to wrap at it. -- cgit v1.2.3 From a7fb4ab826669443e204458ecbe5e4074ca1329a Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 21 Jan 2021 16:44:53 +0100 Subject: Make Message respect header removal instructions more * doc/misc/message.texi (Forwarding): Document it. * lisp/gnus/message.el (message-forward-ignored-headers): Improve documentation. (message-forward-included-headers): Ditto. (message-forward-included-mime-headers): New user option. (message-remove-ignored-headers): Use it to preserve the necessary MIME headers. (message-forward-make-body): Remove headers when forwarding as MIME, too. --- doc/misc/message.texi | 6 +++++ etc/NEWS | 8 ++++--- lisp/gnus/message.el | 63 ++++++++++++++++++++++++++++++++++++++++++--------- 3 files changed, 63 insertions(+), 14 deletions(-) (limited to 'lisp') diff --git a/doc/misc/message.texi b/doc/misc/message.texi index f2680b4a797..be6c9a419b2 100644 --- a/doc/misc/message.texi +++ b/doc/misc/message.texi @@ -317,6 +317,12 @@ when forwarding a message. In non-@code{nil}, only headers that match this regexp will be kept when forwarding a message. This can also be a list of regexps. +@item message-forward-included-mime-headers +@vindex message-forward-included-mime-headers +In non-@code{nil}, headers that match this regexp will be kept when +forwarding a message as @acronym{MIME}, but @acronym{MML} isn't used. +This can also be a list of regexps. + @item message-make-forward-subject-function @vindex message-make-forward-subject-function A list of functions that are called to generate a subject header for diff --git a/etc/NEWS b/etc/NEWS index 59b13998cfa..357c75b7e96 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -721,9 +721,11 @@ not. --- *** Respect 'message-forward-ignored-headers' more. Previously, this variable would not be consulted if -'message-forward-show-mml' was nil. It's now always used, except if -'message-forward-show-mml' is 'best', and we're forwarding an -encrypted/signed message. +'message-forward-show-mml' was nil and forwarding as MIME. + ++++ +*** New user option 'message-forward-included-mime-headers'. +This is used when forwarding messages as MIME, but not using MML. +++ *** Message now supports the OpenPGP header. diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index b22b4543e71..2bcd367638f 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -620,8 +620,8 @@ Done before generating the new subject of a forward." (defcustom message-forward-ignored-headers "^Content-Transfer-Encoding:\\|^X-Gnus" "All headers that match this regexp will be deleted when forwarding a message. -This variable is not consulted when forwarding encrypted messages -and `message-forward-show-mml' is `best'. +Also see `message-forward-included-headers' -- both variables are applied. +In addition, see `message-forward-included-mime-headers'. This may also be a list of regexps." :version "21.1" @@ -637,7 +637,14 @@ This may also be a list of regexps." '("^From:" "^Subject:" "^Date:" "^To:" "^Cc:") "If non-nil, delete non-matching headers when forwarding a message. Only headers that match this regexp will be included. This -variable should be a regexp or a list of regexps." +variable should be a regexp or a list of regexps. + +Also see `message-forward-ignored-headers' -- both variables are applied. +In addition, see `message-forward-included-mime-headers'. + +When forwarding messages as MIME, but when +`message-forward-show-mml' results in MML not being used, +`message-forward-included-mime-headers' take precedence." :version "27.1" :group 'message-forwarding :type '(repeat :value-to-internal (lambda (widget value) @@ -647,6 +654,24 @@ variable should be a regexp or a list of regexps." (widget-editable-list-match widget value))) regexp)) +(defcustom message-forward-included-mime-headers + '("^Content-Type:" "^MIME-Version:" "^Content-Transfer-Encoding:") + "When forwarding as MIME, but not using MML, don't delete these headers. +Also see `message-forward-ignored-headers' and +`message-forward-ignored-headers'. + +When forwarding messages as MIME, but when +`message-forward-show-mml' results in MML not being used, +`message-forward-included-mime-headers' take precedence." + :version "28.1" + :group 'message-forwarding + :type '(repeat :value-to-internal (lambda (widget value) + (custom-split-regexp-maybe value)) + :match (lambda (widget value) + (or (stringp value) + (widget-editable-list-match widget value))) + regexp)) + (defcustom message-ignored-cited-headers "." "Delete these headers from the messages you yank." :group 'message-insertion @@ -7617,14 +7642,28 @@ Optional DIGEST will use digest to forward." "-------------------- End of forwarded message --------------------\n") (message-remove-ignored-headers b e))) -(defun message-remove-ignored-headers (b e) +(defun message-remove-ignored-headers (b e &optional preserve-mime) (when (or message-forward-ignored-headers message-forward-included-headers) + (let ((saved-headers nil)) (save-restriction (narrow-to-region b e) (goto-char b) (narrow-to-region (point) (or (search-forward "\n\n" nil t) (point))) + ;; When forwarding as MIME, preserve some MIME headers. + (when preserve-mime + (let ((headers (buffer-string))) + (with-temp-buffer + (insert headers) + (message-remove-header + (if (listp message-forward-included-mime-headers) + (mapconcat + #'identity (cons "^$" message-forward-included-mime-headers) + "\\|") + message-forward-included-mime-headers) + t nil t) + (setq saved-headers (string-lines (buffer-string) t))))) (when message-forward-ignored-headers (let ((ignored (if (stringp message-forward-ignored-headers) (list message-forward-ignored-headers) @@ -7637,10 +7676,14 @@ Optional DIGEST will use digest to forward." (mapconcat #'identity (cons "^$" message-forward-included-headers) "\\|") message-forward-included-headers) - t nil t))))) + t nil t)) + ;; Insert the MIME headers, if any. + (goto-char (point-max)) + (forward-line -1) + (dolist (header saved-headers) + (insert header "\n")))))) -(defun message-forward-make-body-mime (forward-buffer &optional beg end - remove-headers) +(defun message-forward-make-body-mime (forward-buffer &optional beg end) (let ((b (point))) (insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n") (save-restriction @@ -7650,8 +7693,7 @@ Optional DIGEST will use digest to forward." (goto-char (point-min)) (when (looking-at "From ") (replace-match "X-From-Line: ")) - (when remove-headers - (message-remove-ignored-headers (point-min) (point-max))) + (message-remove-ignored-headers (point-min) (point-max) t) (goto-char (point-max))) (insert "<#/part>\n") ;; Consider there is no illegible text. @@ -7790,8 +7832,7 @@ is for the internal use." (message-signed-or-encrypted-p) (error t)))))) (message-forward-make-body-mml forward-buffer) - (message-forward-make-body-mime - forward-buffer nil nil (not (eq message-forward-show-mml 'best)))) + (message-forward-make-body-mime forward-buffer)) (message-forward-make-body-plain forward-buffer))) (message-position-point)) -- cgit v1.2.3 From 7d122cf9a3c5e02d1fab625a1c81791806f80c40 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 21 Jan 2021 16:48:01 +0100 Subject: Tweak previous message-forward-included-mime-headers change * lisp/gnus/message.el (message-forward-included-mime-headers): Should probably not include Content-Transfer-Encoding, because we will reencode anyway. --- lisp/gnus/message.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 2bcd367638f..7d1eb970c6b 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -655,7 +655,7 @@ When forwarding messages as MIME, but when regexp)) (defcustom message-forward-included-mime-headers - '("^Content-Type:" "^MIME-Version:" "^Content-Transfer-Encoding:") + '("^Content-Type:" "^MIME-Version:") "When forwarding as MIME, but not using MML, don't delete these headers. Also see `message-forward-ignored-headers' and `message-forward-ignored-headers'. -- cgit v1.2.3 From de761b58f091b11221469b796394e23b34685991 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 21 Jan 2021 17:08:28 +0100 Subject: Add dired support for compressing .pax files * lisp/dired-aux.el (dired-compress-files-alist): Add support for compressing .pax files (bug#40135). --- lisp/dired-aux.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index 5a96742fda9..f860743a066 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -1168,7 +1168,8 @@ ARGS are command switches passed to PROGRAM.") ("\\.tar\\.bz2\\'" . "tar -cf - %i | bzip2 -c9 > %o") ("\\.tar\\.xz\\'" . "tar -cf - %i | xz -c9 > %o") ("\\.tar\\.zst\\'" . "tar -cf - %i | zstd -19 -o %o") - ("\\.zip\\'" . "zip %o -r --filesync %i")) + ("\\.zip\\'" . "zip %o -r --filesync %i") + ("\\.pax\\'" . "pax -wf %o %i")) "Control the compression shell command for `dired-do-compress-to'. Each element is (REGEXP . CMD), where REGEXP is the name of the -- cgit v1.2.3 From a6f030fc7bb3eae2a93dc4d944b6d7d313bd0bce Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 21 Jan 2021 17:10:02 +0100 Subject: Fix message.el build warning from previous change * lisp/gnus/message.el (subr-x): Fix build warning from previous commit. --- lisp/gnus/message.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 7d1eb970c6b..1409a4384ab 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -47,7 +47,7 @@ (require 'rfc2047) (require 'puny) (require 'rmc) ; read-multiple-choice -(eval-when-compile (require 'subr-x)) +(require 'subr-x) (autoload 'mailclient-send-it "mailclient") -- cgit v1.2.3 From 2cf347a0a87bf490391a26fc26b29ca40a0fda93 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 21 Jan 2021 18:10:16 +0100 Subject: Don't have type-break-mode signal errors on corrupted files * lisp/type-break.el (type-break-get-previous-time): (type-break-get-previous-count): Signal a warning instead of an error (bug#38246). type-break will still continue to work even if the database can't be loaded after a restart, but this allows Emacs to be started. --- lisp/type-break.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'lisp') diff --git a/lisp/type-break.el b/lisp/type-break.el index 84c240c9f8c..a6d5cd01702 100644 --- a/lisp/type-break.el +++ b/lisp/type-break.el @@ -487,7 +487,7 @@ Return nil if the file is missing or if the time is not a Lisp time value." (goto-char (point-min)) (read (current-buffer))) (end-of-file - (error "End of file in `%s'" file)))))))) + (warn "End of file in `%s'" file)))))))) (defun type-break-get-previous-count () "Get previous keystroke count from `type-break-file-name'. @@ -505,7 +505,7 @@ integer." (forward-line 1) (read (current-buffer))) (end-of-file - (error "End of file in `%s'" file))))))) + (warn "End of file in `%s'" file))))))) file 0))) -- cgit v1.2.3 From 931be5ee7d618904361ab2d434d3901cbd9abc9a Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Thu, 21 Jan 2021 18:52:48 +0100 Subject: * lisp/net/webjump.el: Add Maintainer: emacs-devel. Ref: https://lists.gnu.org/r/emacs-devel/2021-01/msg01019.html --- lisp/net/webjump.el | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) (limited to 'lisp') diff --git a/lisp/net/webjump.el b/lisp/net/webjump.el index 9bcf1d37345..e5941ae652e 100644 --- a/lisp/net/webjump.el +++ b/lisp/net/webjump.el @@ -2,9 +2,10 @@ ;; Copyright (C) 1996-1997, 2001-2021 Free Software Foundation, Inc. -;; Author: Neil W. Van Dyke -;; Created: 09-Aug-1996 -;; Keywords: comm www +;; Author: Neil W. Van Dyke +;; Maintainer: emacs-devel@gnu.org +;; Created: 09-Aug-1996 +;; Keywords: comm www ;; This file is part of GNU Emacs. -- cgit v1.2.3 From b41b4add7bc2485fadc6ff3a890efbd1307b2351 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 21 Jan 2021 13:15:05 -0500 Subject: Fix spurious "Lexical argument shadows the dynamic variable" due to inlining Before this patch doing: rm lisp/calendar/calendar.elc make lisp/calendar/cal-hebrew.elc would spew out lots of spurious such warnings about a `date` argument, pointing to code which has no `date` argument in sight. This was because that code had calls to inlinable functions (taking a `date` argument) defined in `calendar.el`, and while `date` is a normal lexical var at the site of those functions' definitions, it was declared as dynbound at the call site. * lisp/emacs-lisp/byte-opt.el (byte-compile-inline-expand): Don't impose our local context onto the inlined function. * test/lisp/emacs-lisp/bytecomp-tests.el: Add matching test. --- lisp/emacs-lisp/byte-opt.el | 6 ++++-- .../lisp/emacs-lisp/bytecomp-resources/foo-inlinable.el | 6 ++++++ .../bytecomp-resources/nowarn-inline-after-defvar.el | 17 +++++++++++++++++ test/lisp/emacs-lisp/bytecomp-tests.el | 4 ++++ 4 files changed, 31 insertions(+), 2 deletions(-) create mode 100644 test/lisp/emacs-lisp/bytecomp-resources/foo-inlinable.el create mode 100644 test/lisp/emacs-lisp/bytecomp-resources/nowarn-inline-after-defvar.el (limited to 'lisp') diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index cfa407019a7..66a117fccc8 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -284,8 +284,10 @@ ;; If `fn' is from the same file, it has already ;; been preprocessed! `(function ,fn) - (byte-compile-preprocess - (byte-compile--reify-function fn))))) + ;; Try and process it "in its original environment". + (let ((byte-compile-bound-variables nil)) + (byte-compile-preprocess + (byte-compile--reify-function fn)))))) (if (eq (car-safe newfn) 'function) (byte-compile-unfold-lambda `(,(cadr newfn) ,@(cdr form))) ;; This can happen because of macroexp-warn-and-return &co. diff --git a/test/lisp/emacs-lisp/bytecomp-resources/foo-inlinable.el b/test/lisp/emacs-lisp/bytecomp-resources/foo-inlinable.el new file mode 100644 index 00000000000..47481574ea8 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/foo-inlinable.el @@ -0,0 +1,6 @@ +;; -*- lexical-binding: t; -*- + +(defsubst foo-inlineable (foo-var) + (+ foo-var 2)) + +(provide 'foo-inlinable) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/nowarn-inline-after-defvar.el b/test/lisp/emacs-lisp/bytecomp-resources/nowarn-inline-after-defvar.el new file mode 100644 index 00000000000..5582b2ab0ea --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/nowarn-inline-after-defvar.el @@ -0,0 +1,17 @@ +;; -*- lexical-binding: t; -*- + +;; In this test, we try and make sure that inlined functions's code isn't +;; mistakenly re-interpreted in the caller's context: we import an +;; inlinable function from another file where `foo-var' is a normal +;; lexical variable, and then call(inline) it in a function where +;; `foo-var' is a dynamically-scoped variable. + +(require 'foo-inlinable + (expand-file-name "foo-inlinable.el" + (file-name-directory + (or byte-compile-current-file load-file-name)))) + +(defvar foo-var) + +(defun foo-fun () + (+ (foo-inlineable 5) 1)) diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index 263736af4ed..980b402ca2d 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -713,6 +713,10 @@ Subtests signal errors if something goes wrong." "warn-wide-docstring-multiline.el" "defvar.*foo.*wider than.*characters") +(bytecomp--define-warning-file-test + "nowarn-inline-after-defvar.el" + "Lexical argument shadows" 'reverse) + ;;;; Macro expansion. -- cgit v1.2.3 From ee1c54ebc01bc377dce99af891730c1a53cc3f86 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Fri, 22 Jan 2021 09:57:19 +0200 Subject: Improve documentation of sendmail.el defcustom's * lisp/mail/sendmail.el (mail-archive-file-name) (mail-default-reply-to, mail-self-blind, mail-default-headers): Say in the doc string that 'message-default-mail-headers' shall be customized when using 'message-mode' for email composition. (Bug#46029) --- lisp/mail/sendmail.el | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) (limited to 'lisp') diff --git a/lisp/mail/sendmail.el b/lisp/mail/sendmail.el index ad1a02734c8..15f7f224028 100644 --- a/lisp/mail/sendmail.el +++ b/lisp/mail/sendmail.el @@ -104,7 +104,9 @@ being sent is used), or nil (in which case the value of (defcustom mail-self-blind nil "Non-nil means insert Bcc to self in messages to be sent. This is done when the message is initialized, -so you can remove or alter the Bcc field to override the default." +so you can remove or alter the Bcc field to override the default. +If you are using `message-mode' to compose messages, customize the +variable `message-default-mail-headers' instead." :type 'boolean) ;;;###autoload @@ -172,14 +174,18 @@ This is used by the default mail-sending commands. See also (defcustom mail-archive-file-name nil "Name of file to write all outgoing messages in, or nil for none. This is normally an mbox file, but for backwards compatibility may also -be a Babyl file." +be a Babyl file. +If you are using `message-mode' to compose messages, customize the +variable `message-default-mail-headers' instead." :type '(choice file (const nil))) ;;;###autoload (defcustom mail-default-reply-to nil "Address to insert as default Reply-To field of outgoing messages. If nil, it will be initialized from the REPLYTO environment variable -when you first send mail." +when you first send mail. +If you are using `message-mode' to compose messages, customize the +variable `message-default-mail-headers' instead." :type '(choice (const nil) string)) (defcustom mail-alias-file nil @@ -388,7 +394,9 @@ in `message-auto-save-directory'." (defcustom mail-default-headers nil "A string containing header lines, to be inserted in outgoing messages. It can contain newlines, and should end in one. It is inserted -before you edit the message, so you can edit or delete the lines." +before you edit the message, so you can edit or delete the lines. +If you are using `message-mode' to compose messages, customize the +variable `message-default-mail-headers' instead." :type '(choice (const nil) string)) (defcustom mail-bury-selects-summary t -- cgit v1.2.3 From 6bfc672bc7f467edf39cfba262c5c4f11897d4e0 Mon Sep 17 00:00:00 2001 From: Glenn Morris Date: Fri, 22 Jan 2021 08:52:12 +0000 Subject: * lisp/textmodes/remember.el (remember-text-format-function): Fix type. --- lisp/textmodes/remember.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/textmodes/remember.el b/lisp/textmodes/remember.el index 811a265118c..820ee38d101 100644 --- a/lisp/textmodes/remember.el +++ b/lisp/textmodes/remember.el @@ -415,7 +415,7 @@ The default emulates `current-time-string' for backward compatibility." "The function to format the remembered text. The function receives the remembered text as argument and should return the text to be remembered." - :type 'function + :type '(choice (const nil) function) :group 'remember :version "28.1") -- cgit v1.2.3 From 4c0dce4b66c41a12a4cf7439b036962e9525eeaa Mon Sep 17 00:00:00 2001 From: Mattias Engdegård Date: Fri, 22 Jan 2021 15:47:48 +0100 Subject: Calc: use big brackets around function arguments * lisp/calc/calccomp.el (math-compose-expr): Use big brackets around arguments in Big mode, so that expressions like sin(a/b) look a bit better. --- lisp/calc/calccomp.el | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) (limited to 'lisp') diff --git a/lisp/calc/calccomp.el b/lisp/calc/calccomp.el index 5f38ee71c78..bd81d7fe406 100644 --- a/lisp/calc/calccomp.el +++ b/lisp/calc/calccomp.el @@ -822,9 +822,16 @@ (if (setq spfn (get calc-language 'math-func-formatter)) (funcall spfn func a) - (list 'horiz func calc-function-open - (math-compose-vector (cdr a) ", " 0) - calc-function-close)))))))))) + (let ((args (math-compose-vector (cdr a) ", " 0))) + (if (and (member calc-function-open '("(" "[" "{")) + (member calc-function-close '(")" "]" "}"))) + (list 'horiz func + (math--comp-bracket + (string-to-char calc-function-open) + (string-to-char calc-function-close) + args)) + (list 'horiz func calc-function-open + args calc-function-close)))))))))))) (defun math-prod-first-term (x) -- cgit v1.2.3 From b2b26bd4d66d25f2456baa4e9eb9516c122a30e0 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Fri, 22 Jan 2021 17:39:52 +0100 Subject: Use RemoteCommand option for Tramp's sshx and scpx methods * doc/misc/tramp.texi (Inline methods) : (External methods) : Adapt call sequence. (Remote shell setup): Mention, that sshx and scpx overwrite RemoteCommand. (Remote processes): Restriction: direct asynchronous processes cannot be used when RemoteCommand is in use. `tramp-remote-process-environment' is not ignored any longer. * lisp/net/tramp-sh.el (tramp-methods) : Handle login shell via RemoteCommand. Remove `tramp-direct-async' parameter. (tramp-maybe-open-connection): Add "-i" to login. * lisp/net/tramp-smb.el (tramp-smb-errors): Add "NT_STATUS_NOT_SUPPORTED". (tramp-smb-handle-insert-directory): Fix point moving error. * test/lisp/net/tramp-tests.el (tramp-test34-explicit-shell-file-name): Use `get-buffer-process' where appropriate. --- doc/misc/tramp.texi | 27 +++++++++++++++++---------- lisp/net/tramp-sh.el | 12 +++++------- lisp/net/tramp-smb.el | 24 ++++++++++++------------ test/lisp/net/tramp-tests.el | 2 +- 4 files changed, 35 insertions(+), 30 deletions(-) (limited to 'lisp') diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index e9ffd6a8c43..5d89b065882 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -810,9 +810,10 @@ behavior. @cindex @option{sshx} method Works like @option{ssh} but without the extra authentication prompts. -@option{sshx} uses @samp{ssh -t -t @var{host} -l @var{user} /bin/sh} -to open a connection with a ``standard'' login shell. It supports -changing the remote login shell @command{/bin/sh}. +@option{sshx} uses @samp{ssh -t -t -l @var{user} -o +RemoteCommand='/bin/sh -i' @var{host}} to open a connection with a +``standard'' login shell. It supports changing the remote login shell +@command{/bin/sh}. @strong{Note} that @option{sshx} does not bypass authentication questions. For example, if the host key of the remote host is not @@ -935,9 +936,10 @@ This method supports the @samp{-p} argument. @cindex @command{ssh} (with @option{scpx} method) @option{scpx} is useful to avoid login shell questions. It is similar -in performance to @option{scp}. @option{scpx} uses @samp{ssh -t -t -@var{host} -l @var{user} /bin/sh} to open a connection. It supports -changing the remote login shell @command{/bin/sh}. +in performance to @option{scp}. @option{scpx} uses @samp{ssh -t -t -l +@var{user} -o RemoteCommand='/bin/sh -i' @var{host}} to open a +connection. It supports changing the remote login shell +@command{/bin/sh}. @option{scpx} is useful for MS Windows users when @command{ssh} triggers an error about allocating a pseudo tty. This happens due to @@ -2220,7 +2222,10 @@ This uses also the settings in @code{tramp-sh-extra-args}. @vindex RemoteCommand@r{, ssh option} @strong{Note}: If you use an @option{ssh}-based method for connection, do @emph{not} set the @option{RemoteCommand} option in your -@command{ssh} configuration, for example to @command{screen}. +@command{ssh} configuration, for example to @command{screen}. On the +other hand, some @option{ssh}-based methods, like @option{sshx} or +@option{scpx}, silently overwrite a @option{RemoteCommand} option of +the configuration file. @subsection Other remote shell setup hints @@ -3580,13 +3585,16 @@ Furthermore, this approach has the following limitations: It works only for connection methods defined in @file{tramp-sh.el} and @file{tramp-adb.el}. -@vindex ControlMaster@r{, ssh option} @item It does not support interactive user authentication. With @option{ssh}-based methods, this can be avoided by using a password agent like @command{ssh-agent}, using public key authentication, or using @option{ControlMaster} options. +@item +It cannot be applied for @option{ssh}-based methods, which use the +@option{RemoteCommand} option. + @item It cannot be killed via @code{interrupt-process}. @@ -3597,8 +3605,7 @@ It does not report the remote terminal name via @code{process-tty-name}. It does not set process property @code{remote-pid}. @item -It does not use @code{tramp-remote-path} and -@code{tramp-remote-process-environment}. +It does not use @code{tramp-remote-path}. @end itemize In order to gain even more performance, it is recommended to bind diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 618a9fb9d02..d7ca7c9780c 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -181,10 +181,9 @@ The string is used in `tramp-methods'.") `("scpx" (tramp-login-program "ssh") (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c") - ("-e" "none") ("-t" "-t") ("%h") - ("%l"))) + ("-e" "none") ("-t" "-t") + ("-o" "RemoteCommand='%l'") ("%h"))) (tramp-async-args (("-q"))) - (tramp-direct-async t) (tramp-remote-shell ,tramp-default-remote-shell) (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-c")) @@ -238,10 +237,9 @@ The string is used in `tramp-methods'.") `("sshx" (tramp-login-program "ssh") (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c") - ("-e" "none") ("-t" "-t") ("%h") - ("%l"))) + ("-e" "none") ("-t" "-t") + ("-o" "RemoteCommand='%l'") ("%h"))) (tramp-async-args (("-q"))) - (tramp-direct-async t) (tramp-remote-shell ,tramp-default-remote-shell) (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-c")))) @@ -5124,7 +5122,7 @@ connection if a previous connection has died for some reason." options (format-spec options spec) spec (format-spec-make ?h l-host ?u l-user ?p l-port ?c options - ?l (concat remote-shell " " extra-args)) + ?l (concat remote-shell " " extra-args " -i")) command (concat ;; We do not want to see the trailing local diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 1604e8962c0..c5a74a5c653 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -156,6 +156,7 @@ this variable (\"client min protocol=NT1\") ." "NT_STATUS_NO_SUCH_FILE" "NT_STATUS_NO_SUCH_USER" "NT_STATUS_NOT_A_DIRECTORY" + "NT_STATUS_NOT_SUPPORTED" "NT_STATUS_OBJECT_NAME_COLLISION" "NT_STATUS_OBJECT_NAME_INVALID" "NT_STATUS_OBJECT_NAME_NOT_FOUND" @@ -371,17 +372,17 @@ pass to the OPERATION." (tramp-error v2 'file-error "add-name-to-file: %s must not be a directory" filename)) - ;; Do the 'confirm if exists' thing. - (when (file-exists-p newname) - ;; What to do? - (if (or (null ok-if-already-exists) ; not allowed to exist - (and (numberp ok-if-already-exists) - (not (yes-or-no-p - (format - "File %s already exists; make it a link anyway? " - v2-localname))))) - (tramp-error v2 'file-already-exists newname) - (delete-file newname))) + ;; Do the 'confirm if exists' thing. + (when (file-exists-p newname) + ;; What to do? + (if (or (null ok-if-already-exists) ; not allowed to exist + (and (numberp ok-if-already-exists) + (not (yes-or-no-p + (format + "File %s already exists; make it a link anyway? " + v2-localname))))) + (tramp-error v2 'file-already-exists newname) + (delete-file newname))) ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. (tramp-flush-file-properties v2 v2-localname) @@ -1166,7 +1167,6 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (insert " -> " (tramp-compat-file-attribute-type attr)))) (insert "\n") - (forward-line) (beginning-of-line))) entries)))))) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 5deee658296..4c84507807b 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -5247,7 +5247,7 @@ Use direct async.") ;; order to avoid a question. `explicit-sh-args' echoes the ;; test data. (with-current-buffer (get-buffer-create "*shell*") - (ignore-errors (kill-process (current-buffer))) + (ignore-errors (kill-process (get-buffer-process (current-buffer)))) (should-not explicit-shell-file-name) (call-interactively #'shell) (with-timeout (10) -- cgit v1.2.3 From ef14acfb68bb5b0ce42221e9681b93562f8085eb Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Fri, 22 Jan 2021 19:07:52 +0100 Subject: Make nnml handle invalid non-ASCII headers more consistently * lisp/gnus/nnml.el (nnml--encode-headers): New function to RFC2047-encode invalid Subject/From headers (bug#45925). This will make them be displayed more consistently in the Summary buffer (but still "wrong" sometimes, since there's not that much we can guess at at this stage, charset wise). (nnml-parse-head): Use it. --- lisp/gnus/nnml.el | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) (limited to 'lisp') diff --git a/lisp/gnus/nnml.el b/lisp/gnus/nnml.el index ebececa3ce2..3cdfc749703 100644 --- a/lisp/gnus/nnml.el +++ b/lisp/gnus/nnml.el @@ -769,8 +769,24 @@ article number. This function is called narrowed to an article." (let ((headers (nnheader-parse-head t))) (setf (mail-header-chars headers) chars) (setf (mail-header-number headers) number) + ;; If there's non-ASCII raw characters in the data, + ;; RFC2047-encode them to avoid having arbitrary data in the + ;; .overview file. + (nnml--encode-headers headers) headers)))) +(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 ((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))))) + (defun nnml-get-nov-buffer (group &optional incrementalp) (let ((buffer (gnus-get-buffer-create (format " *nnml %soverview %s*" -- cgit v1.2.3 From 2be55ad66910730d81f727d3bc4a25d196422d04 Mon Sep 17 00:00:00 2001 From: Keith David Bershatsky Date: Fri, 22 Jan 2021 19:18:41 +0100 Subject: Add more isearch-related bindings to ns-win.el * lisp/term/ns-win.el (minibuffer-local-isearch-map): Add more bindings to mirror bindings in isearch.el (bug#15667). --- lisp/term/ns-win.el | 9 +++++++++ 1 file changed, 9 insertions(+) (limited to 'lisp') diff --git a/lisp/term/ns-win.el b/lisp/term/ns-win.el index 5f4dd9ef587..94e9d5c5828 100644 --- a/lisp/term/ns-win.el +++ b/lisp/term/ns-win.el @@ -120,6 +120,15 @@ The properties returned may include `top', `left', `height', and `width'." (define-key global-map [?\s-d] 'isearch-repeat-backward) (define-key global-map [?\s-e] 'isearch-yank-kill) (define-key global-map [?\s-f] 'isearch-forward) +(define-key esc-map [?\s-f] 'isearch-forward-regexp) +(define-key minibuffer-local-isearch-map [?\s-f] + 'isearch-forward-exit-minibuffer) +(define-key isearch-mode-map [?\s-f] 'isearch-repeat-forward) +(define-key global-map [?\s-F] 'isearch-backward) +(define-key esc-map [?\s-F] 'isearch-backward-regexp) +(define-key minibuffer-local-isearch-map [?\s-F] + 'isearch-reverse-exit-minibuffer) +(define-key isearch-mode-map [?\s-F] 'isearch-repeat-backward) (define-key global-map [?\s-g] 'isearch-repeat-forward) (define-key global-map [?\s-h] 'ns-do-hide-emacs) (define-key global-map [?\s-H] 'ns-do-hide-others) -- cgit v1.2.3 From b7f318aa9611f132ba93745f663573bd223a2641 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Fri, 22 Jan 2021 19:22:07 +0100 Subject: Fix up previous mh-speed.el ignored variable change * lisp/mh-e/mh-speed.el (mh-speed-toggle, mh-speed-view): Mark the ignored parameter with _ instead of using the Common Lispish (declare (ignore args)) (which Emacs Lisp doesn't really support), except by accident. --- lisp/mh-e/mh-speed.el | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) (limited to 'lisp') diff --git a/lisp/mh-e/mh-speed.el b/lisp/mh-e/mh-speed.el index 00b96804174..7cbd42c8ea2 100644 --- a/lisp/mh-e/mh-speed.el +++ b/lisp/mh-e/mh-speed.el @@ -125,10 +125,9 @@ With non-nil FORCE, the update is always carried out." ;; Otherwise on to your regular programming (t t))) -(defun mh-speed-toggle (&rest ignored) +(defun mh-speed-toggle (&rest _ignored) "Toggle the display of child folders in the speedbar. The optional arguments from speedbar are IGNORED." - (declare (ignore args)) (interactive) (beginning-of-line) (let ((parent (get-text-property (point) 'mh-folder)) @@ -164,10 +163,9 @@ The optional arguments from speedbar are IGNORED." (mh-line-beginning-position) (1+ (line-beginning-position)) '(mh-expanded t))))))) -(defun mh-speed-view (&rest ignored) +(defun mh-speed-view (&rest _ignored) "Visits the selected folder just as if you had used \\\\[mh-visit-folder]. The optional arguments from speedbar are IGNORED." - (declare (ignore args)) (interactive) (let* ((folder (get-text-property (mh-line-beginning-position) 'mh-folder)) (range (and (stringp folder) -- cgit v1.2.3 From b9d0cdcacbd3da93b4ebfa10d778efb618881ccc Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 22 Jan 2021 16:56:57 -0500 Subject: * lisp/simple.el (newline-and-indent): Disable `electric-indent-mode` With `electric-indent-mode` enabled, `newline-and-indent` ends up indenting 3 times: once for the original line and twice on the new line. `reindent-then-newline-and-indent` is even worse, indenting twice both lines. None of those commands should be affected by `electric-indent-mode` since they even explicitly say in their name when and how they do indentation. (reindent-then-newline-and-indent): Temporarily disable `electric-indent-mode` as well. --- lisp/simple.el | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) (limited to 'lisp') diff --git a/lisp/simple.el b/lisp/simple.el index 2c6e3916cd4..8d4e4a7a6bb 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -820,9 +820,10 @@ With ARG, perform this action that many times." (delete-horizontal-space t) (unless arg (setq arg 1)) - (dotimes (_ arg) - (newline nil t) - (indent-according-to-mode))) + (let ((electric-indent-mode nil)) + (dotimes (_ arg) + (newline nil t) + (indent-according-to-mode)))) (defun reindent-then-newline-and-indent () "Reindent current line, insert newline, then indent the new line. @@ -832,7 +833,8 @@ In programming language modes, this is the same as TAB. In some text modes, where TAB inserts a tab, this indents to the column specified by the function `current-left-margin'." (interactive "*") - (let ((pos (point))) + (let ((pos (point)) + (electric-indent-mode nil)) ;; Be careful to insert the newline before indenting the line. ;; Otherwise, the indentation might be wrong. (newline) -- cgit v1.2.3 From 5821dee0949b2913c07970d6e4b8bb8e8a35f036 Mon Sep 17 00:00:00 2001 From: Dmitry Gutov Date: Sat, 23 Jan 2021 02:53:12 +0200 Subject: Erase the buffer only after fetching the new contents * lisp/progmodes/xref.el (xref-revert-buffer): Erase the buffer only after fetching the new contents (bug#46042). --- lisp/progmodes/xref.el | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'lisp') diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index aecb30a0ad4..abaa0dc5e8b 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -967,10 +967,10 @@ Return an alist of the form ((FILENAME . (XREF ...)) ...)." (let ((inhibit-read-only t) (buffer-undo-list t)) (save-excursion - (erase-buffer) (condition-case err - (xref--insert-xrefs - (xref--analyze (funcall xref--fetcher))) + (let ((alist (xref--analyze (funcall xref--fetcher)))) + (erase-buffer) + (xref--insert-xrefs alist)) (user-error (insert (propertize -- cgit v1.2.3 From cc98d0bf5225c281f91152aa838c4cb093df52e9 Mon Sep 17 00:00:00 2001 From: Dmitry Gutov Date: Sat, 23 Jan 2021 02:58:53 +0200 Subject: ; xref-revert-buffer: Drop the (goto-char) at the end --- lisp/progmodes/xref.el | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) (limited to 'lisp') diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index abaa0dc5e8b..898cb4fb4c1 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -975,8 +975,7 @@ Return an alist of the form ((FILENAME . (XREF ...)) ...)." (insert (propertize (error-message-string err) - 'face 'error)))) - (goto-char (point-min))))) + 'face 'error))))))) (defun xref-show-definitions-buffer (fetcher alist) "Show the definitions list in a regular window. -- cgit v1.2.3 From 30d95d33737e4694b579c38328564716d10217b6 Mon Sep 17 00:00:00 2001 From: Gabriel do Nascimento Ribeiro Date: Sat, 23 Jan 2021 15:38:42 -0300 Subject: Use single post-command-hook on hl-line modes * lisp/hl-line.el (hl-line-mode, global-hl-line-mode): Ensure that 'maybe-unhighlight' is called after line is highlighted. (Bug#45946) (hl-line-unhighlight, global-hl-line-unhighlight): Set overlay variable to nil after overlay is deleted. --- lisp/hl-line.el | 58 +++++++++++++++++++++++++-------------------------------- 1 file changed, 25 insertions(+), 33 deletions(-) (limited to 'lisp') diff --git a/lisp/hl-line.el b/lisp/hl-line.el index 73870f9579e..82952e934b6 100644 --- a/lisp/hl-line.el +++ b/lisp/hl-line.el @@ -45,11 +45,7 @@ ;; An overlay is used. In the non-sticky cases, this overlay is ;; active only on the selected window. A hook is added to ;; `post-command-hook' to activate the overlay and move it to the line -;; about point. To get the non-sticky behavior, `hl-line-unhighlight' -;; is added to `pre-command-hook' as well. This function deactivates -;; the overlay unconditionally in case the command changes the -;; selected window. (It does so rather than keeping track of changes -;; in the selected window). +;; about point. ;; You could make variable `global-hl-line-mode' buffer-local and set ;; it to nil to avoid highlighting specific buffers, when the global @@ -91,9 +87,9 @@ when `global-hl-line-sticky-flag' is non-nil.") (set symbol value) (dolist (buffer (buffer-list)) (with-current-buffer buffer - (when hl-line-overlay + (when (overlayp hl-line-overlay) (overlay-put hl-line-overlay 'face hl-line-face)))) - (when global-hl-line-overlay + (when (overlayp global-hl-line-overlay) (overlay-put global-hl-line-overlay 'face hl-line-face)))) (defcustom hl-line-sticky-flag t @@ -141,9 +137,7 @@ non-selected window. Hl-Line mode uses the function `hl-line-highlight' on `post-command-hook' in this case. When `hl-line-sticky-flag' is nil, Hl-Line mode highlights the -line about point in the selected window only. In this case, it -uses the function `hl-line-maybe-unhighlight' in -addition to `hl-line-highlight' on `post-command-hook'." +line about point in the selected window only." :group 'hl-line (if hl-line-mode (progn @@ -151,12 +145,10 @@ addition to `hl-line-highlight' on `post-command-hook'." (add-hook 'change-major-mode-hook #'hl-line-unhighlight nil t) (hl-line-highlight) (setq hl-line-overlay-buffer (current-buffer)) - (add-hook 'post-command-hook #'hl-line-highlight nil t) - (add-hook 'post-command-hook #'hl-line-maybe-unhighlight nil t)) + (add-hook 'post-command-hook #'hl-line-highlight nil t)) (remove-hook 'post-command-hook #'hl-line-highlight t) (hl-line-unhighlight) - (remove-hook 'change-major-mode-hook #'hl-line-unhighlight t) - (remove-hook 'post-command-hook #'hl-line-maybe-unhighlight t))) + (remove-hook 'change-major-mode-hook #'hl-line-unhighlight t))) (defun hl-line-make-overlay () (let ((ol (make-overlay (point) (point)))) @@ -168,17 +160,19 @@ addition to `hl-line-highlight' on `post-command-hook'." "Activate the Hl-Line overlay on the current line." (if hl-line-mode ; Might be changed outside the mode function. (progn - (unless hl-line-overlay + (unless (overlayp hl-line-overlay) (setq hl-line-overlay (hl-line-make-overlay))) ; To be moved. (overlay-put hl-line-overlay 'window (unless hl-line-sticky-flag (selected-window))) - (hl-line-move hl-line-overlay)) + (hl-line-move hl-line-overlay) + (hl-line-maybe-unhighlight)) (hl-line-unhighlight))) (defun hl-line-unhighlight () "Deactivate the Hl-Line overlay on the current line." - (when hl-line-overlay - (delete-overlay hl-line-overlay))) + (when (overlayp hl-line-overlay) + (delete-overlay hl-line-overlay) + (setq hl-line-overlay nil))) (defun hl-line-maybe-unhighlight () "Maybe deactivate the Hl-Line overlay on the current line. @@ -191,8 +185,7 @@ such overlays in all buffers except the current one." (not (eq curbuf hlob)) (not (minibufferp))) (with-current-buffer hlob - (when (overlayp hl-line-overlay) - (delete-overlay hl-line-overlay)))) + (hl-line-unhighlight))) (when (and (overlayp hl-line-overlay) (eq (overlay-buffer hl-line-overlay) curbuf)) (setq hl-line-overlay-buffer curbuf)))) @@ -205,8 +198,8 @@ If `global-hl-line-sticky-flag' is non-nil, Global Hl-Line mode highlights the line about the current buffer's point in all live windows. -Global-Hl-Line mode uses the functions `global-hl-line-highlight' -and `global-hl-line-maybe-unhighlight' on `post-command-hook'." +Global-Hl-Line mode uses the function `global-hl-line-highlight' +on `post-command-hook'." :global t :group 'hl-line (if global-hl-line-mode @@ -214,25 +207,24 @@ and `global-hl-line-maybe-unhighlight' on `post-command-hook'." ;; In case `kill-all-local-variables' is called. (add-hook 'change-major-mode-hook #'global-hl-line-unhighlight) (global-hl-line-highlight-all) - (add-hook 'post-command-hook #'global-hl-line-highlight) - (add-hook 'post-command-hook #'global-hl-line-maybe-unhighlight)) + (add-hook 'post-command-hook #'global-hl-line-highlight)) (global-hl-line-unhighlight-all) (remove-hook 'post-command-hook #'global-hl-line-highlight) - (remove-hook 'change-major-mode-hook #'global-hl-line-unhighlight) - (remove-hook 'post-command-hook #'global-hl-line-maybe-unhighlight))) + (remove-hook 'change-major-mode-hook #'global-hl-line-unhighlight))) (defun global-hl-line-highlight () "Highlight the current line in the current window." (when global-hl-line-mode ; Might be changed outside the mode function. (unless (window-minibuffer-p) - (unless global-hl-line-overlay + (unless (overlayp global-hl-line-overlay) (setq global-hl-line-overlay (hl-line-make-overlay))) ; To be moved. (unless (member global-hl-line-overlay global-hl-line-overlays) (push global-hl-line-overlay global-hl-line-overlays)) (overlay-put global-hl-line-overlay 'window (unless global-hl-line-sticky-flag (selected-window))) - (hl-line-move global-hl-line-overlay)))) + (hl-line-move global-hl-line-overlay) + (global-hl-line-maybe-unhighlight)))) (defun global-hl-line-highlight-all () "Highlight the current line in all live windows." @@ -243,8 +235,9 @@ and `global-hl-line-maybe-unhighlight' on `post-command-hook'." (defun global-hl-line-unhighlight () "Deactivate the Global-Hl-Line overlay on the current line." - (when global-hl-line-overlay - (delete-overlay global-hl-line-overlay))) + (when (overlayp global-hl-line-overlay) + (delete-overlay global-hl-line-overlay) + (setq global-hl-line-overlay nil))) (defun global-hl-line-maybe-unhighlight () "Maybe deactivate the Global-Hl-Line overlay on the current line. @@ -256,9 +249,8 @@ all such overlays in all buffers except the current one." (bufferp ovb) (not (eq ovb (current-buffer))) (not (minibufferp))) - (with-current-buffer ovb - (when (overlayp global-hl-line-overlay) - (delete-overlay global-hl-line-overlay)))))) + (with-current-buffer ovb + (global-hl-line-unhighlight))))) global-hl-line-overlays)) (defun global-hl-line-unhighlight-all () -- cgit v1.2.3 From 259edd435e0c02c3c906e8b34e7ece37724ccf11 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sat, 23 Jan 2021 20:38:54 +0100 Subject: Add a mechanism for buffer-local thing-at-points * doc/lispref/text.texi (Buffer Contents): Document it. * lisp/thingatpt.el (thing-at-point-provider-alist): New variable. (thing-at-point): Use it. --- doc/lispref/text.texi | 19 +++++++++++++++++++ etc/NEWS | 6 ++++++ lisp/thingatpt.el | 35 ++++++++++++++++++++++++++++++++--- 3 files changed, 57 insertions(+), 3 deletions(-) (limited to 'lisp') diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi index 35bc6f9f161..14854a5aafa 100644 --- a/doc/lispref/text.texi +++ b/doc/lispref/text.texi @@ -334,6 +334,25 @@ but there is no peace. (thing-at-point 'whitespace) @result{} nil @end example + +@defvar thing-at-point-provider-alist +This variable allows users and modes to tweak how +@code{thing-at-point} works. It's an association list of @var{thing}s +and functions (called with zero parameters) to return that thing. +Entries for @var{thing} will be evaluated in turn until a +non-@code{nil} result is returned. + +For instance, a major mode could say: + +@lisp +(setq-local thing-at-point-provider-alist + (append thing-at-point-provider-alist + '((url . my-mode--url-at-point)))) +@end lisp + +If no providers have a non-@code{nil} return, the @var{thing} will be +computed the standard way. +@end defvar @end defun @node Comparing Text diff --git a/etc/NEWS b/etc/NEWS index 357c75b7e96..6a80493e239 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1564,6 +1564,12 @@ that makes it a valid button. *** New macro `named-let` that provides Scheme's "named let" looping construct +** thingatpt + ++++ +*** New variable 'thing-at-point-provider-alist'. +This allows mode-specific alterations to how `thing-at-point' works. + ** Miscellaneous --- diff --git a/lisp/thingatpt.el b/lisp/thingatpt.el index 67d4092d407..c52fcfcc051 100644 --- a/lisp/thingatpt.el +++ b/lisp/thingatpt.el @@ -52,8 +52,30 @@ ;;; Code: +(require 'cl-lib) (provide 'thingatpt) +(defvar thing-at-point-provider-alist nil + "Alist of providers for returning a \"thing\" at point. +This variable can be set globally, or appended to buffer-locally +by modes, to provide functions that will return a \"thing\" at +point. The first provider for the \"thing\" that returns a +non-nil value wins. + +For instance, a major mode could say: + +\(setq-local thing-at-point-provider-alist + (append thing-at-point-provider-alist + \\='((url . my-mode--url-at-point)))) + +to provide a way to get an `url' at point in that mode. The +provider functions are called with no parameters at the point in +question. + +\"things\" include `symbol', `list', `sexp', `defun', `filename', +`url', `email', `uuid', `word', `sentence', `whitespace', `line', +and `page'.") + ;; Basic movement ;;;###autoload @@ -143,11 +165,18 @@ strip text properties from the return value. See the file `thingatpt.el' for documentation on how to define a symbol as a valid THING." (let ((text - (if (get thing 'thing-at-point) - (funcall (get thing 'thing-at-point)) + (cond + ((cl-loop for (pthing . function) in thing-at-point-provider-alist + when (eq pthing thing) + for result = (funcall function) + when result + return result)) + ((get thing 'thing-at-point) + (funcall (get thing 'thing-at-point))) + (t (let ((bounds (bounds-of-thing-at-point thing))) (when bounds - (buffer-substring (car bounds) (cdr bounds))))))) + (buffer-substring (car bounds) (cdr bounds)))))))) (when (and text no-properties (sequencep text)) (set-text-properties 0 (length text) nil text)) text)) -- cgit v1.2.3 From b7068be5c410c5592856aeebd7aa4d62b1dc68e5 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sat, 23 Jan 2021 20:39:45 +0100 Subject: Provide a (thing-at-point 'url) in eww buffers * lisp/net/eww.el (eww-mode): Allow (thing-at-point 'url) to work in eww buffers. (eww--url-at-point): New function. --- lisp/net/eww.el | 7 +++++++ 1 file changed, 7 insertions(+) (limited to 'lisp') diff --git a/lisp/net/eww.el b/lisp/net/eww.el index d131b2bf8c9..e39a4c33b20 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -1050,9 +1050,16 @@ the like." ;; multi-page isearch support (setq-local multi-isearch-next-buffer-function #'eww-isearch-next-buffer) (setq truncate-lines t) + (setq-local thing-at-point-provider-alist + (append thing-at-point-provider-alist + '((url . eww--url-at-point)))) (buffer-disable-undo) (setq buffer-read-only t)) +(defun eww--url-at-point () + "`thing-at-point' provider function." + (get-text-property (point) 'shr-url)) + ;;;###autoload (defun eww-browse-url (url &optional new-window) "Ask the EWW browser to load URL. -- cgit v1.2.3 From 1559cc445a306b61b2a47c710e049ea26fe5265d Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sat, 23 Jan 2021 16:04:36 -0500 Subject: Fix missing file&line info in "Unknown defun property" warnings * lisp/emacs-lisp/byte-run.el (defmacro, defun): Use `macroexp--warn-and-return` rather than `message`. * lisp/emacs-lisp/macroexp.el: Fix `macroexp--compiling-p`. (macroexp--warn-and-return): Don't try and detect repetition on forms like `nil`. (macroexp-macroexpand): Don't forget to bind `macroexpand-all-environment`. --- lisp/emacs-lisp/byte-run.el | 16 +++++++++++----- lisp/emacs-lisp/macroexp.el | 14 ++++++++------ 2 files changed, 19 insertions(+), 11 deletions(-) (limited to 'lisp') diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 0f8dd5a2842..88f362d24f0 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -232,8 +232,11 @@ The return value is undefined. #'(lambda (x) (let ((f (cdr (assq (car x) macro-declarations-alist)))) (if f (apply (car f) name arglist (cdr x)) - (message "Warning: Unknown macro property %S in %S" - (car x) name)))) + (macroexp--warn-and-return + (format-message + "Unknown macro property %S in %S" + (car x) name) + nil)))) decls))) ;; Refresh font-lock if this is a new macro, or it is an ;; existing macro whose 'no-font-lock-keyword declaration @@ -301,9 +304,12 @@ The return value is undefined. (cdr body) body))) nil) - (t (message "Warning: Unknown defun property `%S' in %S" - (car x) name))))) - decls)) + (t + (macroexp--warn-and-return + (format-message "Unknown defun property `%S' in %S" + (car x) name) + nil))))) + decls)) (def (list 'defalias (list 'quote name) (list 'function diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 37844977f8f..aa49bccc8d0 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -127,7 +127,7 @@ and also to avoid outputting the warning during normal execution." (cond ((null msg) form) ((macroexp--compiling-p) - (if (gethash form macroexp--warned) + (if (and (consp form) (gethash form macroexp--warned)) ;; Already wrapped this exp with a warning: avoid inf-looping ;; where we keep adding the same warning onto `form' because ;; macroexpand-all gets right back to macroexpanding `form'. @@ -138,9 +138,10 @@ and also to avoid outputting the warning during normal execution." ,form))) (t (unless compile-only - (message "%s%s" (if (stringp load-file-name) - (concat (file-relative-name load-file-name) ": ") - "") + (message "%sWarning: %s" + (if (stringp load-file-name) + (concat (file-relative-name load-file-name) ": ") + "") msg)) form)))) @@ -180,8 +181,9 @@ and also to avoid outputting the warning during normal execution." (defun macroexp-macroexpand (form env) "Like `macroexpand' but checking obsolescence." - (let ((new-form - (macroexpand form env))) + (let* ((macroexpand-all-environment env) + (new-form + (macroexpand form env))) (if (and (not (eq form new-form)) ;It was a macro call. (car-safe form) (symbolp (car form)) -- cgit v1.2.3 From 75f6b264f549ee66faae75bfbad4d3f7602e2a64 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sat, 23 Jan 2021 23:12:05 +0100 Subject: Make (subdirs . nil) in .dir-locals.el work * lisp/files.el (dir-locals-collect-variables): Don't destructively modify the cached structure (bug#17205), because that means that (subdirs . nil) doesn't work. --- lisp/files.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/files.el b/lisp/files.el index d2e5413b3ad..7af5549bcb0 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -4062,7 +4062,7 @@ Return the new variables list." (subdirs (assq 'subdirs alist))) (if (or (not subdirs) (progn - (setq alist (delq subdirs alist)) + (setq alist (remq subdirs alist)) (cdr-safe subdirs)) ;; TODO someone might want to extend this to allow ;; integer values for subdir, where N means -- cgit v1.2.3 From 0ebf9d6cef211a3eddcf035aa8494d95ab7a2649 Mon Sep 17 00:00:00 2001 From: Eric Abrahamsen Date: Sat, 23 Jan 2021 14:24:09 -0800 Subject: Properly initialize gnus-search-namazu-index-directory * lisp/gnus/gnus-search.el (gnus-search-namazu): We were missing the appropriate :initform on this slot definition (Bug#46047). --- lisp/gnus/gnus-search.el | 1 + 1 file changed, 1 insertion(+) (limited to 'lisp') diff --git a/lisp/gnus/gnus-search.el b/lisp/gnus/gnus-search.el index 5c6a5b9efd0..44780609af7 100644 --- a/lisp/gnus/gnus-search.el +++ b/lisp/gnus/gnus-search.el @@ -909,6 +909,7 @@ quirks.") (defclass gnus-search-namazu (gnus-search-indexed) ((index-directory :initarg :index-directory + :initform (symbol-value 'gnus-search-namazu-index-directory) :type string :custom directory) (program -- cgit v1.2.3 From 7cc970e7e3939672ec8ae490fff8300395e16b76 Mon Sep 17 00:00:00 2001 From: Jean Louis Date: Sun, 24 Jan 2021 00:34:44 +0100 Subject: Add support for dired compressing .lz/.lzo files * lisp/dired-aux.el (dired-compress-files-alist): Add support for .lz/.lzo files (bug#44901). --- lisp/dired-aux.el | 2 ++ 1 file changed, 2 insertions(+) (limited to 'lisp') diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index f860743a066..c765e4be45d 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -1168,6 +1168,8 @@ ARGS are command switches passed to PROGRAM.") ("\\.tar\\.bz2\\'" . "tar -cf - %i | bzip2 -c9 > %o") ("\\.tar\\.xz\\'" . "tar -cf - %i | xz -c9 > %o") ("\\.tar\\.zst\\'" . "tar -cf - %i | zstd -19 -o %o") + ("\\.tar\\.lz\\'" . "tar -cf - %i | lzip -c9 > %o") + ("\\.tar\\.lzo\\'" . "tar -cf - %i | lzop -c9 > %o") ("\\.zip\\'" . "zip %o -r --filesync %i") ("\\.pax\\'" . "pax -wf %o %i")) "Control the compression shell command for `dired-do-compress-to'. -- cgit v1.2.3 From b26e09e0f02b94d72bddfb108a16daffb74139f6 Mon Sep 17 00:00:00 2001 From: Eric Abrahamsen Date: Sun, 24 Jan 2021 10:09:05 -0800 Subject: Fix insertion logic of newly subscribed Gnus groups * lisp/gnus/gnus-start.el (gnus-subscribe-newsgroup): This was a misunderstanding of the next/previous argument: no group should ever be inserted before "dummy.group". (gnus-group-change-level): Make it clearer that PREVIOUS can be nil. In fact none of this code would error on a nil value, but it _looks_ like nil is unexpected. --- lisp/gnus/gnus-start.el | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) (limited to 'lisp') diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el index fbdbf41dc05..cf37a1ccdfc 100644 --- a/lisp/gnus/gnus-start.el +++ b/lisp/gnus/gnus-start.el @@ -637,7 +637,7 @@ the first newsgroup." ;; We subscribe the group by changing its level to `subscribed'. (gnus-group-change-level newsgroup gnus-level-default-subscribed - gnus-level-killed (or next "dummy.group")) + gnus-level-killed next) (gnus-request-update-group-status newsgroup 'subscribe) (gnus-message 5 "Subscribe newsgroup: %s" newsgroup) (run-hook-with-args 'gnus-subscribe-newsgroup-functions newsgroup) @@ -1282,7 +1282,8 @@ string name) to insert this group before." (gnus-dribble-enter (format "(gnus-group-change-level %S %S %S %S %S)" group level oldlevel - (cadr (member previous gnus-group-list)) + (when previous + (cadr (member previous gnus-group-list))) fromkilled))) ;; Then we remove the newgroup from any old structures, if needed. @@ -1341,9 +1342,10 @@ string name) to insert this group before." ;; at the head of `gnus-newsrc-alist'. (push info (cdr gnus-newsrc-alist)) (puthash group (list num info) gnus-newsrc-hashtb) - (when (stringp previous) + (when (and previous (stringp previous)) (setq previous (gnus-group-entry previous))) - (let ((idx (or (seq-position gnus-group-list (caadr previous)) + (let ((idx (or (and previous + (seq-position gnus-group-list (caadr previous))) (length gnus-group-list)))) (push group (nthcdr idx gnus-group-list))) (gnus-dribble-enter -- cgit v1.2.3 From 3cefda090304bbbce43d242072918ca855326842 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Sun, 24 Jan 2021 19:26:02 +0100 Subject: Make Tramp's insert-directory more robust * lisp/net/tramp-sh.el (tramp-sh-handle-insert-directory): Use `tramp-sh--quoting-style-options'. * test/lisp/net/tramp-tests.el (tramp--test-hpux-p, tramp--test-ksh-p): Remove superfluous nil. (tramp--test-sh-no-ls--dired-p): New defun. (tramp--test-special-characters): Use it. --- lisp/net/tramp-sh.el | 7 ++----- test/lisp/net/tramp-tests.el | 46 ++++++++++++++++++++++++++++---------------- 2 files changed, 31 insertions(+), 22 deletions(-) (limited to 'lisp') diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index d7ca7c9780c..ed3d15377c3 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -2617,11 +2617,8 @@ The method used must be an out-of-band method." filename switches wildcard full-directory-p) (when (stringp switches) (setq switches (split-string switches))) - (when (tramp-get-ls-command-with ;FIXME: tramp-sh--quoting-style-options? - v "--quoting-style=literal --show-control-chars") - (setq switches - (append - switches '("--quoting-style=literal" "--show-control-chars")))) + (setq switches + (append switches (split-string (tramp-sh--quoting-style-options v)))) (unless (tramp-get-ls-command-with v "--dired") (setq switches (delete "--dired" switches))) (when wildcard diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 4c84507807b..7757c55c16b 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -5720,16 +5720,16 @@ This requires restrictions of file name syntax." (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) 'tramp-ftp-file-name-handler)) +(defun tramp--test-crypt-p () + "Check, whether the remote directory is crypted" + (tramp-crypt-file-name-p tramp-test-temporary-file-directory)) + (defun tramp--test-docker-p () "Check, whether the docker method is used. This does not support some special file names." (string-equal "docker" (file-remote-p tramp-test-temporary-file-directory 'method))) -(defun tramp--test-crypt-p () - "Check, whether the remote directory is crypted" - (tramp-crypt-file-name-p tramp-test-temporary-file-directory)) - (defun tramp--test-ftp-p () "Check, whether an FTP-like method is used. This does not support globbing characters in file names (yet)." @@ -5748,7 +5748,7 @@ If optional METHOD is given, it is checked first." "Check, whether the remote host runs HP-UX. Several special characters do not work properly there." ;; We must refill the cache. `file-truename' does it. - (file-truename tramp-test-temporary-file-directory) nil + (file-truename tramp-test-temporary-file-directory) (string-match-p "^HP-UX" (tramp-get-connection-property tramp-test-vec "uname" ""))) @@ -5757,7 +5757,7 @@ Several special characters do not work properly there." ksh93 makes some strange conversions of non-latin characters into a $'' syntax." ;; We must refill the cache. `file-truename' does it. - (file-truename tramp-test-temporary-file-directory) nil + (file-truename tramp-test-temporary-file-directory) (string-match-p "ksh$" (tramp-get-connection-property tramp-test-vec "remote-shell" ""))) @@ -5787,6 +5787,15 @@ This does not support special file names." "Check, whether the remote host runs a based method from tramp-sh.el." (tramp-sh-file-name-handler-p tramp-test-vec)) +(defun tramp--test-sh-no-ls--dired-p () + "Check, whether the remote host runs a based method from tramp-sh.el. +Additionally, ls does not support \"--dired\"." + (and (tramp--test-sh-p) + (with-temp-buffer + ;; We must refill the cache. `insert-directory' does it. + (insert-directory tramp-test-temporary-file-directory "-al") + (not (tramp-get-connection-property tramp-test-vec "ls--dired" nil))))) + (defun tramp--test-share-p () "Check, whether the method needs a share." (and (tramp--test-gvfs-p) @@ -6023,17 +6032,20 @@ This requires restrictions of file name syntax." ;; expanded to . (let ((files (list - (if (or (tramp--test-ange-ftp-p) - (tramp--test-gvfs-p) - (tramp--test-rclone-p) - (tramp--test-sudoedit-p) - (tramp--test-windows-nt-or-smb-p)) - "foo bar baz" - (if (or (tramp--test-adb-p) - (tramp--test-docker-p) - (eq system-type 'cygwin)) - " foo bar baz " - " foo\tbar baz\t")) + (cond ((or (tramp--test-ange-ftp-p) + (tramp--test-gvfs-p) + (tramp--test-rclone-p) + (tramp--test-sudoedit-p) + (tramp--test-windows-nt-or-smb-p)) + "foo bar baz") + ((or (tramp--test-adb-p) + (tramp--test-docker-p) + (eq system-type 'cygwin)) + " foo bar baz ") + ((tramp--test-sh-no-ls--dired-p) + "\tfoo bar baz\t") + (t " foo\tbar baz\t")) + "@foo@bar@baz@" "$foo$bar$$baz$" "-foo-bar-baz-" "%foo%bar%baz%" -- cgit v1.2.3 From 8f28a1b9da06a12ac3631de38119d8845f14499c Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sun, 24 Jan 2021 21:31:09 +0100 Subject: Tweak `condition-case' keyword highlights * lisp/emacs-lisp/lisp-mode.el (lisp--el-non-funcall-position-p): Tweak `condition-case' position check to skip the VAR form. --- lisp/emacs-lisp/lisp-mode.el | 7 +++++-- test/lisp/progmodes/elisp-mode-tests.el | 9 ++++++++- 2 files changed, 13 insertions(+), 3 deletions(-) (limited to 'lisp') diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 8780c5dcd30..34ecfd1c254 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -234,8 +234,11 @@ (< pos (point)))) (and (eq parent 'condition-case) (progn - (forward-sexp 2) - (< (point) pos)))))))))) + (forward-sexp 1) + ;; If we're in the second form, then we're in + ;; a funcall position. + (not (< (point) pos (progn (forward-sexp 1) + (point))))))))))))) (defun lisp--el-match-keyword (limit) ;; FIXME: Move to elisp-mode.el. diff --git a/test/lisp/progmodes/elisp-mode-tests.el b/test/lisp/progmodes/elisp-mode-tests.el index 0da0e393535..714751eafc8 100644 --- a/test/lisp/progmodes/elisp-mode-tests.el +++ b/test/lisp/progmodes/elisp-mode-tests.el @@ -877,7 +877,7 @@ to (xref-elisp-test-descr-to-target xref)." "(\\(if\\)") nil))) -(ert-deftest test-elisp-font-keywords-if () +(ert-deftest test-elisp-font-keywords-4 () :expected-result :failed ; FIXME bug#43265 (should (eq (test--font '(condition-case nil (foo) @@ -885,5 +885,12 @@ to (xref-elisp-test-descr-to-target xref)." "(\\(if\\)") nil))) +(ert-deftest test-elisp-font-keywords-5 () + (should (eq (test--font '(condition-case (when a) + (foo) + (error t)) + "(\\(when\\)") + nil))) + (provide 'elisp-mode-tests) ;;; elisp-mode-tests.el ends here -- cgit v1.2.3 From 196be2bf12e1018335e4261cd4d6f25d6d16c415 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sun, 24 Jan 2021 21:43:25 +0100 Subject: Fix macro fontification in `condition-case' handler bodies * lisp/emacs-lisp/lisp-mode.el (lisp--el-non-funcall-position-p): Fontify macros in the BODY of HANDLERS in `condition-case' correctly (bug#43265). --- lisp/emacs-lisp/lisp-mode.el | 15 +++++++++------ test/lisp/progmodes/elisp-mode-tests.el | 1 - 2 files changed, 9 insertions(+), 7 deletions(-) (limited to 'lisp') diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 34ecfd1c254..9c2b0dbe200 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -233,12 +233,15 @@ (forward-sexp 1) (< pos (point)))) (and (eq parent 'condition-case) - (progn - (forward-sexp 1) - ;; If we're in the second form, then we're in - ;; a funcall position. - (not (< (point) pos (progn (forward-sexp 1) - (point))))))))))))) + ;; If (cdr paren-posns), then we're in the BODY + ;; of HANDLERS. + (and (not (cdr paren-posns)) + (progn + (forward-sexp 1) + ;; If we're in the second form, then we're in + ;; a funcall position. + (not (< (point) pos (progn (forward-sexp 1) + (point)))))))))))))) (defun lisp--el-match-keyword (limit) ;; FIXME: Move to elisp-mode.el. diff --git a/test/lisp/progmodes/elisp-mode-tests.el b/test/lisp/progmodes/elisp-mode-tests.el index 714751eafc8..e84184ff07d 100644 --- a/test/lisp/progmodes/elisp-mode-tests.el +++ b/test/lisp/progmodes/elisp-mode-tests.el @@ -864,7 +864,6 @@ to (xref-elisp-test-descr-to-target xref)." 'nil))) (ert-deftest test-elisp-font-keywords-2 () - :expected-result :failed ; FIXME bug#43265 (should (eq (test--font '(condition-case nil (foo) (error (when a b))) -- cgit v1.2.3 From 9503f8d96cc89fa89bb68e183c79f0d9cb1b4d32 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sun, 24 Jan 2021 23:25:52 +0100 Subject: Rewrite lisp--el-funcall-position-p to be inverse of the -not function * lisp/emacs-lisp/lisp-mode.el (lisp--el-funcall-position-p): Rename and rewrite to return the inverse value. Non-inverted predicate functions are easier to reason about. (lisp--el-non-funcall-position-p): Make obsolete. --- lisp/emacs-lisp/lisp-mode.el | 81 +++++++++++++++++++++++--------------------- 1 file changed, 43 insertions(+), 38 deletions(-) (limited to 'lisp') diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 9c2b0dbe200..22435d59659 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -200,48 +200,54 @@ res)) (defun lisp--el-non-funcall-position-p (pos) + "Heuristically determine whether POS is an evaluated position." + (declare (obsolete lisp--el-funcall-position-p "28.1")) + (not (lisp--el-funcall-position-p pos))) + +(defun lisp--el-funcall-position-p (pos) "Heuristically determine whether POS is an evaluated position." (save-match-data (save-excursion (ignore-errors (goto-char pos) ;; '(lambda ..) is not a funcall position, but #'(lambda ...) is. - (or (and (eql (char-before) ?\') - (not (eql (char-before (1- (point))) ?#))) - (let* ((ppss (syntax-ppss)) - (paren-posns (nth 9 ppss)) - (parent - (when paren-posns - (goto-char (car (last paren-posns))) ;(up-list -1) - (cond - ((ignore-errors - (and (eql (char-after) ?\() - (when (cdr paren-posns) - (goto-char (car (last paren-posns 2))) - (looking-at "(\\_")))) - (goto-char (match-end 0)) - 'let) - ((looking-at - (rx "(" - (group-n 1 (+ (or (syntax w) (syntax _)))) - symbol-end)) - (prog1 (intern-soft (match-string-no-properties 1)) - (goto-char (match-end 1)))))))) - (or (eq parent 'declare) - (and (eq parent 'let) - (progn - (forward-sexp 1) - (< pos (point)))) - (and (eq parent 'condition-case) - ;; If (cdr paren-posns), then we're in the BODY - ;; of HANDLERS. - (and (not (cdr paren-posns)) - (progn - (forward-sexp 1) - ;; If we're in the second form, then we're in - ;; a funcall position. - (not (< (point) pos (progn (forward-sexp 1) - (point)))))))))))))) + (if (eql (char-before) ?\') + (eql (char-before (1- (point))) ?#) + (let* ((ppss (syntax-ppss)) + (paren-posns (nth 9 ppss)) + (parent + (when paren-posns + (goto-char (car (last paren-posns))) ;(up-list -1) + (cond + ((ignore-errors + (and (eql (char-after) ?\() + (when (cdr paren-posns) + (goto-char (car (last paren-posns 2))) + (looking-at "(\\_")))) + (goto-char (match-end 0)) + 'let) + ((looking-at + (rx "(" + (group-n 1 (+ (or (syntax w) (syntax _)))) + symbol-end)) + (prog1 (intern-soft (match-string-no-properties 1)) + (goto-char (match-end 1)))))))) + (pcase parent + ('declare nil) + ('let + (forward-sexp 1) + (>= pos (point))) + ('condition-case + ;; If (cdr paren-posns), then we're in the BODY + ;; of HANDLERS. + (or (cdr paren-posns) + (progn + (forward-sexp 1) + ;; If we're in the second form, then we're in + ;; a funcall position. + (< (point) pos (progn (forward-sexp 1) + (point)))))) + (_ t)))))))) (defun lisp--el-match-keyword (limit) ;; FIXME: Move to elisp-mode.el. @@ -254,8 +260,7 @@ (when (or (special-form-p sym) (and (macrop sym) (not (get sym 'no-font-lock-keyword)) - (not (lisp--el-non-funcall-position-p - (match-beginning 0))))) + (lisp--el-funcall-position-p (match-beginning 0)))) (throw 'found t)))))) (defmacro let-when-compile (bindings &rest body) -- cgit v1.2.3 From a10c74fbea46d5299e19167248383c69fd30648c Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Mon, 25 Jan 2021 07:44:29 +0100 Subject: Fontify special forms and macros the same * lisp/emacs-lisp/lisp-mode.el (lisp--el-match-keyword): Handle special forms and macros the same way (bug#43265). This makes things like (setq a '(if a b)) be fontified correctly (i.e., not fontified as a keyword). --- lisp/emacs-lisp/lisp-mode.el | 7 +++---- test/lisp/progmodes/elisp-mode-tests.el | 1 - 2 files changed, 3 insertions(+), 5 deletions(-) (limited to 'lisp') diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 22435d59659..c96d849d442 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -257,10 +257,9 @@ (concat "(\\(" lisp-mode-symbol-regexp "\\)\\_>")) limit t) (let ((sym (intern-soft (match-string 1)))) - (when (or (special-form-p sym) - (and (macrop sym) - (not (get sym 'no-font-lock-keyword)) - (lisp--el-funcall-position-p (match-beginning 0)))) + (when (and (or (special-form-p sym) (macrop sym)) + (not (get sym 'no-font-lock-keyword)) + (lisp--el-funcall-position-p (match-beginning 0))) (throw 'found t)))))) (defmacro let-when-compile (bindings &rest body) diff --git a/test/lisp/progmodes/elisp-mode-tests.el b/test/lisp/progmodes/elisp-mode-tests.el index e84184ff07d..badcad670c2 100644 --- a/test/lisp/progmodes/elisp-mode-tests.el +++ b/test/lisp/progmodes/elisp-mode-tests.el @@ -871,7 +871,6 @@ to (xref-elisp-test-descr-to-target xref)." 'font-lock-keyword-face))) (ert-deftest test-elisp-font-keywords-3 () - :expected-result :failed ; FIXME bug#43265 (should (eq (test--font '(setq a '(if when zot)) "(\\(if\\)") nil))) -- cgit v1.2.3 From 49e01d85ed6a6e4c95d43b6eeb4f32c7daa319a7 Mon Sep 17 00:00:00 2001 From: Juri Linkov Date: Mon, 25 Jan 2021 19:14:22 +0200 Subject: Don't move point to the prompt in previous-line-or-history-element (bug#46033) * lisp/simple.el (previous-line-or-history-element): Avoid moving point to the prompt. --- lisp/simple.el | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/simple.el b/lisp/simple.el index 8d4e4a7a6bb..c878fdab921 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -2476,7 +2476,10 @@ previous element of the minibuffer history in the minibuffer." (current-column))))) (condition-case nil (with-no-warnings - (previous-line arg)) + (previous-line arg) + ;; Avoid moving point to the prompt + (when (< (point) (minibuffer-prompt-end)) + (signal 'beginning-of-buffer nil))) (beginning-of-buffer ;; Restore old position since `line-move-visual' moves point to ;; the beginning of the line when it fails to go to the previous line. -- cgit v1.2.3 From 8f0a2c84b66ff8d45a9d088a181617417115ec9e Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Tue, 26 Jan 2021 01:12:45 +0100 Subject: Make subdirs . nil in dir-locals in ~/ work * lisp/files.el (dir-locals-collect-variables): Compare directory names after expanding. This makes a (subdirs . nil) in ~/ work as expected (bug#17205). Test case: ((nil . ((a . "hallo") (subdirs . nil)))) in ~/ --- lisp/files.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/files.el b/lisp/files.el index 7af5549bcb0..77e3a3a834c 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -4068,7 +4068,7 @@ Return the new variables list." ;; integer values for subdir, where N means ;; variables apply to this directory and N levels ;; below it (0 == nil). - (equal root default-directory)) + (equal root (expand-file-name default-directory))) (setq variables (dir-locals-collect-mode-variables alist variables)))))))) (error -- cgit v1.2.3 From b4b6a2684062d4470143b6ea460b5e82012554a1 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 25 Jan 2021 22:58:19 -0500 Subject: Use `lexical-binding` in all `lisp/international` files * lisp/startup.el (keyboard-type): Make obsolete and lex-bound. * admin/unidata/unidata-gen.el (unidata-gen-file) (unidata-gen-charprop): Mark the generated files to use lexical binding. * lisp/international/isearch-x.el: Use lexical-binding. (junk-hist): Declare locally. * lisp/international/iso-cvt.el: * lisp/international/utf-7.el: * lisp/international/robin.el: * lisp/international/ogonek.el: * lisp/international/latin1-disp.el: * lisp/international/kkc.el: * lisp/international/kinsoku.el: * lisp/international/ja-dic-utl.el: Use lexical-binding. * lisp/international/ja-dic-cnv.el: Use lexical-binding. (skkdic-breakup-string): Remove unused var `kana-len`. * lisp/international/latexenc.el: Use lexical-binding. (tex-start-of-header): Declare. * lisp/international/mule-diag.el: Use lexical-binding. (list-character-sets): Remove unused var `pos`. (list-character-sets-1): Remove unused vars `tail` and `charset`. (list-charset-chars): Remove unused vars `chars` and `plane`. (describe-coding-system): Remove unused var `extra-spec`. (mule--print-opened): New var. (print-fontset): Bind it. (print-fontset-element): Use it instead of `print-opened`. * lisp/international/quail.el: Use lexical-binding. (quail-start-translation, quail-start-conversion): Remove unused var `generated-events`. (quail-help-insert-keymap-description): Use local dynbound var `the-keymap`. --- admin/unidata/unidata-gen.el | 6 ++++-- etc/NEWS | 2 ++ lisp/international/isearch-x.el | 5 +++-- lisp/international/iso-cvt.el | 24 ++++++++++++------------ lisp/international/ja-dic-cnv.el | 8 ++++---- lisp/international/ja-dic-utl.el | 2 +- lisp/international/kinsoku.el | 2 +- lisp/international/kkc.el | 2 +- lisp/international/latexenc.el | 4 +++- lisp/international/latin1-disp.el | 19 +++++++++---------- lisp/international/mule-diag.el | 27 +++++++++++++++------------ lisp/international/ogonek.el | 2 +- lisp/international/quail.el | 16 +++++++++------- lisp/international/robin.el | 2 +- lisp/international/utf-7.el | 2 +- lisp/startup.el | 2 ++ 16 files changed, 69 insertions(+), 56 deletions(-) (limited to 'lisp') diff --git a/admin/unidata/unidata-gen.el b/admin/unidata/unidata-gen.el index 3918853088f..221c9b104e0 100644 --- a/admin/unidata/unidata-gen.el +++ b/admin/unidata/unidata-gen.el @@ -1416,7 +1416,8 @@ Property value is a symbol `o' (Open), `c' (Close), or `n' (None)." (or elt (user-error "Unknown output file: %s" basename)) (or noninteractive (message "Generating %s..." file)) (with-temp-file file - (insert ";; " copyright " + (insert ";;; " basename " -*- lexical-binding:t -*- +;; " copyright " ;; Generated from Unicode data files by unidata-gen.el. ;; The sources for this file are found in the admin/unidata/ directory in ;; the Emacs sources. The Unicode data files are used under the @@ -1451,7 +1452,8 @@ Property value is a symbol `o' (Open), `c' (Close), or `n' (None)." (defun unidata-gen-charprop (&optional charprop-file) (or charprop-file (setq charprop-file (pop command-line-args-left))) (with-temp-file charprop-file - (insert ";; Automatically generated by unidata-gen.el.\n" + (insert ";; Automatically generated by unidata-gen.el." + " -*- lexical-binding: t -*-\n" ";; See the admin/unidata/ directory in the Emacs sources.\n") (dolist (elt unidata-file-alist) (dolist (proplist (cdr elt)) diff --git a/etc/NEWS b/etc/NEWS index 6a80493e239..b815d3ac61b 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2133,6 +2133,8 @@ obsolete back in Emacs-23.1. The affected functions are: make-obsolete, define-obsolete-function-alias, make-obsolete-variable, define-obsolete-variable-alias. +** The variable 'keyboard-type' is obsolete and not dynamically scoped any more + * Lisp Changes in Emacs 28.1 diff --git a/lisp/international/isearch-x.el b/lisp/international/isearch-x.el index 400421ddb23..b890bde48d1 100644 --- a/lisp/international/isearch-x.el +++ b/lisp/international/isearch-x.el @@ -1,4 +1,4 @@ -;;; isearch-x.el --- extended isearch handling commands +;;; isearch-x.el --- extended isearch handling commands -*- lexical-binding: t; -*- ;; Copyright (C) 1997, 2001-2021 Free Software Foundation, Inc. ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, @@ -67,7 +67,7 @@ ;; Exit from recursive edit safely. Set in `after-change-functions' ;; by isearch-with-keyboard-coding. -(defun isearch-exit-recursive-edit (start end length) +(defun isearch-exit-recursive-edit (_start _end _length) (interactive) (throw 'exit nil)) @@ -102,6 +102,7 @@ ;;;###autoload (defun isearch-process-search-multibyte-characters (last-char &optional count) + (defvar junk-hist) (if (eq this-command 'isearch-printing-char) (let ((overriding-terminal-local-map nil) (prompt (isearch-message-prefix)) diff --git a/lisp/international/iso-cvt.el b/lisp/international/iso-cvt.el index 3f3843e23dd..ead7c8aa619 100644 --- a/lisp/international/iso-cvt.el +++ b/lisp/international/iso-cvt.el @@ -1,4 +1,4 @@ -;;; iso-cvt.el --- translate ISO 8859-1 from/to various encodings -*- coding: utf-8 -*- +;;; iso-cvt.el --- translate ISO 8859-1 from/to various encodings -*- lexical-binding: t; -*- ;; This file was formerly called gm-lingo.el. ;; Copyright (C) 1993-1998, 2000-2021 Free Software Foundation, Inc. @@ -79,7 +79,7 @@ (point-max)))) ;;;###autoload -(defun iso-spanish (from to &optional buffer) +(defun iso-spanish (from to &optional _buffer) "Translate net conventions for Spanish to ISO 8859-1. Translate the region between FROM and TO using the table `iso-spanish-trans-tab'. @@ -121,7 +121,7 @@ and may translate too little.") "Currently active translation table for German.") ;;;###autoload -(defun iso-german (from to &optional buffer) +(defun iso-german (from to &optional _buffer) "Translate net conventions for German to ISO 8859-1. Translate the region FROM and TO using the table `iso-german-trans-tab'. @@ -194,7 +194,7 @@ Optional arg BUFFER is ignored (for use in `format-alist')." "Translation table for translating ISO 8859-1 characters to TeX sequences.") ;;;###autoload -(defun iso-iso2tex (from to &optional buffer) +(defun iso-iso2tex (from to &optional _buffer) "Translate ISO 8859-1 characters to TeX sequences. Translate the region between FROM and TO using the table `iso-iso2tex-trans-tab'. @@ -387,7 +387,7 @@ This table is not exhaustive (and due to TeX's power can never be). It only contains commonly used sequences.") ;;;###autoload -(defun iso-tex2iso (from to &optional buffer) +(defun iso-tex2iso (from to &optional _buffer) "Translate TeX sequences to ISO 8859-1 characters. Translate the region between FROM and TO using the table `iso-tex2iso-trans-tab'. @@ -646,7 +646,7 @@ It only contains commonly used sequences.") "Translation table for translating ISO 8859-1 characters to German TeX.") ;;;###autoload -(defun iso-gtex2iso (from to &optional buffer) +(defun iso-gtex2iso (from to &optional _buffer) "Translate German TeX sequences to ISO 8859-1 characters. Translate the region between FROM and TO using the table `iso-gtex2iso-trans-tab'. @@ -655,7 +655,7 @@ Optional arg BUFFER is ignored (for use in `format-alist')." (iso-translate-conventions from to iso-gtex2iso-trans-tab)) ;;;###autoload -(defun iso-iso2gtex (from to &optional buffer) +(defun iso-iso2gtex (from to &optional _buffer) "Translate ISO 8859-1 characters to German TeX sequences. Translate the region between FROM and TO using the table `iso-iso2gtex-trans-tab'. @@ -674,7 +674,7 @@ Optional arg BUFFER is ignored (for use in `format-alist')." "Translation table for translating ISO 8859-1 characters to Duden sequences.") ;;;###autoload -(defun iso-iso2duden (from to &optional buffer) +(defun iso-iso2duden (from to &optional _buffer) "Translate ISO 8859-1 characters to Duden sequences. Translate the region between FROM and TO using the table `iso-iso2duden-trans-tab'. @@ -812,7 +812,7 @@ Optional arg BUFFER is ignored (for use in `format-alist')." ("ÿ" "ÿ"))) ;;;###autoload -(defun iso-iso2sgml (from to &optional buffer) +(defun iso-iso2sgml (from to &optional _buffer) "Translate ISO 8859-1 characters in the region to SGML entities. Use entities from \"ISO 8879:1986//ENTITIES Added Latin 1//EN\". Optional arg BUFFER is ignored (for use in `format-alist')." @@ -820,7 +820,7 @@ Optional arg BUFFER is ignored (for use in `format-alist')." (iso-translate-conventions from to iso-iso2sgml-trans-tab)) ;;;###autoload -(defun iso-sgml2iso (from to &optional buffer) +(defun iso-sgml2iso (from to &optional _buffer) "Translate SGML entities in the region to ISO 8859-1 characters. Use entities from \"ISO 8879:1986//ENTITIES Added Latin 1//EN\". Optional arg BUFFER is ignored (for use in `format-alist')." @@ -828,13 +828,13 @@ Optional arg BUFFER is ignored (for use in `format-alist')." (iso-translate-conventions from to iso-sgml2iso-trans-tab)) ;;;###autoload -(defun iso-cvt-read-only (&rest ignore) +(defun iso-cvt-read-only (&rest _ignore) "Warn that format is read-only." (interactive) (error "This format is read-only; specify another format for writing")) ;;;###autoload -(defun iso-cvt-write-only (&rest ignore) +(defun iso-cvt-write-only (&rest _ignore) "Warn that format is write-only." (interactive) (error "This format is write-only")) diff --git a/lisp/international/ja-dic-cnv.el b/lisp/international/ja-dic-cnv.el index b80590491c1..155c85fb42f 100644 --- a/lisp/international/ja-dic-cnv.el +++ b/lisp/international/ja-dic-cnv.el @@ -1,4 +1,4 @@ -;;; ja-dic-cnv.el --- convert a Japanese dictionary (SKK-JISYO.L) to Emacs Lisp +;;; ja-dic-cnv.el --- convert a Japanese dictionary (SKK-JISYO.L) to Emacs Lisp -*- lexical-binding: t; -*- ;; Copyright (C) 2001-2021 Free Software Foundation, Inc. @@ -96,7 +96,7 @@ ("もく" "目") ("ゆき" "行"))) -(defun skkdic-convert-postfix (skkbuf buf) +(defun skkdic-convert-postfix (_skkbuf buf) (byte-compile-info "Processing POSTFIX entries" t) (goto-char (point-min)) (with-current-buffer buf @@ -150,7 +150,7 @@ (defconst skkdic-prefix-list '(skkdic-prefix-list)) -(defun skkdic-convert-prefix (skkbuf buf) +(defun skkdic-convert-prefix (_skkbuf buf) (byte-compile-info "Processing PREFIX entries" t) (goto-char (point-min)) (with-current-buffer buf @@ -209,7 +209,7 @@ (substring str from idx) skkdic-word-list))) (if (or (and (consp kana2-list) - (let ((kana-len (length kana)) + (let (;; (kana-len (length kana)) kana2) (catch 'skkdic-tag (while kana2-list diff --git a/lisp/international/ja-dic-utl.el b/lisp/international/ja-dic-utl.el index 498fb23f707..cc636986f99 100644 --- a/lisp/international/ja-dic-utl.el +++ b/lisp/international/ja-dic-utl.el @@ -1,4 +1,4 @@ -;;; ja-dic-utl.el --- utilities for handling Japanese dictionary (SKK-JISYO.L) +;;; ja-dic-utl.el --- utilities for handling Japanese dictionary (SKK-JISYO.L) -*- lexical-binding: t; -*- ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 diff --git a/lisp/international/kinsoku.el b/lisp/international/kinsoku.el index cd740acc6ac..05179a98ac2 100644 --- a/lisp/international/kinsoku.el +++ b/lisp/international/kinsoku.el @@ -1,4 +1,4 @@ -;;; kinsoku.el --- `Kinsoku' processing funcs +;;; kinsoku.el --- `Kinsoku' processing funcs -*- lexical-binding: t; -*- ;; Copyright (C) 1997, 2001-2021 Free Software Foundation, Inc. ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, diff --git a/lisp/international/kkc.el b/lisp/international/kkc.el index 290f4fa0cf1..87f73897bf6 100644 --- a/lisp/international/kkc.el +++ b/lisp/international/kkc.el @@ -1,4 +1,4 @@ -;;; kkc.el --- Kana Kanji converter +;;; kkc.el --- Kana Kanji converter -*- lexical-binding: t; -*- ;; Copyright (C) 1997-1998, 2001-2021 Free Software Foundation, Inc. ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, diff --git a/lisp/international/latexenc.el b/lisp/international/latexenc.el index e2ee3fb37e3..ff7cddcb26e 100644 --- a/lisp/international/latexenc.el +++ b/lisp/international/latexenc.el @@ -1,4 +1,4 @@ -;;; latexenc.el --- guess correct coding system in LaTeX files -*-coding: utf-8 -*- +;;; latexenc.el --- guess correct coding system in LaTeX files -*- lexical-binding: t; -*- ;; Copyright (C) 2005-2021 Free Software Foundation, Inc. @@ -109,6 +109,8 @@ Return nil if no matching input encoding can be found." (defvar latexenc-dont-use-tex-guess-main-file-flag nil "Non-nil means don't use tex-guessmain-file to find the coding system.") +(defvar tex-start-of-header) + ;;;###autoload (defun latexenc-find-file-coding-system (arg-list) "Determine the coding system of a LaTeX file if it uses \"inputenc.sty\". diff --git a/lisp/international/latin1-disp.el b/lisp/international/latin1-disp.el index bda2c51ab9d..4b6ef9833e5 100644 --- a/lisp/international/latin1-disp.el +++ b/lisp/international/latin1-disp.el @@ -1,4 +1,4 @@ -;;; latin1-disp.el --- display tables for other ISO 8859 on Latin-1 terminals -*-coding: utf-8;-*- +;;; latin1-disp.el --- display tables for other ISO 8859 on Latin-1 terminals -*- lexical-binding: t; -*- ;; Copyright (C) 2000-2021 Free Software Foundation, Inc. @@ -86,8 +86,8 @@ use either \\[customize] or the function `latin1-display'." :group 'latin1-display :type 'boolean :require 'latin1-disp - :initialize 'custom-initialize-default - :set (lambda (symbol value) + :initialize #'custom-initialize-default + :set (lambda (_symbol value) (if value (apply #'latin1-display latin1-display-sets) (latin1-display)))) @@ -186,7 +186,7 @@ character set." 'arabic-iso8859-6 (car (remq 'ascii (get-language-info language 'charset)))))) - (map-charset-chars #'(lambda (range arg) + (map-charset-chars #'(lambda (range _arg) (standard-display-default (car range) (cdr range))) charset)) (sit-for 0)) @@ -201,11 +201,10 @@ character set: `latin-2', `hebrew' etc." (char (and info (decode-char (car (remq 'ascii info)) ?\ )))) (and char (char-displayable-p char)))) -(defun latin1-display-setup (set &optional force) +(defun latin1-display-setup (set &optional _force) "Set up Latin-1 display for characters in the given SET. SET must be a member of `latin1-display-sets'. Normally, check -whether a font for SET is available and don't set the display if it -is. If FORCE is non-nil, set up the display regardless." +whether a font for SET is available and don't set the display if it is." (cond ((eq set 'latin-2) (latin1-display-identities set) @@ -735,7 +734,7 @@ is. If FORCE is non-nil, set up the display regardless." (sit-for 0)) ;;;###autoload -(defcustom latin1-display-ucs-per-lynx nil +(defcustom latin1-display-ucs-per-lynx nil ;FIXME: Isn't this a minor mode? "Set up Latin-1/ASCII display for Unicode characters. This uses the transliterations of the Lynx browser. The display isn't changed if the display can render Unicode characters. @@ -745,8 +744,8 @@ use either \\[customize] or the function `latin1-display'." :group 'latin1-display :type 'boolean :require 'latin1-disp - :initialize 'custom-initialize-default - :set (lambda (symbol value) + :initialize #'custom-initialize-default + :set (lambda (_symbol value) (if value (latin1-display-ucs-per-lynx 1) (latin1-display-ucs-per-lynx -1)))) diff --git a/lisp/international/mule-diag.el b/lisp/international/mule-diag.el index d6222685251..d97d090cd08 100644 --- a/lisp/international/mule-diag.el +++ b/lisp/international/mule-diag.el @@ -1,4 +1,4 @@ -;;; mule-diag.el --- show diagnosis of multilingual environment (Mule) +;;; mule-diag.el --- show diagnosis of multilingual environment (Mule) -*- lexical-binding: t; -*- ;; Copyright (C) 1997-1998, 2000-2021 Free Software Foundation, Inc. ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, @@ -86,8 +86,7 @@ but still shows the full information." (indent-to 48) (insert "| +--CHARS\n") (let ((columns '(("CHARSET-NAME" . name) "\t\t\t\t\t" - ("D CH FINAL-BYTE" . iso-spec))) - pos) + ("D CH FINAL-BYTE" . iso-spec)))) (while columns (if (stringp (car columns)) (insert (car columns)) @@ -117,8 +116,8 @@ but still shows the full information." SORT-KEY should be `name' or `iso-spec' (default `name')." (or sort-key (setq sort-key 'name)) - (let ((tail charset-list) - charset-info-list supplementary-list charset sort-func) + (let (;; (tail charset-list) + charset-info-list supplementary-list sort-func) (dolist (charset charset-list) ;; Generate a list that contains all information to display. (let ((elt (list charset @@ -273,9 +272,9 @@ meanings of these arguments." (setq tab-width 4) (set-buffer-multibyte t) (let ((dim (charset-dimension charset)) - (chars (charset-chars charset)) - ;; (plane (charset-iso-graphic-plane charset)) - (plane 1) + ;; (chars (charset-chars charset)) + ;; (plane (charset-iso-graphic-plane charset)) + ;; (plane 1) (range (plist-get (charset-plist charset) :code-space)) min max min2 max2) (if (> dim 2) @@ -415,7 +414,8 @@ or provided just for backward compatibility." nil))) (print-coding-system-briefly coding-system 'doc-string) (let ((type (coding-system-type coding-system)) ;; Fixme: use this - (extra-spec (coding-system-plist coding-system))) + ;; (extra-spec (coding-system-plist coding-system)) + ) (princ "Type: ") (princ type) (cond ((eq type 'undecided) @@ -858,6 +858,8 @@ The IGNORED argument is ignored." (with-output-to-temp-buffer "*Help*" (describe-font-internal font-info))))) +(defvar mule--print-opened) + (defun print-fontset-element (val) ;; VAL has this format: ;; ((REQUESTED-FONT-NAME OPENED-FONT-NAME ...) ...) @@ -915,7 +917,7 @@ The IGNORED argument is ignored." (or adstyle "*") registry))))) ;; Insert opened font names (if any). - (if (and (boundp 'print-opened) (symbol-value 'print-opened)) + (if (bound-and-true-p mule--print-opened) (dolist (opened (cdr elt)) (insert "\n\t[" opened "]"))))))) @@ -943,8 +945,9 @@ the current buffer." " and [" (propertize "OPENED" 'face 'underline) "])") (let* ((info (fontset-info fontset)) (default-info (char-table-extra-slot info 0)) + (mule--print-opened print-opened) start1 end1 start2 end2) - (describe-vector info 'print-fontset-element) + (describe-vector info #'print-fontset-element) (when (char-table-range info nil) ;; The default of FONTSET is described. (setq start1 (re-search-backward "^default")) @@ -956,7 +959,7 @@ the current buffer." (when default-info (insert "\n ------") (put-text-property (line-beginning-position) (point) 'face 'highlight) - (describe-vector default-info 'print-fontset-element) + (describe-vector default-info #'print-fontset-element) (when (char-table-range default-info nil) ;; The default of the default fontset is described. (setq end2 (re-search-backward "^default")) diff --git a/lisp/international/ogonek.el b/lisp/international/ogonek.el index 79e446875da..e049832d58b 100644 --- a/lisp/international/ogonek.el +++ b/lisp/international/ogonek.el @@ -1,4 +1,4 @@ -;;; ogonek.el --- change the encoding of Polish diacritics +;;; ogonek.el --- change the encoding of Polish diacritics -*- lexical-binding: t; -*- ;; Copyright (C) 1997-1998, 2001-2021 Free Software Foundation, Inc. diff --git a/lisp/international/quail.el b/lisp/international/quail.el index f2ac44a8a60..9698d461535 100644 --- a/lisp/international/quail.el +++ b/lisp/international/quail.el @@ -1,4 +1,4 @@ -;;; quail.el --- provides simple input method for multilingual text +;;; quail.el --- provides simple input method for multilingual text -*- lexical-binding: t; -*- ;; Copyright (C) 1997-1998, 2000-2021 Free Software Foundation, Inc. ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, @@ -1046,7 +1046,7 @@ the following annotation types are supported. (quail-install-decode-map ',decode-map)))))) ;;;###autoload -(defun quail-install-map (map &optional name) +(defun quail-install-map (map &optional _name) "Install the Quail map MAP in the current Quail package. Optional 2nd arg NAME, if non-nil, is a name of Quail package for @@ -1060,7 +1060,7 @@ The installed map can be referred by the function `quail-map'." (setcar (cdr (cdr quail-current-package)) map)) ;;;###autoload -(defun quail-install-decode-map (decode-map &optional name) +(defun quail-install-decode-map (decode-map &optional _name) "Install the Quail decode map DECODE-MAP in the current Quail package. Optional 2nd arg NAME, if non-nil, is a name of Quail package for @@ -1390,7 +1390,7 @@ Return the input string." (let* ((echo-keystrokes 0) (help-char nil) (overriding-terminal-local-map (quail-translation-keymap)) - (generated-events nil) ;FIXME: What is this? + ;; (generated-events nil) ;FIXME: What is this? (input-method-function nil) (modified-p (buffer-modified-p)) last-command-event last-command this-command inhibit-record) @@ -1455,7 +1455,7 @@ Return the input string." (let* ((echo-keystrokes 0) (help-char nil) (overriding-terminal-local-map (quail-conversion-keymap)) - (generated-events nil) ;FIXME: What is this? + ;; (generated-events nil) ;FIXME: What is this? (input-method-function nil) (modified-p (buffer-modified-p)) last-command-event last-command this-command inhibit-record) @@ -2452,7 +2452,7 @@ should be made by `quail-build-decode-map' (which see)." (insert-char ?- single-trans-width) (forward-line 1) ;; Insert the key-tran pairs. - (dotimes (row rows) + (dotimes (_ rows) (let ((elt (pop single-list))) (when elt (move-to-column col) @@ -2625,12 +2625,14 @@ KEY BINDINGS FOR CONVERSION (run-hooks 'temp-buffer-show-hook))))) (defun quail-help-insert-keymap-description (keymap &optional header) + (defvar the-keymap) (let ((pos1 (point)) + (the-keymap keymap) pos2) (if header (insert header)) (save-excursion - (insert (substitute-command-keys "\\{keymap}"))) + (insert (substitute-command-keys "\\{the-keymap}"))) ;; Skip headers "key bindings", etc. (forward-line 3) (setq pos2 (point)) diff --git a/lisp/international/robin.el b/lisp/international/robin.el index 16cac07c773..55390df315f 100644 --- a/lisp/international/robin.el +++ b/lisp/international/robin.el @@ -1,4 +1,4 @@ -;;; robin.el --- yet another input method (smaller than quail) +;;; robin.el --- yet another input method (smaller than quail) -*- lexical-binding: t; -*- ;; Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 ;; National Institute of Advanced Industrial Science and Technology (AIST) diff --git a/lisp/international/utf-7.el b/lisp/international/utf-7.el index e941abb463e..dece184ffef 100644 --- a/lisp/international/utf-7.el +++ b/lisp/international/utf-7.el @@ -1,4 +1,4 @@ -;;; utf-7.el --- utf-7 coding system +;;; utf-7.el --- utf-7 coding system -*- lexical-binding: t; -*- ;; Copyright (C) 2003-2021 Free Software Foundation, Inc. diff --git a/lisp/startup.el b/lisp/startup.el index 7011fbf4583..60e1a200bbd 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -320,6 +320,8 @@ early init file.") This variable is used to define the proper function and keypad keys for use under X. It is used in a fashion analogous to the environment variable TERM.") +(make-obsolete-variable 'keyboard-type nil "28.1") +(internal-make-var-non-special 'keyboard-type) (defvar window-setup-hook nil "Normal hook run after loading init files and handling the command line. -- cgit v1.2.3 From ff7b1a133bfa7f2614650f8551824ffaef13fadc Mon Sep 17 00:00:00 2001 From: Alexander Miller Date: Tue, 26 Jan 2021 10:36:52 +0100 Subject: Add distinct controls for child frames' borders (Bug#45620) The background of the 'child-frame-border' face instead of the 'internal-border' face now controls the color of child frames' borders. The 'child-frame-border-width' frame parameter is now used for the width of child frames' borders instead of internal-border-width', though we still fall back on using the latter if the former is not set. * doc/lispref/frames.texi (Frame Layout): Mention 'child-frame-border' and 'child-frame-border-width'. (Layout Parameters): Mention 'child-frame-border-width'. * etc/NEWS: Mention new face 'child-frame-border' and frame parameter 'child-frame-border-width'. * lisp/faces.el (child-frame-border): New face. * src/dispextern.h (enum face_id): Add CHILD_FRAME_BORDER_FACE_ID. * src/frame.c (Fframe_child_frame_border_width): New function. (gui_report_frame_params): Add entry for Qchild_frame_border_width. * src/frame.h (struct frame): New slot child_frame_border_width. (FRAME_CHILD_FRAME_BORDER_WIDTH): New inlined function. * src/nsfns.m (ns_set_child_frame_border_width): New function. (Fx_create_frame): Handle Qchild_frame_border_width parameter. (ns_frame_parm_handlers): Add ns_set_child_frame_border_width. * src/nsterm.m (ns_clear_under_internal_border): Handle CHILD_FRAME_BORDER_FACE_ID. * src/w32fns.c (w32_clear_under_internal_border): Handle CHILD_FRAME_BORDER_FACE_ID. (w32_set_internal_border_width): New function. (Fx_create_frame): Handle Qchild_frame_border_width parameter. (w32_frame_parm_handlers): Add w32_set_child_frame_border_width. * src/xfaces.c (lookup_basic_face, realize_basic_faces): Handle CHILD_FRAME_BORDER_FACE_ID. * src/xfns.c (x_set_child_frame_border_width): New function. (Fx_create_frame): Handle Qchild_frame_border_width parameter. (x_frame_parm_handlers): Add x_set_child_frame_border_width. * src/xterm.c (x_clear_under_internal_border) (x_after_update_window_line): Handle CHILD_FRAME_BORDER_FACE_ID. --- doc/lispref/frames.texi | 19 +++++++++++++--- etc/NEWS | 8 +++++++ lisp/faces.el | 11 ++++++++- src/dispextern.h | 1 + src/frame.c | 12 ++++++++++ src/frame.h | 24 ++++++++++++++++++-- src/nsfns.m | 19 ++++++++++++++++ src/nsterm.m | 10 ++++++--- src/w32fns.c | 59 ++++++++++++++++++++++++++++++++++++++++++++++--- src/xfaces.c | 3 +++ src/xfns.c | 46 ++++++++++++++++++++++++++++++++++++++ src/xterm.c | 20 ++++++++++++----- 12 files changed, 214 insertions(+), 18 deletions(-) (limited to 'lisp') diff --git a/doc/lispref/frames.texi b/doc/lispref/frames.texi index 7f2a6f75422..ef1b661b2a0 100644 --- a/doc/lispref/frames.texi +++ b/doc/lispref/frames.texi @@ -694,9 +694,17 @@ parameter (@pxref{Management Parameters}). @item Internal Border The internal border is a border drawn by Emacs around the inner frame -(see below). Its width is specified by the @code{internal-border-width} -frame parameter (@pxref{Layout Parameters}). Its color is specified by -the background of the @code{internal-border} face. +(see below). The specification of its appearance depends on whether +the given frame is a child frame (@pxref{Child Frames}) or not. + +For normal frames its width is specified by the @code{internal-border-width} +frame parameter (@pxref{Layout Parameters}) and its color is specified by the +background of the @code{internal-border} face. + +For child frames its width is specified by the @code{child-frame-border-width} +frame parameter (but will use the the @code{internal-border-width} parameter as +a fallback) and its color is specified by the background of the +@code{child-frame-border} face. @item Inner Frame @cindex inner frame @@ -1790,6 +1798,11 @@ The width in pixels of the frame's outer border (@pxref{Frame Geometry}). The width in pixels of the frame's internal border (@pxref{Frame Geometry}). +@vindex child-frame-border-width@r{, a frame parameter} +@item child-frame-border-width +The width in pixels of the frame's internal border (@pxref{Frame +Geometry}) if the given frame is a child frame (@pxref{Child Frames}). + @vindex vertical-scroll-bars@r{, a frame parameter} @item vertical-scroll-bars Whether the frame has scroll bars (@pxref{Scroll Bars}) for vertical diff --git a/etc/NEWS b/etc/NEWS index b815d3ac61b..1d4d6af00e7 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2018,6 +2018,14 @@ hooks 'kill-buffer-hook', 'kill-buffer-query-functions', and 'buffer-list-update-hook' for the temporary buffers they create. This avoids slowing them down when a lot of these hooks are defined. +** New face 'child-frame-border' and frame parameter 'child-frame-border-width'. +The face and width of child frames borders can no be determined +separately from thos of normal frames. To minimize backwards +incompatibility, child frames without a 'child-frame-border-width' +parameter will fall back to using 'internal-border-width'. However the +new 'child-frame-border' face does constitute a breaking change since +child frames' borders no longer use the 'internal-border' face. + --- ** The obsolete function 'thread-alive-p' has been removed. diff --git a/lisp/faces.el b/lisp/faces.el index d654b1f0e2a..90f11bbe3bb 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -2683,11 +2683,20 @@ the same as `window-divider' face." (defface internal-border '((t nil)) - "Basic face for the internal border." + "Basic face for the internal border. +For the internal border of child frames see `child-frame-border'." :version "26.1" :group 'frames :group 'basic-faces) +(defface child-frame-border + '((t nil)) + "Basic face for the internal border of child frames. +For the internal border of non-child frames see `internal-border'." + :version "28.1" + :group 'frames + :group 'basic-faces) + (defface minibuffer-prompt '((((background dark)) :foreground "cyan") ;; Don't use blue because many users of the MS-DOS port customize diff --git a/src/dispextern.h b/src/dispextern.h index 3ad98b8344e..f4e872644db 100644 --- a/src/dispextern.h +++ b/src/dispextern.h @@ -1826,6 +1826,7 @@ enum face_id WINDOW_DIVIDER_FIRST_PIXEL_FACE_ID, WINDOW_DIVIDER_LAST_PIXEL_FACE_ID, INTERNAL_BORDER_FACE_ID, + CHILD_FRAME_BORDER_FACE_ID, TAB_BAR_FACE_ID, TAB_LINE_FACE_ID, BASIC_FACE_ID_SENTINEL diff --git a/src/frame.c b/src/frame.c index 599c4075f88..a2167ce1e49 100644 --- a/src/frame.c +++ b/src/frame.c @@ -3543,6 +3543,13 @@ DEFUN ("frame-fringe-width", Ffringe_width, Sfringe_width, 0, 1, 0, return make_fixnum (FRAME_TOTAL_FRINGE_WIDTH (decode_any_frame (frame))); } +DEFUN ("frame-child-frame-border-width", Fframe_child_frame_border_width, Sframe_child_frame_border_width, 0, 1, 0, + doc: /* Return width of FRAME's child-frame border in pixels. */) + (Lisp_Object frame) +{ + return make_fixnum (FRAME_CHILD_FRAME_BORDER_WIDTH (decode_any_frame (frame))); +} + DEFUN ("frame-internal-border-width", Fframe_internal_border_width, Sframe_internal_border_width, 0, 1, 0, doc: /* Return width of FRAME's internal border in pixels. */) (Lisp_Object frame) @@ -3759,6 +3766,7 @@ static const struct frame_parm_table frame_parms[] = {"foreground-color", -1}, {"icon-name", SYMBOL_INDEX (Qicon_name)}, {"icon-type", SYMBOL_INDEX (Qicon_type)}, + {"child-frame-border-width", SYMBOL_INDEX (Qchild_frame_border_width)}, {"internal-border-width", SYMBOL_INDEX (Qinternal_border_width)}, {"right-divider-width", SYMBOL_INDEX (Qright_divider_width)}, {"bottom-divider-width", SYMBOL_INDEX (Qbottom_divider_width)}, @@ -4302,6 +4310,8 @@ gui_report_frame_params (struct frame *f, Lisp_Object *alistptr) store_in_alist (alistptr, Qborder_width, make_fixnum (f->border_width)); + store_in_alist (alistptr, Qchild_frame_border_width, + make_fixnum (FRAME_CHILD_FRAME_BORDER_WIDTH (f))); store_in_alist (alistptr, Qinternal_border_width, make_fixnum (FRAME_INTERNAL_BORDER_WIDTH (f))); store_in_alist (alistptr, Qright_divider_width, @@ -5999,6 +6009,7 @@ syms_of_frame (void) DEFSYM (Qhorizontal_scroll_bars, "horizontal-scroll-bars"); DEFSYM (Qicon_name, "icon-name"); DEFSYM (Qicon_type, "icon-type"); + DEFSYM (Qchild_frame_border_width, "child-frame-border-width"); DEFSYM (Qinternal_border_width, "internal-border-width"); DEFSYM (Qleft_fringe, "left-fringe"); DEFSYM (Qline_spacing, "line-spacing"); @@ -6423,6 +6434,7 @@ iconify the top level frame instead. */); defsubr (&Sscroll_bar_width); defsubr (&Sscroll_bar_height); defsubr (&Sfringe_width); + defsubr (&Sframe_child_frame_border_width); defsubr (&Sframe_internal_border_width); defsubr (&Sright_divider_width); defsubr (&Sbottom_divider_width); diff --git a/src/frame.h b/src/frame.h index 8cf41dc0046..7b3bf20a241 100644 --- a/src/frame.h +++ b/src/frame.h @@ -534,6 +534,10 @@ struct frame /* Border width of the frame window as known by the (X) window system. */ int border_width; + /* Width of child frames' internal border. Acts as + internal_border_width for child frames. */ + int child_frame_border_width; + /* Width of the internal border. This is a line of background color just inside the window's border. When the frame is selected, a highlighting is displayed inside the internal border. */ @@ -1432,11 +1436,27 @@ FRAME_TOTAL_FRINGE_WIDTH (struct frame *f) return FRAME_LEFT_FRINGE_WIDTH (f) + FRAME_RIGHT_FRINGE_WIDTH (f); } -/* Pixel-width of internal border lines. */ +INLINE int +FRAME_CHILD_FRAME_BORDER_WIDTH (struct frame *f) +{ + return frame_dimension (f->child_frame_border_width); +} + +/* Pixel-width of internal border. Uses child_frame_border_width for + child frames if possible and falls back on internal_border_width + otherwise. */ INLINE int FRAME_INTERNAL_BORDER_WIDTH (struct frame *f) { - return frame_dimension (f->internal_border_width); +#ifdef HAVE_WINDOW_SYSTEM + return FRAME_PARENT_FRAME(f) + ? (f->child_frame_border_width + ? FRAME_CHILD_FRAME_BORDER_WIDTH(f) + : frame_dimension (f->internal_border_width)) + : frame_dimension (f->internal_border_width); +#else + return frame_dimension (f->internal_border_width) +#endif } /* Pixel-size of window divider lines. */ diff --git a/src/nsfns.m b/src/nsfns.m index 24ea7d7f63b..c383e2f7ecf 100644 --- a/src/nsfns.m +++ b/src/nsfns.m @@ -687,6 +687,21 @@ ns_set_tool_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval) } } +static void +ns_set_child_frame_border_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval) +{ + int old_width = FRAME_CHILD_FRAME_BORDER_WIDTH (f); + int new_width = check_int_nonnegative (arg); + + if (new_width == old_width) + return; + f->child_frame_border_width = new_width; + + if (FRAME_NATIVE_WINDOW (f) != 0) + adjust_frame_size (f, -1, -1, 3, 0, Qchild_frame_border_width); + + SET_FRAME_GARBAGED (f); +} static void ns_set_internal_border_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval) @@ -912,6 +927,7 @@ frame_parm_handler ns_frame_parm_handlers[] = ns_set_foreground_color, ns_set_icon_name, ns_set_icon_type, + ns_set_child_frame_border_width, ns_set_internal_border_width, gui_set_right_divider_width, /* generic OK */ gui_set_bottom_divider_width, /* generic OK */ @@ -1197,6 +1213,9 @@ DEFUN ("x-create-frame", Fx_create_frame, Sx_create_frame, gui_default_parameter (f, parms, Qinternal_border_width, make_fixnum (2), "internalBorderWidth", "InternalBorderWidth", RES_TYPE_NUMBER); + gui_default_parameter (f, parms, Qchild_frame_border_width, make_fixnum (2), + "childFrameBorderWidth", "childFrameBorderWidth", + RES_TYPE_NUMBER); gui_default_parameter (f, parms, Qright_divider_width, make_fixnum (0), NULL, NULL, RES_TYPE_NUMBER); gui_default_parameter (f, parms, Qbottom_divider_width, make_fixnum (0), diff --git a/src/nsterm.m b/src/nsterm.m index df3934c5c34..1b2328628ee 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -3037,9 +3037,13 @@ ns_clear_under_internal_border (struct frame *f) NSRectEdge edge[] = {NSMinXEdge, NSMinYEdge, NSMaxXEdge, NSMaxYEdge}; int face_id = - !NILP (Vface_remapping_alist) - ? lookup_basic_face (NULL, f, INTERNAL_BORDER_FACE_ID) - : INTERNAL_BORDER_FACE_ID; + (FRAME_PARENT_FRAME (f) + ? (!NILP (Vface_remapping_alist) + ? lookup_basic_face (NULL, f, CHILD_FRAME_BORDER_FACE_ID) + : CHILD_FRAME_BORDER_FACE_ID) + : (!NILP (Vface_remapping_alist) + ? lookup_basic_face (NULL, f, INTERNAL_BORDER_FACE_ID) + : INTERNAL_BORDER_FACE_ID)); struct face *face = FACE_FROM_ID_OR_NULL (f, face_id); if (!face) diff --git a/src/w32fns.c b/src/w32fns.c index c1e18ff7fad..29d2e3d75f9 100644 --- a/src/w32fns.c +++ b/src/w32fns.c @@ -1519,9 +1519,13 @@ w32_clear_under_internal_border (struct frame *f) int width = FRAME_PIXEL_WIDTH (f); int height = FRAME_PIXEL_HEIGHT (f); int face_id = - !NILP (Vface_remapping_alist) - ? lookup_basic_face (NULL, f, INTERNAL_BORDER_FACE_ID) - : INTERNAL_BORDER_FACE_ID; + (FRAME_PARENT_FRAME (f) + ? (!NILP (Vface_remapping_alist) + ? lookup_basic_face (NULL, f, CHILD_FRAME_BORDER_FACE_ID) + : CHILD_FRAME_BORDER_FACE_ID) + : (!NILP (Vface_remapping_alist) + ? lookup_basic_face (NULL, f, INTERNAL_BORDER_FACE_ID) + : INTERNAL_BORDER_FACE_ID)); struct face *face = FACE_FROM_ID_OR_NULL (f, face_id); block_input (); @@ -1548,6 +1552,32 @@ w32_clear_under_internal_border (struct frame *f) } } +/** + * w32_set_child_frame_border_width: + * + * Set width of child frame F's internal border to ARG pixels. + * ARG < 0 is * treated like ARG = 0. + */ +static void +w32_set_child_frame_border_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval) +{ + int argval = check_integer_range (arg, INT_MIN, INT_MAX); + int border = max (argval, 0); + + if (border != FRAME_CHILD_FRAME_BORDER_WIDTH (f)) + { + f->child_frame_border_width = border; + + if (FRAME_NATIVE_WINDOW (f) != 0) + { + adjust_frame_size (f, -1, -1, 3, false, Qchild_frame_border_width); + + if (FRAME_VISIBLE_P (f)) + w32_clear_under_internal_border (f); + } + } +} + /** * w32_set_internal_border_width: @@ -5873,6 +5903,28 @@ DEFUN ("x-create-frame", Fx_create_frame, Sx_create_frame, parameters); } + /* Same for child frames. */ + if (NILP (Fassq (Qchild_frame_border_width, parameters))) + { + Lisp_Object value; + + value = gui_display_get_arg (dpyinfo, parameters, Qchild_frame_border_width, + "childFrameBorderWidth", "childFrameBorderWidth", + RES_TYPE_NUMBER); + if (! EQ (value, Qunbound)) + parameters = Fcons (Fcons (Qchild_frame_border_width, value), + parameters); + + } + + gui_default_parameter (f, parameters, Qchild_frame_border_width, +#ifdef USE_GTK /* We used to impose 0 in xg_create_frame_widgets. */ + make_fixnum (0), +#else + make_fixnum (1), +#endif + "childFrameBorderWidth", "childFrameBorderWidth", + RES_TYPE_NUMBER); gui_default_parameter (f, parameters, Qinternal_border_width, make_fixnum (0), "internalBorderWidth", "InternalBorder", RES_TYPE_NUMBER); gui_default_parameter (f, parameters, Qright_divider_width, make_fixnum (0), @@ -10232,6 +10284,7 @@ frame_parm_handler w32_frame_parm_handlers[] = w32_set_foreground_color, w32_set_icon_name, w32_set_icon_type, + w32_set_child_frame_border_width, w32_set_internal_border_width, gui_set_right_divider_width, gui_set_bottom_divider_width, diff --git a/src/xfaces.c b/src/xfaces.c index 258b365eda3..12087138e51 100644 --- a/src/xfaces.c +++ b/src/xfaces.c @@ -4914,6 +4914,7 @@ lookup_basic_face (struct window *w, struct frame *f, int face_id) case WINDOW_DIVIDER_FIRST_PIXEL_FACE_ID: name = Qwindow_divider_first_pixel; break; case WINDOW_DIVIDER_LAST_PIXEL_FACE_ID: name = Qwindow_divider_last_pixel; break; case INTERNAL_BORDER_FACE_ID: name = Qinternal_border; break; + case CHILD_FRAME_BORDER_FACE_ID: name = Qchild_frame_border; break; default: emacs_abort (); /* the caller is supposed to pass us a basic face id */ @@ -5620,6 +5621,7 @@ realize_basic_faces (struct frame *f) realize_named_face (f, Qwindow_divider_last_pixel, WINDOW_DIVIDER_LAST_PIXEL_FACE_ID); realize_named_face (f, Qinternal_border, INTERNAL_BORDER_FACE_ID); + realize_named_face (f, Qchild_frame_border, CHILD_FRAME_BORDER_FACE_ID); realize_named_face (f, Qtab_bar, TAB_BAR_FACE_ID); realize_named_face (f, Qtab_line, TAB_LINE_FACE_ID); @@ -6973,6 +6975,7 @@ syms_of_xfaces (void) DEFSYM (Qwindow_divider_first_pixel, "window-divider-first-pixel"); DEFSYM (Qwindow_divider_last_pixel, "window-divider-last-pixel"); DEFSYM (Qinternal_border, "internal-border"); + DEFSYM (Qchild_frame_border, "child-frame-border"); /* TTY color-related functions (defined in tty-colors.el). */ DEFSYM (Qtty_color_desc, "tty-color-desc"); diff --git a/src/xfns.c b/src/xfns.c index 9ab537ca8d9..cac41ee4856 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -1800,6 +1800,28 @@ x_change_tool_bar_height (struct frame *f, int height) #endif /* USE_GTK */ } +static void +x_set_child_frame_border_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval) +{ + int border = check_int_nonnegative (arg); + + if (border != FRAME_CHILD_FRAME_BORDER_WIDTH (f)) + { + f->child_frame_border_width = border; + +#ifdef USE_X_TOOLKIT + if (FRAME_X_OUTPUT (f)->edit_widget) + widget_store_internal_border (FRAME_X_OUTPUT (f)->edit_widget); +#endif + + if (FRAME_X_WINDOW (f)) + { + adjust_frame_size (f, -1, -1, 3, false, Qchild_frame_border_width); + x_clear_under_internal_border (f); + } + } + +} static void x_set_internal_border_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval) @@ -3897,6 +3919,29 @@ This function is an internal primitive--use `make-frame' instead. */) parms = Fcons (Fcons (Qinternal_border_width, value), parms); } + + /* Same for child frames. */ + if (NILP (Fassq (Qchild_frame_border_width, parms))) + { + Lisp_Object value; + + value = gui_display_get_arg (dpyinfo, parms, Qchild_frame_border_width, + "childFrameBorderWidth", "childFrameBorderWidth", + RES_TYPE_NUMBER); + if (! EQ (value, Qunbound)) + parms = Fcons (Fcons (Qchild_frame_border_width, value), + parms); + + } + + gui_default_parameter (f, parms, Qchild_frame_border_width, +#ifdef USE_GTK /* We used to impose 0 in xg_create_frame_widgets. */ + make_fixnum (0), +#else + make_fixnum (1), +#endif + "childFrameBorderWidth", "childFrameBorderWidth", + RES_TYPE_NUMBER); gui_default_parameter (f, parms, Qinternal_border_width, #ifdef USE_GTK /* We used to impose 0 in xg_create_frame_widgets. */ make_fixnum (0), @@ -7762,6 +7807,7 @@ frame_parm_handler x_frame_parm_handlers[] = x_set_foreground_color, x_set_icon_name, x_set_icon_type, + x_set_child_frame_border_width, x_set_internal_border_width, gui_set_right_divider_width, gui_set_bottom_divider_width, diff --git a/src/xterm.c b/src/xterm.c index b8374fed8b1..a855d2d67aa 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -1293,9 +1293,13 @@ x_clear_under_internal_border (struct frame *f) int height = FRAME_PIXEL_HEIGHT (f); int margin = FRAME_TOP_MARGIN_HEIGHT (f); int face_id = - !NILP (Vface_remapping_alist) - ? lookup_basic_face (NULL, f, INTERNAL_BORDER_FACE_ID) - : INTERNAL_BORDER_FACE_ID; + (FRAME_PARENT_FRAME (f) + ? (!NILP (Vface_remapping_alist) + ? lookup_basic_face (NULL, f, CHILD_FRAME_BORDER_FACE_ID) + : CHILD_FRAME_BORDER_FACE_ID) + : (!NILP (Vface_remapping_alist) + ? lookup_basic_face (NULL, f, INTERNAL_BORDER_FACE_ID) + : INTERNAL_BORDER_FACE_ID)); struct face *face = FACE_FROM_ID_OR_NULL (f, face_id); block_input (); @@ -1360,9 +1364,13 @@ x_after_update_window_line (struct window *w, struct glyph_row *desired_row) { int y = WINDOW_TO_FRAME_PIXEL_Y (w, max (0, desired_row->y)); int face_id = - !NILP (Vface_remapping_alist) - ? lookup_basic_face (NULL, f, INTERNAL_BORDER_FACE_ID) - : INTERNAL_BORDER_FACE_ID; + (FRAME_PARENT_FRAME (f) + ? (!NILP (Vface_remapping_alist) + ? lookup_basic_face (NULL, f, CHILD_FRAME_BORDER_FACE_ID) + : CHILD_FRAME_BORDER_FACE_ID) + : (!NILP (Vface_remapping_alist) + ? lookup_basic_face (NULL, f, INTERNAL_BORDER_FACE_ID) + : INTERNAL_BORDER_FACE_ID)); struct face *face = FACE_FROM_ID_OR_NULL (f, face_id); block_input (); -- cgit v1.2.3 From 046db04e3da4afa7c6eb05af8c7ceb048689521a Mon Sep 17 00:00:00 2001 From: Eric Abrahamsen Date: Tue, 26 Jan 2021 08:47:07 -0800 Subject: Revert "Allow gnus-retrieve-headers to return headers directly" This reverts commit 20add1cd22f9775a4475148b300cf2a4de4bd54a. This needs more work before it's ready to merge. --- lisp/gnus/gnus-agent.el | 383 +++++++++++++++++++++++++++++++++--------------- lisp/gnus/gnus-async.el | 9 +- lisp/gnus/gnus-cache.el | 126 ++++++++++++---- lisp/gnus/gnus-cloud.el | 16 +- lisp/gnus/gnus-sum.el | 65 +++----- lisp/gnus/gnus.el | 9 +- lisp/gnus/nnvirtual.el | 172 ++++++++++++++++------ lisp/obsolete/nnir.el | 1 + 8 files changed, 517 insertions(+), 264 deletions(-) (limited to 'lisp') diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el index 686623029ed..56640ea8302 100644 --- a/lisp/gnus/gnus-agent.el +++ b/lisp/gnus/gnus-agent.el @@ -1789,7 +1789,6 @@ variables. Returns the first non-nil value found." . gnus-agent-enable-expiration) (agent-predicate . gnus-agent-predicate))))))) -;; FIXME: This looks an awful lot like `gnus-agent-retrieve-headers'. (defun gnus-agent-fetch-headers (group) "Fetch interesting headers into the agent. The group's overview file will be updated to include the headers while a list of available @@ -1811,9 +1810,10 @@ article numbers will be returned." (cdr active)))) (gnus-uncompress-range (gnus-active group))) (gnus-list-of-unread-articles group))) + (gnus-decode-encoded-word-function 'identity) + (gnus-decode-encoded-address-function 'identity) (file (gnus-agent-article-name ".overview" group)) - (file-name-coding-system nnmail-pathname-coding-system) - headers fetched-headers) + (file-name-coding-system nnmail-pathname-coding-system)) (unless fetch-all ;; Add articles with marks to the list of article headers we want to @@ -1824,7 +1824,7 @@ article numbers will be returned." (dolist (arts (gnus-info-marks (gnus-get-info group))) (unless (memq (car arts) '(seen recent killed cache)) (setq articles (gnus-range-add articles (cdr arts))))) - (setq articles (sort (gnus-uncompress-range articles) '<))) + (setq articles (sort (gnus-uncompress-sequence articles) '<))) ;; At this point, I have the list of articles to consider for ;; fetching. This is the list that I'll return to my caller. Some @@ -1867,52 +1867,38 @@ article numbers will be returned." 10 "gnus-agent-fetch-headers: undownloaded articles are `%s'" (gnus-compress-sequence articles t))) - ;; Parse known headers from FILE. - (if (file-exists-p file) - (with-current-buffer gnus-agent-overview-buffer - (erase-buffer) - (let ((nnheader-file-coding-system - gnus-agent-file-coding-system)) - (nnheader-insert-nov-file file (car articles)) - (with-current-buffer nntp-server-buffer - (erase-buffer) - (insert-buffer-substring gnus-agent-overview-buffer) - (setq headers - (gnus-get-newsgroup-headers-xover - articles nil (buffer-local-value - 'gnus-newsgroup-dependencies - gnus-summary-buffer) - gnus-newsgroup-name))))) - (gnus-make-directory (nnheader-translate-file-chars - (file-name-directory file) t))) - - ;; Fetch our new headers. - (gnus-message 8 "Fetching headers for %s..." group) - (if articles - (setq fetched-headers (gnus-fetch-headers articles))) - - ;; Merge two sets of headers. - (setq headers - (if (and headers fetched-headers) - (delete-dups - (sort (append headers (copy-sequence fetched-headers)) - (lambda (l r) - (< (mail-header-number l) - (mail-header-number r))))) - (or headers fetched-headers))) - - ;; Save the new set of headers to FILE. - (let ((coding-system-for-write - gnus-agent-file-coding-system)) - (with-current-buffer gnus-agent-overview-buffer - (goto-char (point-max)) - (mapc #'nnheader-insert-nov fetched-headers) - (sort-numeric-fields 1 (point-min) (point-max)) - (gnus-agent-check-overview-buffer) - (write-region (point-min) (point-max) file nil 'silent)) - (gnus-agent-update-view-total-fetched-for group t) - (gnus-agent-save-alist group articles nil))) - headers)) + (with-current-buffer nntp-server-buffer + (if articles + (progn + (gnus-message 8 "Fetching headers for %s..." group) + + ;; Fetch them. + (gnus-make-directory (nnheader-translate-file-chars + (file-name-directory file) t)) + + (unless (eq 'nov (gnus-retrieve-headers articles group)) + (nnvirtual-convert-headers)) + (gnus-agent-check-overview-buffer) + ;; Move these headers to the overview buffer so that + ;; gnus-agent-braid-nov can merge them with the contents + ;; of FILE. + (copy-to-buffer + gnus-agent-overview-buffer (point-min) (point-max)) + ;; NOTE: Call g-a-brand-nov even when the file does not + ;; exist. As a minimum, it will validate the article + ;; numbers already in the buffer. + (gnus-agent-braid-nov articles file) + (let ((coding-system-for-write + gnus-agent-file-coding-system)) + (gnus-agent-check-overview-buffer) + (write-region (point-min) (point-max) file nil 'silent)) + (gnus-agent-update-view-total-fetched-for group t) + (gnus-agent-save-alist group articles nil) + articles) + (ignore-errors + (erase-buffer) + (nnheader-insert-file-contents file))))) + articles)) (defsubst gnus-agent-read-article-number () "Read the article number at point. @@ -1938,6 +1924,96 @@ Return nil when a valid article number can not be read." (set-buffer nntp-server-buffer) (insert-buffer-substring gnus-agent-overview-buffer b e)))) +(defun gnus-agent-braid-nov (articles file) + "Merge agent overview data with given file. +Takes unvalidated headers for ARTICLES from +`gnus-agent-overview-buffer' and validated headers from the given +FILE and places the combined valid headers into +`nntp-server-buffer'. This function can be used, when file +doesn't exist, to valid the overview buffer." + (let (start last) + (set-buffer gnus-agent-overview-buffer) + (goto-char (point-min)) + (set-buffer nntp-server-buffer) + (erase-buffer) + (when (file-exists-p file) + (nnheader-insert-file-contents file)) + (goto-char (point-max)) + (forward-line -1) + + (unless (or (= (point-min) (point-max)) + (< (setq last (read (current-buffer))) (car articles))) + ;; Old and new overlap -- We do it the hard way. + (when (nnheader-find-nov-line (car articles)) + ;; Replacing existing NOV entry + (delete-region (point) (progn (forward-line 1) (point)))) + (gnus-agent-copy-nov-line (pop articles)) + + (ignore-errors + (while articles + (while (let ((art (read (current-buffer)))) + (cond ((< art (car articles)) + (forward-line 1) + t) + ((= art (car articles)) + (beginning-of-line) + (delete-region + (point) (progn (forward-line 1) (point))) + nil) + (t + (beginning-of-line) + nil)))) + + (gnus-agent-copy-nov-line (pop articles))))) + + (goto-char (point-max)) + + ;; Append the remaining lines + (when articles + (when last + (set-buffer gnus-agent-overview-buffer) + (setq start (point)) + (set-buffer nntp-server-buffer)) + + (let ((p (point))) + (insert-buffer-substring gnus-agent-overview-buffer start) + (goto-char p)) + + (setq last (or last -134217728)) + (while (catch 'problems + (let (sort art) + (while (not (eobp)) + (setq art (gnus-agent-read-article-number)) + (cond ((not art) + ;; Bad art num - delete this line + (beginning-of-line) + (delete-region (point) (progn (forward-line 1) (point)))) + ((< art last) + ;; Art num out of order - enable sort + (setq sort t) + (forward-line 1)) + ((= art last) + ;; Bad repeat of art number - delete this line + (beginning-of-line) + (delete-region (point) (progn (forward-line 1) (point)))) + (t + ;; Good art num + (setq last art) + (forward-line 1)))) + (when sort + ;; something is seriously wrong as we simply shouldn't see out-of-order data. + ;; First, we'll fix the sort. + (sort-numeric-fields 1 (point-min) (point-max)) + + ;; but now we have to consider that we may have duplicate rows... + ;; so reset to beginning of file + (goto-char (point-min)) + (setq last -134217728) + + ;; and throw a code that restarts this scan + (throw 'problems t)) + nil)))))) + ;; Keeps the compiler from warning about the free variable in ;; gnus-agent-read-agentview. (defvar gnus-agent-read-agentview) @@ -2310,9 +2386,10 @@ modified) original contents, they are first saved to their own file." (gnus-orphan-score gnus-orphan-score) ;; Maybe some other gnus-summary local variables should also ;; be put here. - fetched-headers + gnus-headers gnus-score + articles predicate info marks ) (unless (gnus-check-group group) @@ -2333,35 +2410,38 @@ modified) original contents, they are first saved to their own file." (setq info (gnus-get-info group))))))) (when arts (setq marked-articles (nconc (gnus-uncompress-range arts) - marked-articles)))))) + marked-articles)) + )))) (setq marked-articles (sort marked-articles '<)) - (setq gnus-newsgroup-dependencies - (or gnus-newsgroup-dependencies - (gnus-make-hashtable))) + ;; Fetch any new articles from the server + (setq articles (gnus-agent-fetch-headers group)) - ;; Fetch headers for any new articles from the server. - (setq fetched-headers (gnus-agent-fetch-headers group)) + ;; Merge new articles with marked + (setq articles (sort (append marked-articles articles) '<)) - (when fetched-headers + (when articles + ;; Parse them and see which articles we want to fetch. + (setq gnus-newsgroup-dependencies + (or gnus-newsgroup-dependencies + (gnus-make-hashtable (length articles)))) (setq gnus-newsgroup-headers - (or gnus-newsgroup-headers - fetched-headers))) - (when marked-articles - ;; `gnus-agent-overview-buffer' may be killed for timeout - ;; reason. If so, recreate it. + (or gnus-newsgroup-headers + (gnus-get-newsgroup-headers-xover articles nil nil + group))) + ;; `gnus-agent-overview-buffer' may be killed for + ;; timeout reason. If so, recreate it. (gnus-agent-create-buffer) (setq predicate - (gnus-get-predicate - (gnus-agent-find-parameter group 'agent-predicate))) - - ;; If the selection predicate requires scoring, score each header. + (gnus-get-predicate + (gnus-agent-find-parameter group 'agent-predicate))) + ;; If the selection predicate requires scoring, score each header (unless (memq predicate '(gnus-agent-true gnus-agent-false)) (let ((score-param (gnus-agent-find-parameter group 'agent-score-file))) - ;; Translate score-param into real one. + ;; Translate score-param into real one (cond ((not score-param)) ((eq score-param 'file) @@ -3581,9 +3661,11 @@ has been fetched." (defun gnus-agent-retrieve-headers (articles group &optional fetch-old) (save-excursion (gnus-agent-create-buffer) - (let ((file (gnus-agent-article-name ".overview" group)) - (file-name-coding-system nnmail-pathname-coding-system) - uncached-articles headers fetched-headers) + (let ((gnus-decode-encoded-word-function 'identity) + (gnus-decode-encoded-address-function 'identity) + (file (gnus-agent-article-name ".overview" group)) + uncached-articles + (file-name-coding-system nnmail-pathname-coding-system)) (gnus-make-directory (nnheader-translate-file-chars (file-name-directory file) t)) @@ -3594,63 +3676,122 @@ has been fetched." 1) (car (last articles)))))) - ;; See if we've got cached headers for ARTICLES and put them in - ;; HEADERS. Articles with no cached headers go in - ;; UNCACHED-ARTICLES to be fetched from the server. + ;; Populate temp buffer with known headers (when (file-exists-p file) (with-current-buffer gnus-agent-overview-buffer (erase-buffer) (let ((nnheader-file-coding-system gnus-agent-file-coding-system)) - (nnheader-insert-nov-file file (car articles)) - (with-current-buffer nntp-server-buffer - (erase-buffer) - (insert-buffer-substring gnus-agent-overview-buffer) - (setq headers - (gnus-get-newsgroup-headers-xover - articles nil (buffer-local-value - 'gnus-newsgroup-dependencies - gnus-summary-buffer) - gnus-newsgroup-name)))))) - - (setq uncached-articles - (gnus-agent-uncached-articles articles group t)) - - (when uncached-articles - (let ((gnus-newsgroup-name group) - gnus-agent) ; Prevent loop. - ;; Fetch additional headers for the uncached articles. - (setq fetched-headers (gnus-fetch-headers uncached-articles)) - ;; Merge headers we got from the overview file with our - ;; newly-fetched headers. - (when fetched-headers - (setq headers - (delete-dups - (sort (append headers (copy-sequence fetched-headers)) - (lambda (l r) - (< (mail-header-number l) - (mail-header-number r)))))) - - ;; Add the new set of known headers to the overview file. + (nnheader-insert-nov-file file (car articles))))) + + (if (setq uncached-articles (gnus-agent-uncached-articles articles group + t)) + (progn + ;; Populate nntp-server-buffer with uncached headers + (set-buffer nntp-server-buffer) + (erase-buffer) + (cond ((not (eq 'nov (let (gnus-agent) ; Turn off agent + (gnus-retrieve-headers + uncached-articles group)))) + (nnvirtual-convert-headers)) + ((eq 'nntp (car gnus-current-select-method)) + ;; The author of gnus-get-newsgroup-headers-xover + ;; reports that the XOVER command is commonly + ;; unreliable. The problem is that recently + ;; posted articles may not be entered into the + ;; NOV database in time to respond to my XOVER + ;; query. + ;; + ;; I'm going to use his assumption that the NOV + ;; database is updated in order of ascending + ;; article ID. Therefore, a response containing + ;; article ID N implies that all articles from 1 + ;; to N-1 are up-to-date. Therefore, missing + ;; articles in that range have expired. + + (set-buffer nntp-server-buffer) + (let* ((fetched-articles (list nil)) + (tail-fetched-articles fetched-articles) + (min (car articles)) + (max (car (last articles)))) + + ;; Get the list of articles that were fetched + (goto-char (point-min)) + (let ((pm (point-max)) + art) + (while (< (point) pm) + (when (setq art (gnus-agent-read-article-number)) + (gnus-agent-append-to-list tail-fetched-articles art)) + (forward-line 1))) + + ;; Clip this list to the headers that will + ;; actually be returned + (setq fetched-articles (gnus-list-range-intersection + (cdr fetched-articles) + (cons min max))) + + ;; Clip the uncached articles list to exclude + ;; IDs after the last FETCHED header. The + ;; excluded IDs may be fetchable using HEAD. + (if (car tail-fetched-articles) + (setq uncached-articles + (gnus-list-range-intersection + uncached-articles + (cons (car uncached-articles) + (car tail-fetched-articles))))) + + ;; Create the list of articles that were + ;; "successfully" fetched. Success, in this + ;; case, means that the ID should not be + ;; fetched again. In the case of an expired + ;; article, the header will not be fetched. + (setq uncached-articles + (gnus-sorted-nunion fetched-articles + uncached-articles)) + ))) + + ;; Erase the temp buffer + (set-buffer gnus-agent-overview-buffer) + (erase-buffer) + + ;; Copy the nntp-server-buffer to the temp buffer + (set-buffer nntp-server-buffer) + (copy-to-buffer gnus-agent-overview-buffer (point-min) (point-max)) + + ;; Merge the temp buffer with the known headers (found on + ;; disk in FILE) into the nntp-server-buffer + (when uncached-articles + (gnus-agent-braid-nov uncached-articles file)) + + ;; Save the new set of known headers to FILE + (set-buffer nntp-server-buffer) (let ((coding-system-for-write gnus-agent-file-coding-system)) - (with-current-buffer gnus-agent-overview-buffer - ;; We stick the new headers in at the end, then - ;; re-sort the whole buffer with - ;; `sort-numeric-fields'. If this turns out to be - ;; slow, we could consider a loop to add the headers - ;; in sorted order to begin with. - (goto-char (point-max)) - (mapc #'nnheader-insert-nov fetched-headers) - (sort-numeric-fields 1 (point-min) (point-max)) - (gnus-agent-check-overview-buffer) - (write-region (point-min) (point-max) file nil 'silent) - (gnus-agent-update-view-total-fetched-for group t) - ;; Update the group's article alist to include the - ;; newly fetched articles. - (gnus-agent-load-alist group) - (gnus-agent-save-alist group uncached-articles nil)))))) - headers))) + (gnus-agent-check-overview-buffer) + (write-region (point-min) (point-max) file nil 'silent)) + + (gnus-agent-update-view-total-fetched-for group t) + + ;; Update the group's article alist to include the newly + ;; fetched articles. + (gnus-agent-load-alist group) + (gnus-agent-save-alist group uncached-articles nil) + ) + + ;; Copy the temp buffer to the nntp-server-buffer + (set-buffer nntp-server-buffer) + (erase-buffer) + (insert-buffer-substring gnus-agent-overview-buffer))) + + (if (and fetch-old + (not (numberp fetch-old))) + t ; Don't remove anything. + (nnheader-nov-delete-outside-range + (car articles) + (car (last articles))) + t) + + 'nov)) (defun gnus-agent-request-article (article group) "Retrieve ARTICLE in GROUP from the agent cache." diff --git a/lisp/gnus/gnus-async.el b/lisp/gnus/gnus-async.el index ed948a26c0b..fefd02c7bfb 100644 --- a/lisp/gnus/gnus-async.el +++ b/lisp/gnus/gnus-async.el @@ -357,13 +357,8 @@ that was fetched." (let ((nntp-server-buffer (current-buffer)) (nnheader-callback-function (lambda (_arg) - (setq gnus-async-header-prefetched - (cons group unread))))) - ;; FIXME: If header prefetch is ever put into use, we'll - ;; have to handle the possibility that - ;; `gnus-retrieve-headers' might return a list of header - ;; vectors directly, rather than writing them into the - ;; current buffer. + (setq gnus-async-header-prefetched + (cons group unread))))) (gnus-retrieve-headers unread group gnus-fetch-old-headers)))))) (defun gnus-async-retrieve-fetched-headers (articles group) diff --git a/lisp/gnus/gnus-cache.el b/lisp/gnus/gnus-cache.el index 9423d9f2f6b..36657e46219 100644 --- a/lisp/gnus/gnus-cache.el +++ b/lisp/gnus/gnus-cache.el @@ -294,47 +294,49 @@ it's not cached." (defun gnus-cache-retrieve-headers (articles group &optional fetch-old) "Retrieve the headers for ARTICLES in GROUP." (let ((cached - (setq gnus-newsgroup-cached (gnus-cache-articles-in-group group))) - (gnus-newsgroup-name group) - (gnus-fetch-old-headers fetch-old)) + (setq gnus-newsgroup-cached (gnus-cache-articles-in-group group)))) (if (not cached) ;; No cached articles here, so we just retrieve them ;; the normal way. (let ((gnus-use-cache nil)) - (gnus-retrieve-headers articles group)) + (gnus-retrieve-headers articles group fetch-old)) (let ((uncached-articles (gnus-sorted-difference articles cached)) (cache-file (gnus-cache-file-name group ".overview")) - (file-name-coding-system nnmail-pathname-coding-system) - headers) + type + (file-name-coding-system nnmail-pathname-coding-system)) ;; We first retrieve all the headers that we don't have in ;; the cache. (let ((gnus-use-cache nil)) (when uncached-articles - (setq headers (and articles - (gnus-fetch-headers uncached-articles))))) + (setq type (and articles + (gnus-retrieve-headers + uncached-articles group fetch-old))))) (gnus-cache-save-buffers) - ;; Then we include the cached headers. - (when (file-exists-p cache-file) - (setq headers - (delete-dups - (sort - (append headers - (let ((coding-system-for-read - gnus-cache-overview-coding-system)) - (with-current-buffer nntp-server-buffer - (erase-buffer) - (insert-file-contents cache-file) - (gnus-get-newsgroup-headers-xover - (gnus-sorted-difference - cached uncached-articles) - nil (buffer-local-value - 'gnus-newsgroup-dependencies - gnus-summary-buffer) - group)))) - (lambda (l r) - (< (mail-header-number l) - (mail-header-number r))))))) - headers)))) + ;; Then we insert the cached headers. + (save-excursion + (cond + ((not (file-exists-p cache-file)) + ;; There are no cached headers. + type) + ((null type) + ;; There were no uncached headers (or retrieval was + ;; unsuccessful), so we use the cached headers exclusively. + (set-buffer nntp-server-buffer) + (erase-buffer) + (let ((coding-system-for-read + gnus-cache-overview-coding-system)) + (insert-file-contents cache-file)) + 'nov) + ((eq type 'nov) + ;; We have both cached and uncached NOV headers, so we + ;; braid them. + (gnus-cache-braid-nov group cached) + type) + (t + ;; We braid HEADs. + (gnus-cache-braid-heads group (gnus-sorted-intersection + cached articles)) + type))))))) (defun gnus-cache-enter-article (&optional n) "Enter the next N articles into the cache. @@ -527,6 +529,70 @@ Returns the list of articles removed." (setq gnus-cache-active-altered t))) articles))) +(defun gnus-cache-braid-nov (group cached &optional file) + (let ((cache-buf (gnus-get-buffer-create " *gnus-cache*")) + beg end) + (gnus-cache-save-buffers) + (with-current-buffer cache-buf + (erase-buffer) + (let ((coding-system-for-read gnus-cache-overview-coding-system) + (file-name-coding-system nnmail-pathname-coding-system)) + (insert-file-contents + (or file (gnus-cache-file-name group ".overview")))) + (goto-char (point-min)) + (insert "\n") + (goto-char (point-min))) + (set-buffer nntp-server-buffer) + (goto-char (point-min)) + (while cached + (while (and (not (eobp)) + (< (read (current-buffer)) (car cached))) + (forward-line 1)) + (beginning-of-line) + (set-buffer cache-buf) + (if (search-forward (concat "\n" (int-to-string (car cached)) "\t") + nil t) + (setq beg (point-at-bol) + end (progn (end-of-line) (point))) + (setq beg nil)) + (set-buffer nntp-server-buffer) + (when beg + (insert-buffer-substring cache-buf beg end) + (insert "\n")) + (setq cached (cdr cached))) + (kill-buffer cache-buf))) + +(defun gnus-cache-braid-heads (group cached) + (let ((cache-buf (gnus-get-buffer-create " *gnus-cache*"))) + (with-current-buffer cache-buf + (erase-buffer)) + (set-buffer nntp-server-buffer) + (goto-char (point-min)) + (dolist (entry cached) + (while (and (not (eobp)) + (looking-at "2.. +\\([0-9]+\\) ") + (< (progn (goto-char (match-beginning 1)) + (read (current-buffer))) + entry)) + (search-forward "\n.\n" nil 'move)) + (beginning-of-line) + (set-buffer cache-buf) + (erase-buffer) + (let ((coding-system-for-read gnus-cache-coding-system) + (file-name-coding-system nnmail-pathname-coding-system)) + (insert-file-contents (gnus-cache-file-name group entry))) + (goto-char (point-min)) + (insert "220 ") + (princ (pop cached) (current-buffer)) + (insert " Article retrieved.\n") + (search-forward "\n\n" nil 'move) + (delete-region (point) (point-max)) + (forward-char -1) + (insert ".") + (set-buffer nntp-server-buffer) + (insert-buffer-substring cache-buf)) + (kill-buffer cache-buf))) + ;;;###autoload (defun gnus-jog-cache () "Go through all groups and put the articles into the cache. diff --git a/lisp/gnus/gnus-cloud.el b/lisp/gnus/gnus-cloud.el index 00b85f546c2..f7c71f43ce8 100644 --- a/lisp/gnus/gnus-cloud.el +++ b/lisp/gnus/gnus-cloud.el @@ -30,8 +30,6 @@ (require 'parse-time) (require 'nnimap) -(declare-function gnus-fetch-headers "gnus-sum") -(defvar gnus-alter-header-function) (eval-when-compile (require 'epg)) ;; setf-method for `epg-context-armor' (autoload 'epg-make-context "epg") @@ -393,6 +391,8 @@ When FULL is t, upload everything, not just a difference from the last full." (gnus-group-refresh-group group)) (gnus-error 2 "Failed to upload Gnus Cloud data to %s" group))))) +(defvar gnus-alter-header-function) + (defun gnus-cloud-add-timestamps (elems) (dolist (elem elems) (let* ((file-name (plist-get elem :file-name)) @@ -407,10 +407,14 @@ When FULL is t, upload everything, not just a difference from the last full." (gnus-activate-group gnus-cloud-group-name nil nil gnus-cloud-method) (let* ((group (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method)) (active (gnus-active group)) - (gnus-newsgroup-name group) - (headers (gnus-fetch-headers (gnus-uncompress-range active)))) - (when gnus-alter-header-function - (mapc gnus-alter-header-function headers)) + headers head) + (when (gnus-retrieve-headers (gnus-uncompress-range active) group) + (with-current-buffer nntp-server-buffer + (goto-char (point-min)) + (while (setq head (nnheader-parse-head)) + (when gnus-alter-header-function + (funcall gnus-alter-header-function head)) + (push head headers)))) (sort (nreverse headers) (lambda (h1 h2) (> (gnus-cloud-chunk-sequence (mail-header-subject h1)) diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index 5bd58b690af..b0f9ed4c6f0 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -5658,21 +5658,10 @@ or a straight list of headers." (setf (mail-header-subject header) subject)))))) (defun gnus-fetch-headers (articles &optional limit force-new dependencies) - "Fetch headers of ARTICLES. -This calls the `gnus-retrieve-headers' function of the current -group's backend server. The server can do one of two things: - -1. Write the headers for ARTICLES into the - `nntp-server-buffer' (the current buffer) in a parseable format, or -2. Return the headers directly as a list of vectors. - -In the first case, `gnus-retrieve-headers' returns a symbol -value, either `nov' or `headers'. This value determines which -parsing function is used to read the headers. It is also stored -into the variable `gnus-headers-retrieved-by', which is consulted -later when possibly building full threads." + "Fetch headers of ARTICLES." (gnus-message 7 "Fetching headers for %s..." gnus-newsgroup-name) - (let ((res (setq gnus-headers-retrieved-by + (prog1 + (pcase (setq gnus-headers-retrieved-by (gnus-retrieve-headers articles gnus-newsgroup-name (or limit @@ -5682,34 +5671,22 @@ later when possibly building full threads." (not (eq gnus-fetch-old-headers 'some)) (not (numberp gnus-fetch-old-headers))) (> (length articles) 1)) - gnus-fetch-old-headers)))))) - (prog1 - (pcase res - ('nov - (gnus-get-newsgroup-headers-xover - articles force-new dependencies gnus-newsgroup-name t)) - ;; For now, assume that any backend returning its own - ;; headers takes some effort to do so, so return `headers'. - ((pred listp) - (setq gnus-headers-retrieved-by 'headers) - (let ((dependencies - (or dependencies - (buffer-local-value - 'gnus-newsgroup-dependencies gnus-summary-buffer)))) - (when (functionp gnus-alter-header-function) - (mapc gnus-alter-header-function res)) - (mapc (lambda (header) - ;; The agent or the cache may have already - ;; registered this header in the dependency - ;; table. - (unless (gethash (mail-header-id header) dependencies) - (gnus-dependencies-add-header - header dependencies force-new))) - res) - res)) - (_ (gnus-get-newsgroup-headers dependencies force-new))) - (gnus-message 7 "Fetching headers for %s...done" - gnus-newsgroup-name)))) + gnus-fetch-old-headers)))) + ('nov + (gnus-get-newsgroup-headers-xover + articles force-new dependencies gnus-newsgroup-name t)) + ('headers + (gnus-get-newsgroup-headers dependencies force-new)) + ((pred listp) + (let ((dependencies + (or dependencies + (with-current-buffer gnus-summary-buffer + gnus-newsgroup-dependencies)))) + (delq nil (mapcar #'(lambda (header) + (gnus-dependencies-add-header + header dependencies force-new)) + gnus-headers-retrieved-by))))) + (gnus-message 7 "Fetching headers for %s...done" gnus-newsgroup-name))) (defun gnus-select-newsgroup (group &optional read-all select-articles) "Select newsgroup GROUP. @@ -6466,10 +6443,6 @@ The resulting hash table is returned, or nil if no Xrefs were found." (unless (gnus-ephemeral-group-p group) (gnus-group-update-group group t)))))) -;; FIXME: Refactor this with `gnus-get-newsgroup-headers-xover' and -;; extract the necessary bits for the direct-header-return case. Also -;; look at this and see how similar it is to -;; `nnheader-parse-naked-head'. (defun gnus-get-newsgroup-headers (&optional dependencies force-new) (let ((dependencies (or dependencies diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index 2e9ee7189d2..3b172db2111 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -2388,14 +2388,7 @@ Typical marks are those that make no sense in a standalone back end, such as a mark that says whether an article is stored in the cache \(which doesn't make sense in a standalone back end).") -(defvar gnus-headers-retrieved-by nil - "Holds the return value of `gnus-retrieve-headers'. -This is either the symbol `nov' or the symbol `headers'. This -value is checked during the summary creation process, when -building threads. A value of `nov' indicates that header -retrieval is relatively cheap and threading is encouraged to -include more old articles. A value of `headers' indicates that -retrieval is expensive and should be minimized.") +(defvar gnus-headers-retrieved-by nil) (defvar gnus-article-reply nil) (defvar gnus-override-method nil) (defvar gnus-opened-servers nil) diff --git a/lisp/gnus/nnvirtual.el b/lisp/gnus/nnvirtual.el index ba2934351d6..1e2feda6365 100644 --- a/lisp/gnus/nnvirtual.el +++ b/lisp/gnus/nnvirtual.el @@ -101,10 +101,15 @@ It is computed from the marks of individual component groups.") (erase-buffer) (if (stringp (car articles)) 'headers - (let ((carticles (nnvirtual-partition-sequence articles)) + (let ((vbuf (nnheader-set-temp-buffer + (gnus-get-buffer-create " *virtual headers*"))) + (carticles (nnvirtual-partition-sequence articles)) (sysname (system-name)) - cgroup headers all-headers article prefix) - (pcase-dolist (`(,cgroup . ,articles) carticles) + cgroup carticle article result prefix) + (while carticles + (setq cgroup (caar carticles)) + (setq articles (cdar carticles)) + (pop carticles) (when (and articles (gnus-check-server (gnus-find-method-for-group cgroup) t) @@ -114,37 +119,69 @@ It is computed from the marks of individual component groups.") ;; This is probably evil if people have set ;; gnus-use-cache to nil themselves, but I ;; have no way of finding the true value of it. - (let ((gnus-use-cache t) - (gnus-newsgroup-name cgroup) - (gnus-fetch-old-headers nil)) - (setq headers (gnus-fetch-headers articles)))) - (erase-buffer) - ;; Remove all header article numbers from `articles'. - ;; If there's anything left, those are expired or - ;; canceled articles, so we update the component group - ;; below. - (dolist (h headers) - (setq articles (delq (mail-header-number h) articles) - article (nnvirtual-reverse-map-article - cgroup (mail-header-number h))) - ;; Update all the header numbers according to their - ;; reverse mapping, and drop any with no such mapping. - (when article - ;; Do this first, before we re-set the header's - ;; article number. - (nnvirtual-update-xref-header - h cgroup prefix sysname) - (setf (mail-header-number h) article) - (push h all-headers))) - ;; Anything left in articles is expired or canceled. - ;; Could be smart and not tell it about articles already - ;; known? - (when articles - (gnus-group-make-articles-read cgroup articles)))) - - (sort all-headers (lambda (h1 h2) - (< (mail-header-number h1) - (mail-header-number h2))))))))) + (let ((gnus-use-cache t)) + (setq result (gnus-retrieve-headers + articles cgroup nil)))) + (set-buffer nntp-server-buffer) + ;; If we got HEAD headers, we convert them into NOV + ;; headers. This is slow, inefficient and, come to think + ;; of it, downright evil. So sue me. I couldn't be + ;; bothered to write a header parse routine that could + ;; parse a mixed HEAD/NOV buffer. + (when (eq result 'headers) + (nnvirtual-convert-headers)) + (goto-char (point-min)) + (while (not (eobp)) + (delete-region (point) + (progn + (setq carticle (read nntp-server-buffer)) + (point))) + + ;; We remove this article from the articles list, if + ;; anything is left in the articles list after going through + ;; the entire buffer, then those articles have been + ;; expired or canceled, so we appropriately update the + ;; component group below. They should be coming up + ;; generally in order, so this shouldn't be slow. + (setq articles (delq carticle articles)) + + (setq article (nnvirtual-reverse-map-article cgroup carticle)) + (if (null article) + ;; This line has no reverse mapping, that means it + ;; was an extra article reference returned by nntp. + (progn + (beginning-of-line) + (delete-region (point) (progn (forward-line 1) (point)))) + ;; Otherwise insert the virtual article number, + ;; and clean up the xrefs. + (princ article nntp-server-buffer) + (nnvirtual-update-xref-header cgroup carticle + prefix sysname) + (forward-line 1)) + ) + + (set-buffer vbuf) + (goto-char (point-max)) + (insert-buffer-substring nntp-server-buffer)) + ;; Anything left in articles is expired or canceled. + ;; Could be smart and not tell it about articles already known? + (when articles + (gnus-group-make-articles-read cgroup articles)) + ) + + ;; The headers are ready for reading, so they are inserted into + ;; the nntp-server-buffer, which is where Gnus expects to find + ;; them. + (prog1 + (with-current-buffer nntp-server-buffer + (erase-buffer) + (insert-buffer-substring vbuf) + ;; FIX FIX FIX, we should be able to sort faster than + ;; this if needed, since each cgroup is sorted, we just + ;; need to merge + (sort-numeric-fields 1 (point-min) (point-max)) + 'nov) + (kill-buffer vbuf))))))) (defvoo nnvirtual-last-accessed-component-group nil) @@ -335,18 +372,61 @@ It is computed from the marks of individual component groups.") ;;; Internal functions. -(defun nnvirtual-update-xref-header (header group prefix sysname) - "Add xref to component GROUP to HEADER. -Also add a server PREFIX any existing xref lines." - (let ((bits (split-string (mail-header-xref header) - nil t "[[:blank:]]")) - (art-no (mail-header-number header))) - (setf (mail-header-xref header) - (concat - (format "%s %s:%d " sysname group art-no) - (mapconcat (lambda (bit) - (concat prefix bit)) - bits " "))))) +(defun nnvirtual-convert-headers () + "Convert HEAD headers into NOV headers." + (with-current-buffer nntp-server-buffer + (let* ((dependencies (make-hash-table :test #'equal)) + (headers (gnus-get-newsgroup-headers dependencies))) + (erase-buffer) + (mapc 'nnheader-insert-nov headers)))) + + +(defun nnvirtual-update-xref-header (group article prefix sysname) + "Edit current NOV header in current buffer to have an xref to the component group, and also server prefix any existing xref lines." + ;; Move to beginning of Xref field, creating a slot if needed. + (beginning-of-line) + (looking-at + "[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t") + (goto-char (match-end 0)) + (unless (search-forward "\t" (point-at-eol) 'move) + (insert "\t")) + + ;; Remove any spaces at the beginning of the Xref field. + (while (eq (char-after (1- (point))) ? ) + (forward-char -1) + (delete-char 1)) + + (insert "Xref: " sysname " " group ":") + (princ article (current-buffer)) + (insert " ") + + ;; If there were existing xref lines, clean them up to have the correct + ;; component server prefix. + (save-restriction + (narrow-to-region (point) + (or (search-forward "\t" (point-at-eol) t) + (point-at-eol))) + (goto-char (point-min)) + (when (re-search-forward "Xref: *[^\n:0-9 ]+ *" nil t) + (replace-match "" t t)) + (goto-char (point-min)) + (when (re-search-forward + (concat (regexp-quote (gnus-group-real-name group)) ":[0-9]+") + nil t) + (replace-match "" t t)) + (unless (eobp) + (insert " ") + (when (not (string= "" prefix)) + (while (re-search-forward "[^ ]+:[0-9]+" nil t) + (save-excursion + (goto-char (match-beginning 0)) + (insert prefix)))))) + + ;; Ensure a trailing \t. + (end-of-line) + (or (eq (char-after (1- (point))) ?\t) + (insert ?\t))) + (defun nnvirtual-possibly-change-server (server) (or (not server) diff --git a/lisp/obsolete/nnir.el b/lisp/obsolete/nnir.el index 0b7d1e454c3..147efed0057 100644 --- a/lisp/obsolete/nnir.el +++ b/lisp/obsolete/nnir.el @@ -504,6 +504,7 @@ Add an entry here when adding a new search engine.") ,@(mapcar (lambda (elem) (list 'const (car elem))) nnir-engines))))) + (defmacro nnir-add-result (dirnam artno score prefix server artlist) "Construct a result vector and add it to ARTLIST. DIRNAM, ARTNO, SCORE, PREFIX and SERVER are passed to -- cgit v1.2.3 From a572b21928a33b7ede445769bde5a67356327fef Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Tue, 26 Jan 2021 17:57:26 -0500 Subject: * lisp/progmodes/sh-script.el (sh-smie-sh-rules): Tweak indent of new `for` The new `for (TEST) { BODY }` syntax introduces various challenges. This patch just fixes a trivial subcase. --- lisp/progmodes/sh-script.el | 14 ++++++++++---- test/manual/indent/shell.sh | 7 +++++++ 2 files changed, 17 insertions(+), 4 deletions(-) (limited to 'lisp') diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el index cc045a1b2d1..fd689527676 100644 --- a/lisp/progmodes/sh-script.el +++ b/lisp/progmodes/sh-script.el @@ -1957,12 +1957,18 @@ May return nil if the line should not be treated as continued." ('(:after . "case-)") (- (sh-var-value 'sh-indent-for-case-alt) (sh-var-value 'sh-indent-for-case-label))) (`(:before . ,(or "(" "{" "[" "while" "if" "for" "case")) - (if (not (smie-rule-prev-p "&&" "||" "|")) - (when (smie-rule-hanging-p) - (smie-rule-parent)) + (cond + ((and (equal token "{") (smie-rule-parent-p "for")) + (let ((data (smie-backward-sexp "in"))) + (when (equal (nth 2 data) "for") + `(column . ,(smie-indent-virtual))))) + ((not (smie-rule-prev-p "&&" "||" "|")) + (when (smie-rule-hanging-p) + (smie-rule-parent))) + (t (unless (smie-rule-bolp) (while (equal "|" (nth 2 (smie-backward-sexp 'halfexp)))) - `(column . ,(smie-indent-virtual))))) + `(column . ,(smie-indent-virtual)))))) ;; FIXME: Maybe this handling of ;; should be made into ;; a smie-rule-terminator function that takes the substitute ";" as arg. (`(:before . ,(or ";;" ";&" ";;&")) diff --git a/test/manual/indent/shell.sh b/test/manual/indent/shell.sh index dc184ea0d77..bd4a74f7054 100755 --- a/test/manual/indent/shell.sh +++ b/test/manual/indent/shell.sh @@ -6,6 +6,13 @@ setlock -n /tmp/getmail.lock && echo getmail isn\'t running toto=$(grep hello foo | wc) +myfun () { + for ((it=0; it<${limit}; ++it)) + { + echo "whatever $it" + } +} + # adsgsdg if foo; then -- cgit v1.2.3 From b870e584a4275be83d6878001ee613997282fd37 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Tue, 26 Jan 2021 18:17:00 -0500 Subject: Use lexical-binding in all of `lisp/url` * lisp/url/url-dav.el: Use lexical-binding. (url-dav-process-DAV:prop): Remove unused var `handler-func`. (url-dav-lock-resource): Remove unused var `child-url`. (url-dav-active-locks): Remove unused var `properties`. (url-dav-delete-directory): Remove unused var `props`. (url-dav-file-name-completion): Remove unused var `result`. * lisp/url/url-expand.el (url-expand-file-name): Use \s * lisp/url/url-file.el (url-file): Improve regexp. * lisp/url/url-gw.el: Use lexical-binding. (url-open-stream): Remove unused var `cur-retries`, `retry`, `errobj`. * lisp/url/url-imap.el: Use lexical-binding. (imap-username, imap-password): Declare. * lisp/url/url-mailto.el: Use lexical-binding. (url-mailto): Remove unused var `func`. Use `push`. * lisp/url/url-news.el: Use lexical-binding. (url-news): Remove unused var `article-brackets`. * lisp/url/url-cid.el: * lisp/url/url-cache.el: * lisp/url/url-about.el: * lisp/url/url-tramp.el: * lisp/url/url-proxy.el: * lisp/url/url-privacy.el: * lisp/url/url-nfs.el: * lisp/url/url-ldap.el: * lisp/url/url-misc.el: * lisp/url/url-methods.el: Use lexical-binding. --- lisp/url/url-about.el | 10 ++++++---- lisp/url/url-cache.el | 2 +- lisp/url/url-cid.el | 2 +- lisp/url/url-dav.el | 18 ++++++++++-------- lisp/url/url-expand.el | 2 +- lisp/url/url-file.el | 2 +- lisp/url/url-gw.el | 15 +++++++-------- lisp/url/url-http.el | 25 ++++++++++++------------- lisp/url/url-imap.el | 5 ++++- lisp/url/url-ldap.el | 2 +- lisp/url/url-mailto.el | 11 ++++++----- lisp/url/url-methods.el | 4 ++-- lisp/url/url-misc.el | 2 +- lisp/url/url-news.el | 4 ++-- lisp/url/url-nfs.el | 2 +- lisp/url/url-privacy.el | 4 ++-- lisp/url/url-proxy.el | 2 +- lisp/url/url-tramp.el | 2 +- lisp/url/url.el | 22 +++++++++++----------- 19 files changed, 71 insertions(+), 65 deletions(-) (limited to 'lisp') diff --git a/lisp/url/url-about.el b/lisp/url/url-about.el index bff5570f6df..6ae90ccefad 100644 --- a/lisp/url/url-about.el +++ b/lisp/url/url-about.el @@ -1,4 +1,4 @@ -;;; url-about.el --- Show internal URLs +;;; url-about.el --- Show internal URLs -*- lexical-binding: t; -*- ;; Copyright (C) 2001, 2004-2021 Free Software Foundation, Inc. @@ -44,7 +44,7 @@ (defvar url-scheme-registry) -(defun url-about-protocols (url) +(defun url-about-protocols (_url) (url-probe-protocols) (insert "\n" " \n" @@ -73,13 +73,15 @@ "ynchronous
\n" (if (url-scheme-get-property k 'default-port) (format "Default Port: %d
\n" - (url-scheme-get-property k 'default-port)) "") + (url-scheme-get-property k 'default-port)) + "") (if (assoc k url-proxy-services) (format "Proxy: %s
\n" (assoc k url-proxy-services)) "")) ;; Now the description... (insert " " (or (url-scheme-get-property k 'description) "N/A")))) - (sort (let (x) (maphash (lambda (k v) (push k x)) url-scheme-registry) x) 'string-lessp)) + (sort (let (x) (maphash (lambda (k _v) (push k x)) url-scheme-registry) x) + #'string-lessp)) (insert " \n" " \n" "\n")) diff --git a/lisp/url/url-cache.el b/lisp/url/url-cache.el index acf88eb0212..830e6ba9dcc 100644 --- a/lisp/url/url-cache.el +++ b/lisp/url/url-cache.el @@ -1,4 +1,4 @@ -;;; url-cache.el --- Uniform Resource Locator retrieval tool +;;; url-cache.el --- Uniform Resource Locator retrieval tool -*- lexical-binding: t; -*- ;; Copyright (C) 1996-1999, 2004-2021 Free Software Foundation, Inc. diff --git a/lisp/url/url-cid.el b/lisp/url/url-cid.el index d465cabc90c..0ca2d8a0737 100644 --- a/lisp/url/url-cid.el +++ b/lisp/url/url-cid.el @@ -1,4 +1,4 @@ -;;; url-cid.el --- Content-ID URL loader +;;; url-cid.el --- Content-ID URL loader -*- lexical-binding: t; -*- ;; Copyright (C) 1998-1999, 2004-2021 Free Software Foundation, Inc. diff --git a/lisp/url/url-dav.el b/lisp/url/url-dav.el index 12d5a683e97..edb1c1de9fc 100644 --- a/lisp/url/url-dav.el +++ b/lisp/url/url-dav.el @@ -1,4 +1,4 @@ -;;; url-dav.el --- WebDAV support +;;; url-dav.el --- WebDAV support -*- lexical-binding: t; -*- ;; Copyright (C) 2001, 2004-2021 Free Software Foundation, Inc. @@ -133,7 +133,8 @@ Returns nil if WebDAV is not supported." (node-type nil) (props nil) (value nil) - (handler-func nil)) + ;; (handler-func nil) + ) (when (not children) (error "No child nodes in DAV:prop")) @@ -453,7 +454,7 @@ FAILURE-RESULTS is a list of (URL STATUS)." " \n")) (response nil) ; Responses to the LOCK request (result nil) ; For walking thru the response list - (child-url nil) + ;; (child-url nil) (child-status nil) (failures nil) ; List of failure cases (URL . STATUS) (successes nil)) ; List of success cases (URL . STATUS) @@ -468,7 +469,7 @@ FAILURE-RESULTS is a list of (URL STATUS)." ;; status code. (while response (setq result (pop response) - child-url (url-expand-file-name (pop result) url) + ;; child-url (url-expand-file-name (pop result) url) child-status (or (plist-get result 'DAV:status) 500)) (if (url-dav-http-success-p child-status) (push (list url child-status "huh") successes) @@ -478,7 +479,7 @@ FAILURE-RESULTS is a list of (URL STATUS)." (defun url-dav-active-locks (url &optional depth) "Return an assoc list of all active locks on URL." (let ((response (url-dav-get-properties url '(DAV:lockdiscovery) depth)) - (properties nil) + ;; (properties nil) (child nil) (child-url nil) (child-results nil) @@ -676,7 +677,6 @@ Use with care, and even then think three times." If optional second argument RECURSIVE is non-nil, then delete all files in the collection as well." (let ((status nil) - (props nil) (props nil)) (setq props (url-dav-delete-something url lock-token @@ -769,7 +769,7 @@ If NOSORT is non-nil, the list is not sorted--its order is unpredictable. (when (member 'DAV:collection (plist-get properties 'DAV:resourcetype)) t))) -(defun url-dav-make-directory (url &optional parents) +(defun url-dav-make-directory (url &optional _parents) "Create the directory DIR and any nonexistent parent dirs." (let* ((url-request-extra-headers nil) (url-request-method "MKCOL") @@ -849,7 +849,9 @@ that start with FILE. If there is only one and FILE matches it exactly, returns t. Returns nil if URL contains no name starting with FILE." (let ((matches (url-dav-file-name-all-completions file url)) - (result nil)) + ;; (result nil) + ) + ;; FIXME: Use `try-completion'! (cond ((null matches) ;; No matches diff --git a/lisp/url/url-expand.el b/lisp/url/url-expand.el index a42b4c7ad23..05088e3cac8 100644 --- a/lisp/url/url-expand.el +++ b/lisp/url/url-expand.el @@ -66,7 +66,7 @@ path components followed by `..' are removed, along with the `..' itself." ;; Need to nuke newlines and spaces in the URL, or we open ;; ourselves up to potential security holes. (setq url (mapconcat (lambda (x) - (if (memq x '(? ?\n ?\r)) + (if (memq x '(?\s ?\n ?\r)) "" (char-to-string x))) url ""))) diff --git a/lisp/url/url-file.el b/lisp/url/url-file.el index 52a9588030e..0e2ab5544b9 100644 --- a/lisp/url/url-file.el +++ b/lisp/url/url-file.el @@ -154,7 +154,7 @@ to them." ;; not the compressed one. ;; FIXME should this regexp not include more extensions; basically ;; everything that url-file-find-possibly-compressed-file does? - (setq uncompressed-filename (if (string-match "\\.\\(gz\\|Z\\|z\\)$" filename) + (setq uncompressed-filename (if (string-match "\\.\\(gz\\|Z\\|z\\)\\'" filename) (substring filename 0 (match-beginning 0)) filename)) (setq content-type (mailcap-extension-to-mime diff --git a/lisp/url/url-gw.el b/lisp/url/url-gw.el index 68df67f6486..d2bf843fc36 100644 --- a/lisp/url/url-gw.el +++ b/lisp/url/url-gw.el @@ -1,4 +1,4 @@ -;;; url-gw.el --- Gateway munging for URL loading +;;; url-gw.el --- Gateway munging for URL loading -*- lexical-binding: t; -*- ;; Copyright (C) 1997-1998, 2004-2021 Free Software Foundation, Inc. @@ -222,18 +222,17 @@ overriding the value of `url-gateway-method'." host)) 'native gwm)) - ;; An attempt to deal with denied connections, and attempt - ;; to reconnect - (cur-retries 0) - (retry t) - (errobj nil) - (conn nil)) + ;; An attempt to deal with denied connections, and attempt + ;; to reconnect + ;; (cur-retries 0) + ;; (retry t) + (conn nil)) ;; If the user told us to do DNS for them, do it. (if url-gateway-broken-resolution (setq host (url-gateway-nslookup-host host))) - (condition-case errobj + (condition-case nil ;; This is a clean way to ensure the new process inherits the ;; right coding systems in both Emacs and XEmacs. (let ((coding-system-for-read 'binary) diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el index 324cf99554d..61e07a0d9ca 100644 --- a/lisp/url/url-http.el +++ b/lisp/url/url-http.el @@ -66,7 +66,7 @@ (defconst url-http-default-port 80 "Default HTTP port.") (defconst url-http-asynchronous-p t "HTTP retrievals are asynchronous.") -(defalias 'url-http-expand-file-name 'url-default-expander) +(defalias 'url-http-expand-file-name #'url-default-expander) (defvar url-http-real-basic-auth-storage nil) (defvar url-http-proxy-basic-auth-storage nil) @@ -150,7 +150,7 @@ request.") ;; These routines will allow us to implement persistent HTTP ;; connections. (defsubst url-http-debug (&rest args) - (apply 'url-debug 'http args)) + (apply #'url-debug 'http args)) (defun url-http-mark-connection-as-busy (host port proc) (url-http-debug "Marking connection as busy: %s:%d %S" host port proc) @@ -1203,8 +1203,7 @@ the end of the document." ;; We got back a headerless malformed response from the ;; server. (url-http-activate-callback)) - ((or (= url-http-response-status 204) - (= url-http-response-status 205)) + ((memq url-http-response-status '(204 205)) (url-http-debug "%d response must have headers only (%s)." url-http-response-status (buffer-name)) (when (url-http-parse-headers) @@ -1239,11 +1238,11 @@ the end of the document." (url-http-debug "Saw HTTP/0.9 response, connection closed means end of document.") (setq url-http-after-change-function - 'url-http-simple-after-change-function)) + #'url-http-simple-after-change-function)) ((equal url-http-transfer-encoding "chunked") (url-http-debug "Saw chunked encoding.") (setq url-http-after-change-function - 'url-http-chunked-encoding-after-change-function) + #'url-http-chunked-encoding-after-change-function) (when (> nd url-http-end-of-headers) (url-http-debug "Calling initial chunked-encoding for extra data at end of headers") @@ -1254,7 +1253,7 @@ the end of the document." (url-http-debug "Got a content-length, being smart about document end.") (setq url-http-after-change-function - 'url-http-content-length-after-change-function) + #'url-http-content-length-after-change-function) (cond ((= 0 url-http-content-length) ;; We got a NULL body! Activate the callback @@ -1275,7 +1274,7 @@ the end of the document." (t (url-http-debug "No content-length, being dumb.") (setq url-http-after-change-function - 'url-http-simple-after-change-function))))) + #'url-http-simple-after-change-function))))) ;; We are still at the beginning of the buffer... must just be ;; waiting for a response. (url-http-debug "Spinning waiting for headers...") @@ -1374,7 +1373,7 @@ The return value of this function is the retrieval buffer." url-http-referer referer) (set-process-buffer connection buffer) - (set-process-filter connection 'url-http-generic-filter) + (set-process-filter connection #'url-http-generic-filter) (pcase (process-status connection) ('connect ;; Asynchronous connection @@ -1388,12 +1387,12 @@ The return value of this function is the retrieval buffer." (url-type url-current-object))) (url-https-proxy-connect connection) (set-process-sentinel connection - 'url-http-end-of-document-sentinel) + #'url-http-end-of-document-sentinel) (process-send-string connection (url-http-create-request))))))) buffer)) (defun url-https-proxy-connect (connection) - (setq url-http-after-change-function 'url-https-proxy-after-change-function) + (setq url-http-after-change-function #'url-https-proxy-after-change-function) (process-send-string connection (format @@ -1441,7 +1440,7 @@ The return value of this function is the retrieval buffer." (with-current-buffer process-buffer (erase-buffer)) (set-process-buffer tls-connection process-buffer) (setq url-http-after-change-function - 'url-http-wait-for-headers-change-function) + #'url-http-wait-for-headers-change-function) (set-process-filter tls-connection 'url-http-generic-filter) (process-send-string tls-connection (url-http-create-request))) @@ -1510,7 +1509,7 @@ The return value of this function is the retrieval buffer." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defalias 'url-http-symbol-value-in-buffer (if (fboundp 'symbol-value-in-buffer) - 'symbol-value-in-buffer + #'symbol-value-in-buffer (lambda (symbol buffer &optional unbound-value) "Return the value of SYMBOL in BUFFER, or UNBOUND-VALUE if it is unbound." (with-current-buffer buffer diff --git a/lisp/url/url-imap.el b/lisp/url/url-imap.el index 05c3e73fb0e..492907f33ff 100644 --- a/lisp/url/url-imap.el +++ b/lisp/url/url-imap.el @@ -1,4 +1,4 @@ -;;; url-imap.el --- IMAP retrieval routines +;;; url-imap.el --- IMAP retrieval routines -*- lexical-binding: t; -*- ;; Copyright (C) 1999, 2004-2021 Free Software Foundation, Inc. @@ -37,6 +37,9 @@ (defconst url-imap-default-port 143 "Default IMAP port.") +(defvar imap-username) +(defvar imap-password) + (defun url-imap-open-host (host port user pass) ;; xxx use user and password (if (fboundp 'nnheader-init-server-buffer) diff --git a/lisp/url/url-ldap.el b/lisp/url/url-ldap.el index 0fa9970fa47..d26562b7f10 100644 --- a/lisp/url/url-ldap.el +++ b/lisp/url/url-ldap.el @@ -1,4 +1,4 @@ -;;; url-ldap.el --- LDAP Uniform Resource Locator retrieval code +;;; url-ldap.el --- LDAP Uniform Resource Locator retrieval code -*- lexical-binding: t; -*- ;; Copyright (C) 1998-1999, 2004-2021 Free Software Foundation, Inc. diff --git a/lisp/url/url-mailto.el b/lisp/url/url-mailto.el index 688f102cabd..72884c07cc9 100644 --- a/lisp/url/url-mailto.el +++ b/lisp/url/url-mailto.el @@ -1,4 +1,4 @@ -;;; url-mail.el --- Mail Uniform Resource Locator retrieval code +;;; url-mail.el --- Mail Uniform Resource Locator retrieval code -*- lexical-binding: t; -*- ;; Copyright (C) 1996-1999, 2004-2021 Free Software Foundation, Inc. @@ -67,7 +67,7 @@ ;; mailto:wmperry@gnu.org (setf (url-filename url) (concat (url-user url) "@" (url-filename url)))) (setq url (url-filename url)) - (let (to args source-url subject func headers-start) + (let (to args source-url subject headers-start) ;; func (if (string-match (regexp-quote "?") url) (setq headers-start (match-end 0) to (url-unhex-string (substring url 0 (match-beginning 0))) @@ -76,10 +76,11 @@ (setq to (url-unhex-string url))) (setq source-url (url-view-url t)) (if (and url-request-data (not (assoc "subject" args))) - (setq args (cons (list "subject" + (push (list "subject" (concat "Automatic submission from " url-package-name "/" - url-package-version)) args))) + url-package-version)) + args)) (if (and source-url (not (assoc "x-url-from" args))) (setq args (cons (list "x-url-from" source-url) args))) @@ -107,7 +108,7 @@ (replace-regexp-in-string "\r\n" "\n" string)) (cdar args) "\n"))) (url-mail-goto-field (caar args)) - (setq func (intern-soft (concat "mail-" (caar args)))) + ;; (setq func (intern-soft (concat "mail-" (caar args)))) (insert (mapconcat 'identity (cdar args) ", "))) (setq args (cdr args))) ;; (url-mail-goto-field "User-Agent") diff --git a/lisp/url/url-methods.el b/lisp/url/url-methods.el index 7aad741210d..cfe7d5bc6a3 100644 --- a/lisp/url/url-methods.el +++ b/lisp/url/url-methods.el @@ -1,4 +1,4 @@ -;;; url-methods.el --- Load URL schemes as needed +;;; url-methods.el --- Load URL schemes as needed -*- lexical-binding: t; -*- ;; Copyright (C) 1996-1999, 2004-2021 Free Software Foundation, Inc. @@ -57,7 +57,7 @@ 'file-exists-p 'ignore 'file-attributes 'ignore)) -(defun url-scheme-default-loader (url &optional callback cbargs) +(defun url-scheme-default-loader (url &optional _callback _cbargs) "Signal an error for an unknown URL scheme." (error "Unknown URL scheme: %s" (url-type url))) diff --git a/lisp/url/url-misc.el b/lisp/url/url-misc.el index d3db31d612a..fe2393beb64 100644 --- a/lisp/url/url-misc.el +++ b/lisp/url/url-misc.el @@ -1,4 +1,4 @@ -;;; url-misc.el --- Misc Uniform Resource Locator retrieval code +;;; url-misc.el --- Misc Uniform Resource Locator retrieval code -*- lexical-binding: t; -*- ;; Copyright (C) 1996-1999, 2002, 2004-2021 Free Software Foundation, ;; Inc. diff --git a/lisp/url/url-news.el b/lisp/url/url-news.el index d5f8483ab7a..585a28291ae 100644 --- a/lisp/url/url-news.el +++ b/lisp/url/url-news.el @@ -1,4 +1,4 @@ -;;; url-news.el --- News Uniform Resource Locator retrieval code +;;; url-news.el --- News Uniform Resource Locator retrieval code -*- lexical-binding: t; -*- ;; Copyright (C) 1996-1999, 2004-2021 Free Software Foundation, Inc. @@ -106,7 +106,7 @@ ;; Find a news reference (let* ((host (or (url-host url) url-news-server)) (port (url-port url)) - (article-brackets nil) + ;; (article-brackets nil) (buf nil) (article (url-unhex-string (url-filename url)))) (url-news-open-host host port (url-user url) (url-password url)) diff --git a/lisp/url/url-nfs.el b/lisp/url/url-nfs.el index 3c80c8059b5..0449930408d 100644 --- a/lisp/url/url-nfs.el +++ b/lisp/url/url-nfs.el @@ -1,4 +1,4 @@ -;;; url-nfs.el --- NFS URL interface +;;; url-nfs.el --- NFS URL interface -*- lexical-binding: t; -*- ;; Copyright (C) 1996-1999, 2004-2021 Free Software Foundation, Inc. diff --git a/lisp/url/url-privacy.el b/lisp/url/url-privacy.el index e3ca0f66d98..d926775c48d 100644 --- a/lisp/url/url-privacy.el +++ b/lisp/url/url-privacy.el @@ -1,4 +1,4 @@ -;;; url-privacy.el --- Global history tracking for URL package +;;; url-privacy.el --- Global history tracking for URL package -*- lexical-binding: t; -*- ;; Copyright (C) 1996-1999, 2004-2021 Free Software Foundation, Inc. @@ -23,7 +23,7 @@ (require 'url-vars) -(defun url-device-type (&optional device) +(defun url-device-type (&optional _device) (declare (obsolete nil "27.1")) (or window-system 'tty)) diff --git a/lisp/url/url-proxy.el b/lisp/url/url-proxy.el index 6bf65845098..8436c7a4be2 100644 --- a/lisp/url/url-proxy.el +++ b/lisp/url/url-proxy.el @@ -1,4 +1,4 @@ -;;; url-proxy.el --- Proxy server support +;;; url-proxy.el --- Proxy server support -*- lexical-binding: t; -*- ;; Copyright (C) 1999, 2004-2021 Free Software Foundation, Inc. diff --git a/lisp/url/url-tramp.el b/lisp/url/url-tramp.el index 325d25cb8e2..5b9dd8a2682 100644 --- a/lisp/url/url-tramp.el +++ b/lisp/url/url-tramp.el @@ -1,4 +1,4 @@ -;;; url-tramp.el --- file-name-handler magic invoking Tramp for some protocols +;;; url-tramp.el --- file-name-handler magic invoking Tramp for some protocols -*- lexical-binding: t; -*- ;; Copyright (C) 2014-2021 Free Software Foundation, Inc. diff --git a/lisp/url/url.el b/lisp/url/url.el index 172a3af2b3b..8daf9f0a8e8 100644 --- a/lisp/url/url.el +++ b/lisp/url/url.el @@ -156,16 +156,16 @@ If INHIBIT-COOKIES, cookies will neither be stored nor sent to the server. If URL is a multibyte string, it will be encoded as utf-8 and URL-encoded before it's used." -;;; XXX: There is code in Emacs that does dynamic binding -;;; of the following variables around url-retrieve: -;;; url-standalone-mode, url-gateway-unplugged, w3-honor-stylesheets, -;;; url-confirmation-func, url-cookie-multiple-line, -;;; url-cookie-{{,secure-}storage,confirmation} -;;; url-standalone-mode and url-gateway-unplugged should work as -;;; usual. url-confirmation-func is only used in nnwarchive.el and -;;; webmail.el; the latter should be updated. Is -;;; url-cookie-multiple-line needed anymore? The other url-cookie-* -;;; are (for now) only used in synchronous retrievals. + ;; XXX: There is code in Emacs that does dynamic binding + ;; of the following variables around url-retrieve: + ;; url-standalone-mode, url-gateway-unplugged, w3-honor-stylesheets, + ;; url-confirmation-func, url-cookie-multiple-line, + ;; url-cookie-{{,secure-}storage,confirmation} + ;; url-standalone-mode and url-gateway-unplugged should work as + ;; usual. url-confirmation-func is only used in nnwarchive.el and + ;; webmail.el; the latter should be updated. Is + ;; url-cookie-multiple-line needed anymore? The other url-cookie-* + ;; are (for now) only used in synchronous retrievals. (url-retrieve-internal url callback (cons nil cbargs) silent inhibit-cookies)) @@ -210,7 +210,7 @@ URL-encoded before it's used." (asynch (url-scheme-get-property (url-type url) 'asynchronous-p))) (if url-using-proxy (setq asynch t - loader 'url-proxy)) + loader #'url-proxy)) (if asynch (let ((url-current-object url)) (setq buffer (funcall loader url callback cbargs))) -- cgit v1.2.3 From eded2a7ad7d456a417354a2797c18e9a578414d7 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 27 Jan 2021 03:38:49 +0100 Subject: Try to improve the read-regexp doc string * lisp/replace.el (read-regexp): Attempt to clarify the semantics (bug#46088). --- lisp/replace.el | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) (limited to 'lisp') diff --git a/lisp/replace.el b/lisp/replace.el index db5b340631a..cf1dcb4992f 100644 --- a/lisp/replace.el +++ b/lisp/replace.el @@ -835,12 +835,14 @@ If DEFAULTS is a list of strings, the first element is the default return value, but all the elements are accessible using the history command \\\\[next-history-element]. -If DEFAULTS is a non-nil symbol, then if `read-regexp-defaults-function' -is non-nil, we use that in place of DEFAULTS in the following: - If DEFAULTS is the symbol `regexp-history-last', we use the first - element of HISTORY (if specified) or `regexp-history'. - If DEFAULTS is a function, we call it with no arguments and use - what it returns, which should be either nil, a string, or a list of strings. +DEFAULTS can be a symbol. If DEFAULTS is the symbol +`regexp-history-last', we use the first element of HISTORY (if +specified) or `regexp-history'. If DEFAULTS is a symbol with a +function definition, we call it with no arguments and use what it +returns, which should be either nil, a string, or a list of +strings. Other symbol values for DEFAULTS are ignored. If +`read-regexp-defaults-function' is non-nil, its value is used +instead of DEFAULTS in the two cases described in this paragraph. We append the standard values from `read-regexp-suggestions' to DEFAULTS before using it. -- cgit v1.2.3 From f9cc2d48246fe8370e9286866e6115ba8e2acf44 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 27 Jan 2021 03:47:02 +0100 Subject: read-regexp-suggestions doc string improvement * lisp/replace.el (read-regexp-suggestions): Add a link to the manual to explain what a tag is (bug#46089). --- lisp/replace.el | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) (limited to 'lisp') diff --git a/lisp/replace.el b/lisp/replace.el index cf1dcb4992f..32fbc24064c 100644 --- a/lisp/replace.el +++ b/lisp/replace.el @@ -808,10 +808,12 @@ the function that you set this to can check `this-command'." (defun read-regexp-suggestions () "Return a list of standard suggestions for `read-regexp'. -By default, the list includes the tag at point, the last isearch regexp, -the last isearch string, and the last replacement regexp. `read-regexp' -appends the list returned by this function to the end of values available -via \\\\[next-history-element]." +By default, the list includes the \"tag\" at point (see Info +node `(emacs) Identifier Search'), the last isearch regexp, the +last isearch string, and the last replacement regexp. +`read-regexp' appends the list returned by this function to the +end of values available via +\\\\[next-history-element]." (list (find-tag-default-as-regexp) (find-tag-default-as-symbol-regexp) -- cgit v1.2.3 From 883c15fb3244500901bb30bddc66c26e8a6ba200 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 27 Jan 2021 04:27:42 +0100 Subject: Fix setting of line/point style in calc gnuplot * lisp/calc/calc-graph.el (calc-graph-set-styles): Modern gnuplot requires "ls" before the line style and "ps" before the point style (bug#46070). --- lisp/calc/calc-graph.el | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'lisp') diff --git a/lisp/calc/calc-graph.el b/lisp/calc/calc-graph.el index 4785fb7fba2..423d1e64126 100644 --- a/lisp/calc/calc-graph.el +++ b/lisp/calc/calc-graph.el @@ -1136,11 +1136,11 @@ This \"dumb\" driver will be present in Gnuplot 3.0." (if penbl "linespoints" "lines") (if penbl "points" "dots")))) (if (and pstyle (> pstyle 0)) - (insert " " + (insert " ls " (if (and lstyle (> lstyle 0)) (int-to-string lstyle) "1") - " " (int-to-string pstyle)) + " ps " (int-to-string pstyle)) (if (and lstyle (> lstyle 0)) - (insert " " (int-to-string lstyle))))))) + (insert " ls " (int-to-string lstyle))))))) (calc-graph-view-commands)) (defun calc-graph-zero-x (flag) -- cgit v1.2.3 From 9d50d7a0c6ff742ad682ef63e09c7e7341909b28 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 27 Jan 2021 07:04:08 +0100 Subject: Fix indentation in sieve-mode * lisp/net/sieve-mode.el (sieve-mode-indent-function): New function. (sieve-mode): Don't inherit from C mode, because the syntax doesn't really resemble C mode that much (except being curly braced). --- lisp/net/sieve-mode.el | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) (limited to 'lisp') diff --git a/lisp/net/sieve-mode.el b/lisp/net/sieve-mode.el index fbc4e75fae5..7bc1d16122d 100644 --- a/lisp/net/sieve-mode.el +++ b/lisp/net/sieve-mode.el @@ -128,6 +128,9 @@ (modify-syntax-entry ?| "." st) (modify-syntax-entry ?_ "_" st) (modify-syntax-entry ?\' "\"" st) + (modify-syntax-entry ?\{ "(}" st) + (modify-syntax-entry ?\} "){" st) + (modify-syntax-entry ?\" "\"" st) st) "Syntax table in use in sieve-mode buffers.") @@ -178,12 +181,8 @@ 'syntax-table (string-to-syntax "|"))))) ;;;###autoload -(define-derived-mode sieve-mode c-mode "Sieve" +(define-derived-mode sieve-mode prog-mode "Sieve" "Major mode for editing Sieve code. -This is much like C mode except for the syntax of comments. Its keymap -inherits from C mode's and it has the same variables for customizing -indentation. It has its own abbrev table and its own syntax table. - Turning on Sieve mode runs `sieve-mode-hook'." (setq-local paragraph-start (concat "$\\|" page-delimiter)) (setq-local paragraph-separate paragraph-start) @@ -194,8 +193,17 @@ Turning on Sieve mode runs `sieve-mode-hook'." (setq-local syntax-propertize-function #'sieve-syntax-propertize) (setq-local font-lock-defaults '(sieve-font-lock-keywords nil nil ((?_ . "w")))) + (setq-local indent-line-function #'sieve-mode-indent-function) (easy-menu-add-item nil nil sieve-mode-menu)) +(defun sieve-mode-indent-function () + (save-excursion + (beginning-of-line) + (let ((depth (car (syntax-ppss)))) + (when (looking-at "[ \t]*}") + (setq depth (1- depth))) + (indent-line-to (* 2 depth))))) + (provide 'sieve-mode) ;; sieve-mode.el ends here -- cgit v1.2.3 From fb05199b0bf2055d75b7eba52c3ab2fd49d38509 Mon Sep 17 00:00:00 2001 From: Juri Linkov Date: Mon, 25 Jan 2021 22:10:15 +0200 Subject: Support variable name for previous-window in display-buffer-in-previous-window * lisp/window.el (display-buffer-in-previous-window): Support the value of 'previous-window' entry as a symbol for variable name (bug#45688). --- lisp/window.el | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) (limited to 'lisp') diff --git a/lisp/window.el b/lisp/window.el index 0a37d16273f..d5876914201 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -8196,8 +8196,8 @@ such alists. If ALIST has a non-nil `inhibit-same-window' entry, the selected window is not usable. A dedicated window is usable only if it already shows BUFFER. If ALIST contains a `previous-window' -entry, the window specified by that entry is usable even if it -never showed BUFFER before. +entry, the window specified by that entry (either a variable +or a value) is usable even if it never showed BUFFER before. If ALIST contains a `reusable-frames' entry, its value determines which frames to search for a usable window: @@ -8239,6 +8239,7 @@ indirectly called by the latter." 0) (display-buffer-reuse-frames 0) (t (last-nonminibuffer-frame)))) + (previous-window (cdr (assq 'previous-window alist))) best-window second-best-window window) ;; Scan windows whether they have shown the buffer recently. (catch 'best @@ -8252,7 +8253,9 @@ indirectly called by the latter." (throw 'best t))))) ;; When ALIST has a `previous-window' entry, that entry may override ;; anything we found so far. - (when (and (setq window (cdr (assq 'previous-window alist))) + (when (and previous-window (boundp previous-window)) + (setq previous-window (symbol-value previous-window))) + (when (and (setq window previous-window) (window-live-p window) (or (eq buffer (window-buffer window)) (not (window-dedicated-p window)))) -- cgit v1.2.3 From 08574a7f40f27ad29efb8f7d975012ecc9111717 Mon Sep 17 00:00:00 2001 From: Juri Linkov Date: Wed, 27 Jan 2021 11:42:30 +0200 Subject: * lisp/subr.el (empty-history): Move defvar to functions where it's used. --- lisp/subr.el | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) (limited to 'lisp') diff --git a/lisp/subr.el b/lisp/subr.el index f249ec3578c..afa73c72eaa 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -2965,8 +2965,6 @@ Also discard all previous input in the minibuffer." (minibuffer-message "Wrong answer") (sit-for 2))) -(defvar empty-history) - (defun read-char-from-minibuffer (prompt &optional chars history) "Read a character from the minibuffer, prompting for it with PROMPT. Like `read-char', but uses the minibuffer to read and return a character. @@ -2981,6 +2979,7 @@ while calling this function, then pressing `help-char' causes it to evaluate `help-form' and display the result. There is no need to explicitly add `help-char' to CHARS; `help-char' is bound automatically to `help-form-show'." + (defvar empty-history) (let* ((empty-history '()) (map (if (consp chars) (or (gethash (list help-form (cons help-char chars)) @@ -3093,8 +3092,6 @@ Also discard all previous input in the minibuffer." "Prefer `read-key' when answering a \"y or n\" question by `y-or-n-p'. Otherwise, use the minibuffer.") -(defvar empty-history) - (defun y-or-n-p (prompt) "Ask user a \"y or n\" question. Return t if answer is \"y\" and nil if it is \"n\". @@ -3190,6 +3187,7 @@ is nil and `use-dialog-box' is non-nil." (discard-input))) (t (setq prompt (funcall padded prompt)) + (defvar empty-history) (let* ((empty-history '()) (enable-recursive-minibuffers t) (msg help-form) -- cgit v1.2.3 From 49eb03d6c8a181fd46adbbcf1f0a976d0a9efa87 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Wed, 27 Jan 2021 17:15:46 +0200 Subject: Improve documentation of 'read-regexp' and friends * doc/emacs/glossary.texi (Glossary): Add "Tag" to the Glossary. * doc/emacs/maintaining.texi (Xref): Mention that identifiers are also known as "tags". * lisp/replace.el (read-regexp, read-regexp-suggestions): Improve wording of doc strings. (Bug#46088) (Bug#46089) --- doc/emacs/glossary.texi | 8 ++++++-- doc/emacs/maintaining.texi | 22 ++++++++++++---------- lisp/replace.el | 44 +++++++++++++++++++++++--------------------- 3 files changed, 41 insertions(+), 33 deletions(-) (limited to 'lisp') diff --git a/doc/emacs/glossary.texi b/doc/emacs/glossary.texi index 35df06591eb..4f971eb1e01 100644 --- a/doc/emacs/glossary.texi +++ b/doc/emacs/glossary.texi @@ -1369,10 +1369,14 @@ configurations. @xref{Tab Bars}. The tab line is a line of tabs at the top of an Emacs window. Clicking on one of these tabs switches window buffers. @xref{Tab Line}. +@item Tag +A tag is an identifier in a program source. @xref{Xref}. + @anchor{Glossary---Tags Table} @item Tags Table -A tags table is a file that serves as an index to the function -definitions in one or more other files. @xref{Tags Tables}. +A tags table is a file that serves as an index to identifiers: definitions +of functions, macros, data structures, etc., in one or more other files. +@xref{Tags Tables}. @item Termscript File A termscript file contains a record of all characters sent by Emacs to diff --git a/doc/emacs/maintaining.texi b/doc/emacs/maintaining.texi index 415815473e5..bc276c49046 100644 --- a/doc/emacs/maintaining.texi +++ b/doc/emacs/maintaining.texi @@ -1994,19 +1994,21 @@ Of course, you should substitute the proper years and copyright holder. @section Find Identifier References @cindex xref +@cindex tag An @dfn{identifier} is a name of a syntactical subunit of the program: a function, a subroutine, a method, a class, a data type, a macro, etc. In a programming language, each identifier is a symbol in -the language's syntax. Program development and maintenance requires -capabilities to quickly find where each identifier was defined and -referenced, to rename identifiers across the entire project, etc. - -These capabilities are also useful for finding references in major -modes other than those defined to support programming languages. For -example, chapters, sections, appendices, etc.@: of a text or a @TeX{} -document can be treated as subunits as well, and their names can be -used as identifiers. In this chapter, we use the term ``identifiers'' -to collectively refer to the names of any kind of subunits, in program +the language's syntax. Identifiers are also known as @dfn{tags}. + +Program development and maintenance requires capabilities to quickly +find where each identifier was defined and referenced, to rename +identifiers across the entire project, etc. These capabilities are +also useful for finding references in major modes other than those +defined to support programming languages. For example, chapters, +sections, appendices, etc.@: of a text or a @TeX{} document can be +treated as subunits as well, and their names can be used as +identifiers. In this chapter, we use the term ``identifiers'' to +collectively refer to the names of any kind of subunits, in program source and in other kinds of text alike. Emacs provides a unified interface to these capabilities, called diff --git a/lisp/replace.el b/lisp/replace.el index 32fbc24064c..4483d7f7800 100644 --- a/lisp/replace.el +++ b/lisp/replace.el @@ -808,11 +808,11 @@ the function that you set this to can check `this-command'." (defun read-regexp-suggestions () "Return a list of standard suggestions for `read-regexp'. -By default, the list includes the \"tag\" at point (see Info -node `(emacs) Identifier Search'), the last isearch regexp, the -last isearch string, and the last replacement regexp. -`read-regexp' appends the list returned by this function to the -end of values available via +By default, the list includes the identifier (a.k.a. \"tag\") +at point (see Info node `(emacs) Identifier Search'), the last +isearch regexp, the last isearch string, and the last +replacement regexp. `read-regexp' appends the list returned +by this function to the end of values available via \\\\[next-history-element]." (list (find-tag-default-as-regexp) @@ -827,33 +827,35 @@ Prompt with the string PROMPT. If PROMPT ends in \":\" (followed by optional whitespace), use it as-is. Otherwise, add \": \" to the end, possibly preceded by the default result (see below). -The optional argument DEFAULTS can be either: nil, a string, a list -of strings, or a symbol. We use DEFAULTS to construct the default -return value in case of empty input. +The optional argument DEFAULTS is used to construct the default +return value in case of empty input. DEFAULTS can be nil, a string, +a list of strings, or a symbol. -If DEFAULTS is a string, we use it as-is. +If DEFAULTS is a string, the function uses it as-is. If DEFAULTS is a list of strings, the first element is the default return value, but all the elements are accessible using the history command \\\\[next-history-element]. -DEFAULTS can be a symbol. If DEFAULTS is the symbol -`regexp-history-last', we use the first element of HISTORY (if -specified) or `regexp-history'. If DEFAULTS is a symbol with a -function definition, we call it with no arguments and use what it -returns, which should be either nil, a string, or a list of -strings. Other symbol values for DEFAULTS are ignored. If -`read-regexp-defaults-function' is non-nil, its value is used -instead of DEFAULTS in the two cases described in this paragraph. +If DEFAULTS is the symbol `regexp-history-last', the default return +value will be the first element of HISTORY. If HISTORY is omitted or +nil, `regexp-history' is used instead. +If DEFAULTS is a symbol with a function definition, it is called with +no arguments and should return either nil, a string, or a list of +strings, which will be used as above. +Other symbol values for DEFAULTS are ignored. -We append the standard values from `read-regexp-suggestions' to DEFAULTS -before using it. +If `read-regexp-defaults-function' is non-nil, its value is used +instead of DEFAULTS in the two cases described in the last paragraph. + +Before using whatever value DEFAULTS yields, the function appends the +standard values from `read-regexp-suggestions' to that value. If the first element of DEFAULTS is non-nil (and if PROMPT does not end -in \":\", followed by optional whitespace), we add it to the prompt. +in \":\", followed by optional whitespace), DEFAULT is added to the prompt. The optional argument HISTORY is a symbol to use for the history list. -If nil, uses `regexp-history'." +If nil, use `regexp-history'." (let* ((defaults (if (and defaults (symbolp defaults)) (cond -- cgit v1.2.3 From 45112398cdcfa1e32986ef630dc235ce38d10774 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Wed, 27 Jan 2021 16:30:08 +0100 Subject: * lisp/net/dbus.el (dbus-monitor-handler): Disable buffer undo. --- lisp/net/dbus.el | 1 + 1 file changed, 1 insertion(+) (limited to 'lisp') diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el index 7a7bbef5364..195ddc6bbac 100644 --- a/lisp/net/dbus.el +++ b/lisp/net/dbus.el @@ -2079,6 +2079,7 @@ daemon, it is rather the timestamp the corresponding D-Bus event has been handled by this function." (with-current-buffer (get-buffer-create "*D-Bus Monitor*") (special-mode) + (buffer-disable-undo) ;; Move forward and backward between messages. (local-set-key [?n] #'forward-paragraph) (local-set-key [?p] #'backward-paragraph) -- cgit v1.2.3 From 12095de8b918b3c44c603bf88bc98f1842910f86 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Wed, 27 Jan 2021 16:30:49 +0100 Subject: Some Tramp fixes * doc/misc/tramp.texi (GVFS-based methods): Ban sftp RemoteCommand option. * lisp/net/tramp-adb.el (tramp-adb-handle-copy-file) (tramp-adb-handle-rename-file): Avoid calling jka-compr when writing the target file. * lisp/net/tramp-sh.el (tramp-sh-handle-file-ownership-preserved-p): Skip GROUP test on *BSD machines. * test/lisp/net/tramp-tests.el (tramp-test17-insert-directory-one-file): Skip for tamp-crypt.el. (tramp--test-sh-no-ls--dired-p): Ignore errors. --- doc/misc/tramp.texi | 3 +++ lisp/net/tramp-adb.el | 10 ++++++++-- lisp/net/tramp-sh.el | 6 ++++++ test/lisp/net/tramp-tests.el | 6 +++++- 4 files changed, 22 insertions(+), 3 deletions(-) (limited to 'lisp') diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index 5d89b065882..efe839574d2 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -1286,6 +1286,9 @@ This method uses @command{sftp} in order to securely access remote hosts. @command{sftp} is a more secure option for connecting to hosts that for security reasons refuse @command{ssh} connections. +When there is a respective entry in your @command{ssh} configuration, +do @emph{not} set the @option{RemoteCommand} option. + @end table @defopt tramp-gvfs-methods diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 2c4ef2acaef..73dffe1d64f 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -636,7 +636,10 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (copy-directory filename newname keep-date t) (let ((t1 (tramp-tramp-file-p filename)) - (t2 (tramp-tramp-file-p newname))) + (t2 (tramp-tramp-file-p newname)) + ;; We don't want the target file to be compressed, so we + ;; let-bind `jka-compr-inhibit' to t. + (jka-compr-inhibit t)) (with-parsed-tramp-file-name (if t1 filename newname) nil (unless (file-exists-p filename) (tramp-error @@ -717,7 +720,10 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (delete-directory filename 'recursive)) (let ((t1 (tramp-tramp-file-p filename)) - (t2 (tramp-tramp-file-p newname))) + (t2 (tramp-tramp-file-p newname)) + ;; We don't want the target file to be compressed, so we + ;; let-bind `jka-compr-inhibit' to t. + (jka-compr-inhibit t)) (with-parsed-tramp-file-name (if t1 filename newname) nil (unless (file-exists-p filename) (tramp-error diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index ed3d15377c3..2274efdf8b5 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -1708,6 +1708,12 @@ ID-FORMAT valid values are `string' and `integer'." (= (tramp-compat-file-attribute-user-id attributes) (tramp-get-remote-uid v 'integer)) (or (not group) + ;; On BSD-derived systems files always inherit the + ;; parent directory's group, so skip the group-gid + ;; test. + (string-match-p + "BSD\\|DragonFly\\|Darwin" + (tramp-get-connection-property v "uname" "")) (= (tramp-compat-file-attribute-group-id attributes) (tramp-get-remote-gid v 'integer))))))))) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 7757c55c16b..6467c7ee219 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -3192,6 +3192,8 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (ert-deftest tramp-test17-insert-directory-one-file () "Check `insert-directory' inside directory listing." (skip-unless (tramp--test-enabled)) + ;; Relative file names in dired are not supported in tramp-crypt.el. + (skip-unless (not (tramp--test-crypt-p))) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let* ((tmp-name1 @@ -5793,7 +5795,9 @@ Additionally, ls does not support \"--dired\"." (and (tramp--test-sh-p) (with-temp-buffer ;; We must refill the cache. `insert-directory' does it. - (insert-directory tramp-test-temporary-file-directory "-al") + ;; This fails for tramp-crypt.el, so we ignore that. + (ignore-errors + (insert-directory tramp-test-temporary-file-directory "-al")) (not (tramp-get-connection-property tramp-test-vec "ls--dired" nil))))) (defun tramp--test-share-p () -- cgit v1.2.3 From b0e96e554c0e78c17ee6e092e307112e814e5a65 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Tue, 26 Jan 2021 21:11:49 -0500 Subject: Use lexical-binding in of all lisp/language * lisp/international/titdic-cnv.el (pinyin-convert): Enable lexical-binding in the generated file(s). * lisp/language/ethio-util.el: Use lexical-binding. (ethio-tex-to-fidel-buffer): Use `inhibit-read-only`. Remove unused vars `p` and `ch`. * lisp/language/hanja-util.el: Use lexical-binding. * lisp/language/ind-util.el: Use lexical-binding. (indian-translate-region): Actually use the `from` and `to` arguments. (): Use `dlet`. Remove unused var `current-repertory`. (indian-2-column-to-ucs-region): Remove unused var `pos`. * lisp/language/japan-util.el: Use lexical-binding. (japanese-katakana-region, japanese-hiragana-region) (japanese-zenkaku-region): Remove unused var `next`. * lisp/language/korea-util.el: Use lexical-binding. * lisp/language/lao-util.el: Use lexical-binding. (lao-composition-function): Remove unused var `glyph`. * lisp/language/thai-util.el: Use lexical-binding. (thai-composition-function): Remove unused var `glyph`. * lisp/language/thai-word.el: Use lexical-binding. (thai-forward-word): Remove unused var `tail`. * lisp/language/tibet-util.el: Use lexical-binding. (tibetan-add-components): Remove unused var `tmp`. (tibetan-compose-region): Remove unused vars `str`, `result`, `chars`. * lisp/language/viet-util.el: * lisp/language/tv-util.el: * lisp/language/cyril-util.el: * lisp/language/china-util.el: Use lexical-binding. --- lisp/international/titdic-cnv.el | 6 ++-- lisp/language/burmese.el | 4 +-- lisp/language/cham.el | 2 +- lisp/language/china-util.el | 2 +- lisp/language/cyril-util.el | 2 +- lisp/language/ethio-util.el | 11 ++++--- lisp/language/ethiopic.el | 4 +-- lisp/language/hanja-util.el | 2 +- lisp/language/hebrew.el | 6 ++-- lisp/language/ind-util.el | 14 ++++----- lisp/language/indian.el | 2 +- lisp/language/japan-util.el | 8 ++--- lisp/language/khmer.el | 2 +- lisp/language/korea-util.el | 6 ++-- lisp/language/korean.el | 4 +-- lisp/language/lao-util.el | 8 ++--- lisp/language/lao.el | 2 +- lisp/language/misc-lang.el | 8 ++--- lisp/language/sinhala.el | 2 +- lisp/language/tai-viet.el | 2 +- lisp/language/thai-util.el | 8 ++--- lisp/language/thai-word.el | 5 ++- lisp/language/tibet-util.el | 66 ++++++++++++++++++++-------------------- lisp/language/tibetan.el | 2 +- lisp/language/tv-util.el | 4 +-- lisp/language/viet-util.el | 2 +- 26 files changed, 93 insertions(+), 91 deletions(-) (limited to 'lisp') diff --git a/lisp/international/titdic-cnv.el b/lisp/international/titdic-cnv.el index 58c81bfd1f3..753139e5dd8 100644 --- a/lisp/international/titdic-cnv.el +++ b/lisp/international/titdic-cnv.el @@ -1212,8 +1212,10 @@ The library is named pinyin.el, and contains the constant (dst-file (cadr command-line-args-left)) (coding-system-for-write 'utf-8-unix)) (with-temp-file dst-file - (insert ";; This file is automatically generated from pinyin.map,\ - by the\n;; function pinyin-convert.\n\n") + (insert ";;; " (file-name-nondirectory dst-file) + " -*- lexical-binding:t -*- +;; This file is automatically generated from pinyin.map, by the +;; function pinyin-convert.\n\n") (insert "(defconst pinyin-character-map\n'(") (let ((pos (point))) (insert-file-contents src-file) diff --git a/lisp/language/burmese.el b/lisp/language/burmese.el index d689e87d785..373f25ac5ca 100644 --- a/lisp/language/burmese.el +++ b/lisp/language/burmese.el @@ -51,7 +51,7 @@ regexp t t)))) regexp)) -(let ((elt (list (vector burmese-composable-pattern 0 'font-shape-gstring) - (vector "." 0 'font-shape-gstring)))) +(let ((elt (list (vector burmese-composable-pattern 0 #'font-shape-gstring) + (vector "." 0 #'font-shape-gstring)))) (set-char-table-range composition-function-table '(#x1000 . #x107F) elt) (set-char-table-range composition-function-table '(#xAA60 . #xAA7B) elt)) diff --git a/lisp/language/cham.el b/lisp/language/cham.el index aa820dc649c..3aac986b437 100644 --- a/lisp/language/cham.el +++ b/lisp/language/cham.el @@ -29,7 +29,7 @@ (set-char-table-range composition-function-table '(#xAA00 . #xAA5F) - (list (vector "[\xAA00-\xAA5F]+" 0 'font-shape-gstring))) + (list (vector "[\xAA00-\xAA5F]+" 0 #'font-shape-gstring))) (set-language-info-alist "Cham" '((charset unicode) diff --git a/lisp/language/china-util.el b/lisp/language/china-util.el index 4bc2eaa2cdd..105e7a735fd 100644 --- a/lisp/language/china-util.el +++ b/lisp/language/china-util.el @@ -1,4 +1,4 @@ -;;; china-util.el --- utilities for Chinese -*- coding: utf-8 -*- +;;; china-util.el --- utilities for Chinese -*- lexical-binding: t; -*- ;; Copyright (C) 1995, 2001-2021 Free Software Foundation, Inc. ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, diff --git a/lisp/language/cyril-util.el b/lisp/language/cyril-util.el index 72ceffdf0d6..04e681d743d 100644 --- a/lisp/language/cyril-util.el +++ b/lisp/language/cyril-util.el @@ -1,4 +1,4 @@ -;;; cyril-util.el --- utilities for Cyrillic scripts +;;; cyril-util.el --- utilities for Cyrillic scripts -*- lexical-binding: t; -*- ;; Copyright (C) 1997-1998, 2001-2021 Free Software Foundation, Inc. diff --git a/lisp/language/ethio-util.el b/lisp/language/ethio-util.el index 174b9ecfda2..9b5fdf24d2b 100644 --- a/lisp/language/ethio-util.el +++ b/lisp/language/ethio-util.el @@ -1,4 +1,4 @@ -;;; ethio-util.el --- utilities for Ethiopic -*- coding: utf-8-emacs; -*- +;;; ethio-util.el --- utilities for Ethiopic -*- coding: utf-8-emacs; lexical-binding: t; -*- ;; Copyright (C) 1997-1998, 2002-2021 Free Software Foundation, Inc. ;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -832,11 +832,12 @@ The 2nd and 3rd arguments BEGIN and END specify the region." (set-buffer-modified-p nil))) ;;;###autoload -(defun ethio-tex-to-fidel-buffer nil +(defun ethio-tex-to-fidel-buffer () "Convert fidel-tex commands in the current buffer into fidel chars." (interactive) - (let ((buffer-read-only nil) - (p) (ch)) + (let ((inhibit-read-only t) + ;; (p) (ch) + ) ;; TeX macros to Ethiopic characters (robin-convert-region (point-min) (point-max) "ethiopic-tex") @@ -1018,7 +1019,7 @@ With ARG, insert that many delimiters." ;; ;;;###autoload -(defun ethio-composition-function (pos to font-object string _direction) +(defun ethio-composition-function (pos _to _font-object string _direction) (setq pos (1- pos)) (let ((pattern "\\ce\\(፟\\|\\)")) (if string diff --git a/lisp/language/ethiopic.el b/lisp/language/ethiopic.el index 8573f6177df..209dcd51c90 100644 --- a/lisp/language/ethiopic.el +++ b/lisp/language/ethiopic.el @@ -79,8 +79,8 @@ ))) ;; For automatic composition -(aset composition-function-table ? 'ethio-composition-function) -(aset composition-function-table ?፟ 'ethio-composition-function) +(aset composition-function-table ? #'ethio-composition-function) +(aset composition-function-table ?፟ #'ethio-composition-function) (provide 'ethiopic) diff --git a/lisp/language/hanja-util.el b/lisp/language/hanja-util.el index 313fc63bebd..9e9213536cb 100644 --- a/lisp/language/hanja-util.el +++ b/lisp/language/hanja-util.el @@ -1,4 +1,4 @@ -;;; hanja-util.el --- Korean Hanja util module -*- coding: utf-8 -*- +;;; hanja-util.el --- Korean Hanja util module -*- lexical-binding: t; -*- ;; Copyright (C) 2008-2021 Free Software Foundation, Inc. diff --git a/lisp/language/hebrew.el b/lisp/language/hebrew.el index 389565669a9..c55d23f72d6 100644 --- a/lisp/language/hebrew.el +++ b/lisp/language/hebrew.el @@ -245,9 +245,9 @@ Bidirectional editing is supported."))) (pattern2 (concat base "\u200D" combining))) (set-char-table-range composition-function-table '(#x591 . #x5C7) - (list (vector pattern2 3 'hebrew-shape-gstring) - (vector pattern2 2 'hebrew-shape-gstring) - (vector pattern1 1 'hebrew-shape-gstring) + (list (vector pattern2 3 #'hebrew-shape-gstring) + (vector pattern2 2 #'hebrew-shape-gstring) + (vector pattern1 1 #'hebrew-shape-gstring) [nil 0 hebrew-shape-gstring])) ;; Exclude non-combining characters. (set-char-table-range diff --git a/lisp/language/ind-util.el b/lisp/language/ind-util.el index 4bd1cd76a6d..8d4b2a826e6 100644 --- a/lisp/language/ind-util.el +++ b/lisp/language/ind-util.el @@ -1,4 +1,4 @@ -;;; ind-util.el --- Transliteration and Misc. Tools for Indian Languages -*- coding: utf-8-emacs; -*- +;;; ind-util.el --- Transliteration and Misc. Tools for Indian Languages -*- coding: utf-8-emacs; lexical-binding: t; -*- ;; Copyright (C) 2001-2021 Free Software Foundation, Inc. @@ -40,7 +40,7 @@ (defun indian-regexp-of-hashtbl-keys (hashtbl) "Return the regular expression of hash table keys." (let (keys) - (maphash (lambda (key val) (push key keys)) hashtbl) + (maphash (lambda (key _val) (push key keys)) hashtbl) (regexp-opt keys))) (defvar indian-dev-base-table @@ -565,7 +565,7 @@ (let ((regexp ,(indian-regexp-of-hashtbl-keys (if encode-p (car (eval hashtable)) (cdr (eval hashtable)))))) - (narrow-to-region from to) + (narrow-to-region ,from ,to) (goto-char (point-min)) (while (re-search-forward regexp nil t) (let ((matchstr (gethash (match-string 0) @@ -613,7 +613,7 @@ ;; The followings provide conversion between IS 13194 (ISCII) and UCS. -(let +(dlet ;;Unicode vs IS13194 ;; only Devanagari is supported now. ((ucs-devanagari-to-is13194-alist '((?\x0900 . "[U+0900]") @@ -820,11 +820,11 @@ Returns new end position." (save-restriction (narrow-to-region from to) (goto-char (point-min)) - (let* ((current-repertory is13194-default-repertory)) + ;; (let* ((current-repertory is13194-default-repertory)) (while (re-search-forward indian-ucs-to-is13194-regexp nil t) (replace-match (get-char-code-property (string-to-char (match-string 0)) - 'iscii)))) + 'iscii)));; ) (point-max)))) (defun indian-iscii-to-ucs-region (from to) @@ -1246,7 +1246,7 @@ Returns new end position." (interactive "r") (save-excursion (save-restriction - (let ((pos from) + (let (;; (pos from) (alist (char-table-extra-slot indian-2-column-to-ucs-chartable 0))) (narrow-to-region from to) (decompose-region from to) diff --git a/lisp/language/indian.el b/lisp/language/indian.el index 5ff57966c12..6f9d2703849 100644 --- a/lisp/language/indian.el +++ b/lisp/language/indian.el @@ -381,7 +381,7 @@ South Indian language Malayalam is supported in this language environment.")) (if slot (set-char-table-range composition-function-table key - (list (vector (cdr slot) 0 'font-shape-gstring)))))) + (list (vector (cdr slot) 0 #'font-shape-gstring)))))) char-script-table)) (provide 'indian) diff --git a/lisp/language/japan-util.el b/lisp/language/japan-util.el index 9dce17c4967..948bfef9f22 100644 --- a/lisp/language/japan-util.el +++ b/lisp/language/japan-util.el @@ -1,4 +1,4 @@ -;;; japan-util.el --- utilities for Japanese +;;; japan-util.el --- utilities for Japanese -*- lexical-binding: t; -*- ;; Copyright (C) 2001-2021 Free Software Foundation, Inc. ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, @@ -236,7 +236,7 @@ of which charset is `japanese-jisx0201-kana'." (composition (and (not hankaku) (get-char-code-property kana 'kana-composition))) - next slot) + slot) ;; next (if (and composition (setq slot (assq (following-char) composition))) (japanese-replace-region (match-beginning 0) (1+ (point)) (cdr slot)) @@ -258,7 +258,7 @@ of which charset is `japanese-jisx0201-kana'." (while (re-search-forward "\\cK\\|\\ck" nil t) (let* ((kata (preceding-char)) (composition (get-char-code-property kata 'kana-composition)) - next slot) + slot) ;; next (if (and composition (setq slot (assq (following-char) composition))) (japanese-replace-region (match-beginning 0) (1+ (point)) (get-char-code-property @@ -305,7 +305,7 @@ Optional argument KATAKANA-ONLY non-nil means to convert only KATAKANA char." (re-search-forward "\\ca\\|\\ck" nil t))) (let* ((hankaku (preceding-char)) (composition (get-char-code-property hankaku 'kana-composition)) - next slot) + slot) ;; next (if (and composition (setq slot (assq (following-char) composition))) (japanese-replace-region (match-beginning 0) (1+ (point)) (cdr slot)) diff --git a/lisp/language/khmer.el b/lisp/language/khmer.el index 37173c9fb95..6f08e60d601 100644 --- a/lisp/language/khmer.el +++ b/lisp/language/khmer.el @@ -31,7 +31,7 @@ (documentation . t))) (let ((val (list (vector "[\x1780-\x17FF\x19E0-\x19FF\x200C\x200D]+" - 0 'font-shape-gstring)))) + 0 #'font-shape-gstring)))) (set-char-table-range composition-function-table '(#x1780 . #x17FF) val) (set-char-table-range composition-function-table '(#x19E0 . #x19FF) val)) diff --git a/lisp/language/korea-util.el b/lisp/language/korea-util.el index eb7b85bce81..c99ff3c3f2d 100644 --- a/lisp/language/korea-util.el +++ b/lisp/language/korea-util.el @@ -1,4 +1,4 @@ -;;; korea-util.el --- utilities for Korean +;;; korea-util.el --- utilities for Korean -*- lexical-binding: t; -*- ;; Copyright (C) 1997, 1999, 2001-2021 Free Software Foundation, Inc. ;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, @@ -45,7 +45,7 @@ (activate-input-method (concat "korean-hangul" default-korean-keyboard)))) -(defun quail-hangul-switch-symbol-ksc (&rest ignore) +(defun quail-hangul-switch-symbol-ksc (&rest _ignore) "Switch to/from Korean symbol package." (interactive "i") (and current-input-method @@ -54,7 +54,7 @@ default-korean-keyboard)) (activate-input-method "korean-symbol")))) -(defun quail-hangul-switch-hanja (&rest ignore) +(defun quail-hangul-switch-hanja (&rest _ignore) "Switch to/from Korean hanja package." (interactive "i") (and current-input-method diff --git a/lisp/language/korean.el b/lisp/language/korean.el index 22b33a440ef..bdf8240de96 100644 --- a/lisp/language/korean.el +++ b/lisp/language/korean.el @@ -92,10 +92,10 @@ and the following key bindings are available within Korean input methods: (pattern (concat choseong jungseong jongseong))) (set-char-table-range composition-function-table '(#x1100 . #x115F) - (list (vector pattern 0 'font-shape-gstring))) + (list (vector pattern 0 #'font-shape-gstring))) (set-char-table-range composition-function-table '(#xA960 . #xA97C) - (list (vector pattern 0 'font-shape-gstring)))) + (list (vector pattern 0 #'font-shape-gstring)))) (provide 'korean) diff --git a/lisp/language/lao-util.el b/lisp/language/lao-util.el index 59c9850b1a1..c8c3fe4f7e6 100644 --- a/lisp/language/lao-util.el +++ b/lisp/language/lao-util.el @@ -1,4 +1,4 @@ -;;; lao-util.el --- utilities for Lao -*- coding: utf-8; -*- +;;; lao-util.el --- utilities for Lao -*- lexical-binding: t; -*- ;; Copyright (C) 2001-2021 Free Software Foundation, Inc. ;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, @@ -498,10 +498,10 @@ syllable. In that case, FROM and TO are indexes to STR." (compose-gstring-for-graphic gstring direction) (or (font-shape-gstring gstring direction) (let ((glyph-len (lgstring-glyph-len gstring)) - (i 0) - glyph) + (i 0)) ;; glyph (while (and (< i glyph-len) - (setq glyph (lgstring-glyph gstring i))) + ;; (setq glyph + (lgstring-glyph gstring i)) ;;) (setq i (1+ i))) (compose-glyph-string-relative gstring 0 i 0.1))))) diff --git a/lisp/language/lao.el b/lisp/language/lao.el index 5252f1e60ea..c699d57c15a 100644 --- a/lisp/language/lao.el +++ b/lisp/language/lao.el @@ -66,7 +66,7 @@ (t (string c)))) (cdr l) "")) ;; Element of composition-function-table. - (elt (list (vector regexp 1 'lao-composition-function) + (elt (list (vector regexp 1 #'lao-composition-function) fallback-rule)) ch) (dotimes (i len) diff --git a/lisp/language/misc-lang.el b/lisp/language/misc-lang.el index 0a274f144c2..a2ca678b2be 100644 --- a/lisp/language/misc-lang.el +++ b/lisp/language/misc-lang.el @@ -137,9 +137,9 @@ thin (i.e. 1-dot width) space." composition-function-table '(#x600 . #x74F) (list (vector "[\u200C\u200D][\u0600-\u074F\u200C\u200D]+" - 1 'arabic-shape-gstring) + 1 #'arabic-shape-gstring) (vector "[\u0600-\u074F\u200C\u200D]+" - 0 'arabic-shape-gstring))) + 0 #'arabic-shape-gstring))) ;; The Egyptian Hieroglyph Format Controls were introduced in Unicode ;; Standard v12.0. Apparently, they are not yet well supported in @@ -186,13 +186,13 @@ thin (i.e. 1-dot width) space." ;; doesn't support these controls, the glyphs are ;; displayed individually, and not as a single ;; grapheme cluster. - 1 'font-shape-gstring))) + 1 #'font-shape-gstring))) ;; Grouping controls (set-char-table-range composition-function-table #x13437 (list (vector "\U00013437[\U00013000-\U0001343F]+" - 0 'egyptian-shape-grouping)))) + 0 #'egyptian-shape-grouping)))) (provide 'misc-lang) diff --git a/lisp/language/sinhala.el b/lisp/language/sinhala.el index 90fc41c1c41..99a104ec339 100644 --- a/lisp/language/sinhala.el +++ b/lisp/language/sinhala.el @@ -43,6 +43,6 @@ "[\u0D85-\u0D96][\u0D82-\u0D83]?\\|" ;; any other singleton characters "[\u0D80-\u0DFF]") - 0 'font-shape-gstring))) + 0 #'font-shape-gstring))) ;; sinhala.el ends here diff --git a/lisp/language/tai-viet.el b/lisp/language/tai-viet.el index 17abf136f7f..4549b111a3d 100644 --- a/lisp/language/tai-viet.el +++ b/lisp/language/tai-viet.el @@ -30,7 +30,7 @@ (set-char-table-range composition-function-table '(#xAA80 . #xAADF) - 'tai-viet-composition-function) + #'tai-viet-composition-function) (set-language-info-alist "TaiViet" '((charset unicode) diff --git a/lisp/language/thai-util.el b/lisp/language/thai-util.el index f9c57e8ca83..e11a05445c7 100644 --- a/lisp/language/thai-util.el +++ b/lisp/language/thai-util.el @@ -1,4 +1,4 @@ -;;; thai-util.el --- utilities for Thai -*- coding: utf-8; -*- +;;; thai-util.el --- utilities for Thai -*- lexical-binding: t; -*- ;; Copyright (C) 2000-2021 Free Software Foundation, Inc. ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, @@ -232,10 +232,10 @@ positions (integers or markers) specifying the region." (let ((glyph-len (lgstring-glyph-len gstring)) (last-char (lgstring-char gstring (1- (lgstring-char-len gstring)))) - (i 0) - glyph) + (i 0)) ;; glyph (while (and (< i glyph-len) - (setq glyph (lgstring-glyph gstring i))) + ;; (setq glyph + (lgstring-glyph gstring i)) ;; ) (setq i (1+ i))) (if (= last-char ?ำ) (setq i (1- i))) diff --git a/lisp/language/thai-word.el b/lisp/language/thai-word.el index 94c6ab98979..ff1e80298ba 100644 --- a/lisp/language/thai-word.el +++ b/lisp/language/thai-word.el @@ -1,4 +1,4 @@ -;;; thai-word.el -- find Thai word boundaries +;;; thai-word.el -- find Thai word boundaries -*- lexical-binding: t; -*- ;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 ;; National Institute of Advanced Industrial Science and Technology (AIST) @@ -10973,8 +10973,7 @@ If COUNT is negative, move point backward (- COUNT) words." ;; special instead of using forward-word. (let ((start (point)) (limit (match-end 0)) - boundaries - tail) + boundaries) ;; tail ;; If thai-forward-word has been called within a Thai ;; region, we must go back until the Thai region starts ;; to do the contextual analysis for finding word diff --git a/lisp/language/tibet-util.el b/lisp/language/tibet-util.el index e741af18740..ddf4a0c0fb1 100644 --- a/lisp/language/tibet-util.el +++ b/lisp/language/tibet-util.el @@ -1,4 +1,4 @@ -;;; tibet-util.el --- utilities for Tibetan -*- coding: utf-8-emacs; -*- +;;; tibet-util.el --- utilities for Tibetan -*- coding: utf-8-emacs; lexical-binding: t; -*- ;; Copyright (C) 1997, 2001-2021 Free Software Foundation, Inc. ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, @@ -126,42 +126,42 @@ The returned string has no composition information." (setq t-str-list (cons (substring str idx) t-str-list))) (apply 'concat (nreverse t-str-list)))) -;;; +;; ;;; Functions for composing/decomposing Tibetan sequence. -;;; -;;; A Tibetan syllable is typically structured as follows: -;;; -;;; [Prefix] C [C+] V [M] [Suffix [Post suffix]] -;;; -;;; where C's are all vertically stacked, V appears below or above -;;; consonant cluster and M is always put above the C[C+]V combination. -;;; (Sanskrit visarga, though it is a vowel modifier, is considered -;;; to be a punctuation.) -;;; -;;; Here are examples of the words "bsgrubs" and "hfauM" -;;; -;;; བསྒྲུབས ཧཱུཾ -;;; -;;; M -;;; b s b s h -;;; g fa -;;; r u -;;; u -;;; -;;; Consonants `'' (འ), `w' (ཝ), `y' (ཡ), `r' (ར) take special -;;; forms when they are used as subjoined consonant. Consonant `r' -;;; takes another special form when used as superjoined in such a case -;;; as "rka", while it does not change its form when conjoined with -;;; subjoined `'', `w' or `y' as in "rwa", "rya". - -;; Append a proper composition rule and glyph to COMPONENTS to compose -;; CHAR with a composition that has COMPONENTS. +;; +;; A Tibetan syllable is typically structured as follows: +;; +;; [Prefix] C [C+] V [M] [Suffix [Post suffix]] +;; +;; where C's are all vertically stacked, V appears below or above +;; consonant cluster and M is always put above the C[C+]V combination. +;; (Sanskrit visarga, though it is a vowel modifier, is considered +;; to be a punctuation.) +;; +;; Here are examples of the words "bsgrubs" and "hfauM" +;; +;; བསྒྲུབས ཧཱུཾ +;; +;; M +;; b s b s h +;; g fa +;; r u +;; u +;; +;; Consonants `'' (འ), `w' (ཝ), `y' (ཡ), `r' (ར) take special +;; forms when they are used as subjoined consonant. Consonant `r' +;; takes another special form when used as superjoined in such a case +;; as "rka", while it does not change its form when conjoined with +;; subjoined `'', `w' or `y' as in "rwa", "rya". + +; Append a proper composition rule and glyph to COMPONENTS to compose +; CHAR with a composition that has COMPONENTS. (defun tibetan-add-components (components char) (let ((last (last components)) (stack-upper '(tc . bc)) (stack-under '(bc . tc)) - rule comp-vowel tmp) + rule comp-vowel) ;; Special treatment for 'a chung. ;; If 'a follows a consonant, turn it into the subjoined form. ;; * Disabled by Tomabechi 2000/06/09 * @@ -246,7 +246,7 @@ The returned string has no composition information." (defun tibetan-compose-region (beg end) "Compose Tibetan text the region BEG and END." (interactive "r") - (let (str result chars) + ;; (let (str result chars) (save-excursion (save-restriction (narrow-to-region beg end) @@ -272,7 +272,7 @@ The returned string has no composition information." (while (< (point) to) (tibetan-add-components components (following-char)) (forward-char 1)) - (compose-region from to components))))))) + (compose-region from to components)))))) ;; ) (defvar tibetan-decompose-precomposition-alist (mapcar (lambda (x) (cons (string-to-char (cdr x)) (car x))) diff --git a/lisp/language/tibetan.el b/lisp/language/tibetan.el index edd9d765b1e..48c7638948c 100644 --- a/lisp/language/tibetan.el +++ b/lisp/language/tibetan.el @@ -605,7 +605,7 @@ This also matches some punctuation characters which need conversion.") ;; For automatic composition. (set-char-table-range composition-function-table '(#xF00 . #xFD1) - (list (vector tibetan-composable-pattern 0 'font-shape-gstring))) + (list (vector tibetan-composable-pattern 0 #'font-shape-gstring))) (provide 'tibetan) diff --git a/lisp/language/tv-util.el b/lisp/language/tv-util.el index 7ce8ee1e500..1a530d350f2 100644 --- a/lisp/language/tv-util.el +++ b/lisp/language/tv-util.el @@ -1,4 +1,4 @@ -;;; tv-util.el --- support for Tai Viet -*- coding: utf-8 -*- +;;; tv-util.el --- support for Tai Viet -*- lexical-binding: t; -*- ;; Copyright (C) 2007, 2008, 2009, 2010, 2011 ;; National Institute of Advanced Industrial Science and Technology (AIST) @@ -128,7 +128,7 @@ ;;;###autoload -(defun tai-viet-composition-function (from to font-object string _direction) +(defun tai-viet-composition-function (from _to _font-object string _direction) (if string (if (string-match tai-viet-re string from) (tai-viet-compose-string from (match-end 0) string)) diff --git a/lisp/language/viet-util.el b/lisp/language/viet-util.el index 177b04bc473..bfaf0f3b94a 100644 --- a/lisp/language/viet-util.el +++ b/lisp/language/viet-util.el @@ -1,4 +1,4 @@ -;;; viet-util.el --- utilities for Vietnamese -*- coding: utf-8; -*- +;;; viet-util.el --- utilities for Vietnamese -*- lexical-binding: t; -*- ;; Copyright (C) 1998, 2001-2021 Free Software Foundation, Inc. ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, -- cgit v1.2.3 From 89327ce68d096da9539f5032f598870ba97155c7 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 27 Jan 2021 12:25:52 -0500 Subject: * lisp/international/titdic-cnv.el: Revert to utf-8 encoding While it's true that using the iso-2022-jp encoding on the file does allow Emacs to render the two strings differently, this only applies to the source file. The .elc files all use `utf-8-emacs` encoding anyway, so that info is lost. And the difference is even lost before we write the .elc file because when Emacs byte-compiles that code the byte-compiler considers those two strings as "equal" and emits only one string in the byte-code (so the two branches return `eq` strings). So, I think using `iso-2022-jp` is a bad idea here: it gives the illusion that the the `charset` info exists, even it will be lost. Eli discussed it with Handa-san a year ago, and they arrived at the conclusion that the charset information is indeed no longer important. --- lisp/international/titdic-cnv.el | 236 +++++++++++++++++++-------------------- 1 file changed, 118 insertions(+), 118 deletions(-) (limited to 'lisp') diff --git a/lisp/international/titdic-cnv.el b/lisp/international/titdic-cnv.el index 753139e5dd8..84e218f1799 100644 --- a/lisp/international/titdic-cnv.el +++ b/lisp/international/titdic-cnv.el @@ -1,4 +1,4 @@ -;;; titdic-cnv.el --- convert cxterm dictionary (TIT format) to Quail package -*- coding:iso-2022-7bit; lexical-binding:t -*- +;;; titdic-cnv.el --- convert cxterm dictionary (TIT format) to Quail package -*- coding: utf-8-emacs; lexical-binding:t -*- ;; Copyright (C) 1997-1998, 2000-2021 Free Software Foundation, Inc. ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, @@ -83,9 +83,9 @@ ;; how to select a translation from a list of candidates. (defvar quail-cxterm-package-ext-info - '(("chinese-4corner" "$(0(?-F(B") - ("chinese-array30" "$(0#R#O(B") - ("chinese-ccdospy" "$AKuF4(B" + '(("chinese-4corner" "四角") + ("chinese-array30" "３０") + ("chinese-ccdospy" "缩拼" "Pinyin base input method for Chinese charset GB2312 (`chinese-gb2312'). Pinyin is the standard Roman transliteration method for Chinese. @@ -94,10 +94,10 @@ method `chinese-py'. This input method works almost the same way as `chinese-py'. The difference is that you type a single key for these Pinyin spelling. - Pinyin: zh en eng ang ch an ao ai ong sh ing yu($A(9(B) + Pinyin: zh en eng ang ch an ao ai ong sh ing yu(ü) keyseq: a f g h i j k l s u y v For example: - Chinese: $A0!(B $A9{(B $AVP(B $AND(B $A9b(B $ASq(B $AH+(B + Chinese: 啊 果 中 文 光 玉 全 Pinyin: a guo zhong wen guang yu quan Keyseq: a1 guo4 as1 wf4 guh1 yu..6 qvj6 @@ -106,14 +106,14 @@ For example: For double-width GB2312 characters corresponding to ASCII, use the input method `chinese-qj'.") - ("chinese-ecdict" "$(05CKH(B" + ("chinese-ecdict" "英漢" "In this input method, you enter a Chinese (Big5) character or word by typing the corresponding English word. For example, if you type -\"computer\", \"$(0IZH+(B\" is input. +\"computer\", \"電腦\" is input. \\") - ("chinese-etzy" "$(06/0D(B" + ("chinese-etzy" "倚注" "Zhuyin base input method for Chinese Big5 characters (`chinese-big5-1', `chinese-big5-2'). @@ -122,20 +122,20 @@ compose one Chinese character. In this input method, you enter a Chinese character by first typing keys corresponding to Zhuyin symbols (see the above table) followed by -SPC, 1, 2, 3, or 4 specifying a tone (SPC:$(0?v(N(B, 1:$(0M=Vy(B, 2:$(0Dm(N(B, 3: $(0&9Vy(B, -4:$(0(+Vy(B). +SPC, 1, 2, 3, or 4 specifying a tone (SPC:陰平, 1:輕聲, 2:陽平, 3: 上聲, +4:去聲). \\") - ("chinese-punct-b5" "$(0O:(BB" + ("chinese-punct-b5" "標B" "Input method for Chinese punctuation and symbols of Big5 \(`chinese-big5-1' and `chinese-big5-2').") - ("chinese-punct" "$A1j(BG" + ("chinese-punct" "标G" "Input method for Chinese punctuation and symbols of GB2312 \(`chinese-gb2312').") - ("chinese-py-b5" "$(03<(BB" + ("chinese-py-b5" "拼B" "Pinyin base input method for Chinese Big5 characters \(`chinese-big5-1', `chinese-big5-2'). @@ -153,28 +153,28 @@ method `chinese-qj-b5'. The input method `chinese-py' and `chinese-tonepy' are also Pinyin based, but for the character set GB2312 (`chinese-gb2312').") - ("chinese-qj-b5" "$(0)A(BB") + ("chinese-qj-b5" "全B") - ("chinese-qj" "$AH+(BG") + ("chinese-qj" "全G") - ("chinese-sw" "$AJWN2(B" + ("chinese-sw" "首尾" "Radical base input method for Chinese charset GB2312 (`chinese-gb2312'). In this input method, you enter a Chinese character by typing two -keys. The first key corresponds to the first ($AJW(B) radical, the second -key corresponds to the last ($AN2(B) radical. The correspondence of keys +keys. The first key corresponds to the first (首) radical, the second +key corresponds to the last (尾) radical. The correspondence of keys and radicals is as below: first radical: a b c d e f g h i j k l m n o p q r s t u v w x y z - $APD(B $AZ"(B $AJ,(B $AX<(B $A;p(B $A?Z(B $A^P(B $Ac_(B $AZ%(B $A\3(B $AXi(B $AD>(B $Alj(B $Ab;(B $ATB(B $Afy(B $AJ/(B $AMu(B $A0K(B $AX/(B $AHU(B $AeA(B $Aak(B $AVq(B $AR;(B $AHK(B + 心 冖 尸 丶 火 口 扌 氵 讠 艹 亻 木 礻 饣 月 纟 石 王 八 丿 日 辶 犭 竹 一 人 last radical: a b c d e f g h i j k l m n o p q r s t u v w x y z - $ASV(B $AI=(B $AMA(B $A56(B $AZb(B $A?Z(B $ARB(B $Aqb(B $A4s(B $A6!(B $A[L(B $Ala(B $AJ.(B $A4u(B $AXg(B $ACE(B $A=q(B $AX-(B $AE.(B $ARR(B $A`m(B $AP!(B $A3'(B $A3f(B $A_.(B $A27(B + 又 山 土 刀 阝 口 衣 疋 大 丁 厶 灬 十 歹 冂 门 今 丨 女 乙 囗 小 厂 虫 弋 卜 \\") - ("chinese-tonepy" "$A5wF4(B" + ("chinese-tonepy" "调拼" "Pinyin base input method for Chinese charset GB2312 (`chinese-gb2312'). Pinyin is the standard roman transliteration method for Chinese. @@ -183,18 +183,18 @@ method `chinese-py'. This input method works almost the same way as `chinese-py'. The difference is that you must type 1..5 after each Pinyin spelling to -specify a tone (1:$ARuF=(B, 2:$AQtF=(B, 3:$AIOIy(B, 4$AOBIy(B, 5:$AGaIy(B). +specify a tone (1:阴平, 2:阳平, 3:上声, 4下声, 5:轻声). \\ -For instance, to input $ADc(B, you type \"n i 3 3\", the first \"n i\" is +For instance, to input 你, you type \"n i 3 3\", the first \"n i\" is a Pinyin, the next \"3\" specifies tone, and the last \"3\" selects the third character from the candidate list. For double-width GB2312 characters corresponding to ASCII, use the input method `chinese-qj'.") - ("chinese-zozy" "$(0I\0D(B" + ("chinese-zozy" "零注" "Zhuyin base input method for Chinese Big5 characters (`chinese-big5-1', `chinese-big5-2'). @@ -203,8 +203,8 @@ compose a Chinese character. In this input method, you enter a Chinese character by first typing keys corresponding to Zhuyin symbols (see the above table) followed by -SPC, 6, 3, 4, or 7 specifying a tone (SPC:$(0?v(N(B, 6:$(0Dm(N(B, 3:$(0&9Vy(B, 4:$(0(+Vy(B, -7:$(0M=Vy(B). +SPC, 6, 3, 4, or 7 specifying a tone (SPC:陰平, 6:陽平, 3:上聲, 4:去聲, +7:輕聲). \\"))) @@ -354,7 +354,7 @@ SPC, 6, 3, 4, or 7 specifying a tone (SPC:$(0?v(N(B, 6:$(0Dm(N(B, 3:$(0&9Vy (princ (nth 2 (assoc tit-encode tit-encode-list))) (princ "\" \"") (princ (or title - (if (string-match "[:$A!K$(0!(!J(B]+\\([^:$A!K$(0!(!K(B]+\\)" tit-prompt) + (if (string-match "[:∷：【]+\\([^:∷：】]+\\)" tit-prompt) (substring tit-prompt (match-beginning 1) (match-end 1)) tit-prompt))) (princ "\"\n")) @@ -580,7 +580,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ;; ) (defvar quail-misc-package-ext-info - '(("chinese-b5-tsangchi" "$(06A(BB" + '(("chinese-b5-tsangchi" "倉B" "cangjie-table.b5" big5 "tsang-b5.el" tsang-b5-converter "\ @@ -590,7 +590,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ;; # unmodified versions is granted without royalty provided ;; # this notice is preserved.") - ("chinese-b5-quick" "$(0X|(BB" + ("chinese-b5-quick" "簡B" "cangjie-table.b5" big5 "quick-b5.el" quick-b5-converter "\ @@ -600,7 +600,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ;; # unmodified versions is granted without royalty provided ;; # this notice is preserved.") - ("chinese-cns-tsangchi" "$(GT?(BC" + ("chinese-cns-tsangchi" "倉C" "cangjie-table.cns" iso-2022-cn-ext "tsang-cns.el" tsang-cns-converter "\ @@ -610,7 +610,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ;; # unmodified versions is granted without royalty provided ;; # this notice is preserved.") - ("chinese-cns-quick" "$(Gv|(BC" + ("chinese-cns-quick" "簡C" "cangjie-table.cns" iso-2022-cn-ext "quick-cns.el" quick-cns-converter "\ @@ -620,7 +620,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ;; # unmodified versions is granted without royalty provided ;; # this notice is preserved.") - ("chinese-py" "$AF4(BG" + ("chinese-py" "拼G" "pinyin.map" cn-gb-2312 "PY.el" py-converter "\ @@ -648,7 +648,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ;; You should have received a copy of the GNU General Public License along with ;; CCE. If not, see .") - ("chinese-ziranma" "$AWTH;(B" + ("chinese-ziranma" "自然" "ziranma.cin" cn-gb-2312 "ZIRANMA.el" ziranma-converter "\ @@ -676,7 +676,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ;; You should have received a copy of the GNU General Public License along with ;; CCE. If not, see .") - ("chinese-ctlau" "$AAuTA(B" + ("chinese-ctlau" "刘粤" "CTLau.html" cn-gb-2312 "CTLau.el" ctlau-gb-converter "\ @@ -701,7 +701,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ;; # You should have received a copy of the GNU General Public License ;; # along with this program. If not, see .") - ("chinese-ctlaub" "$(0N,Gn(B" + ("chinese-ctlaub" "劉粵" "CTLau-b5.html" big5 "CTLau-b5.el" ctlau-b5-converter "\ @@ -731,38 +731,38 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ;; dictionary in the buffer DICBUF. The input method name of the ;; Quail package is NAME, and the title string is TITLE. -;; TSANG-P is non-nil, generate $(06AQo(B input method. Otherwise -;; generate $(0X|/y(B (simple version of $(06AQo(B). If BIG5-P is non-nil, the +;; TSANG-P is non-nil, generate 倉頡 input method. Otherwise +;; generate 簡易 (simple version of 倉頡). If BIG5-P is non-nil, the ;; input method is for inputting Big5 characters. Otherwise the input ;; method is for inputting CNS characters. (defun tsang-quick-converter (dicbuf tsang-p big5-p) - (let ((fulltitle (if tsang-p (if big5-p "$(06AQo(B" "$(GT?on(B") - (if big5-p "$(0X|/y(B" "$(Gv|Mx(B"))) + (let ((fulltitle (if tsang-p (if big5-p "倉頡" "倉頡") + (if big5-p "簡易" "簡易"))) dic) (goto-char (point-max)) (if big5-p - (insert (format "\"$(0&d'GTT&,!J(B%s$(0!K(BBIG5 + (insert (format "\"中文輸入【%s】BIG5 - $(0KHM$(B%s$(0TT&,WoOu(B + 漢語%s輸入鍵盤 - [Q $(0'D(B] [W $(0(q(B] [E $(0'V(B] [R $(0&H(B] [T $(0'>(B] [Y $(0&4(B] [U $(0&U(B] [I $(0'B(B] [O $(0&*(B] [P $(0'A(B] + [Q 手] [W 田] [E 水] [R 口] [T 廿] [Y 卜] [U 山] [I 戈] [O 人] [P 心] - [A $(0'K(B] [S $(0&T(B] [D $(0'N(B] [F $(0'W(B] [G $(0&I(B] [H $(0*M(B] [J $(0&3(B] [L $(0&d(B] + [A 日] [S 尸] [D 木] [F 火] [G 土] [H 竹] [J 十] [L 中] - [Z ] [X $(0[E(B] [C $(01[(B] [V $(0&M(B] [B $(0'M(B] [N $(0&_(B] [M $(0&"(B] + [Z ] [X 難] [C 金] [V 女] [B 月] [N 弓] [M 一] \\\\\"\n" fulltitle fulltitle)) - (insert (format "\"$(GDcEFrSD+!J(B%s$(G!K(BCNS + (insert (format "\"中文輸入【%s】CNS - $(GiGk#(B%s$(GrSD+uomu(B + 漢語%s輸入鍵盤 - [Q $(GEC(B] [W $(GFp(B] [E $(GEU(B] [R $(GDG(B] [T $(GE=(B] [Y $(GD3(B] [U $(GDT(B] [I $(GEA(B] [O $(GD)(B] [P $(GE@(B] + [Q 手] [W 田] [E 水] [R 口] [T 廿] [Y 卜] [U 山] [I 戈] [O 人] [P 心] - [A $(GEJ(B] [S $(GDS(B] [D $(GEM(B] [F $(GEV(B] [G $(GDH(B] [H $(GHL(B] [J $(GD2(B] [L $(GDc(B] + [A 日] [S 尸] [D 木] [F 火] [G 土] [H 竹] [J 十] [L 中] - [Z ] [X $(GyE(B] [C $(GOZ(B] [V $(GDL(B] [B $(GEL(B] [N $(GD^(B] [M $(GD!(B] + [Z ] [X 難] [C 金] [V 女] [B 月] [N 弓] [M 一] \\\\\"\n" fulltitle fulltitle))) @@ -798,35 +798,35 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." (setq dic (sort dic (lambda (x y) (string< (car x ) (car y))))) (dolist (elt dic) (insert (format "(%S\t%S)\n" (car elt) (cdr elt)))) - (let ((punctuation '((";" "$(0!'!2!"!#!.!/(B" "$(G!'!2!"!#!.!/(B") - (":" "$(0!(!+!3!%!$!&!0!1(B" "$(G!(!+!3!%!$!&!0!1(B") - ("'" "$(0!e!d(B" "$(G!e!d(B") - ("\"" "$(0!g!f!h!i!q(B" "$(G!g!f!h!i!q(B") - ("\\" "$(0"`"b#M(B" "$(G"`"b#M(B") - ("|" "$(0!6!8!:"^(B" "$(G!6!8!:"^(B") - ("/" "$(0"_"a#L(B" "$(G"_"a#L(B") - ("?" "$(0!)!4(B" "$(G!)!4(B") - ("<" "$(0!R"6"A!T"H(B" "$(G!R"6"A!T"H(B") - (">" "$(0!S"7"B!U(B" "$(G!S"7"B!U(B") - ("[" "$(0!F!J!b!H!L!V!Z!X!\(B" "$(G!F!J!b!H!L!V!Z!X!\(B") - ("]" "$(0!G!K!c!I!M!W![!Y!](B" "$(G!G!K!c!I!M!W![!Y!](B") - ("{" "$(0!B!`!D(B " "$(G!B!`!D(B ") - ("}" "$(0!C!a!E(B" "$(G!C!a!E(B") - ("`" "$(0!j!k(B" "$(G!j!k(B") - ("~" "$(0"D"+",!!^!@(B" "$(G!>!^!@(B") - (")" "$(0!?!_!A(B" "$(G!?!_!A(B") - ("-" "$(0!7!9"#"$"1"@(B" "$(G!7!9"#"$"1"@(B") - ("_" "$(0"%"&(B" "$(G"%"&(B") - ("=" "$(0"8"C(B" "$(G"8"C(B") - ("+" "$(0"0"?(B" "$(G"0"?(B")))) + (let ((punctuation '((";" "；﹔，、﹐﹑" "；﹔，、﹐﹑") + (":" "：︰﹕．。‧﹒·" "：︰﹕．。・﹒·") + ("'" "’‘" "’‘") + ("\"" "”“〝〞〃" "”“〝〞〃") + ("\\" "＼﹨╲" "＼﹨╲") + ("|" "｜︱︳∣" "︱︲｜") + ("/" "／∕╱" "／∕╱") + ("?" "？﹖" "？﹖") + ("<" "〈＜﹤︿∠" "〈＜﹤︿∠") + (">" "〉＞﹥﹀" "〉＞﹦﹀") + ("[" "〔【﹝︹︻「『﹁﹃" "〔【﹝︹︻「『﹁﹃") + ("]" "〕】﹞︺︼」』﹂﹄" "〕】﹞︺︼」』﹂﹄") + ("{" "｛﹛︷ " "｛﹛︷ ") + ("}" "｝﹜︸" "｝﹜︸") + ("`" "‵′" "′‵") + ("~" "～﹋﹌︴﹏" "∼﹋﹌") + ("!" "！﹗" "！﹗") + ("@" "＠﹫" "＠﹫") + ("#" "＃﹟" "＃﹟") + ("$" "＄﹩" "＄﹩") + ("%" "％﹪" "％﹪") + ("&" "＆﹠" "＆﹠") + ("*" "＊﹡※☆★" "＊﹡※☆★") + ("(" "（﹙︵" "（﹙︵") + (")" "）﹚︶" "）﹚︶") + ("-" "–—¯￣－﹣" "—–‾－﹣") + ("_" "＿ˍ" "＿") + ("=" "＝﹦" "＝﹥") + ("+" "＋﹢" "＋﹢")))) (dolist (elt punctuation) (insert (format "(%S %S)\n" (concat "z" (car elt)) (if big5-p (nth 1 elt) (nth 2 elt)))))) @@ -850,11 +850,11 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." (defun py-converter (dicbuf) (goto-char (point-max)) - (insert (format "%S\n" "$A::WVJdHk!KF4Rt!K(B + (insert (format "%S\n" "汉字输入∷拼音∷ - $AF4Rt7=08(B + 拼音方案 - $AP!P4S"NDWVD84z1m!8F4Rt!97{:E#,(B \"u(yu) $ATrSC(B u: $A1mJ>!C(B + 小写英文字母代表「拼音」符号， \"u(yu) 则用 u: 表示∶ Pinyin base input method for Chinese charset GB2312 (`chinese-gb2312'). @@ -868,14 +868,14 @@ character. The sequence is made by the combination of the initials iang ing iong u ua uo uai ui uan un uan ueng yu yue yuan yun (Note: In the correct Pinyin writing, the sequence \"yu\" in the last - four finals should be written by the character u-umlaut `$A(9(B'.) + four finals should be written by the character u-umlaut `ü'.) With this input method, you enter a Chinese character by first entering its pinyin spelling. \\ -For instance, to input $ADc(B, you type \"n i C-n 3\". The first \"n i\" +For instance, to input 你, you type \"n i C-n 3\". The first \"n i\" is a Pinyin, \"C-n\" selects the next group of candidates (each group contains at most 10 characters), \"3\" select the third character in that group. @@ -958,22 +958,22 @@ method `chinese-tonepy' with which you must specify tones by digits table))) (setq dic (sort dic (lambda (x y) (string< (car x) (car y))))) (goto-char (point-max)) - (insert (format "%S\n" "$A::WVJdHk!K!>WTH;!?!K(B - - $A<|EL6TUU1m(B: - $A)3)%)%)W)%)%)W)%)%)W)%)%)W)%)%)W)%)%)W)%)%)W)%)%)W)%)%)W)%)%)7(B - $A)'#Q(B $A)'#W(B $A)'#E(B $A)'#R(B $A)'#T(B $A)'#Y(B $A)'#U(Bsh$A)'#I(Bch$A)'#O(B $A)'#P(B $A)'(B - $A)'(B iu$A)'(B ua$A)'(B e$A)'(B uan$A)'(B ue$A)'(B uai$A)'(B u$A)'(B i$A)'(B o$A)'(B un$A)'(B - $A)'(B $A)'(B ia$A)'(B $A)'(B van$A)'(B ve$A)'(B ing$A)'(B $A)'(B $A)'(B uo$A)'(B vn$A)'(B - $A);)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)?(B - $A)'#A(B $A)'#S(B $A)'#D(B $A)'#F(B $A)'#G(B $A)'#H(B $A)'#J(B $A)'#K(B $A)'#L(B $A)'(B - $A)'(B a$A)'(Biong$A)'(Buang$A)'(B en$A)'(B eng$A)'(B ang$A)'(B an$A)'(B ao$A)'(B ai$A)'(B - $A)'(B $A)'(B ong$A)'(Biang$A)'(B $A)'(B ng$A)'(B $A)'(B $A)'(B $A)'(B $A)'(B - $A);)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)%)7(B - $A)'#Z(B $A)'#X(B $A)'#C(B $A)'#V(Bzh$A)'#B(B $A)'#N(B $A)'#M(B $A)'#,(B $A)'#.(B $A)'(B $A#/(B $A)'(B - $A)'(B ei$A)'(B ie$A)'(B iao$A)'(B ui$A)'(B ou$A)'(B in$A)'(B ian$A)'G0R3)':sR3)'7{:E)'(B - $A)'(B $A)'(B $A)'(B $A)'(B v$A)'(B $A)'(B $A)'(B $A)'(B $A)'(B $A)'(B $A)'(B - $A);)%)%)_)%)%)_)%)%)_)%)%)_)%)%)_)%)%)_)%)%)_)%)%)_)%)%)_)%)%)?(B + (insert (format "%S\n" "汉字输入∷【自然】∷ + + 键盘对照表: + ┏━━┳━━┳━━┳━━┳━━┳━━┳━━┳━━┳━━┳━━┓ + ┃Ｑ ┃Ｗ ┃Ｅ ┃Ｒ ┃Ｔ ┃Ｙ ┃Ｕsh┃Ｉch┃Ｏ ┃Ｐ ┃ + ┃ iu┃ ua┃ e┃ uan┃ ue┃ uai┃ u┃ i┃ o┃ un┃ + ┃ ┃ ia┃ ┃ van┃ ve┃ ing┃ ┃ ┃ uo┃ vn┃ + ┗┳━┻┳━┻┳━┻┳━┻┳━┻┳━┻┳━┻┳━┻┳━┻┳━┛ + ┃Ａ ┃Ｓ ┃Ｄ ┃Ｆ ┃Ｇ ┃Ｈ ┃Ｊ ┃Ｋ ┃Ｌ ┃ + ┃ a┃iong┃uang┃ en┃ eng┃ ang┃ an┃ ao┃ ai┃ + ┃ ┃ ong┃iang┃ ┃ ng┃ ┃ ┃ ┃ ┃ + ┗┳━┻┳━┻┳━┻┳━┻┳━┻┳━┻┳━┻┳━┻┳━┻┳━━┓ + ┃Ｚ ┃Ｘ ┃Ｃ ┃Ｖzh┃Ｂ ┃Ｎ ┃Ｍ ┃， ┃． ┃ ／ ┃ + ┃ ei┃ ie┃ iao┃ ui┃ ou┃ in┃ ian┃前页┃后页┃符号┃ + ┃ ┃ ┃ ┃ v┃ ┃ ┃ ┃ ┃ ┃ ┃ + ┗━━┻━━┻━━┻━━┻━━┻━━┻━━┻━━┻━━┻━━┛ Pinyin base input method for Chinese GB2312 characters (`chinese-gb2312'). @@ -985,34 +985,34 @@ method `chinese-py'. Unlike the standard spelling of Pinyin, in this input method all initials and finals are assigned to single keys (see the above table). For instance, the initial \"ch\" is assigned to the key `i', the final -\"iu\" is assigned to the key `q', and tones 1, 2, 3, 4, and $AGaIy(B are +\"iu\" is assigned to the key `q', and tones 1, 2, 3, 4, and 轻声 are assigned to the keys `q', `w', `e', `r', `t' respectively. \\ To input one-letter words, you type 4 keys, the first two for the Pinyin of the letter, next one for tone, and the last one is always a -quote ('). For instance, \"vsq'\" input $AVP(B. Exceptions are these +quote ('). For instance, \"vsq'\" input 中. Exceptions are these letters. You can input them just by typing a single key. - Character: $A04(B $A2;(B $A4N(B $A5D(B $A6~(B $A7"(B $A8v(B $A:M(B $A3v(B $A<0(B $A?I(B $AAK(B $AC;(B + Character: 按 不 次 的 二 发 个 和 出 及 可 了 没 Key: a b c d e f g h i j k l m - Character: $ADc(B $AE7(B $AF,(B $AF_(B $AHK(B $AH}(B $AK{(B $AJG(B $AWE(B $ANR(B $AP!(B $AR;(B $ATZ(B + Character: 你 欧 片 七 人 三 他 是 着 我 小 一 在 Key: n o p q r s t u v w x y z To input two-letter words, you have two ways. One way is to type 4 keys, two for the first Pinyin, two for the second Pinyin. For -instance, \"vsgo\" inputs $AVP9z(B. Another way is to type 3 keys: 2 +instance, \"vsgo\" inputs 中国. Another way is to type 3 keys: 2 initials of two letters, and quote ('). For instance, \"vg'\" also -inputs $AVP9z(B. +inputs 中国. To input three-letter words, you type 4 keys: initials of three -letters, and the last is quote ('). For instance, \"bjy'2\" inputs $A11(B -$A>)Q<(B (the last `2' is to select one of the candidates). +letters, and the last is quote ('). For instance, \"bjy'2\" inputs 北 +京鸭 (the last `2' is to select one of the candidates). To input words of more than three letters, you type 4 keys, initials of the first three letters and the last letter. For instance, -\"bjdt\" inputs $A11>)5gJSL((B. +\"bjdt\" inputs 北京电视台. To input symbols and punctuation, type `/' followed by one of `a' to `z', then select one of the candidates.")) @@ -1059,7 +1059,7 @@ To input symbols and punctuation, type `/' followed by one of `a' to ;; which the file is converted have no Big5 equivalent. Go ;; through and delete them. (goto-char pos) - (while (search-forward "$(0!{(B" nil t) + (while (search-forward "□" nil t) (delete-char -1)) ;; Uppercase keys in dictionary need to be downcased. Backslashes ;; at the beginning of keys need to be turned into double @@ -1083,31 +1083,31 @@ To input symbols and punctuation, type `/' followed by one of `a' to (defun ctlau-gb-converter (dicbuf) (ctlau-converter dicbuf -"$A::WVJdHk!KAuN}OiJ=TARt!K(B +"汉字输入∷刘锡祥式粤音∷ - $AAuN}OiJ=TASoW"Rt7=08(B + 刘锡祥式粤语注音方案 Sidney Lau's Cantonese transcription scheme as described in his book \"Elementary Cantonese\", The Government Printer, Hong Kong, 1972. - This file was prepared by Fung Fung Lee ($A@n7c7e(B). + This file was prepared by Fung Fung Lee (李枫峰). Originally converted from CTCPS3.tit Last modified: June 2, 1993. Some infrequent GB characters are accessed by typing \\, followed by - the Cantonese romanization of the respective radical ($A2?JW(B).")) + the Cantonese romanization of the respective radical (部首).")) (defun ctlau-b5-converter (dicbuf) (ctlau-converter dicbuf -"$(0KH)tTT&,!(N,Tg>A*#Gn5x!((B +"漢字輸入：劉錫祥式粵音： - $(0N,Tg>A*#GnM$0D5x'J7{(B + 劉錫祥式粵語注音方案 Sidney Lau's Cantonese transcription scheme as described in his book \"Elementary Cantonese\", The Government Printer, Hong Kong, 1972. - This file was prepared by Fung Fung Lee ($(0,XFS76(B). + This file was prepared by Fung Fung Lee (李楓峰). Originally converted from CTCPS3.tit Last modified: June 2, 1993. Some infrequent characters are accessed by typing \\, followed by - the Cantonese romanization of the respective radical ($(0?f5}(B).")) + the Cantonese romanization of the respective radical (部首).")) (declare-function dos-8+3-filename "dos-fns.el" (filename)) -- cgit v1.2.3 From 2d8daac122e71dd5ee69a991c9c1dd0d31c2433f Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 27 Jan 2021 12:35:19 -0500 Subject: * lisp/international/titdic-cnv.el (tsang-quick-converter): Simplify Merge branches which only differed in the `charset` property of the strings they intended to return, since that info gets lost later on anyway. --- lisp/international/titdic-cnv.el | 24 +++++------------------- 1 file changed, 5 insertions(+), 19 deletions(-) (limited to 'lisp') diff --git a/lisp/international/titdic-cnv.el b/lisp/international/titdic-cnv.el index 84e218f1799..ce5c04293ad 100644 --- a/lisp/international/titdic-cnv.el +++ b/lisp/international/titdic-cnv.el @@ -375,7 +375,7 @@ SPC, 6, 3, 4, or 7 specifying a tone (SPC:陰平, 6:陽平, 3:上聲, 4:去聲, ;; Arg DOCSTRING (let ((doc (concat tit-prompt "\n")) (comments (if tit-comments - (mapconcat 'identity (nreverse tit-comments) "\n"))) + (mapconcat #'identity (nreverse tit-comments) "\n"))) (doc-ext (nth 2 (assoc package quail-cxterm-package-ext-info)))) (if comments (setq doc (concat doc "\n" comments "\n"))) @@ -737,12 +737,10 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ;; method is for inputting CNS characters. (defun tsang-quick-converter (dicbuf tsang-p big5-p) - (let ((fulltitle (if tsang-p (if big5-p "倉頡" "倉頡") - (if big5-p "簡易" "簡易"))) + (let ((fulltitle (if tsang-p "倉頡" "簡易")) dic) (goto-char (point-max)) - (if big5-p - (insert (format "\"中文輸入【%s】BIG5 + (insert (format "\"中文輸入【%s】%s 漢語%s輸入鍵盤 @@ -753,19 +751,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." [Z ] [X 難] [C 金] [V 女] [B 月] [N 弓] [M 一] \\\\\"\n" - fulltitle fulltitle)) - (insert (format "\"中文輸入【%s】CNS - - 漢語%s輸入鍵盤 - - [Q 手] [W 田] [E 水] [R 口] [T 廿] [Y 卜] [U 山] [I 戈] [O 人] [P 心] - - [A 日] [S 尸] [D 木] [F 火] [G 土] [H 竹] [J 十] [L 中] - - [Z ] [X 難] [C 金] [V 女] [B 月] [N 弓] [M 一] - -\\\\\"\n" - fulltitle fulltitle))) + fulltitle (if big5-p "BIG5" "CNS") fulltitle)) (insert " '((\".\" . quail-next-translation-block) (\",\" . quail-prev-translation-block)) nil nil)\n\n") @@ -953,7 +939,7 @@ method `chinese-tonepy' with which you must specify tones by digits (= (length (aref trans i)) 1)) (setq i (1+ i))) (if (= i len) - (setq trans (mapconcat 'identity trans ""))))) + (setq trans (mapconcat #'identity trans ""))))) (setq dic (cons (cons key trans) dic))) table))) (setq dic (sort dic (lambda (x y) (string< (car x) (car y))))) -- cgit v1.2.3 From 85f8b575001ec8c3503d7e8746862e49c0c7a3bf Mon Sep 17 00:00:00 2001 From: Juri Linkov Date: Wed, 27 Jan 2021 20:08:43 +0200 Subject: Support multi-line prompt and contents in previous-line-or-history-element. * lisp/simple.el (previous-line-or-history-element): Move to the beginning of minibuffer contents if there is editable minibuffer contents on the same line after moving point to the prompt (bug#46033). Fix minimal old-column from 0 to 1 to put point at the beginning of minibuffer contents after going to the previous history element. --- lisp/simple.el | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) (limited to 'lisp') diff --git a/lisp/simple.el b/lisp/simple.el index c878fdab921..e82b138b0da 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -2472,14 +2472,24 @@ previous element of the minibuffer history in the minibuffer." (save-excursion (goto-char (1- prompt-end)) (current-column))) - 0) + 1) (current-column))))) (condition-case nil (with-no-warnings (previous-line arg) ;; Avoid moving point to the prompt (when (< (point) (minibuffer-prompt-end)) - (signal 'beginning-of-buffer nil))) + ;; If there is minibuffer contents on the same line + (if (<= (minibuffer-prompt-end) + (save-excursion + (if (or truncate-lines (not line-move-visual)) + (end-of-line) + (end-of-visual-line)) + (point))) + ;; Move to the beginning of minibuffer contents + (goto-char (minibuffer-prompt-end)) + ;; Otherwise, go to the previous history element + (signal 'beginning-of-buffer nil)))) (beginning-of-buffer ;; Restore old position since `line-move-visual' moves point to ;; the beginning of the line when it fails to go to the previous line. -- cgit v1.2.3 From 9f25ca5107fdb0b6da268d0a41a30aa2e55a1c64 Mon Sep 17 00:00:00 2001 From: Juri Linkov Date: Wed, 27 Jan 2021 20:33:13 +0200 Subject: * lisp/replace.el (query-replace-read-from-suggestions): New function. (query-replace-read-from): Use it instead of hard-coded '(car search-ring)'. (read-regexp-suggestions): Add the active region (bug#41692). --- lisp/replace.el | 27 +++++++++++++++++++++++---- 1 file changed, 23 insertions(+), 4 deletions(-) (limited to 'lisp') diff --git a/lisp/replace.el b/lisp/replace.el index 4483d7f7800..cbf24bedef4 100644 --- a/lisp/replace.el +++ b/lisp/replace.el @@ -186,6 +186,21 @@ See `replace-regexp' and `query-replace-regexp-eval'.") length) length))))) +(defun query-replace-read-from-suggestions () + "Return a list of standard suggestions for `query-replace-read-from'. +By default, the list includes the active region, the identifier +(a.k.a. \"tag\") at point (see Info node `(emacs) Identifier Search'), +the last isearch string, and the last replacement regexp. +`query-replace-read-from' appends the list returned +by this function to the end of values available via +\\\\[next-history-element]." + (delq nil (list (when (use-region-p) + (buffer-substring-no-properties + (region-beginning) (region-end))) + (find-tag-default) + (car search-ring) + (car (symbol-value query-replace-from-history-variable))))) + (defun query-replace-read-from (prompt regexp-flag) "Query and return the `from' argument of a query-replace operation. Prompt with PROMPT. REGEXP-FLAG non-nil means the response should be a regexp. @@ -242,7 +257,8 @@ wants to replace FROM with TO." (if regexp-flag (read-regexp prompt nil 'minibuffer-history) (read-from-minibuffer - prompt nil nil nil nil (car search-ring) t))))) + prompt nil nil nil nil + (query-replace-read-from-suggestions) t))))) (to)) (if (and (zerop (length from)) query-replace-defaults) (cons (caar query-replace-defaults) @@ -808,13 +824,16 @@ the function that you set this to can check `this-command'." (defun read-regexp-suggestions () "Return a list of standard suggestions for `read-regexp'. -By default, the list includes the identifier (a.k.a. \"tag\") -at point (see Info node `(emacs) Identifier Search'), the last -isearch regexp, the last isearch string, and the last +By default, the list includes the active region, the identifier +(a.k.a. \"tag\") at point (see Info node `(emacs) Identifier Search'), +the last isearch regexp, the last isearch string, and the last replacement regexp. `read-regexp' appends the list returned by this function to the end of values available via \\\\[next-history-element]." (list + (when (use-region-p) + (buffer-substring-no-properties + (region-beginning) (region-end))) (find-tag-default-as-regexp) (find-tag-default-as-symbol-regexp) (car regexp-search-ring) -- cgit v1.2.3 From d168110a322389a9f991d7a5bdd1cf777642c990 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 27 Jan 2021 17:35:28 -0500 Subject: * lisp/emacs-lisp/macroexp.el (macroexp--expand-all): Perform β-reduction MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Also, in `funcall` macroexpand the function before checking to see if we can remove the `funcall`. (macroexp-if): Trim trailing `nil` in the generated code while we're at it. --- lisp/emacs-lisp/macroexp.el | 39 ++++++++++++++++++++++++++++----------- 1 file changed, 28 insertions(+), 11 deletions(-) (limited to 'lisp') diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index aa49bccc8d0..78f0b636a74 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -241,9 +241,22 @@ Assumes the caller has bound `macroexpand-all-environment'." form)) (`(,(and fun `(lambda . ,_)) . ,args) ;; Embedded lambda in function position. - (macroexp--cons (macroexp--all-forms fun 2) - (macroexp--all-forms args) - form)) + ;; If the byte-optimizer is loaded, try to unfold this, + ;; i.e. rewrite it to (let () ). We'd do it in the optimizer + ;; anyway, but doing it here (i.e. earlier) can sometimes avoid the + ;; creation of a closure, thus resulting in much better code. + (let ((newform (if (not (fboundp 'byte-compile-unfold-lambda)) + 'macroexp--not-unfolded + ;; Don't unfold if byte-opt is not yet loaded. + (byte-compile-unfold-lambda form)))) + (if (or (eq newform 'macroexp--not-unfolded) + (eq newform form)) + ;; Unfolding failed for some reason, avoid infinite recursion. + (macroexp--cons (macroexp--all-forms fun 2) + (macroexp--all-forms args) + form) + (macroexp--expand-all newform)))) + ;; The following few cases are for normal function calls that ;; are known to funcall one of their arguments. The byte ;; compiler has traditionally handled these functions specially @@ -257,17 +270,21 @@ Assumes the caller has bound `macroexpand-all-environment'." (macroexp--warn-and-return (format "%s quoted with ' rather than with #'" (list 'lambda (nth 1 f) '...)) - (macroexp--expand-all `(,fun ,f . ,args)))) + (macroexp--expand-all `(,fun #',f . ,args)))) ;; Second arg is a function: (`(,(and fun (or 'sort)) ,arg1 ',(and f `(lambda . ,_)) . ,args) (macroexp--warn-and-return (format "%s quoted with ' rather than with #'" (list 'lambda (nth 1 f) '...)) - (macroexp--expand-all `(,fun ,arg1 ,f . ,args)))) - (`(funcall #',(and f (pred symbolp)) . ,args) - ;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo' - ;; has a compiler-macro. - (macroexp--expand-all `(,f . ,args))) + (macroexp--expand-all `(,fun ,arg1 #',f . ,args)))) + (`(funcall ,exp . ,args) + (let ((eexp (macroexp--expand-all exp)) + (eargs (macroexp--all-forms args))) + ;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo' + ;; has a compiler-macro, or to unfold it. + (pcase eexp + (`#',f (macroexp--expand-all `(,f . ,eargs))) + (_ `(funcall ,eexp . ,eargs))))) (`(,func . ,_) ;; Macro expand compiler macros. This cannot be delayed to ;; byte-optimize-form because the output of the compiler-macro can @@ -360,12 +377,12 @@ Never returns an empty list." (t `(cond (,test ,@(macroexp-unprogn then)) (,(nth 1 else) ,@(macroexp-unprogn (nth 2 else))) - (t ,@(nthcdr 3 else)))))) + ,@(let ((def (nthcdr 3 else))) (if def '((t ,@def)))))))) ((eq (car-safe else) 'cond) `(cond (,test ,@(macroexp-unprogn then)) ,@(cdr else))) ;; Invert the test if that lets us reduce the depth of the tree. ((memq (car-safe then) '(if cond)) (macroexp-if `(not ,test) else then)) - (t `(if ,test ,then ,@(macroexp-unprogn else))))) + (t `(if ,test ,then ,@(if else (macroexp-unprogn else)))))) (defmacro macroexp-let2 (test sym exp &rest body) "Evaluate BODY with SYM bound to an expression for EXP's value. -- cgit v1.2.3 From d93bca019713e98228aca9f4d1a4838a72b1cf92 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 27 Jan 2021 18:51:09 -0500 Subject: * lisp/emacs-lisp/pcase.el (pcase--split-pred): Handle `memq` pred. Improve handling of the `member` tests generated from (or 'a 'b 'c). This will expand (pcase EXP ((and (or 1 2 3) (guard (FOO))) EXP1) (1 EXP2) (6 EXP3)) to (cond ((memql '(3 2 1) EXP) (cond ((FOO) EXP1) ((eql EXP 1) EXP2))) ((eql EXP 6) EXP3)) rather than to (cond ((memql '(3 2 1) EXP) (cond ((FOO) EXP1) ((eql EXP 1) EXP2) ((eql EXP 6) EXP3))) ((eql EXP 1) EXP2) ((eql EXP 6) EXP3)) --- lisp/emacs-lisp/pcase.el | 44 +++++++++++++++++++++++++++----------------- 1 file changed, 27 insertions(+), 17 deletions(-) (limited to 'lisp') diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index bfd577c5d14..cf129c453ec 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -683,11 +683,6 @@ A and B can be one of: ;; and catch at least the easy cases such as (bug#14773). (not (macroexp--fgrep (mapcar #'car vars) (cadr upat))))) '(:pcase--succeed . :pcase--fail)) - ;; In case UPAT is of the form (pred (not PRED)) - ((and (eq 'pred (car upat)) (eq 'not (car-safe (cadr upat)))) - (let* ((test (cadr (cadr upat))) - (res (pcase--split-pred vars `(pred ,test) pat))) - (cons (cdr res) (car res)))) ;; In case PAT is of the form (pred (not PRED)) ((and (eq 'pred (car-safe pat)) (eq 'not (car-safe (cadr pat)))) (let* ((test (cadr (cadr pat))) @@ -696,19 +691,34 @@ A and B can be one of: ((eq x :pcase--fail) :pcase--succeed))))) (cons (funcall reverse (car res)) (funcall reverse (cdr res))))) - ((and (eq 'pred (car upat)) - (let ((otherpred - (cond ((eq 'pred (car-safe pat)) (cadr pat)) - ((not (eq 'quote (car-safe pat))) nil) - ((consp (cadr pat)) #'consp) - ((stringp (cadr pat)) #'stringp) - ((vectorp (cadr pat)) #'vectorp) - ((byte-code-function-p (cadr pat)) - #'byte-code-function-p)))) - (pcase--mutually-exclusive-p (cadr upat) otherpred))) + ;; All the rest below presumes UPAT is of the form (pred ...). + ((not (eq 'pred (car upat))) nil) + ;; In case UPAT is of the form (pred (not PRED)) + ((eq 'not (car-safe (cadr upat))) + (let* ((test (cadr (cadr upat))) + (res (pcase--split-pred vars `(pred ,test) pat))) + (cons (cdr res) (car res)))) + ((let ((otherpred + (cond ((eq 'pred (car-safe pat)) (cadr pat)) + ((not (eq 'quote (car-safe pat))) nil) + ((consp (cadr pat)) #'consp) + ((stringp (cadr pat)) #'stringp) + ((vectorp (cadr pat)) #'vectorp) + ((byte-code-function-p (cadr pat)) + #'byte-code-function-p)))) + (pcase--mutually-exclusive-p (cadr upat) otherpred)) '(:pcase--fail . nil)) - ((and (eq 'pred (car upat)) - (eq 'quote (car-safe pat)) + ;; Since we turn (or 'a 'b 'c) into (pred (pcase--flip (memq '(a b c)))) + ;; try and preserve the info we get from that memq test. + ((and (eq 'pcase--flip (car-safe (cadr upat))) + (memq (cadr (cadr upat)) '(memq member memql)) + (eq 'quote (car-safe (nth 2 (cadr upat)))) + (eq 'quote (car-safe pat))) + (let ((set (cadr (nth 2 (cadr upat))))) + (if (member (cadr pat) set) + '(nil . :pcase--fail) + '(:pcase--fail . nil)))) + ((and (eq 'quote (car-safe pat)) (symbolp (cadr upat)) (or (symbolp (cadr pat)) (stringp (cadr pat)) (numberp (cadr pat))) (get (cadr upat) 'side-effect-free) -- cgit v1.2.3 From 30914167fd49e208c483541663f0275253e42227 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 27 Jan 2021 18:53:58 -0500 Subject: * lisp/emacs-lisp/macroexp.el (macroexp-if): Fix typo --- lisp/emacs-lisp/macroexp.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 78f0b636a74..e842222b7c3 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -377,7 +377,7 @@ Never returns an empty list." (t `(cond (,test ,@(macroexp-unprogn then)) (,(nth 1 else) ,@(macroexp-unprogn (nth 2 else))) - ,@(let ((def (nthcdr 3 else))) (if def '((t ,@def)))))))) + ,@(let ((def (nthcdr 3 else))) (if def `((t ,@def)))))))) ((eq (car-safe else) 'cond) `(cond (,test ,@(macroexp-unprogn then)) ,@(cdr else))) ;; Invert the test if that lets us reduce the depth of the tree. -- cgit v1.2.3 From 2a71831eb3dcd122ee4f91254b31a801922c7917 Mon Sep 17 00:00:00 2001 From: João Távora Date: Thu, 28 Jan 2021 04:18:12 +0100 Subject: Allow project/xref packages to be used in Emacs 26.1 * lisp/progmodes/project.el: Change Package-Requires to Emacs 26.1 (bug#44671). * lisp/progmodes/xref.el: Ditto. --- lisp/progmodes/project.el | 4 ++-- lisp/progmodes/xref.el | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) (limited to 'lisp') diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 768cd58ae44..fc5e30111e5 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -1,8 +1,8 @@ ;;; project.el --- Operations on the current project -*- lexical-binding: t; -*- ;; Copyright (C) 2015-2021 Free Software Foundation, Inc. -;; Version: 0.5.3 -;; Package-Requires: ((emacs "26.3") (xref "1.0.2")) +;; Version: 0.5.4 +;; Package-Requires: ((emacs "26.1") (xref "1.0.2")) ;; This is a GNU ELPA :core package. Avoid using functionality that ;; not compatible with the version of Emacs recorded above. diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index 898cb4fb4c1..07a65d4ed93 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2014-2021 Free Software Foundation, Inc. ;; Version: 1.0.4 -;; Package-Requires: ((emacs "26.3")) +;; Package-Requires: ((emacs "26.1")) ;; This is a GNU ELPA :core package. Avoid functionality that is not ;; compatible with the version of Emacs recorded above. -- cgit v1.2.3 From 9b01bc568278a939bd7e36a37623153d07171894 Mon Sep 17 00:00:00 2001 From: Harald Jörg Date: Thu, 28 Jan 2021 04:22:21 +0100 Subject: perl-mode.el: Eliminate keywords which are not in Perl. * lisp/progmodes/perl-mode.el (perl-imenu-generic-expression): Remove keywords which are not part of Perl. (perl-font-lock-keywords-2): Remove keywords which are not part of Perl (bug#46024). (These keywords are part of Raku; aka. Perl 6.) --- lisp/progmodes/perl-mode.el | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) (limited to 'lisp') diff --git a/lisp/progmodes/perl-mode.el b/lisp/progmodes/perl-mode.el index d047dd543c2..0120e4a7cd1 100644 --- a/lisp/progmodes/perl-mode.el +++ b/lisp/progmodes/perl-mode.el @@ -143,7 +143,7 @@ '(;; Functions (nil "^[ \t]*sub\\s-+\\([-[:alnum:]+_:]+\\)" 1) ;;Variables - ("Variables" "^[ \t]*\\(?:anon\\|argument\\|has\\|local\\|my\\|our\\|state\\|supersede\\)\\s-+\\([$@%][-[:alnum:]+_:]+\\)\\s-*=" 1) + ("Variables" "^[ \t]*\\(?:has\\|local\\|my\\|our\\|state\\)\\s-+\\([$@%][-[:alnum:]+_:]+\\)\\s-*=" 1) ("Packages" "^[ \t]*package\\s-+\\([-[:alnum:]+_:]+\\);" 1) ("Doc sections" "^=head[0-9][ \t]+\\(.*\\)" 1)) "Imenu generic expression for Perl mode. See `imenu-generic-expression'.") @@ -188,9 +188,8 @@ "\\>") ;; ;; Fontify declarators and prefixes as types. - ("\\<\\(anon\\|argument\\|has\\|local\\|my\\|our\\|state\\|supersede\\)\\>" . font-lock-type-face) ; declarators - ("\\<\\(let\\|temp\\)\\>" . font-lock-type-face) ; prefixes - ;; + ("\\<\\(has\\|local\\|my\\|our\\|state\\)\\>" . font-lock-type-face) ; declarators + ;; ;; Fontify function, variable and file name references. ("&\\(\\sw+\\(::\\sw+\\)*\\)" 1 font-lock-function-name-face) ;; Additionally fontify non-scalar variables. `perl-non-scalar-variable' -- cgit v1.2.3 From e4c667079086528c6e0a9eead9c2d4d5f5b7c6e1 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 28 Jan 2021 06:21:40 +0100 Subject: Fix Gnus icalendar button navigation * lisp/gnus/gnus-icalendar.el (gnus-icalendar-insert-button): Mark buttons correctly for TAB navigation (bug#46135). --- lisp/gnus/gnus-icalendar.el | 1 + 1 file changed, 1 insertion(+) (limited to 'lisp') diff --git a/lisp/gnus/gnus-icalendar.el b/lisp/gnus/gnus-icalendar.el index 1e0e2071018..9811e8b440f 100644 --- a/lisp/gnus/gnus-icalendar.el +++ b/lisp/gnus/gnus-icalendar.el @@ -835,6 +835,7 @@ These will be used to retrieve the RSVP information from ical events." keymap ,gnus-mime-button-map face ,gnus-article-button-face follow-link t + category t button t gnus-data ,data)))) -- cgit v1.2.3 From 0870ebb3cbfcb097d85eea5eacaf992dd88ed204 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 28 Jan 2021 07:09:18 +0100 Subject: Allow commenting out white space lines in latex-mode * lisp/newcomment.el (comment-region-default-1): Allow commenting out whitespace-only regions (bug#41793). * lisp/textmodes/tex-mode.el (latex--comment-region): Use it. (latex-mode): Set a comment style shim. --- lisp/newcomment.el | 30 +++++++++++++++++++++--------- lisp/textmodes/tex-mode.el | 7 ++++++- 2 files changed, 27 insertions(+), 10 deletions(-) (limited to 'lisp') diff --git a/lisp/newcomment.el b/lisp/newcomment.el index 5d0d1053f4b..4216fc1a397 100644 --- a/lisp/newcomment.el +++ b/lisp/newcomment.el @@ -1221,21 +1221,33 @@ changed with `comment-style'." ;; FIXME: maybe we should call uncomment depending on ARG. (funcall comment-region-function beg end arg))) -(defun comment-region-default-1 (beg end &optional arg) +(defun comment-region-default-1 (beg end &optional arg noadjust) + "Comment region between BEG and END. +See `comment-region' for ARG. If NOADJUST, do not skip past +leading/trailing space when determining the region to comment +out." (let* ((numarg (prefix-numeric-value arg)) (style (cdr (assoc comment-style comment-styles))) (lines (nth 2 style)) (block (nth 1 style)) (multi (nth 0 style))) - ;; We use `chars' instead of `syntax' because `\n' might be - ;; of end-comment syntax rather than of whitespace syntax. - ;; sanitize BEG and END - (goto-char beg) (skip-chars-forward " \t\n\r") (beginning-of-line) - (setq beg (max beg (point))) - (goto-char end) (skip-chars-backward " \t\n\r") (end-of-line) - (setq end (min end (point))) - (if (>= beg end) (error "Nothing to comment")) + (if noadjust + (when (bolp) + (setq end (1- end))) + ;; We use `chars' instead of `syntax' because `\n' might be + ;; of end-comment syntax rather than of whitespace syntax. + ;; sanitize BEG and END + (goto-char beg) + (skip-chars-forward " \t\n\r") + (beginning-of-line) + (setq beg (max beg (point))) + (goto-char end) + (skip-chars-backward " \t\n\r") + (end-of-line) + (setq end (min end (point))) + (when (>= beg end) + (error "Nothing to comment"))) ;; sanitize LINES (setq lines diff --git a/lisp/textmodes/tex-mode.el b/lisp/textmodes/tex-mode.el index c4e4864da17..ce665e61656 100644 --- a/lisp/textmodes/tex-mode.el +++ b/lisp/textmodes/tex-mode.el @@ -1169,7 +1169,12 @@ subshell is initiated, `tex-shell-hook' is run." (setq-local outline-regexp latex-outline-regexp) (setq-local outline-level #'latex-outline-level) (setq-local forward-sexp-function #'latex-forward-sexp) - (setq-local skeleton-end-hook nil)) + (setq-local skeleton-end-hook nil) + (setq-local comment-region-function #'latex--comment-region) + (setq-local comment-style 'plain)) + +(defun latex--comment-region (beg end &optional arg) + (comment-region-default-1 beg end arg t)) ;;;###autoload (define-derived-mode slitex-mode latex-mode "SliTeX" -- cgit v1.2.3 From e7e7ef15886ce28d1d1873164e7ee17a6a5878e0 Mon Sep 17 00:00:00 2001 From: Mattias M Date: Thu, 28 Jan 2021 07:34:10 +0100 Subject: Fix fill-paragraph in asm-mode * lisp/progmodes/asm-mode.el: The value of fill-prefix ought to be nil not "\t" so that fill-context-prefix can do its thing. In fact, fill-prefix does not have to be set at all becuase asm-mode derives from prog-mode and fill-prefix is set in simple.el. * test/lisp/progmodes/asm-mode-tests.el: Add relevant test (bug#41064). Copyright-paperwork-exempt: yes --- lisp/progmodes/asm-mode.el | 3 +-- test/lisp/progmodes/asm-mode-tests.el | 10 ++++++++++ 2 files changed, 11 insertions(+), 2 deletions(-) (limited to 'lisp') diff --git a/lisp/progmodes/asm-mode.el b/lisp/progmodes/asm-mode.el index 62ff783fbac..99b2ec6d87e 100644 --- a/lisp/progmodes/asm-mode.el +++ b/lisp/progmodes/asm-mode.el @@ -141,8 +141,7 @@ Special commands: (setq-local comment-add 1) (setq-local comment-start-skip "\\(?:\\s<+\\|/[/*]+\\)[ \t]*") (setq-local comment-end-skip "[ \t]*\\(\\s>\\|\\*+/\\)") - (setq-local comment-end "") - (setq fill-prefix "\t")) + (setq-local comment-end "")) (defun asm-indent-line () "Auto-indent the current line." diff --git a/test/lisp/progmodes/asm-mode-tests.el b/test/lisp/progmodes/asm-mode-tests.el index 6ae4fdf5850..87872179d93 100644 --- a/test/lisp/progmodes/asm-mode-tests.el +++ b/test/lisp/progmodes/asm-mode-tests.el @@ -69,4 +69,14 @@ (should (string-match-p ";;; \nlabel:" (buffer-string))) (should (= (current-column) 4)))) +(ert-deftest asm-mode-tests-fill-comment () + (asm-mode-tests--with-temp-buffer + (call-interactively #'comment-dwim) + (insert "Pellentesque condimentum, magna ut suscipit hendrerit, \ +ipsum augue ornare nulla, non luctus diam neque sit amet urna.") + (call-interactively #'fill-paragraph) + (should (equal (buffer-string) "\t;; Pellentesque condimentum, \ +magna ut suscipit hendrerit,\n\t;; ipsum augue ornare nulla, non \ +luctus diam neque sit amet\n\t;; urna.")))) + ;;; asm-mode-tests.el ends here -- cgit v1.2.3 From 8992f8abf348b5b4eb2b2074d00b9c9aaaa6df17 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 28 Jan 2021 08:40:15 +0100 Subject: Make the default `whitespace-enable-predicate' use `derived-mode-p' * lisp/whitespace.el (whitespace-enable-predicate): Use `derived-mode-p' to check modes instead of `eq' (bug#40481). --- etc/NEWS | 5 +++++ lisp/whitespace.el | 4 ++-- 2 files changed, 7 insertions(+), 2 deletions(-) (limited to 'lisp') diff --git a/etc/NEWS b/etc/NEWS index e038076e96c..f12c94d6491 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1098,6 +1098,11 @@ If present in 'whitespace-style' (as it is by default), the final character in the buffer will be highlighted if the buffer doesn't end with a newline. +--- +*** The default 'whitespace-enable-predicate' predicate has changed. +It used to check elements in the list version of +'whitespace-global-modes' with 'eq', but now uses 'derived-mode-p'. + ** Texinfo --- diff --git a/lisp/whitespace.el b/lisp/whitespace.el index 7b8e5b7cc11..22bfae06975 100644 --- a/lisp/whitespace.el +++ b/lisp/whitespace.el @@ -1000,8 +1000,8 @@ See also `whitespace-style', `whitespace-newline' and ((eq whitespace-global-modes t)) ((listp whitespace-global-modes) (if (eq (car-safe whitespace-global-modes) 'not) - (not (memq major-mode (cdr whitespace-global-modes))) - (memq major-mode whitespace-global-modes))) + (not (apply #'derived-mode-p (cdr whitespace-global-modes))) + (apply #'derived-mode-p whitespace-global-modes))) (t nil)) ;; ...we have a display (not running a batch job) (not noninteractive) -- cgit v1.2.3 From 64d464886983378b9fa62a38b31ec6fc996f587b Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 28 Jan 2021 09:57:48 +0100 Subject: Fix numerical `comment-padding' value * lisp/newcomment.el (comment-padright): Allow using a number for `comment-padding', like the doc string says (bug#40056). --- lisp/newcomment.el | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) (limited to 'lisp') diff --git a/lisp/newcomment.el b/lisp/newcomment.el index 4216fc1a397..ea47eec4fda 100644 --- a/lisp/newcomment.el +++ b/lisp/newcomment.el @@ -832,12 +832,17 @@ Ensure that `comment-normalize-vars' has been called before you use this." (when (and (stringp str) (string-match "\\S-" str)) ;; Separate the actual string from any leading/trailing padding (string-match "\\`\\s-*\\(.*?\\)\\s-*\\'" str) - (let ((s (match-string 1 str)) ;actual string + (let ((s (match-string 1 str)) ;actual string (lpad (substring str 0 (match-beginning 1))) ;left padding - (rpad (concat (substring str (match-end 1)) ;original right padding - (substring comment-padding ;additional right padding - (min (- (match-end 0) (match-end 1)) - (length comment-padding))))) + (rpad (concat + (substring str (match-end 1)) ;original right padding + (if (numberp comment-padding) + (make-string (min comment-padding + (- (match-end 0) (match-end 1))) + ?\s) + (substring comment-padding ;additional right padding + (min (- (match-end 0) (match-end 1)) + (length comment-padding)))))) ;; We can only duplicate C if the comment-end has multiple chars ;; or if comments can be nested, else the comment-end `}' would ;; be turned into `}}}' where only the first ends the comment @@ -852,7 +857,7 @@ Ensure that `comment-normalize-vars' has been called before you use this." (concat (mapconcat (lambda (c) (concat (regexp-quote (string c)) "?")) lpad "") ;padding is not required (regexp-quote s) - (when multi "+") ;the last char of S might be repeated + (when multi "+") ;the last char of S might be repeated (mapconcat (lambda (c) (concat (regexp-quote (string c)) "?")) rpad "")))))) ;padding is not required -- cgit v1.2.3 From 0120f45db630753bc8c4d6c43f7cdb7f953144fd Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 28 Jan 2021 13:10:45 +0100 Subject: Protect against bad results from libravatar * lisp/image/gravatar.el (gravatar--service-libravatar): Don't have (gravatar-retrieve "foobar@zjp.codes" 'ignore) (which returns a CNAME) bug out. --- lisp/image/gravatar.el | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) (limited to 'lisp') diff --git a/lisp/image/gravatar.el b/lisp/image/gravatar.el index 4f37834a27f..b1e2a314ce8 100644 --- a/lisp/image/gravatar.el +++ b/lisp/image/gravatar.el @@ -160,12 +160,16 @@ to track whether you're reading a specific mail." (cond ((and result ;there is a result - (let* ((data (mapcar (lambda (record) + (let* ((answers (dns-get 'answers result)) + (data (mapcar (lambda (record) (dns-get 'data (cdr record))) - (dns-get 'answers result))) - (priorities (mapcar (lambda (r) - (dns-get 'priority r)) - data)) + ;; We may get junk data back (or CNAME; + ;; ignore). + (and (eq (dns-get 'type answers) 'SRV) + answers))) + (priorities (and (mapcar (lambda (r) + (dns-get 'priority r)) + data))) (max-priority (if priorities (apply #'max priorities) 0)) -- cgit v1.2.3 From 62233c9824047e989cb72c8e2d05e4b4444fe0be Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 28 Jan 2021 08:43:01 -0500 Subject: Use lexical-binding in lisp/{term,nxml,language} * test/lisp/electric-tests.el: * lisp/term/w32console.el: * lisp/nxml/rng-util.el: * leim/leim-ext.el: Use lexical-binding. * lisp/international/titdic-cnv.el (tit-process-header) (miscdic-convert): * lisp/international/mule-cmds.el (leim-list-header): * lisp/international/ja-dic-cnv.el (skkdic-convert): Use lexical-binding in the generated file. --- leim/leim-ext.el | 12 ++++++------ lisp/international/ja-dic-cnv.el | 3 ++- lisp/international/mule-cmds.el | 2 +- lisp/international/quail.el | 2 +- lisp/international/titdic-cnv.el | 4 ++++ lisp/nxml/rng-util.el | 2 +- lisp/term/w32console.el | 2 +- test/lisp/electric-tests.el | 2 +- 8 files changed, 17 insertions(+), 12 deletions(-) (limited to 'lisp') diff --git a/leim/leim-ext.el b/leim/leim-ext.el index 2378f6fdb4f..687379db9f0 100644 --- a/leim/leim-ext.el +++ b/leim/leim-ext.el @@ -1,4 +1,4 @@ -;; leim-ext.el -- extra leim configuration -*- coding:utf-8; -*- +;; leim-ext.el -- extra leim configuration -*- lexical-binding: t; -*- ;; Copyright (C) 2004-2021 Free Software Foundation, Inc. ;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 @@ -39,13 +39,13 @@ (eval-after-load "quail/Punct-b5" '(quail-defrule " " ?　 nil t)) -(register-input-method "ucs" "UTF-8" 'ucs-input-activate "U+" +(register-input-method "ucs" "UTF-8" #'ucs-input-activate "U+" "Unicode input as hex in the form Uxxxx.") (register-input-method "korean-hangul" "UTF-8" - 'hangul-input-method-activate + #'hangul-input-method-activate "한2" "Hangul 2-Bulsik Input" 'hangul2-input-method @@ -54,7 +54,7 @@ (register-input-method "korean-hangul3f" "UTF-8" - 'hangul-input-method-activate + #'hangul-input-method-activate "한3f" "Hangul 3-Bulsik final Input" 'hangul3-input-method @@ -63,7 +63,7 @@ (register-input-method "korean-hangul390" "UTF-8" - 'hangul-input-method-activate + #'hangul-input-method-activate "한390" "Hangul 3-Bulsik 390 Input" 'hangul390-input-method @@ -72,7 +72,7 @@ (register-input-method "korean-hangul3" "UTF-8" - 'hangul-input-method-activate + #'hangul-input-method-activate "한390" "Hangul 3-Bulsik 390 Input" 'hangul390-input-method diff --git a/lisp/international/ja-dic-cnv.el b/lisp/international/ja-dic-cnv.el index 155c85fb42f..3be7849df19 100644 --- a/lisp/international/ja-dic-cnv.el +++ b/lisp/international/ja-dic-cnv.el @@ -342,7 +342,8 @@ The name of generated file is specified by the variable `ja-dic-filename'." (with-current-buffer buf (erase-buffer) (buffer-disable-undo) - (insert ";;; ja-dic.el --- dictionary for Japanese input method\n" + (insert ";;; ja-dic.el --- dictionary for Japanese input method" + " -*- lexical-binding:t -*-\n" ";;\tGenerated by the command `skkdic-convert'\n" ";;\tOriginal SKK dictionary file: " (file-relative-name (expand-file-name filename) dirname) diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el index 347e6782590..8202c3ee27a 100644 --- a/lisp/international/mule-cmds.el +++ b/lisp/international/mule-cmds.el @@ -1279,7 +1279,7 @@ in the format of Lisp expression for registering each input method. Emacs loads this file at startup time.") (defconst leim-list-header (format-message -";;; %s -- list of LEIM (Library of Emacs Input Method) -*-coding: utf-8;-*- +";;; %s --- list of LEIM (Library of Emacs Input Method) -*- lexical-binding:t -*- ;; ;; This file is automatically generated. ;; diff --git a/lisp/international/quail.el b/lisp/international/quail.el index 9698d461535..0901115cffe 100644 --- a/lisp/international/quail.el +++ b/lisp/international/quail.el @@ -3013,7 +3013,7 @@ of each directory." ;; At first, clean up the file. (with-current-buffer list-buf - (goto-char 1) + (goto-char (point-min)) ;; Insert the correct header. (if (looking-at (regexp-quote leim-list-header)) diff --git a/lisp/international/titdic-cnv.el b/lisp/international/titdic-cnv.el index ce5c04293ad..64d66443760 100644 --- a/lisp/international/titdic-cnv.el +++ b/lisp/international/titdic-cnv.el @@ -269,6 +269,8 @@ SPC, 6, 3, 4, or 7 specifying a tone (SPC:陰平, 6:陽平, 3:上聲, 4:去聲, (tit-moveleft ",<") (tit-keyprompt nil)) + (princ (format ";;; %s -*- lexical-binding:t -*-\n" + (file-name-nondirectory filename))) (princ ";; Quail package `") (princ package) (princ "\n") @@ -1133,6 +1135,8 @@ the generated Quail package is saved." ;; Explicitly set eol format to `unix'. (setq coding-system-for-write 'utf-8-unix) (with-temp-file (expand-file-name quailfile dirname) + (insert (format ";;; %s -*- lexical-binding:t -*-\n" + (file-name-nondirectory quailfile))) (insert (format-message ";; Quail package `%s'\n" name)) (insert (format-message ";; Generated by the command `miscdic-convert'\n")) diff --git a/lisp/nxml/rng-util.el b/lisp/nxml/rng-util.el index 59465c371eb..a20e95086cb 100644 --- a/lisp/nxml/rng-util.el +++ b/lisp/nxml/rng-util.el @@ -1,4 +1,4 @@ -;;; rng-util.el --- utility functions for RELAX NG library +;;; rng-util.el --- utility functions for RELAX NG library -*- lexical-binding: t; -*- ;; Copyright (C) 2003, 2007-2021 Free Software Foundation, Inc. diff --git a/lisp/term/w32console.el b/lisp/term/w32console.el index 8859f13bd20..4a925cd84c3 100644 --- a/lisp/term/w32console.el +++ b/lisp/term/w32console.el @@ -1,4 +1,4 @@ -;;; w32console.el -- Setup w32 console keys and colors. +;;; w32console.el -- Setup w32 console keys and colors. -*- lexical-binding: t; -*- ;; Copyright (C) 2007-2021 Free Software Foundation, Inc. diff --git a/test/lisp/electric-tests.el b/test/lisp/electric-tests.el index 1b7beeaa366..05a6989664d 100644 --- a/test/lisp/electric-tests.el +++ b/test/lisp/electric-tests.el @@ -1,4 +1,4 @@ -;;; electric-tests.el --- tests for electric.el +;;; electric-tests.el --- tests for electric.el -*- lexical-binding: t; -*- ;; Copyright (C) 2013-2021 Free Software Foundation, Inc. -- cgit v1.2.3 From a8c4f8041cc64e3dafc0e435bab8043d7165ffff Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Thu, 28 Jan 2021 15:09:18 +0100 Subject: Simplify auto-revert buffer list by watch descriptor (Bug#44639) * lisp/autorevert.el (auto-revert--buffer-by-watch-descriptor): Rename from `auto-revert--buffers-by-watch-descriptor'. Make it an assoc list. (auto-revert-notify-rm-watch, auto-revert-notify-add-watch) (auto-revert-notify-handler): Adapt accordingly. Based on a patch provided by Spencer Baugh . (Bug#44639) --- lisp/autorevert.el | 105 ++++++++++++++++++++++++----------------------------- 1 file changed, 47 insertions(+), 58 deletions(-) (limited to 'lisp') diff --git a/lisp/autorevert.el b/lisp/autorevert.el index 1b2d68939ad..57258f9c833 100644 --- a/lisp/autorevert.el +++ b/lisp/autorevert.el @@ -355,10 +355,9 @@ the list of old buffers.") (add-hook 'after-set-visited-file-name-hook #'auto-revert-set-visited-file-name) -(defvar auto-revert--buffers-by-watch-descriptor - (make-hash-table :test 'equal) - "A hash table mapping notification descriptors to lists of buffers. -The buffers use that descriptor for auto-revert notifications. +(defvar auto-revert--buffer-by-watch-descriptor nil + "An association list mapping notification descriptors to buffers. +The buffer uses that descriptor for auto-revert notifications. The key is equal to `auto-revert-notify-watch-descriptor' in each buffer.") @@ -630,16 +629,12 @@ will use an up-to-date value of `auto-revert-interval'." (defun auto-revert-notify-rm-watch () "Disable file notification for current buffer's associated file." - (let ((desc auto-revert-notify-watch-descriptor) - (table auto-revert--buffers-by-watch-descriptor)) - (when desc - (let ((buffers (delq (current-buffer) (gethash desc table)))) - (if buffers - (puthash desc buffers table) - (remhash desc table))) - (ignore-errors - (file-notify-rm-watch desc)) - (remove-hook 'kill-buffer-hook #'auto-revert-notify-rm-watch t))) + (when-let ((desc auto-revert-notify-watch-descriptor)) + (setq auto-revert--buffer-by-watch-descriptor + (assoc-delete-all desc auto-revert--buffer-by-watch-descriptor)) + (ignore-errors + (file-notify-rm-watch desc)) + (remove-hook 'kill-buffer-hook #'auto-revert-notify-rm-watch t)) (setq auto-revert-notify-watch-descriptor nil auto-revert-notify-modified-p nil)) @@ -660,13 +655,10 @@ will use an up-to-date value of `auto-revert-interval'." (if buffer-file-name '(change attribute-change) '(change)) 'auto-revert-notify-handler)))) (when auto-revert-notify-watch-descriptor - (setq auto-revert-notify-modified-p t) - (puthash - auto-revert-notify-watch-descriptor - (cons (current-buffer) - (gethash auto-revert-notify-watch-descriptor - auto-revert--buffers-by-watch-descriptor)) - auto-revert--buffers-by-watch-descriptor) + (setq auto-revert-notify-modified-p t + auto-revert--buffer-by-watch-descriptor + (cons (cons auto-revert-notify-watch-descriptor (current-buffer)) + auto-revert--buffer-by-watch-descriptor)) (add-hook 'kill-buffer-hook #'auto-revert-notify-rm-watch nil t)))) ;; If we have file notifications, we want to update the auto-revert buffers @@ -696,8 +688,8 @@ system.") (action (nth 1 event)) (file (nth 2 event)) (file1 (nth 3 event)) ;; Target of `renamed'. - (buffers (gethash descriptor - auto-revert--buffers-by-watch-descriptor))) + (buffer (alist-get descriptor auto-revert--buffer-by-watch-descriptor + nil nil #'equal))) ;; Check, that event is meant for us. (cl-assert descriptor) ;; Since we watch a directory, a file name must be returned. @@ -706,9 +698,9 @@ system.") (when auto-revert-debug (message "auto-revert-notify-handler %S" event)) - (if (eq action 'stopped) - ;; File notification has stopped. Continue with polling. - (cl-dolist (buffer buffers) + (when (buffer-live-p buffer) + (if (eq action 'stopped) + ;; File notification has stopped. Continue with polling. (with-current-buffer buffer (when (or ;; A buffer associated with a file. @@ -721,38 +713,35 @@ system.") (auto-revert-notify-rm-watch) ;; Restart the timer if it wasn't running. (unless auto-revert-timer - (auto-revert-set-timer))))) - - ;; Loop over all buffers, in order to find the intended one. - (cl-dolist (buffer buffers) - (when (buffer-live-p buffer) - (with-current-buffer buffer - (when (or - ;; A buffer associated with a file. - (and (stringp buffer-file-name) - (or - (and (memq - action '(attribute-changed changed created)) - (string-equal - (file-name-nondirectory file) - (file-name-nondirectory buffer-file-name))) - (and (eq action 'renamed) - (string-equal - (file-name-nondirectory file1) - (file-name-nondirectory buffer-file-name))))) - ;; A buffer w/o a file, like dired. - (and (null buffer-file-name) - (memq action '(created renamed deleted)))) - ;; Mark buffer modified. - (setq auto-revert-notify-modified-p t) - - ;; Revert the buffer now if we're not locked out. - (unless auto-revert--lockout-timer - (auto-revert-handler) - (setq auto-revert--lockout-timer - (run-with-timer - auto-revert--lockout-interval nil - #'auto-revert--end-lockout buffer))))))))))) + (auto-revert-set-timer)))) + + (with-current-buffer buffer + (when (or + ;; A buffer associated with a file. + (and (stringp buffer-file-name) + (or + (and (memq + action '(attribute-changed changed created)) + (string-equal + (file-name-nondirectory file) + (file-name-nondirectory buffer-file-name))) + (and (eq action 'renamed) + (string-equal + (file-name-nondirectory file1) + (file-name-nondirectory buffer-file-name))))) + ;; A buffer w/o a file, like dired. + (and (null buffer-file-name) + (memq action '(created renamed deleted)))) + ;; Mark buffer modified. + (setq auto-revert-notify-modified-p t) + + ;; Revert the buffer now if we're not locked out. + (unless auto-revert--lockout-timer + (auto-revert-handler) + (setq auto-revert--lockout-timer + (run-with-timer + auto-revert--lockout-interval nil + #'auto-revert--end-lockout buffer)))))))))) (defun auto-revert--end-lockout (buffer) "End the lockout period after a notification. -- cgit v1.2.3 From ac102bb966f7944babbd8594684550905eecca0a Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Thu, 28 Jan 2021 15:09:29 +0100 Subject: * lisp/net/ange-ftp.el (ange-ftp-ls): Handle several "--dired" switches. --- lisp/net/ange-ftp.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/net/ange-ftp.el b/lisp/net/ange-ftp.el index 9559b125135..fa13dd57d1d 100644 --- a/lisp/net/ange-ftp.el +++ b/lisp/net/ange-ftp.el @@ -2547,7 +2547,7 @@ can parse the output from a DIR listing for a host of type TYPE.") FILE is the full name of the remote file, LSARGS is any args to pass to the `ls' command, and PARSE specifies that the output should be parsed and stored away in the internal cache." - (when (string-match "^--dired\\s-+" lsargs) + (while (string-match "^--dired\\s-+" lsargs) (setq lsargs (replace-match "" nil t lsargs))) ;; If parse is t, we assume that file is a directory. i.e. we only parse ;; full directory listings. -- cgit v1.2.3 From 6c601689a40079dd6c253f15a690a3c0cf6918df Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Sun, 24 Jan 2021 00:53:38 +0100 Subject: ; * lisp/dired-aux.el (dired-compress-files-alist): Minor doc fix. --- lisp/dired-aux.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index c765e4be45d..ec864d54d69 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -1179,7 +1179,7 @@ archive to which you want to compress, and CMD is the corresponding command. Within CMD, %i denotes the input file(s), and %o denotes the -output file. %i path(s) are relative, while %o is absolute.") +output file. %i path(s) are relative, while %o is absolute.") ;;;###autoload (defun dired-do-compress-to () -- cgit v1.2.3 From 80d964ec8b64a1c604c99aa51ecdbd813d739a90 Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Thu, 28 Jan 2021 15:08:51 +0100 Subject: Add missing file systems to etc-fstab-generic-mode * lisp/generic-x.el (etc-fstab-generic-mode): Add entries for missing file systems. --- lisp/generic-x.el | 69 ++++++++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 66 insertions(+), 3 deletions(-) (limited to 'lisp') diff --git a/lisp/generic-x.el b/lisp/generic-x.el index f3ea22a4a30..60cf8468a4e 100644 --- a/lisp/generic-x.el +++ b/lisp/generic-x.el @@ -1490,41 +1490,104 @@ like an INI file. You can add this hook to `find-file-hook'." (define-generic-mode etc-fstab-generic-mode '(?#) '("adfs" + "ados" "affs" + "anon_inodefs" + "atfs" + "audiofs" "autofs" + "bdev" + "befs" + "bfs" + "binfmt_misc" + "btrfs" + "cd9660" + "cfs" + "cgroup" + "cifs" "coda" "coherent" + "configfs" + "cpuset" "cramfs" + "devfs" "devpts" + "devtmpfs" + "e2compr" "efs" "ext2" + "ext2fs" "ext3" "ext4" + "fdesc" + "ffs" + "filecore" + "fuse" + "fuseblk" + "fusectl" "hfs" "hpfs" + "hugetlbfs" "iso9660" + "jffs" + "jffs2" "jfs" + "kernfs" + "lfs" + "linprocfs" + "mfs" "minix" + "mqueue" "msdos" "ncpfs" "nfs" + "nfsd" + "nilfs2" + "none" "ntfs" + "null" + "nwfs" + "overlay" + "ovlfs" + "pipefs" + "portal" "proc" + "procfs" + "pstore" + "ptyfs" "qnx4" + "ramfs" "reiserfs" "romfs" + "securityfs" + "shm" "smbfs" - "cifs" - "usbdevfs" - "sysv" + "sockfs" + "squashfs" + "sshfs" + "std" + "subfs" "sysfs" + "sysv" + "tcfs" "tmpfs" "udf" "ufs" + "umap" "umsdos" + "union" + "usbdevfs" + "usbfs" + "userfs" "vfat" + "vs3fs" + "vxfs" + "wrapfs" + "wvfs" + "xenfs" "xenix" "xfs" + "zisofs" "swap" "auto" "ignore") -- cgit v1.2.3 From 4cded88b0ebb005f67447cd07da016eb0b7ef4a4 Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Thu, 28 Jan 2021 17:05:06 +0100 Subject: * lisp/generic-x.el (hosts-generic-mode): Support IPv6 addresses. --- lisp/generic-x.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/generic-x.el b/lisp/generic-x.el index 60cf8468a4e..bd03f287fc7 100644 --- a/lisp/generic-x.el +++ b/lisp/generic-x.el @@ -365,7 +365,8 @@ your changes into effect." (define-generic-mode hosts-generic-mode '(?#) '("localhost") - '(("\\([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\\)" 1 font-lock-constant-face)) + '(("\\([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\\)" 1 font-lock-constant-face) + ("\\<\\([0-9A-Fa-f:]+\\)\\>" 1 font-lock-constant-face)) '("[hH][oO][sS][tT][sS]\\'") nil "Generic mode for HOSTS files.")) -- cgit v1.2.3 From b04f1c0cec5bc722fd5823861044f212206c3d3b Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Thu, 28 Jan 2021 18:16:49 +0100 Subject: Add cross-reference to with-eval-after-load * lisp/subr.el (eval-after-load): Doc fix; add cross-reference to 'with-eval-after-load'. --- lisp/subr.el | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/subr.el b/lisp/subr.el index afa73c72eaa..34129ea38a0 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -4921,7 +4921,9 @@ file, FORM is evaluated immediately after the provide statement. Usually FILE is just a library name like \"font-lock\" or a feature name like `font-lock'. -This function makes or adds to an entry on `after-load-alist'." +This function makes or adds to an entry on `after-load-alist'. + +See also `with-eval-after-load'." (declare (compiler-macro (lambda (whole) (if (eq 'quote (car-safe form)) -- cgit v1.2.3 From c407b54cf37ae56f65a75f5238f86898be7d8159 Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Thu, 28 Jan 2021 18:35:45 +0100 Subject: * lisp/ezimage.el: Use lexical-binding. --- lisp/ezimage.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/ezimage.el b/lisp/ezimage.el index 9c1d8599101..13f5c039a7f 100644 --- a/lisp/ezimage.el +++ b/lisp/ezimage.el @@ -1,4 +1,4 @@ -;;; ezimage --- Generalized Image management +;;; ezimage.el --- Generalized Image management -*- lexical-binding: t -*- ;; Copyright (C) 1999-2021 Free Software Foundation, Inc. -- cgit v1.2.3 From f782f1a8e07c7ef689e9f3a763259a030883c5c6 Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Thu, 28 Jan 2021 18:49:17 +0100 Subject: * lisp/leim/quail/compose.el: Use lexical-binding. --- lisp/leim/quail/compose.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/leim/quail/compose.el b/lisp/leim/quail/compose.el index f7ac83aec5b..264a9b479b3 100644 --- a/lisp/leim/quail/compose.el +++ b/lisp/leim/quail/compose.el @@ -1,4 +1,4 @@ -;;; compose.el --- Quail package for Multi_key character composition -*-coding: utf-8;-*- +;;; compose.el --- Quail package for Multi_key character composition -*-coding: utf-8; lexical-binding: t -*- ;; Copyright (C) 2020-2021 Free Software Foundation, Inc. -- cgit v1.2.3 From aca93f67239e82f7c63444525e00337db8f168fe Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Thu, 28 Jan 2021 18:49:29 +0100 Subject: * lisp/leim/quail/viqr.el: Use lexical-binding. --- lisp/leim/quail/viqr.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/leim/quail/viqr.el b/lisp/leim/quail/viqr.el index b7591b15e05..d127ff247cf 100644 --- a/lisp/leim/quail/viqr.el +++ b/lisp/leim/quail/viqr.el @@ -1,4 +1,4 @@ -;;; viqr.el --- Quail packages for inputting Vietnamese with VIQR system -*-coding: utf-8;-*- +;;; viqr.el --- Quail packages for inputting Vietnamese with VIQR system -*-coding: utf-8; lexical-binding: t -*- ;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, ;; 2006, 2007, 2008, 2009, 2010, 2011 -- cgit v1.2.3 From a8caa66906b157c9c2b4c4dc1c447b6a9e747c5e Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Thu, 28 Jan 2021 19:06:18 +0100 Subject: Avoid recommending Google * doc/misc/org.texi (Link Abbreviations): * lisp/net/webjump.el (webjump-sample-sites): * lisp/org/ol.el (org-link-shell-confirm-function) (org-link-elisp-confirm-function): * lisp/org/org.el (org-highlight-links): * lisp/wdired.el: Avoid recommending Google. squash! Avoid recommending Google --- doc/misc/org.texi | 6 +++--- lisp/net/webjump.el | 3 --- lisp/org/ol.el | 8 ++++---- lisp/org/org.el | 2 +- lisp/wdired.el | 4 ++-- 5 files changed, 10 insertions(+), 13 deletions(-) (limited to 'lisp') diff --git a/doc/misc/org.texi b/doc/misc/org.texi index 5eeb098cc72..8902d628875 100644 --- a/doc/misc/org.texi +++ b/doc/misc/org.texi @@ -4071,7 +4071,7 @@ the link. Such a function will be called with the tag as the only argument. With the above setting, you could link to a specific bug with -@samp{[[bugzilla:129]]}, search the web for @samp{OrgMode} with @samp{[[google:OrgMode]]}, +@samp{[[bugzilla:129]]}, search the web for @samp{OrgMode} with @samp{[[duckduckgo:OrgMode]]}, show the map location of the Free Software Foundation @samp{[[gmap:51 Franklin Street, Boston]]} or of Carsten office @samp{[[omap:Science Park 904, Amsterdam, The Netherlands]]} and find out what the Org author is doing @@ -4082,8 +4082,8 @@ can define them in the file with @cindex @samp{LINK}, keyword @example -#+LINK: bugzilla http://10.1.2.9/bugzilla/show_bug.cgi?id= -#+LINK: google http://www.google.com/search?q=%s +#+LINK: bugzilla http://10.1.2.9/bugzilla/show_bug.cgi?id= +#+LINK: duckduckgo https://duckduckgo.com/?q=%s @end example In-buffer completion (see @ref{Completion}) can be used after @samp{[} to diff --git a/lisp/net/webjump.el b/lisp/net/webjump.el index e5941ae652e..1fa625c3245 100644 --- a/lisp/net/webjump.el +++ b/lisp/net/webjump.el @@ -96,9 +96,6 @@ ("DuckDuckGo" . [simple-query "duckduckgo.com" "duckduckgo.com/?q=" ""]) - ("Google" . - [simple-query "www.google.com" - "www.google.com/search?q=" ""]) ("Google Groups" . [simple-query "groups.google.com" "groups.google.com/groups?q=" ""]) diff --git a/lisp/org/ol.el b/lisp/org/ol.el index d1db1683bbe..994e30f4f43 100644 --- a/lisp/org/ol.el +++ b/lisp/org/ol.el @@ -376,9 +376,9 @@ changes to the current buffer." Shell links can be dangerous: just think about a link - [[shell:rm -rf ~/*][Google Search]] + [[shell:rm -rf ~/*][Web Search]] -This link would show up in your Org document as \"Google Search\", +This link would show up in your Org document as \"Web Search\", but really it would remove your entire home directory. Therefore we advise against setting this variable to nil. Just change it to `y-or-n-p' if you want to confirm with a @@ -401,9 +401,9 @@ single keystroke rather than having to type \"yes\"." "Non-nil means ask for confirmation before executing Emacs Lisp links. Elisp links can be dangerous: just think about a link - [[elisp:(shell-command \"rm -rf ~/*\")][Google Search]] + [[elisp:(shell-command \"rm -rf ~/*\")][Web Search]] -This link would show up in your Org document as \"Google Search\", +This link would show up in your Org document as \"Web Search\", but really it would remove your entire home directory. Therefore we advise against setting this variable to nil. Just change it to `y-or-n-p' if you want to confirm with a diff --git a/lisp/org/org.el b/lisp/org/org.el index 43aa0a178a9..2d21a44fb48 100644 --- a/lisp/org/org.el +++ b/lisp/org/org.el @@ -1846,7 +1846,7 @@ link types. The types are: bracket The recommended [[link][description]] or [[link]] links with hiding. angle Links in angular brackets that may contain whitespace like . -plain Plain links in normal text, no whitespace, like http://google.com. +plain Plain links in normal text, no whitespace, like https://gnu.org. radio Text that is matched by a radio target, see manual for details. tag Tag settings in a headline (link to tag search). date Time stamps (link to calendar). diff --git a/lisp/wdired.el b/lisp/wdired.el index f4a0b6d9a93..037eb31245b 100644 --- a/lisp/wdired.el +++ b/lisp/wdired.el @@ -68,8 +68,8 @@ ;;; Change Log: -;; Google is your friend (previous versions with complete changelogs -;; were posted to gnu.emacs.sources) +;; Previous versions with complete changelogs were posted to +;; gnu.emacs.sources. ;;; Code: -- cgit v1.2.3 From 50c7de093a4e699fb86b05b8fdd6b6a47a886106 Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Thu, 28 Jan 2021 19:21:41 +0100 Subject: * lisp/wdired.el: Minor doc fixes. --- lisp/wdired.el | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) (limited to 'lisp') diff --git a/lisp/wdired.el b/lisp/wdired.el index 037eb31245b..a096abd106f 100644 --- a/lisp/wdired.el +++ b/lisp/wdired.el @@ -27,26 +27,26 @@ ;; wdired.el (the "w" is for writable) provides an alternative way of ;; renaming files. ;; -;; Have you ever wished to use C-x r t (string-rectangle), M-% +;; Have you ever wanted to use C-x r t (string-rectangle), M-% ;; (query-replace), M-c (capitalize-word), etc... to change the name of -;; the files in a "dired" buffer? Now you can do this. All the power -;; of Emacs commands are available to renaming files! +;; the files in a "dired" buffer? Now you can do this. All the power +;; of Emacs commands are available when renaming files! ;; ;; This package provides a function that makes the filenames of a ;; dired buffer editable, by changing the buffer mode (which inhibits -;; all of the commands of dired mode). Here you can edit the names of +;; all of the commands of dired mode). Here you can edit the names of ;; one or more files and directories, and when you press C-c C-c, the ;; renaming takes effect and you are back to dired mode. ;; -;; Another things you can do with WDired: +;; Other things you can do with WDired: ;; -;; - To move files to another directory (by typing their path, +;; - Move files to another directory (by typing their path, ;; absolute or relative, as a part of the new filename). ;; -;; - To change the target of symbolic links. +;; - Change the target of symbolic links. ;; -;; - To change the permission bits of the filenames (in systems with a -;; working unix-alike `dired-chmod-program'). See and customize the +;; - Change the permission bits of the filenames (in systems with a +;; working unix-alike `dired-chmod-program'). See and customize the ;; variable `wdired-allow-to-change-permissions'. To change a single ;; char (toggling between its two more usual values) you can press ;; the space bar over it or left-click the mouse. To set any char to @@ -56,7 +56,7 @@ ;; the change would affect to their targets, and this would not be ;; WYSIWYG :-). ;; -;; - To mark files for deletion, by deleting their whole filename. +;; - Mark files for deletion, by deleting their whole filename. ;;; Usage: -- cgit v1.2.3 From c8c4d65d6510724acd40527a9af67e21e3cf4d5e Mon Sep 17 00:00:00 2001 From: Juri Linkov Date: Thu, 28 Jan 2021 21:27:26 +0200 Subject: Use isearch-tmm-menubar when tmm-menubar is called in isearch-mode (bug#43966) * lisp/isearch.el (isearch-menu-bar-commands): Add tmm-menubar to defaults. (isearch-mode-map): Remove remapping of tmm-menubar to isearch-tmm-menubar. * lisp/tmm.el (tmm-menubar): Call isearch-tmm-menubar in isearch-mode. --- lisp/isearch.el | 3 +-- lisp/tmm.el | 14 ++++++++------ 2 files changed, 9 insertions(+), 8 deletions(-) (limited to 'lisp') diff --git a/lisp/isearch.el b/lisp/isearch.el index a86678572c4..a1e3fe2c3f0 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el @@ -513,7 +513,7 @@ This is like `describe-bindings', but displays only Isearch keys." (call-interactively command))) (defvar isearch-menu-bar-commands - '(isearch-tmm-menubar menu-bar-open mouse-minor-mode-menu) + '(isearch-tmm-menubar tmm-menubar menu-bar-open mouse-minor-mode-menu) "List of commands that can open a menu during Isearch.") (defvar isearch-menu-bar-yank-map @@ -787,7 +787,6 @@ This is like `describe-bindings', but displays only Isearch keys." (define-key map [menu-bar search-menu] (list 'menu-item "Isearch" isearch-menu-bar-map)) - (define-key map [remap tmm-menubar] 'isearch-tmm-menubar) map) "Keymap for `isearch-mode'.") diff --git a/lisp/tmm.el b/lisp/tmm.el index e49246a5c4f..2040f522700 100644 --- a/lisp/tmm.el +++ b/lisp/tmm.el @@ -56,12 +56,14 @@ to invoke `tmm-menubar' instead, customize the variable `tty-menu-open-use-tmm' to a non-nil value." (interactive) (run-hooks 'menu-bar-update-hook) - (let ((menu-bar (menu-bar-keymap)) - (menu-bar-item-cons (and x-position - (menu-bar-item-at-x x-position)))) - (tmm-prompt menu-bar - nil - (and menu-bar-item-cons (car menu-bar-item-cons))))) + (if isearch-mode + (isearch-tmm-menubar) + (let ((menu-bar (menu-bar-keymap)) + (menu-bar-item-cons (and x-position + (menu-bar-item-at-x x-position)))) + (tmm-prompt menu-bar + nil + (and menu-bar-item-cons (car menu-bar-item-cons)))))) ;;;###autoload (defun tmm-menubar-mouse (event) -- cgit v1.2.3 From 991c8946b6e9c87403dc2691100566cb98577de1 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 28 Jan 2021 14:42:21 -0500 Subject: Use lexical-binding in all of `lisp/emacs-lisp` * lisp/emacs-lisp/bindat.el: Use lexical-binding. (bindat--unpack-group, bindat--length-group, bindat--pack-group): Declare `last` and `tag` as dyn-scoped. (bindat-unpack, bindat-pack): Bind `bindat-raw` and `bindat-idx` via `let` rather than via the formal arglist. * lisp/emacs-lisp/package-x.el: * lisp/emacs-lisp/generic.el: * lisp/emacs-lisp/eieio-opt.el: * lisp/emacs-lisp/derived.el: * lisp/emacs-lisp/crm.el: Use lexical-binding. * lisp/emacs-lisp/helper.el: Use lexical-binding. (Helper-help-map): Move initialization into declaration. * lisp/emacs-lisp/regi.el: Use lexical-binding. (regi-interpret): Remove unused var `tstart`. Declare `curframe`, `curentry` and `curline` as dyn-scoped. * lisp/emacs-lisp/shadow.el: Use lexical-binding. (load-path-shadows-find): Remove unused var `file`. Tighten a regexp, use `push`. * lisp/emacs-lisp/tcover-ses.el: Use lexical-binding. Require `ses`. Remove correspondingly redundant declarations. (ses--curcell-overlay): Declare. (ses-exercise): Use `dlet` and use a properly-prefixed var name. Fix name of `curcell-overlay` variable. * lisp/emacs-lisp/unsafep.el: Use lexical-binding. (unsafep): Bind `unsafep-vars` via `let` rather than via the formal arglist. --- admin/notes/unicode | 1 + lisp/emacs-lisp/bindat.el | 112 +++++++++++++++++++++++------------------- lisp/emacs-lisp/crm.el | 2 +- lisp/emacs-lisp/derived.el | 2 +- lisp/emacs-lisp/eieio-opt.el | 2 +- lisp/emacs-lisp/generic.el | 9 ++-- lisp/emacs-lisp/helper.el | 29 ++++++----- lisp/emacs-lisp/package-x.el | 2 +- lisp/emacs-lisp/regi.el | 55 +++++++++++---------- lisp/emacs-lisp/shadow.el | 22 +++++---- lisp/emacs-lisp/tcover-ses.el | 28 +++++------ lisp/emacs-lisp/unsafep.el | 9 ++-- 12 files changed, 143 insertions(+), 130 deletions(-) (limited to 'lisp') diff --git a/admin/notes/unicode b/admin/notes/unicode index d69d5418e26..bcede9c6ed1 100644 --- a/admin/notes/unicode +++ b/admin/notes/unicode @@ -267,6 +267,7 @@ nontrivial changes to the build process. lisp/language/tibetan.el lisp/leim/quail/ethiopic.el lisp/leim/quail/tibetan.el + lisp/international/titdic-cnv.el * binary files diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el index 5f432b80bc2..0d9ba57d663 100644 --- a/lisp/emacs-lisp/bindat.el +++ b/lisp/emacs-lisp/bindat.el @@ -1,4 +1,4 @@ -;;; bindat.el --- binary data structure packing and unpacking. +;;; bindat.el --- binary data structure packing and unpacking. -*- lexical-binding: t; -*- ;; Copyright (C) 2002-2021 Free Software Foundation, Inc. @@ -198,7 +198,7 @@ (defun bindat--unpack-u8 () (prog1 - (aref bindat-raw bindat-idx) + (aref bindat-raw bindat-idx) (setq bindat-idx (1+ bindat-idx)))) (defun bindat--unpack-u16 () @@ -276,6 +276,8 @@ (t nil))) (defun bindat--unpack-group (spec) + (with-suppressed-warnings ((lexical last)) + (defvar last)) (let (struct last) (while spec (let* ((item (car spec)) @@ -287,11 +289,11 @@ data) (setq spec (cdr spec)) (if (and (consp field) (eq (car field) 'eval)) - (setq field (eval (car (cdr field))))) + (setq field (eval (car (cdr field)) t))) (if (and type (consp type) (eq (car type) 'eval)) - (setq type (eval (car (cdr type))))) + (setq type (eval (car (cdr type)) t))) (if (and len (consp len) (eq (car len) 'eval)) - (setq len (eval (car (cdr len))))) + (setq len (eval (car (cdr len)) t))) (if (memq field '(eval fill align struct union)) (setq tail 2 len type @@ -304,48 +306,51 @@ (cond ((eq type 'eval) (if field - (setq data (eval len)) - (eval len))) + (setq data (eval len t)) + (eval len t))) ((eq type 'fill) (setq bindat-idx (+ bindat-idx len))) ((eq type 'align) (while (/= (% bindat-idx len) 0) (setq bindat-idx (1+ bindat-idx)))) ((eq type 'struct) - (setq data (bindat--unpack-group (eval len)))) + (setq data (bindat--unpack-group (eval len t)))) ((eq type 'repeat) (let ((index 0) (count len)) (while (< index count) - (setq data (cons (bindat--unpack-group (nthcdr tail item)) data)) + (push (bindat--unpack-group (nthcdr tail item)) data) (setq index (1+ index))) (setq data (nreverse data)))) ((eq type 'union) + (with-suppressed-warnings ((lexical tag)) + (defvar tag)) (let ((tag len) (cases (nthcdr tail item)) case cc) (while cases (setq case (car cases) cases (cdr cases) cc (car case)) (if (or (equal cc tag) (equal cc t) - (and (consp cc) (eval cc))) + (and (consp cc) (eval cc t))) (setq data (bindat--unpack-group (cdr case)) cases nil))))) (t (setq data (bindat--unpack-item type len vectype) last data))) (if data - (if field - (setq struct (cons (cons field data) struct)) - (setq struct (append data struct)))))) + (setq struct (if field + (cons (cons field data) struct) + (append data struct)))))) struct)) -(defun bindat-unpack (spec bindat-raw &optional bindat-idx) - "Return structured data according to SPEC for binary data in BINDAT-RAW. -BINDAT-RAW is a unibyte string or vector. -Optional third arg BINDAT-IDX specifies the starting offset in BINDAT-RAW." - (when (multibyte-string-p bindat-raw) +(defun bindat-unpack (spec raw &optional idx) + "Return structured data according to SPEC for binary data in RAW. +RAW is a unibyte string or vector. +Optional third arg IDX specifies the starting offset in RAW." + (when (multibyte-string-p raw) (error "String is multibyte")) - (unless bindat-idx (setq bindat-idx 0)) - (bindat--unpack-group spec)) + (let ((bindat-idx (or idx 0)) + (bindat-raw raw)) + (bindat--unpack-group spec))) (defun bindat-get-field (struct &rest field) "In structured data STRUCT, return value of field named FIELD. @@ -373,6 +378,8 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (ip . 4))) (defun bindat--length-group (struct spec) + (with-suppressed-warnings ((lexical last)) + (defvar last)) (let (last) (while spec (let* ((item (car spec)) @@ -383,32 +390,31 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (tail 3)) (setq spec (cdr spec)) (if (and (consp field) (eq (car field) 'eval)) - (setq field (eval (car (cdr field))))) + (setq field (eval (car (cdr field)) t))) (if (and type (consp type) (eq (car type) 'eval)) - (setq type (eval (car (cdr type))))) + (setq type (eval (car (cdr type)) t))) (if (and len (consp len) (eq (car len) 'eval)) - (setq len (eval (car (cdr len))))) + (setq len (eval (car (cdr len)) t))) (if (memq field '(eval fill align struct union)) (setq tail 2 len type type field field nil)) (if (and (consp len) (not (eq type 'eval))) - (setq len (apply 'bindat-get-field struct len))) + (setq len (apply #'bindat-get-field struct len))) (if (not len) (setq len 1)) (while (eq type 'vec) - (let ((vlen 1)) - (if (consp vectype) - (setq len (* len (nth 1 vectype)) - type (nth 2 vectype)) - (setq type (or vectype 'u8) - vectype nil)))) + (if (consp vectype) + (setq len (* len (nth 1 vectype)) + type (nth 2 vectype)) + (setq type (or vectype 'u8) + vectype nil))) (cond ((eq type 'eval) (if field - (setq struct (cons (cons field (eval len)) struct)) - (eval len))) + (setq struct (cons (cons field (eval len t)) struct)) + (eval len t))) ((eq type 'fill) (setq bindat-idx (+ bindat-idx len))) ((eq type 'align) @@ -416,7 +422,7 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (setq bindat-idx (1+ bindat-idx)))) ((eq type 'struct) (bindat--length-group - (if field (bindat-get-field struct field) struct) (eval len))) + (if field (bindat-get-field struct field) struct) (eval len t))) ((eq type 'repeat) (let ((index 0) (count len)) (while (< index count) @@ -425,13 +431,15 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (nthcdr tail item)) (setq index (1+ index))))) ((eq type 'union) + (with-suppressed-warnings ((lexical tag)) + (defvar tag)) (let ((tag len) (cases (nthcdr tail item)) case cc) (while cases (setq case (car cases) cases (cdr cases) cc (car case)) (if (or (equal cc tag) (equal cc t) - (and (consp cc) (eval cc))) + (and (consp cc) (eval cc t))) (progn (bindat--length-group struct (cdr case)) (setq cases nil)))))) @@ -536,6 +544,8 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (setq bindat-idx (+ bindat-idx len))))) (defun bindat--pack-group (struct spec) + (with-suppressed-warnings ((lexical last)) + (defvar last)) (let (last) (while spec (let* ((item (car spec)) @@ -546,11 +556,11 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (tail 3)) (setq spec (cdr spec)) (if (and (consp field) (eq (car field) 'eval)) - (setq field (eval (car (cdr field))))) + (setq field (eval (car (cdr field)) t))) (if (and type (consp type) (eq (car type) 'eval)) - (setq type (eval (car (cdr type))))) + (setq type (eval (car (cdr type)) t))) (if (and len (consp len) (eq (car len) 'eval)) - (setq len (eval (car (cdr len))))) + (setq len (eval (car (cdr len)) t))) (if (memq field '(eval fill align struct union)) (setq tail 2 len type @@ -563,8 +573,8 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (cond ((eq type 'eval) (if field - (setq struct (cons (cons field (eval len)) struct)) - (eval len))) + (setq struct (cons (cons field (eval len t)) struct)) + (eval len t))) ((eq type 'fill) (setq bindat-idx (+ bindat-idx len))) ((eq type 'align) @@ -572,7 +582,7 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (setq bindat-idx (1+ bindat-idx)))) ((eq type 'struct) (bindat--pack-group - (if field (bindat-get-field struct field) struct) (eval len))) + (if field (bindat-get-field struct field) struct) (eval len t))) ((eq type 'repeat) (let ((index 0) (count len)) (while (< index count) @@ -581,13 +591,15 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (nthcdr tail item)) (setq index (1+ index))))) ((eq type 'union) + (with-suppressed-warnings ((lexical tag)) + (defvar tag)) (let ((tag len) (cases (nthcdr tail item)) case cc) (while cases (setq case (car cases) cases (cdr cases) cc (car case)) (if (or (equal cc tag) (equal cc t) - (and (consp cc) (eval cc))) + (and (consp cc) (eval cc t))) (progn (bindat--pack-group struct (cdr case)) (setq cases nil)))))) @@ -596,19 +608,19 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (bindat--pack-item last type len vectype) )))))) -(defun bindat-pack (spec struct &optional bindat-raw bindat-idx) +(defun bindat-pack (spec struct &optional raw idx) "Return binary data packed according to SPEC for structured data STRUCT. -Optional third arg BINDAT-RAW is a pre-allocated unibyte string or vector to +Optional third arg RAW is a pre-allocated unibyte string or vector to pack into. -Optional fourth arg BINDAT-IDX is the starting offset into BINDAT-RAW." - (when (multibyte-string-p bindat-raw) +Optional fourth arg IDX is the starting offset into RAW." + (when (multibyte-string-p raw) (error "Pre-allocated string is multibyte")) - (let ((no-return bindat-raw)) - (unless bindat-idx (setq bindat-idx 0)) - (unless bindat-raw - (setq bindat-raw (make-string (+ bindat-idx (bindat-length spec struct)) 0))) + (let* ((bindat-idx (or idx 0)) + (bindat-raw + (or raw + (make-string (+ bindat-idx (bindat-length spec struct)) 0)))) (bindat--pack-group struct spec) - (if no-return nil bindat-raw))) + (if raw nil bindat-raw))) ;; Misc. format conversions diff --git a/lisp/emacs-lisp/crm.el b/lisp/emacs-lisp/crm.el index eb3193c8213..e106815817e 100644 --- a/lisp/emacs-lisp/crm.el +++ b/lisp/emacs-lisp/crm.el @@ -1,4 +1,4 @@ -;;; crm.el --- read multiple strings with completion +;;; crm.el --- read multiple strings with completion -*- lexical-binding: t; -*- ;; Copyright (C) 1985-1986, 1993-2021 Free Software Foundation, Inc. diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el index 42528429aaf..54528b2fb91 100644 --- a/lisp/emacs-lisp/derived.el +++ b/lisp/emacs-lisp/derived.el @@ -1,4 +1,4 @@ -;;; derived.el --- allow inheritance of major modes +;;; derived.el --- allow inheritance of major modes -*- lexical-binding: t; -*- ;; (formerly mode-clone.el) ;; Copyright (C) 1993-1994, 1999, 2001-2021 Free Software Foundation, diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index edf4d34b649..e65f424cbab 100644 --- a/lisp/emacs-lisp/eieio-opt.el +++ b/lisp/emacs-lisp/eieio-opt.el @@ -1,4 +1,4 @@ -;;; eieio-opt.el -- eieio optional functions (debug, printing, speedbar) +;;; eieio-opt.el -- eieio optional functions (debug, printing, speedbar) -*- lexical-binding: t; -*- ;; Copyright (C) 1996, 1998-2003, 2005, 2008-2021 Free Software ;; Foundation, Inc. diff --git a/lisp/emacs-lisp/generic.el b/lisp/emacs-lisp/generic.el index 93f780eac2f..6db1bbbb224 100644 --- a/lisp/emacs-lisp/generic.el +++ b/lisp/emacs-lisp/generic.el @@ -1,4 +1,4 @@ -;;; generic.el --- defining simple major modes with comment and font-lock +;;; generic.el --- defining simple major modes with comment and font-lock -*- lexical-binding: t; -*- ;; ;; Copyright (C) 1997, 1999, 2001-2021 Free Software Foundation, Inc. ;; @@ -245,7 +245,6 @@ Some generic modes are defined in `generic-x.el'." "Set up comment functionality for generic mode." (let ((chars nil) (comstyles) - (comstyle "") (comment-start nil)) ;; Go through all the comments. @@ -269,14 +268,16 @@ Some generic modes are defined in `generic-x.el'." ;; Store the relevant info but don't update yet. (push (cons c0 (concat (cdr (assoc c0 chars)) "1")) chars) (push (cons c1 (concat (cdr (assoc c1 chars)) - (concat "2" comstyle))) chars))) + (concat "2" comstyle))) + chars))) (if (= (length end) 1) (modify-syntax-entry (aref end 0) (concat ">" comstyle) st) (let ((c0 (aref end 0)) (c1 (aref end 1))) ;; Store the relevant info but don't update yet. (push (cons c0 (concat (cdr (assoc c0 chars)) - (concat "3" comstyle))) chars) + (concat "3" comstyle))) + chars) (push (cons c1 (concat (cdr (assoc c1 chars)) "4")) chars))))) ;; Process the chars that were part of a 2-char comment marker diff --git a/lisp/emacs-lisp/helper.el b/lisp/emacs-lisp/helper.el index 737f3ec2f33..a5f21a55924 100644 --- a/lisp/emacs-lisp/helper.el +++ b/lisp/emacs-lisp/helper.el @@ -1,4 +1,4 @@ -;;; helper.el --- utility help package supporting help in electric modes +;;; helper.el --- utility help package supporting help in electric modes -*- lexical-binding: t; -*- ;; Copyright (C) 1985, 2001-2021 Free Software Foundation, Inc. @@ -39,20 +39,19 @@ ;; keymap either. -(defvar Helper-help-map nil) -(if Helper-help-map - nil - (setq Helper-help-map (make-keymap)) - ;(fillarray Helper-help-map 'undefined) - (define-key Helper-help-map "m" 'Helper-describe-mode) - (define-key Helper-help-map "b" 'Helper-describe-bindings) - (define-key Helper-help-map "c" 'Helper-describe-key-briefly) - (define-key Helper-help-map "k" 'Helper-describe-key) - ;(define-key Helper-help-map "f" 'Helper-describe-function) - ;(define-key Helper-help-map "v" 'Helper-describe-variable) - (define-key Helper-help-map "?" 'Helper-help-options) - (define-key Helper-help-map (char-to-string help-char) 'Helper-help-options) - (fset 'Helper-help-map Helper-help-map)) +(defvar Helper-help-map + (let ((map (make-sparse-keymap))) + ;(fillarray map 'undefined) + (define-key map "m" 'Helper-describe-mode) + (define-key map "b" 'Helper-describe-bindings) + (define-key map "c" 'Helper-describe-key-briefly) + (define-key map "k" 'Helper-describe-key) + ;(define-key map "f" 'Helper-describe-function) + ;(define-key map "v" 'Helper-describe-variable) + (define-key map "?" 'Helper-help-options) + (define-key map (char-to-string help-char) 'Helper-help-options) + (fset 'Helper-help-map map) + map)) (defun Helper-help-scroller () (let ((blurb (or (and (boundp 'Helper-return-blurb) diff --git a/lisp/emacs-lisp/package-x.el b/lisp/emacs-lisp/package-x.el index 8a0853ce445..b723643ffb9 100644 --- a/lisp/emacs-lisp/package-x.el +++ b/lisp/emacs-lisp/package-x.el @@ -1,4 +1,4 @@ -;;; package-x.el --- Package extras +;;; package-x.el --- Package extras -*- lexical-binding: t; -*- ;; Copyright (C) 2007-2021 Free Software Foundation, Inc. diff --git a/lisp/emacs-lisp/regi.el b/lisp/emacs-lisp/regi.el index 38b202fa101..527af1ddf24 100644 --- a/lisp/emacs-lisp/regi.el +++ b/lisp/emacs-lisp/regi.el @@ -1,4 +1,4 @@ -;;; regi.el --- REGular expression Interpreting engine +;;; regi.el --- REGular expression Interpreting engine -*- lexical-binding: t; -*- ;; Copyright (C) 1993, 2001-2021 Free Software Foundation, Inc. @@ -153,7 +153,7 @@ useful information: ;; set up the narrowed region (and start end - (let* ((tstart start) + (let* (;; (tstart start) (start (min start end)) (end (max start end))) (narrow-to-region @@ -206,30 +206,33 @@ useful information: ;; if the line matched, package up the argument list and ;; funcall the FUNC (if match-p - (let* ((curline (buffer-substring - (regi-pos 'bol) - (regi-pos 'eol))) - (curframe current-frame) - (curentry entry) - (result (eval func)) - (step (or (cdr (assq 'step result)) 1)) - ) - ;; changing frame on the fly? - (if (assq 'frame result) - (setq working-frame (cdr (assq 'frame result)))) - - ;; continue processing current frame? - (if (memq 'continue result) - (setq current-frame (cdr current-frame)) - (forward-line step) - (setq current-frame working-frame)) - - ;; abort current frame? - (if (memq 'abort result) - (progn - (setq donep t) - (throw 'regi-throw-top t))) - ) ; end-let + (with-suppressed-warnings + ((lexical curframe curentry curline)) + (defvar curframe) (defvar curentry) (defvar curline) + (let* ((curline (buffer-substring + (regi-pos 'bol) + (regi-pos 'eol))) + (curframe current-frame) + (curentry entry) + (result (eval func)) + (step (or (cdr (assq 'step result)) 1)) + ) + ;; changing frame on the fly? + (if (assq 'frame result) + (setq working-frame (cdr (assq 'frame result)))) + + ;; continue processing current frame? + (if (memq 'continue result) + (setq current-frame (cdr current-frame)) + (forward-line step) + (setq current-frame working-frame)) + + ;; abort current frame? + (if (memq 'abort result) + (progn + (setq donep t) + (throw 'regi-throw-top t))) + )) ; end-let ;; else if no match occurred, then process the next ;; frame-entry on the current line diff --git a/lisp/emacs-lisp/shadow.el b/lisp/emacs-lisp/shadow.el index 168e5e46f37..c1d05941239 100644 --- a/lisp/emacs-lisp/shadow.el +++ b/lisp/emacs-lisp/shadow.el @@ -1,4 +1,4 @@ -;;; shadow.el --- locate Emacs Lisp file shadowings +;;; shadow.el --- locate Emacs Lisp file shadowings -*- lexical-binding: t; -*- ;; Copyright (C) 1995, 2001-2021 Free Software Foundation, Inc. @@ -58,8 +58,7 @@ (defcustom load-path-shadows-compare-text nil "If non-nil, then shadowing files are reported only if their text differs. This is slower, but filters out some innocuous shadowing." - :type 'boolean - :group 'lisp-shadow) + :type 'boolean) (defun load-path-shadows-find (&optional path) "Return a list of Emacs Lisp files that create shadows. @@ -78,8 +77,7 @@ See the documentation for `list-load-path-shadows' for further information." dir-case-insensitive ; `file-name-case-insensitive-p' of dir. curr-files ; This dir's Emacs Lisp files. orig-dir ; Where the file was first seen. - files-seen-this-dir ; Files seen so far in this dir. - file) ; The current file. + files-seen-this-dir) ; Files seen so far in this dir. (dolist (pp (or path load-path)) (setq dir (directory-file-name (file-truename (or pp ".")))) (if (member dir true-names) @@ -109,7 +107,7 @@ See the documentation for `list-load-path-shadows' for further information." (dolist (file curr-files) - (if (string-match "\\.gz$" file) + (if (string-match "\\.gz\\'" file) (setq file (substring file 0 -3))) (setq file (substring file 0 (if (string= (substring file -1) "c") -4 -3))) @@ -125,9 +123,13 @@ See the documentation for `list-load-path-shadows' for further information." ;; XXX.elc (or vice-versa) when they are in the same directory. (setq files-seen-this-dir (cons file files-seen-this-dir)) - (if (setq orig-dir (assoc file files - (when dir-case-insensitive - (lambda (f1 f2) (eq (compare-strings f1 nil nil f2 nil nil t) t))))) + (if (setq orig-dir + (assoc file files + (when dir-case-insensitive + (lambda (f1 f2) + (eq (compare-strings f1 nil nil + f2 nil nil t) + t))))) ;; This file was seen before, we have a shadowing. ;; Report it unless the files are identical. (let ((base1 (concat (cdr orig-dir) "/" (car orig-dir))) @@ -142,7 +144,7 @@ See the documentation for `list-load-path-shadows' for further information." (append shadows (list base1 base2))))) ;; Not seen before, add it to the list of seen files. - (setq files (cons (cons file dir) files))))))) + (push (cons file dir) files)))))) ;; Return the list of shadowings. shadows)) diff --git a/lisp/emacs-lisp/tcover-ses.el b/lisp/emacs-lisp/tcover-ses.el index 7de9d547ce4..fb9cd8f47df 100644 --- a/lisp/emacs-lisp/tcover-ses.el +++ b/lisp/emacs-lisp/tcover-ses.el @@ -1,4 +1,4 @@ -;;;; testcover-ses.el -- Example use of `testcover' to test "SES" +;;;; testcover-ses.el -- Example use of `testcover' to test "SES" -*- lexical-binding: t; -*- ;; Copyright (C) 2002-2021 Free Software Foundation, Inc. @@ -19,21 +19,14 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see . -(require 'testcover) +;;; Commentary: -(defvar ses-initial-global-parameters) -(defvar ses-mode-map) +;; FIXME: Convert to ERT and move to `test/'? -(declare-function ses-set-curcell "ses") -(declare-function ses-update-cells "ses") -(declare-function ses-load "ses") -(declare-function ses-vector-delete "ses") -(declare-function ses-create-header-string "ses") -(declare-function ses-read-cell "ses") -(declare-function ses-read-symbol "ses") -(declare-function ses-command-hook "ses") -(declare-function ses-jump "ses") +;;; Code: +(require 'testcover) +(require 'ses) ;;;Here are some macros that exercise SES. Set `pause' to t if you want the ;;;macros to pause after each step. @@ -652,6 +645,7 @@ spreadsheet files with invalid formatting." (testcover-start "ses.el" t)) (require 'unsafep)) ;In case user has safe-functions = t! +(defvar ses--curcell-overlay) ;;;######################################################################### (defun ses-exercise () @@ -674,8 +668,8 @@ spreadsheet files with invalid formatting." (ses-load)) ;;ses-vector-delete is always called from buffer-undo-list with the same ;;symbol as argument. We'll give it a different one here. - (let ((x [1 2 3])) - (ses-vector-delete 'x 0 0)) + (dlet ((tcover-ses--x [1 2 3])) + (ses-vector-delete 'tcover-ses--x 0 0)) ;;ses-create-header-string behaves differently in a non-window environment ;;but we always test under windows. (let ((window-system (not window-system))) @@ -704,7 +698,7 @@ spreadsheet files with invalid formatting." (ses-mode))))) ;;Test error-handling in command hook, outside a macro. ;;This will ring the bell. - (let (curcell-overlay) + (let (ses--curcell-overlay) (ses-command-hook)) ;;Due to use of run-with-timer, ses-command-hook sometimes gets called ;;after we switch to another buffer. @@ -720,4 +714,4 @@ spreadsheet files with invalid formatting." ;;Could do this here: (testcover-end "ses.el") (message "Done")) -;; testcover-ses.el ends here. +;;; testcover-ses.el ends here. diff --git a/lisp/emacs-lisp/unsafep.el b/lisp/emacs-lisp/unsafep.el index f46d9c77eae..d52a6c796db 100644 --- a/lisp/emacs-lisp/unsafep.el +++ b/lisp/emacs-lisp/unsafep.el @@ -1,4 +1,4 @@ -;;;; unsafep.el -- Determine whether a Lisp form is safe to evaluate +;;;; unsafep.el -- Determine whether a Lisp form is safe to evaluate -*- lexical-binding: t; -*- ;; Copyright (C) 2002-2021 Free Software Foundation, Inc. @@ -129,15 +129,16 @@ in the parse.") (put x 'safe-function t)) ;;;###autoload -(defun unsafep (form &optional unsafep-vars) +(defun unsafep (form &optional vars) "Return nil if evaluating FORM couldn't possibly do any harm. Otherwise result is a reason why FORM is unsafe. -UNSAFEP-VARS is a list of symbols with local bindings." +VARS is a list of symbols with local bindings like `unsafep-vars'." (catch 'unsafep (if (or (eq safe-functions t) ;User turned off safety-checking (atom form)) ;Atoms are never unsafe (throw 'unsafep nil)) - (let* ((fun (car form)) + (let* ((unsafep-vars vars) + (fun (car form)) (reason (unsafep-function fun)) arg) (cond -- cgit v1.2.3 From 11c504c9d2742cd7b19a2ed188b6545c9e86d206 Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Thu, 28 Jan 2021 21:28:03 +0100 Subject: Define compat alias obsolete * lisp/generic-x.el (generic-mode-ini-file-find-file-hook): Define compat alias introduced after rename in 22.1 obsolete. --- lisp/generic-x.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/generic-x.el b/lisp/generic-x.el index bd03f287fc7..0063cb73b3b 100644 --- a/lisp/generic-x.el +++ b/lisp/generic-x.el @@ -416,7 +416,8 @@ like an INI file. You can add this hook to `find-file-hook'." (goto-char (point-min)) (and (looking-at "^\\s-*\\[.*\\]") (ini-generic-mode))))) -(defalias 'generic-mode-ini-file-find-file-hook 'ini-generic-mode-find-file-hook)) +(define-obsolete-function-alias 'generic-mode-ini-file-find-file-hook + #'ini-generic-mode-find-file-hook "28.1")) ;;; Windows REG files ;;; Unfortunately, Windows 95 and Windows NT have different REG file syntax! -- cgit v1.2.3 From 554ec932ba37e0191df33959abaec9e1bfdaa891 Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Thu, 28 Jan 2021 21:35:34 +0100 Subject: Use lexical-binding in generic-x.el * lisp/generic-x.el: Use lexical-binding. Remove redundant :groups. (generic-rul-mode-setup-function): Prefer setq-local. --- lisp/generic-x.el | 34 ++++++++++++---------------------- 1 file changed, 12 insertions(+), 22 deletions(-) (limited to 'lisp') diff --git a/lisp/generic-x.el b/lisp/generic-x.el index 0063cb73b3b..be8d41bde00 100644 --- a/lisp/generic-x.el +++ b/lisp/generic-x.el @@ -1,4 +1,4 @@ -;;; generic-x.el --- A collection of generic modes +;;; generic-x.el --- A collection of generic modes -*- lexical-binding: t -*- ;; Copyright (C) 1997-1998, 2001-2021 Free Software Foundation, Inc. @@ -121,14 +121,12 @@ "If non-nil, add a hook to enter `default-generic-mode' automatically. This is done if the first few lines of a file in fundamental mode start with a hash comment character." - :group 'generic-x :type 'boolean) (defcustom generic-lines-to-scan 3 "Number of lines that `generic-mode-find-file-hook' looks at. Relevant when deciding whether to enter Default-Generic mode automatically. This variable should be set to a small positive number." - :group 'generic-x :type 'integer) (defcustom generic-find-file-regexp "^#" @@ -137,7 +135,6 @@ Files in fundamental mode whose first few lines contain a match for this regexp, should be put into Default-Generic mode instead. The number of lines tested for the matches is specified by the value of the variable `generic-lines-to-scan', which see." - :group 'generic-x :type 'regexp) (defcustom generic-ignore-files-regexp "[Tt][Aa][Gg][Ss]\\'" @@ -146,7 +143,6 @@ Files whose names match this regular expression should not be put into Default-Generic mode, even if they have lines which match the regexp in `generic-find-file-regexp'. If the value is nil, `generic-mode-find-file-hook' does not check the file names." - :group 'generic-x :type '(choice (const :tag "Don't check file names" nil) regexp)) ;; This generic mode is always defined @@ -249,7 +245,6 @@ This hook will be installed if the variable Each entry in the list should be a symbol. If you set this variable directly, without using customize, you must reload generic-x to put your changes into effect." - :group 'generic-x :type (let (list) (dolist (mode (sort (append generic-default-modes @@ -1298,19 +1293,16 @@ like an INI file. You can add this hook to `find-file-hook'." ;; here manually instead (defun generic-rul-mode-setup-function () - (make-local-variable 'parse-sexp-ignore-comments) - (make-local-variable 'comment-start) (make-local-variable 'comment-start-skip) - (make-local-variable 'comment-end) (setq imenu-generic-expression - '((nil "^function\\s-+\\([A-Za-z0-9_]+\\)" 1)) - parse-sexp-ignore-comments t - comment-end "*/" - comment-start "/*" -;;; comment-end "" -;;; comment-start "//" -;;; comment-start-skip "" - ) + '((nil "^function\\s-+\\([A-Za-z0-9_]+\\)" 1))) + (setq-local parse-sexp-ignore-comments t + comment-end "*/" + comment-start "/*" +;;; comment-end "" +;;; comment-start "//" +;;; comment-start-skip "" + ) ;; (set-syntax-table rul-generic-mode-syntax-table) (setq-local font-lock-syntax-table rul-generic-mode-syntax-table)) @@ -1460,7 +1452,7 @@ like an INI file. You can add this hook to `find-file-hook'." ":" ;; Password, UID and GID (mapconcat - 'identity + #'identity (make-list 3 "\\([^:]+\\)") ":") ":" @@ -1640,8 +1632,7 @@ like an INI file. You can add this hook to `find-file-hook'." (((class color) (min-colors 88)) (:background "red1")) (((class color)) (:background "red")) (t (:weight bold))) - "Font Lock mode face used to highlight TABs." - :group 'generic-x) + "Font Lock mode face used to highlight TABs.") (defface show-tabs-space '((((class grayscale) (background light)) (:background "DimGray" :weight bold)) @@ -1649,8 +1640,7 @@ like an INI file. You can add this hook to `find-file-hook'." (((class color) (min-colors 88)) (:background "yellow1")) (((class color)) (:background "yellow")) (t (:weight bold))) - "Font Lock mode face used to highlight spaces." - :group 'generic-x) + "Font Lock mode face used to highlight spaces.") (define-generic-mode show-tabs-generic-mode nil ;; no comment char -- cgit v1.2.3 From ae7fe263b28cc87f5d8c8770b7d321ff436a12bb Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Thu, 28 Jan 2021 21:55:31 +0100 Subject: ; Fix my previous commit * lisp/generic-x.el (generic-mode-ini-file-find-file-hook): Fix my previous commit; for some reason 'function' produces a warning here while 'quote' does not. --- lisp/generic-x.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/generic-x.el b/lisp/generic-x.el index be8d41bde00..4c6e1189003 100644 --- a/lisp/generic-x.el +++ b/lisp/generic-x.el @@ -412,7 +412,7 @@ like an INI file. You can add this hook to `find-file-hook'." (and (looking-at "^\\s-*\\[.*\\]") (ini-generic-mode))))) (define-obsolete-function-alias 'generic-mode-ini-file-find-file-hook - #'ini-generic-mode-find-file-hook "28.1")) + 'ini-generic-mode-find-file-hook "28.1")) ;;; Windows REG files ;;; Unfortunately, Windows 95 and Windows NT have different REG file syntax! -- cgit v1.2.3 From a50fe43337eef4b287784527f33cceab4f9ab30c Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Thu, 28 Jan 2021 21:45:26 +0100 Subject: * lisp/progmodes/bat-mode.el: Use lexical-binding. --- lisp/progmodes/bat-mode.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/progmodes/bat-mode.el b/lisp/progmodes/bat-mode.el index 44295c3f679..7ba8a69775e 100644 --- a/lisp/progmodes/bat-mode.el +++ b/lisp/progmodes/bat-mode.el @@ -1,4 +1,4 @@ -;;; bat-mode.el --- Major mode for editing DOS/Windows scripts +;;; bat-mode.el --- Major mode for editing DOS/Windows scripts -*- lexical-binding: t -*- ;; Copyright (C) 2003, 2008-2021 Free Software Foundation, Inc. -- cgit v1.2.3 From cb97581870cb1e3c211e4cead5f14f6cb67e4c8f Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Thu, 28 Jan 2021 22:06:35 +0100 Subject: Use lexical-binding in nroff-mode.el * lisp/textmodes/nroff-mode.el: Use lexical-binding. Remove redundant :group args. --- lisp/textmodes/nroff-mode.el | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) (limited to 'lisp') diff --git a/lisp/textmodes/nroff-mode.el b/lisp/textmodes/nroff-mode.el index 896578513cf..fe70e925b05 100644 --- a/lisp/textmodes/nroff-mode.el +++ b/lisp/textmodes/nroff-mode.el @@ -1,4 +1,4 @@ -;;; nroff-mode.el --- GNU Emacs major mode for editing nroff source +;;; nroff-mode.el --- GNU Emacs major mode for editing nroff source -*- lexical-binding: t -*- ;; Copyright (C) 1985-1986, 1994-1995, 1997, 2001-2021 Free Software ;; Foundation, Inc. @@ -43,7 +43,6 @@ (defcustom nroff-electric-mode nil "Non-nil means automatically closing requests when you insert an open." - :group 'nroff :type 'boolean) (defvar nroff-mode-map @@ -111,7 +110,7 @@ ;; arguments in common cases, like \f. (concat "\\\\" ; backslash "\\(" ; followed by various possibilities - (mapconcat 'identity + (mapconcat #'identity '("[f*n]*\\[.+?]" ; some groff extensions "(.." ; two chars after ( "[^(\"#]" ; single char escape @@ -119,13 +118,11 @@ "\\)") ) "Font-lock highlighting control in `nroff-mode'." - :group 'nroff :type '(repeat regexp)) (defcustom nroff-mode-hook nil "Hook run by function `nroff-mode'." - :type 'hook - :group 'nroff) + :type 'hook) ;;;###autoload (define-derived-mode nroff-mode text-mode "Nroff" -- cgit v1.2.3 From 3ddea271cc9542e29829629991a4073ab3cf5db9 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Fri, 29 Jan 2021 05:52:51 +0100 Subject: Slight gravatar.el code clean up * lisp/image/gravatar.el (gravatar--service-libravatar): Clean the code up slightly. --- lisp/image/gravatar.el | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) (limited to 'lisp') diff --git a/lisp/image/gravatar.el b/lisp/image/gravatar.el index b1e2a314ce8..f6f056a2baf 100644 --- a/lisp/image/gravatar.el +++ b/lisp/image/gravatar.el @@ -167,13 +167,12 @@ to track whether you're reading a specific mail." ;; ignore). (and (eq (dns-get 'type answers) 'SRV) answers))) - (priorities (and (mapcar (lambda (r) - (dns-get 'priority r)) - data))) - (max-priority (if priorities - (apply #'max priorities) - 0)) - (sum 0) top) + (priorities (mapcar (lambda (r) + (dns-get 'priority r)) + data)) + (max-priority (apply #'max 0 priorities)) + (sum 0) + top) ;; Attempt to find all records with the same maximal ;; priority, and calculate the sum of their weights. (dolist (ent data) -- cgit v1.2.3 From bab133e6d0bff03e5ddd7f43eca169f4843d5860 Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Fri, 29 Jan 2021 02:47:38 +0100 Subject: Use lexical-binding in find-cmd.el and add tests * lisp/find-cmd.el: Use lexical-binding. * test/lisp/find-cmd-tests.el: New file. --- lisp/find-cmd.el | 4 ++-- test/lisp/find-cmd-tests.el | 45 +++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 47 insertions(+), 2 deletions(-) create mode 100644 test/lisp/find-cmd-tests.el (limited to 'lisp') diff --git a/lisp/find-cmd.el b/lisp/find-cmd.el index 5866b308551..bb2e97d8662 100644 --- a/lisp/find-cmd.el +++ b/lisp/find-cmd.el @@ -1,4 +1,4 @@ -;;; find-cmd.el --- Build a valid find(1) command with sexps +;;; find-cmd.el --- Build a valid find(1) command with sexps -*- lexical-binding: t -*- ;; Copyright (C) 2008-2021 Free Software Foundation, Inc. @@ -28,7 +28,7 @@ ;; (find-cmd '(prune (name ".svn" ".git" ".CVS")) ;; '(and (or (name "*.pl" "*.pm" "*.t") ;; (mtime "+1")) -;; (fstype "nfs" "ufs")))) +;; (fstype "nfs" "ufs"))) ;; will become (un-wrapped): diff --git a/test/lisp/find-cmd-tests.el b/test/lisp/find-cmd-tests.el new file mode 100644 index 00000000000..b8e0f273988 --- /dev/null +++ b/test/lisp/find-cmd-tests.el @@ -0,0 +1,45 @@ +;;; find-cmd-tests.el --- tests for find-cmd.el. -*- lexical-binding: t -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(require 'ert) +(require 'find-cmd) + +(ert-deftest find-cmd-test-find-cmd () + (should + (string-match + (rx "find " (+ any) + " \\( \\( -name .svn -or -name .git -or -name .CVS \\)" + " -prune -or -true \\)" + " \\( \\( \\(" " -name \\*.pl -or -name \\*.pm -or -name \\*.t \\)" + " -or -mtime \\+1 \\) -and \\( -fstype nfs -or -fstype ufs \\) \\) ") + (find-cmd '(prune (name ".svn" ".git" ".CVS")) + '(and (or (name "*.pl" "*.pm" "*.t") + (mtime "+1")) + (fstype "nfs" "ufs")))))) + +(ert-deftest find-cmd-test-find-cmd/error-unknown-atom () + (should-error (find-cmd '(unknown 123)))) + +(ert-deftest find-cmd-test-find-cmd/error-wrong-argnum () + (should-error (find-cmd '(name)))) + +(provide 'find-cmd-tests) +;;; find-cmd-tests.el ends here -- cgit v1.2.3 From a27512e21c710ab39a0b811701a952db482204c1 Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Fri, 29 Jan 2021 02:55:34 +0100 Subject: * lisp/flow-ctrl.el: Use lexical-binding. * lisp/flow-ctrl.el (enable-flow-control): Minor cleanup. --- lisp/flow-ctrl.el | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) (limited to 'lisp') diff --git a/lisp/flow-ctrl.el b/lisp/flow-ctrl.el index 656edf2eb09..adb52d7253a 100644 --- a/lisp/flow-ctrl.el +++ b/lisp/flow-ctrl.el @@ -1,4 +1,4 @@ -;;; flow-ctrl.el --- help for lusers on cu(1) or ttys with wired-in ^S/^Q flow control +;;; flow-ctrl.el --- help for lusers on cu(1) or ttys with wired-in ^S/^Q flow control -*- lexical-binding: t -*- ;; Copyright (C) 1990-1991, 1994, 2001-2021 Free Software Foundation, ;; Inc. @@ -64,12 +64,11 @@ With arg, enable flow control mode if arg is positive, otherwise disable." (progn ;; Turn flow control off, and stop exchanging chars. (set-input-mode t nil (nth 2 (current-input-mode))) - (if keyboard-translate-table - (progn - (aset keyboard-translate-table flow-control-c-s-replacement nil) - (aset keyboard-translate-table ?\^s nil) - (aset keyboard-translate-table flow-control-c-q-replacement nil) - (aset keyboard-translate-table ?\^q nil)))) + (when keyboard-translate-table + (aset keyboard-translate-table flow-control-c-s-replacement nil) + (aset keyboard-translate-table ?\^s nil) + (aset keyboard-translate-table flow-control-c-q-replacement nil) + (aset keyboard-translate-table ?\^q nil))) ;; Turn flow control on. ;; Tell emacs to pass C-s and C-q to OS. (set-input-mode nil t (nth 2 (current-input-mode))) -- cgit v1.2.3 From e52f2ec968a73a3f29939cf62d67a5ffe811ee09 Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Fri, 29 Jan 2021 04:43:57 +0100 Subject: Remove Emacs 21 compat code from sasl.el * lisp/net/sasl.el (sasl-read-passphrase): Remove compat code; 'read-passwd' is preloaded since Emacs 22. --- lisp/net/sasl.el | 9 +-------- 1 file changed, 1 insertion(+), 8 deletions(-) (limited to 'lisp') diff --git a/lisp/net/sasl.el b/lisp/net/sasl.el index 7f0431afb60..d2e08f7e3ed 100644 --- a/lisp/net/sasl.el +++ b/lisp/net/sasl.el @@ -161,15 +161,8 @@ the current challenge. At the first time STEP should be set to nil." (if function (vector function (funcall function client step))))) -(defvar sasl-read-passphrase nil) +(defvar sasl-read-passphrase 'read-passwd) (defun sasl-read-passphrase (prompt) - (if (not sasl-read-passphrase) - (if (functionp 'read-passwd) - (setq sasl-read-passphrase 'read-passwd) - (if (load "passwd" t) - (setq sasl-read-passphrase 'read-passwd) - (autoload 'ange-ftp-read-passwd "ange-ftp") - (setq sasl-read-passphrase 'ange-ftp-read-passwd)))) (funcall sasl-read-passphrase prompt)) (defun sasl-unique-id () -- cgit v1.2.3 From de51d94721efb90b153d70dc15691c16d0fbb46a Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Fri, 29 Jan 2021 06:46:14 +0100 Subject: Mention using buffer-list-update-hook in recentf-mode * lisp/recentf.el (recentf-mode): Mention using `buffer-list-update-hook' (bug#46153). --- lisp/recentf.el | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/recentf.el b/lisp/recentf.el index a28a3977a76..d39a523289f 100644 --- a/lisp/recentf.el +++ b/lisp/recentf.el @@ -1352,7 +1352,14 @@ That is, remove duplicates, non-kept, and excluded files." When Recentf mode is enabled, a \"Open Recent\" submenu is displayed in the \"File\" menu, containing a list of files that -were operated on recently, in the most-recently-used order." +were operated on recently, in the most-recently-used order. + +By default, only operations like opening a file, writing a buffer +to a file, and killing a buffer is counted as \"operating\" on +the file. If instead you want to prioritize files that appear in +buffers you switch to a lot, you can say something like the following: + + (add-hook 'buffer-list-update-hook 'recentf-track-opened-file)" :global t :group 'recentf :keymap recentf-mode-map -- cgit v1.2.3 From 5f650422e4a4c44ffc5ee0be4ec969765a307c7b Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Fri, 29 Jan 2021 06:50:38 +0100 Subject: Set revert-buffer-function in shell command output buffers * simple.el (shell-command, shell-command-on-region): Set revert-buffer-function in shell command output buffers (bug#46151). --- lisp/simple.el | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'lisp') diff --git a/lisp/simple.el b/lisp/simple.el index e82b138b0da..64ee0421356 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -3991,6 +3991,9 @@ impose the use of a shell (with its need to quote arguments)." (start-process-shell-command "Shell" buffer command))) (setq mode-line-process '(":%s")) (shell-mode) + (setq revert-buffer-function + (lambda (&rest _) + (async-shell-command command (current-buffer)))) (set-process-sentinel proc #'shell-command-sentinel) ;; Use the comint filter for proper handling of ;; carriage motion (see comint-inhibit-carriage-motion). @@ -4257,6 +4260,9 @@ characters." buffer)))) ;; Report the output. (with-current-buffer buffer + (setq revert-buffer-function + (lambda (&rest _) + (shell-command command))) (setq mode-line-process (cond ((null exit-status) " - Error") -- cgit v1.2.3 From 0b80935d37f4a089ee7e925e246622dcd4b1addb Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Fri, 29 Jan 2021 07:04:43 +0100 Subject: Fix position in empty buffers in checkdoc-file-comments-engine * lisp/emacs-lisp/checkdoc.el (checkdoc-file-comments-engine): Don't give invalid positions on empty buffers (bug#39987). --- lisp/emacs-lisp/checkdoc.el | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index 76638ec13b1..9722792a5a5 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -2362,7 +2362,9 @@ Code:, and others referenced in the style guide." (checkdoc-create-error (format "The footer should be: (provide '%s)\\n;;; %s%s ends here" fn fn fe) - (1- (point-max)) (point-max))))) + ;; The buffer may be empty. + (max (point-min) (1- (point-max))) + (point-max))))) err)) ;; The below checks will not return errors if the user says NO -- cgit v1.2.3 From 9fb859010fa624f4b63ad4a1a8ba22a0f64f16f2 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Fri, 29 Jan 2021 07:15:35 +0100 Subject: flymake-diagnostic-beg/end doc string and error reporting improvement * lisp/progmodes/flymake.el (flymake-diagnostic-beg): (flymake-diagnostic-end): Improve doc string and error reporting (bug#39971). --- lisp/progmodes/flymake.el | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) (limited to 'lisp') diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el index 460af718aad..5d96c62b418 100644 --- a/lisp/progmodes/flymake.el +++ b/lisp/progmodes/flymake.el @@ -352,12 +352,20 @@ diagnostics at BEG." (flymake--diag-accessor flymake-diagnostic-data flymake--diag-data backend) (defun flymake-diagnostic-beg (diag) - "Get Flymake diagnostic DIAG's start position." - (overlay-start (flymake--diag-overlay diag))) + "Get Flymake diagnostic DIAG's start position. +This position only be queried after DIAG has been reported to Flymake." + (let ((overlay (flymake--diag-overlay diag))) + (unless overlay + (error "DIAG %s not reported to Flymake yet" diag)) + (overlay-start overlay))) (defun flymake-diagnostic-end (diag) - "Get Flymake diagnostic DIAG's end position." - (overlay-end (flymake--diag-overlay diag))) + "Get Flymake diagnostic DIAG's end position. +This position only be queried after DIAG has been reported to Flymake." + (let ((overlay (flymake--diag-overlay diag))) + (unless overlay + (error "DIAG %s not reported to Flymake yet" diag)) + (overlay-end overlay))) (cl-defun flymake--overlays (&key beg end filter compare key) "Get flymake-related overlays. -- cgit v1.2.3 From 1275dc4711af77c9c223063dcd149d782d497463 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Fri, 29 Jan 2021 07:40:06 +0100 Subject: Improve fontifying of #| ... |# in `lisp-mode' * lisp/emacs-lisp/lisp-mode.el (lisp-mode): Fontify the end delimiter in #| ... |# correctly (bug#39820). --- lisp/emacs-lisp/lisp-mode.el | 1 + 1 file changed, 1 insertion(+) (limited to 'lisp') diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index c96d849d442..3918fa01b2a 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -775,6 +775,7 @@ or to switch back to an existing one." (setq-local find-tag-default-function 'lisp-find-tag-default) (setq-local comment-start-skip "\\(\\(^\\|[^\\\n]\\)\\(\\\\\\\\\\)*\\)\\(;+\\|#|\\) *") + (setq-local comment-end "|#") (setq imenu-case-fold-search t)) (defun lisp-find-tag-default () -- cgit v1.2.3 From d4e9d191aeba9076db06857a90649f6fcddc7f3b Mon Sep 17 00:00:00 2001 From: Marco Wahl Date: Fri, 29 Jan 2021 08:01:12 +0100 Subject: Add a command for redisplay during keyboard macros * doc/emacs/kmacro.texi (Basic Keyboard Macro): Document it (bug#39252). * lisp/kmacro.el (kdb-macro-redisplay): New function. (kmacro-keymap): Bind it. --- doc/emacs/kmacro.texi | 8 ++++++++ etc/NEWS | 3 +++ lisp/kmacro.el | 11 +++++++++++ 3 files changed, 22 insertions(+) (limited to 'lisp') diff --git a/doc/emacs/kmacro.texi b/doc/emacs/kmacro.texi index adb2ab8d561..e713c6ef8c0 100644 --- a/doc/emacs/kmacro.texi +++ b/doc/emacs/kmacro.texi @@ -179,6 +179,14 @@ itself counts as the first repetition, since it is executed as you define it, so @kbd{C-u 4 C-x )} executes the macro immediately 3 additional times. +@findex kdb-macro-redisplay +@kindex C-x C-k Q + While executing a long-running keyboard macro, it can sometimes be +useful to trigger a redisplay (to show how far we've gotten). The +@kbd{C-x C-k Q} can be used for this. As a not very useful example, +@kbd{C-x ( M-f C-x C-k Q C-x )} will create a macro that will +redisplay once per iteration when saying @kbd{C-u 42 C-x e}. + @node Keyboard Macro Ring @section The Keyboard Macro Ring diff --git a/etc/NEWS b/etc/NEWS index f12c94d6491..8e233f8f196 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1577,6 +1577,9 @@ This allows mode-specific alterations to how `thing-at-point' works. ** Miscellaneous ++++ +*** New command `C-x C-k Q' to force redisplay in keyboard macros. + --- *** New user option 'remember-diary-regexp'. diff --git a/lisp/kmacro.el b/lisp/kmacro.el index bb8dacf4f48..303f38a59b6 100644 --- a/lisp/kmacro.el +++ b/lisp/kmacro.el @@ -172,6 +172,7 @@ macro to be executed before appending to it." (define-key map "\C-k" 'kmacro-end-or-call-macro-repeat) (define-key map "r" 'apply-macro-to-region-lines) (define-key map "q" 'kbd-macro-query) ;; Like C-x q + (define-key map "Q" 'kdb-macro-redisplay) ;; macro ring (define-key map "\C-n" 'kmacro-cycle-ring-next) @@ -1298,6 +1299,16 @@ To customize possible responses, change the \"bindings\" in (kmacro-push-ring) (setq last-kbd-macro kmacro-step-edit-new-macro)))) +(defun kdb-macro-redisplay () + "Force redisplay during kbd macro execution." + (interactive) + (or executing-kbd-macro + defining-kbd-macro + (user-error "Not defining or executing kbd macro")) + (when executing-kbd-macro + (let ((executing-kbd-macro nil)) + (redisplay)))) + (provide 'kmacro) ;;; kmacro.el ends here -- cgit v1.2.3 From 19afd6de25eb836014301009620091be6f0012b0 Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Fri, 29 Jan 2021 08:18:52 +0100 Subject: Fix previous commit regarding revert-buffer-function * simple.el (shell-command, shell-command-on-region): Set revert-buffer-function buffer-locally, not globally. Also, avoid an unnecessary call to (current-buffer) by taking advantage of the closure (bug#46151). --- lisp/simple.el | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) (limited to 'lisp') diff --git a/lisp/simple.el b/lisp/simple.el index 64ee0421356..742fc5004dc 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -3991,9 +3991,9 @@ impose the use of a shell (with its need to quote arguments)." (start-process-shell-command "Shell" buffer command))) (setq mode-line-process '(":%s")) (shell-mode) - (setq revert-buffer-function - (lambda (&rest _) - (async-shell-command command (current-buffer)))) + (setq-local revert-buffer-function + (lambda (&rest _) + (async-shell-command command buffer))) (set-process-sentinel proc #'shell-command-sentinel) ;; Use the comint filter for proper handling of ;; carriage motion (see comint-inhibit-carriage-motion). @@ -4260,9 +4260,9 @@ characters." buffer)))) ;; Report the output. (with-current-buffer buffer - (setq revert-buffer-function - (lambda (&rest _) - (shell-command command))) + (setq-local revert-buffer-function + (lambda (&rest _) + (shell-command command))) (setq mode-line-process (cond ((null exit-status) " - Error") -- cgit v1.2.3 From 4ce5646d592c8d998d066d56108e6dd92372e22b Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Fri, 29 Jan 2021 09:44:31 +0100 Subject: Fix Bug#45518 in compile.el * lisp/progmodes/compile.el (compilation-get-file-structure): Avoid call of `file-truename' for remote files. (Bug#45518) --- lisp/progmodes/compile.el | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el index 94e4f3c6fa7..2c1e6ff52ec 100644 --- a/lisp/progmodes/compile.el +++ b/lisp/progmodes/compile.el @@ -3041,7 +3041,12 @@ TRUE-DIRNAME is the `file-truename' of DIRNAME, if given." ;; Get the specified directory from FILE. (spec-directory (if (cdr file) - (file-truename (concat comint-file-name-prefix (cdr file)))))) + ;; This function is active in `compilation-filter'. + ;; There could be problems to call `file-truename' + ;; for remote compilation processes. + (if (file-remote-p default-directory) + (concat comint-file-name-prefix (cdr file)) + (file-truename (concat comint-file-name-prefix (cdr file))))))) ;; Check for a comint-file-name-prefix and prepend it if appropriate. ;; (This is very useful for compilation-minor-mode in an rlogin-mode -- cgit v1.2.3 From 840b1c66b4a686763c9288de8efb7ec48ccf06da Mon Sep 17 00:00:00 2001 From: Juri Linkov Date: Fri, 29 Jan 2021 10:55:16 +0200 Subject: Use save-mark-and-excursion in query-replace-read-args (bug#45617) --- lisp/replace.el | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) (limited to 'lisp') diff --git a/lisp/replace.el b/lisp/replace.el index cbf24bedef4..f13d27aff89 100644 --- a/lisp/replace.el +++ b/lisp/replace.el @@ -343,14 +343,15 @@ Prompt with PROMPT. REGEXP-FLAG non-nil means the response should a regexp." (defun query-replace-read-args (prompt regexp-flag &optional noerror) (unless noerror (barf-if-buffer-read-only)) - (let* ((from (query-replace-read-from prompt regexp-flag)) - (to (if (consp from) (prog1 (cdr from) (setq from (car from))) - (query-replace-read-to from prompt regexp-flag)))) - (list from to - (or (and current-prefix-arg (not (eq current-prefix-arg '-))) - (and (plist-member (text-properties-at 0 from) 'isearch-regexp-function) - (get-text-property 0 'isearch-regexp-function from))) - (and current-prefix-arg (eq current-prefix-arg '-))))) + (save-mark-and-excursion + (let* ((from (query-replace-read-from prompt regexp-flag)) + (to (if (consp from) (prog1 (cdr from) (setq from (car from))) + (query-replace-read-to from prompt regexp-flag)))) + (list from to + (or (and current-prefix-arg (not (eq current-prefix-arg '-))) + (and (plist-member (text-properties-at 0 from) 'isearch-regexp-function) + (get-text-property 0 'isearch-regexp-function from))) + (and current-prefix-arg (eq current-prefix-arg '-)))))) (defun query-replace (from-string to-string &optional delimited start end backward region-noncontiguous-p) "Replace some occurrences of FROM-STRING with TO-STRING. -- cgit v1.2.3 From e86b30d6fd04070b86560774ec82392dbe24ca1e Mon Sep 17 00:00:00 2001 From: Dmitry Gutov Date: Fri, 29 Jan 2021 15:53:28 +0200 Subject: (xref-revert-buffer): Also 'erase-buffer' when handling a user-error * lisp/progmodes/xref.el (xref-revert-buffer): Also 'erase-buffer' when handling a user-error (bug#46042). --- lisp/progmodes/xref.el | 1 + 1 file changed, 1 insertion(+) (limited to 'lisp') diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index 07a65d4ed93..18fdd963fb1 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -972,6 +972,7 @@ Return an alist of the form ((FILENAME . (XREF ...)) ...)." (erase-buffer) (xref--insert-xrefs alist)) (user-error + (erase-buffer) (insert (propertize (error-message-string err) -- cgit v1.2.3 From c7a86cb7ecb79cd07c66ce6a5af5fac32fc2fca4 Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Fri, 29 Jan 2021 20:11:38 +0100 Subject: Use lexical-binding in sasl.el and add tests * lisp/net/sasl.el: * lisp/net/sasl-digest.el: * lisp/net/sasl-cram.el: * lisp/net/sasl-ntlm.el: Use lexical-binding. * test/lisp/net/sasl-tests.el: * test/lisp/net/sasl-cram-tests.el: New files. --- lisp/net/sasl-cram.el | 2 +- lisp/net/sasl-digest.el | 2 +- lisp/net/sasl-ntlm.el | 2 +- lisp/net/sasl.el | 2 +- test/lisp/net/sasl-cram-tests.el | 46 +++++++++++++++++++++++++++++++ test/lisp/net/sasl-tests.el | 59 ++++++++++++++++++++++++++++++++++++++++ 6 files changed, 109 insertions(+), 4 deletions(-) create mode 100644 test/lisp/net/sasl-cram-tests.el create mode 100644 test/lisp/net/sasl-tests.el (limited to 'lisp') diff --git a/lisp/net/sasl-cram.el b/lisp/net/sasl-cram.el index bc2612d9452..4022a35b391 100644 --- a/lisp/net/sasl-cram.el +++ b/lisp/net/sasl-cram.el @@ -1,4 +1,4 @@ -;;; sasl-cram.el --- CRAM-MD5 module for the SASL client framework +;;; sasl-cram.el --- CRAM-MD5 module for the SASL client framework -*- lexical-binding: t -*- ;; Copyright (C) 2000, 2007-2021 Free Software Foundation, Inc. diff --git a/lisp/net/sasl-digest.el b/lisp/net/sasl-digest.el index efc8f82890c..5afc195d4b4 100644 --- a/lisp/net/sasl-digest.el +++ b/lisp/net/sasl-digest.el @@ -1,4 +1,4 @@ -;;; sasl-digest.el --- DIGEST-MD5 module for the SASL client framework +;;; sasl-digest.el --- DIGEST-MD5 module for the SASL client framework -*- lexical-binding: t -*- ;; Copyright (C) 2000, 2007-2021 Free Software Foundation, Inc. diff --git a/lisp/net/sasl-ntlm.el b/lisp/net/sasl-ntlm.el index 66582265615..1ceb6d179ca 100644 --- a/lisp/net/sasl-ntlm.el +++ b/lisp/net/sasl-ntlm.el @@ -1,4 +1,4 @@ -;;; sasl-ntlm.el --- NTLM (NT Lan Manager) module for the SASL client framework +;;; sasl-ntlm.el --- NTLM (NT Lan Manager) module for the SASL client framework -*- lexical-binding: t -*- ;; Copyright (C) 2000, 2007-2021 Free Software Foundation, Inc. diff --git a/lisp/net/sasl.el b/lisp/net/sasl.el index d2e08f7e3ed..aa4681f11c8 100644 --- a/lisp/net/sasl.el +++ b/lisp/net/sasl.el @@ -1,4 +1,4 @@ -;;; sasl.el --- SASL client framework +;;; sasl.el --- SASL client framework -*- lexical-binding: t -*- ;; Copyright (C) 2000, 2007-2021 Free Software Foundation, Inc. diff --git a/test/lisp/net/sasl-cram-tests.el b/test/lisp/net/sasl-cram-tests.el new file mode 100644 index 00000000000..e0230ddee60 --- /dev/null +++ b/test/lisp/net/sasl-cram-tests.el @@ -0,0 +1,46 @@ +;;; sasl-cram-tests.el --- tests for sasl-cram.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; Author: Stefan Kangas + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; Test case from RFC 2195. + +;;; Code: + +(require 'ert) +(require 'sasl) +(require 'sasl-cram) + +(ert-deftest sasl-cram-md5-response-test () + ;; The following strings are taken from section 2 of RFC 2195. + (let ((client + (sasl-make-client (sasl-find-mechanism '("CRAM-MD5")) + "user" + "imap" + "localhost")) + (data (base64-decode-string "PDE4OTYuNjk3MTcwOTUyQHBvc3RvZmZpY2UucmVzdG9uLm1jaS5uZXQ+")) + (sasl-read-passphrase + (lambda (_prompt) (copy-sequence "tanstaaftanstaaf")))) + (should (equal (sasl-cram-md5-response client (vector nil data)) + "user b913a602c7eda7a495b4e6e7334d3890")))) + +(provide 'sasl-cram-tests) +;;; sasl-cram-tests.el ends here diff --git a/test/lisp/net/sasl-tests.el b/test/lisp/net/sasl-tests.el new file mode 100644 index 00000000000..dab40754c00 --- /dev/null +++ b/test/lisp/net/sasl-tests.el @@ -0,0 +1,59 @@ +;;; sasl-tests.el --- tests for sasl.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; Author: Stefan Kangas + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'sasl) + +(ert-deftest sasl-test-make-client () + (let ((client (sasl-make-client 'foo 'bar 'baz 'zut))) + (should (eq (sasl-client-mechanism client) 'foo)) + (should (eq (sasl-client-name client) 'bar)) + (should (eq (sasl-client-service client) 'baz)) + (should (eq (sasl-client-server client) 'zut)))) + +(ert-deftest sasl-test-client-set-properties () + (let ((client (sasl-make-client 'foo 'bar 'baz 'zut))) + (sasl-client-set-property client 'foo 'bar) + (should (eq (sasl-client-property client 'foo) 'bar)))) + +(ert-deftest sasl-test-step-data () + (let ((step [nil nil])) + (sasl-step-set-data step "foo") + (should (equal (sasl-step-data step) "foo")))) + +(ert-deftest sasl-test-unique-id () + (should (stringp (sasl-unique-id))) + (should-not (equal (sasl-unique-id) (sasl-unique-id)))) + +(ert-deftest sasl-test-find-mechanism () + (should (sasl-find-mechanism '("ANONYMOUS"))) + (should-not (sasl-find-mechanism '("nonexistent mechanism")))) + +(ert-deftest sasl-test-mechanism-name () + (let ((mechanism (sasl-find-mechanism '("ANONYMOUS")))) + (should (equal (sasl-mechanism-name mechanism) "ANONYMOUS")))) + +(provide 'sasl-tests) +;;; sasl-tests.el ends here -- cgit v1.2.3 From 47147db9b0f40c77657aff625048bbef5d32fb05 Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Fri, 29 Jan 2021 21:06:02 +0100 Subject: ; Silence byte-compiler * lisp/net/sasl-ntlm.el (sasl-ntlm-request): * lisp/net/sasl.el (sasl-plain-response, sasl-login-response-1) (sasl-login-response-2, sasl-anonymous-response): Fix warnings introduced by my previous commit. --- lisp/net/sasl-ntlm.el | 2 +- lisp/net/sasl.el | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) (limited to 'lisp') diff --git a/lisp/net/sasl-ntlm.el b/lisp/net/sasl-ntlm.el index 1ceb6d179ca..dfb7e713302 100644 --- a/lisp/net/sasl-ntlm.el +++ b/lisp/net/sasl-ntlm.el @@ -40,7 +40,7 @@ "A list of functions to be called in sequence for the NTLM authentication steps. They are called by `sasl-next-step'.") -(defun sasl-ntlm-request (client step) +(defun sasl-ntlm-request (client _step) "SASL step function to generate a NTLM authentication request to the server. Called from `sasl-next-step'. CLIENT is a vector [mechanism user service server sasl-client-properties] diff --git a/lisp/net/sasl.el b/lisp/net/sasl.el index aa4681f11c8..b7f814f7237 100644 --- a/lisp/net/sasl.el +++ b/lisp/net/sasl.el @@ -203,7 +203,7 @@ It contain at least 64 bits of entropy." (defconst sasl-plain-steps '(sasl-plain-response)) -(defun sasl-plain-response (client step) +(defun sasl-plain-response (client _step) (let ((passphrase (sasl-read-passphrase (format "PLAIN passphrase for %s: " (sasl-client-name client)))) @@ -229,12 +229,12 @@ It contain at least 64 bits of entropy." sasl-login-response-1 sasl-login-response-2)) -(defun sasl-login-response-1 (client step) +(defun sasl-login-response-1 (client _step) ;;; (unless (string-match "^Username:" (sasl-step-data step)) ;;; (sasl-error (format "Unexpected response: %s" (sasl-step-data step)))) (sasl-client-name client)) -(defun sasl-login-response-2 (client step) +(defun sasl-login-response-2 (client _step) ;;; (unless (string-match "^Password:" (sasl-step-data step)) ;;; (sasl-error (format "Unexpected response: %s" (sasl-step-data step)))) (sasl-read-passphrase @@ -250,7 +250,7 @@ It contain at least 64 bits of entropy." '(ignore ;no initial response sasl-anonymous-response)) -(defun sasl-anonymous-response (client step) +(defun sasl-anonymous-response (client _step) (or (sasl-client-property client 'trace) (sasl-client-name client))) -- cgit v1.2.3 From 1a4bb1e2f28ec20aff23bab335ba949a0f2b75a1 Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Sat, 30 Jan 2021 00:10:10 +0100 Subject: Use lexical-binding in handwrite.el * lisp/play/handwrite.el: Use lexical-binding. Remove redundant :group args. Minor cleanups. (handwrite): Minor cleanups. (handwrite-set-pagenumber-off, handwrite-set-pagenumber-on): Make comments into docstrings. --- lisp/play/handwrite.el | 86 +++++++++++++++++++------------------------------- 1 file changed, 32 insertions(+), 54 deletions(-) (limited to 'lisp') diff --git a/lisp/play/handwrite.el b/lisp/play/handwrite.el index 7ad3de6fb64..98da26c2e6c 100644 --- a/lisp/play/handwrite.el +++ b/lisp/play/handwrite.el @@ -1,8 +1,9 @@ -;;; handwrite.el --- turns your emacs buffer into a handwritten document +;;; handwrite.el --- turns your emacs buffer into a handwritten document -*- lexical-binding: t -*- ;; Copyright (C) 1996, 2001-2021 Free Software Foundation, Inc. ;; Author: Danny Roozendaal (was: ) +;; Maintainer: emacs-devel@gnu.org ;; Created: October 21 1996 ;; Keywords: wp, print, postscript, cursive writing @@ -22,11 +23,11 @@ ;; along with GNU Emacs. If not, see . ;;; Commentary: + +;; The function `handwrite' creates PostScript output containing a +;; handwritten version of the current buffer. ;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; The function handwrite creates PostScript output containing a -;; handwritten version of the current buffer.. -;; Other functions that may be useful are +;; Other functions that may be useful are: ;; ;; handwrite-10pt: sets the font size to 10 and finds corresponding ;; values for the line spacing and the number of lines @@ -54,8 +55,6 @@ ;; unknown characters. ;; ;; Thanks to anyone who emailed me suggestions! -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;; Code: @@ -64,7 +63,6 @@ (defvar ps-lpr-command) (defvar ps-lpr-switches) - ;; Variables (defgroup handwrite nil @@ -98,44 +96,43 @@ (defcustom handwrite-numlines 60 "The number of lines on a page of the PostScript output from `handwrite'." - :type 'integer - :group 'handwrite) + :type 'integer) + (defcustom handwrite-fontsize 11 "The size of the font for the PostScript output from `handwrite'." - :type 'integer - :group 'handwrite) + :type 'integer) + (defcustom handwrite-linespace 12 "The spacing for the PostScript output from `handwrite'." - :type 'integer - :group 'handwrite) + :type 'integer) + (defcustom handwrite-xstart 30 "X-axis translation in the PostScript output from `handwrite'." - :type 'integer - :group 'handwrite) + :type 'integer) + (defcustom handwrite-ystart 810 "Y-axis translation in the PostScript output from `handwrite'." - :type 'integer - :group 'handwrite) + :type 'integer) + (defcustom handwrite-pagenumbering nil "If non-nil, number each page of the PostScript output from `handwrite'." - :type 'boolean - :group 'handwrite) + :type 'boolean) + (defcustom handwrite-10pt-numlines 65 "The number of lines on a page for the function `handwrite-10pt'." - :type 'integer - :group 'handwrite) + :type 'integer) + (defcustom handwrite-11pt-numlines 60 "The number of lines on a page for the function `handwrite-11pt'." - :type 'integer - :group 'handwrite) + :type 'integer) + (defcustom handwrite-12pt-numlines 55 "The number of lines on a page for the function `handwrite-12pt'." - :type 'integer - :group 'handwrite) + :type 'integer) + (defcustom handwrite-13pt-numlines 50 "The number of lines on a page for the function `handwrite-13pt'." - :type 'integer - :group 'handwrite) + :type 'integer) ;; Interactive functions @@ -150,17 +147,17 @@ Variables: `handwrite-linespace' (default 12) `handwrite-numlines' (default 60) `handwrite-pagenumbering' (default nil)" (interactive) + (setq handwrite-psindex (1+ handwrite-psindex)) (let - (;(pmin) ; thanks, Havard - (cur-buf (current-buffer)) + ((cur-buf (current-buffer)) (tpoint (point)) (ps-ypos 63) (lcount 0) (ipage 1) - (nlan next-line-add-newlines) ;remember the old value + (next-line-add-newlines t) (buf-name (buffer-name) ) (textp) - (ps-buf-name) ;name of the PostScript buffer + (ps-buf-name (format "*handwritten%d.ps*" handwrite-psindex)) (trans-table '(("ÿ" . "264") ("á" . "207") ("à" . "210") ("â" . "211") ("ä" . "212") ("ã" . "213") ("å" . "214") ("é" . "216") @@ -175,10 +172,6 @@ Variables: `handwrite-linespace' (default 12) ; on inserted backslashes line) (goto-char (point-min)) ;start at beginning - (setq handwrite-psindex (1+ handwrite-psindex)) - (setq ps-buf-name - (format "*handwritten%d.ps*" handwrite-psindex)) - (setq next-line-add-newlines t) (switch-to-buffer ps-buf-name) (handwrite-insert-header buf-name) (insert "%%Creator: GNU Emacs's handwrite version " emacs-version "\n") @@ -258,9 +251,7 @@ Variables: `handwrite-linespace' (default 12) (message "") (bury-buffer ()) (switch-to-buffer cur-buf) - (goto-char tpoint) - (setq next-line-add-newlines nlan) - )) + (goto-char tpoint))) (defun handwrite-set-pagenumber () @@ -280,7 +271,6 @@ values for `handwrite-linespace' and `handwrite-numlines'." (setq handwrite-numlines handwrite-10pt-numlines) (message "Handwrite output size set to 10 points")) - (defun handwrite-11pt () "Specify 11-point output for `handwrite'. This sets `handwrite-fontsize' to 11 and finds correct @@ -1238,28 +1228,16 @@ end /Joepie Hwfdict definefont %%EndFont Joepie\n\n")) -;;Sets page numbering off (defun handwrite-set-pagenumber-off () + "Set page numbering off." (setq handwrite-pagenumbering nil) (message "page numbering off")) -;;Sets page numbering on (defun handwrite-set-pagenumber-on () + "Set page numbering on." (setq handwrite-pagenumbering t) (message "page numbering on" )) - -;; Key bindings - -;; I'd rather not fill up the menu bar menus with -;; lots of random miscellaneous features. -- rms. -;;;(define-key-after -;;; (lookup-key global-map [menu-bar edit]) -;;; [handwrite] -;;; '("Write by hand" . menu-bar-handwrite-map) -;;; 'spell) - (provide 'handwrite) - ;;; handwrite.el ends here -- cgit v1.2.3 From f3f6e84ca6f16c243cd1242ca51c333972a4bb9a Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Sat, 30 Jan 2021 00:32:20 +0100 Subject: Use lexical-binding in mpuz.el * lisp/play/mpuz.el: Use lexical-binding. Remove redundant :group args. (mpuz-switch-to-window): Minor cleanup. --- lisp/play/mpuz.el | 30 +++++++++++------------------- 1 file changed, 11 insertions(+), 19 deletions(-) (limited to 'lisp') diff --git a/lisp/play/mpuz.el b/lisp/play/mpuz.el index 7fff604aead..838bddfb665 100644 --- a/lisp/play/mpuz.el +++ b/lisp/play/mpuz.el @@ -1,4 +1,4 @@ -;;; mpuz.el --- multiplication puzzle for GNU Emacs +;;; mpuz.el --- multiplication puzzle for GNU Emacs -*- lexical-binding: t -*- ;; Copyright (C) 1990, 2001-2021 Free Software Foundation, Inc. @@ -40,49 +40,41 @@ The value t means never ding, and `error' means only ding on wrong input." :type '(choice (const :tag "No" nil) (const :tag "Yes" t) - (const :tag "If correct" error)) - :group 'mpuz) + (const :tag "If correct" error))) (defcustom mpuz-solve-when-trivial t "Solve any row that can be trivially calculated from what you've found." - :type 'boolean - :group 'mpuz) + :type 'boolean) (defcustom mpuz-allow-double-multiplicator nil "Allow 2nd factors like 33 or 77." - :type 'boolean - :group 'mpuz) + :type 'boolean) (defface mpuz-unsolved '((default :weight bold) (((class color)) :foreground "red1")) - "Face for letters to be solved." - :group 'mpuz) + "Face for letters to be solved.") (defface mpuz-solved '((default :weight bold) (((class color)) :foreground "green1")) - "Face for solved digits." - :group 'mpuz) + "Face for solved digits.") (defface mpuz-trivial '((default :weight bold) (((class color)) :foreground "blue")) - "Face for trivial digits solved for you." - :group 'mpuz) + "Face for trivial digits solved for you.") (defface mpuz-text '((t :inherit variable-pitch)) - "Face for text on right." - :group 'mpuz) + "Face for text on right.") ;; Mpuz mode and keymaps ;;---------------------- (defcustom mpuz-mode-hook nil "Hook to run upon entry to mpuz." - :type 'hook - :group 'mpuz) + :type 'hook) (defvar mpuz-mode-map (let ((map (make-sparse-keymap))) @@ -341,8 +333,8 @@ You may abort a game by typing \\\\[mpuz-offer-abort]." (defun mpuz-switch-to-window () "Find or create the Mult-Puzzle buffer, and display it." - (let ((buf (mpuz-get-buffer))) - (or buf (setq buf (mpuz-create-buffer))) + (let ((buf (or (mpuz-get-buffer) + (mpuz-create-buffer)))) (switch-to-buffer buf) (setq buffer-read-only t) (mpuz-mode))) -- cgit v1.2.3 From bbad7904e20ba0366a3397a45fb89de0275bbf28 Mon Sep 17 00:00:00 2001 From: Dmitry Gutov Date: Sat, 30 Jan 2021 03:56:27 +0200 Subject: vc-dir-mode-map: Remove the mouse-2 binding * lisp/vc/vc-dir.el (vc-dir-mode-map): Remove the mouse-2 binding (bug#13692). (vc-dir-mode): Update the docstring accordingly. (vc-dir-status-mouse-map): New variable. (vc-default-dir-printer): Use it on the state buttons. * lisp/vc/vc-git.el (vc-git-dir-printer): Same. --- lisp/vc/vc-dir.el | 11 ++++++++--- lisp/vc/vc-git.el | 3 ++- 2 files changed, 10 insertions(+), 4 deletions(-) (limited to 'lisp') diff --git a/lisp/vc/vc-dir.el b/lisp/vc/vc-dir.el index bbb73240be2..9d0808c0435 100644 --- a/lisp/vc/vc-dir.el +++ b/lisp/vc/vc-dir.el @@ -300,7 +300,6 @@ See `run-hooks'." (define-key map "\C-o" 'vc-dir-display-file) (define-key map "\C-c\C-c" 'vc-dir-kill-dir-status-process) (define-key map [down-mouse-3] 'vc-dir-menu) - (define-key map [mouse-2] 'vc-dir-toggle-mark) (define-key map [follow-link] 'mouse-face) (define-key map "x" 'vc-dir-hide-up-to-date) (define-key map [?\C-k] 'vc-dir-kill-line) @@ -1085,7 +1084,6 @@ U - if the cursor is on a file: unmark all the files with the same state as the current file - if the cursor is on a directory: unmark all child files - with a prefix argument: unmark all files -mouse-2 - toggles the mark state VC commands VC commands in the `C-x v' prefix can be used. @@ -1392,6 +1390,12 @@ These are the commands available for use in the file status buffer: (propertize "Please add backend specific headers here. It's easy!" 'face 'font-lock-warning-face))) +(defvar vc-dir-status-mouse-map + (let ((map (make-sparse-keymap))) + (define-key map [mouse-2] 'vc-dir-toggle-mark) + map) + "Local keymap for toggling mark.") + (defvar vc-dir-filename-mouse-map (let ((map (make-sparse-keymap))) (define-key map [mouse-2] 'vc-dir-find-file-other-window) @@ -1418,7 +1422,8 @@ These are the commands available for use in the file status buffer: ((memq state '(missing conflict)) 'font-lock-warning-face) ((eq state 'edited) 'font-lock-constant-face) (t 'font-lock-variable-name-face)) - 'mouse-face 'highlight) + 'mouse-face 'highlight + 'keymap vc-dir-status-mouse-map) " " (propertize (format "%s" filename) diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index a9ee28e3aad..94fac3a83b8 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -481,7 +481,8 @@ or an empty string if none." 'face (cond ((eq state 'up-to-date) 'font-lock-builtin-face) ((eq state 'missing) 'font-lock-warning-face) (t 'font-lock-variable-name-face)) - 'mouse-face 'highlight) + 'mouse-face 'highlight + 'keymap vc-dir-status-mouse-map) " " (vc-git-permissions-as-string old-perm new-perm) " " (propertize (vc-git-escape-file-name (vc-dir-fileinfo->name info)) -- cgit v1.2.3 From 90ce2b80342299ef4c6c2f6b08cca55e20ffa06b Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Fri, 29 Jan 2021 08:34:43 +0100 Subject: rmail-summary-mark-deleted optional argument fix * lisp/mail/rmailsum.el (rmail-summary-mark-deleted): Argument N is optional, so don't assume that it's a number (bug#39076). --- lisp/mail/rmailsum.el | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'lisp') diff --git a/lisp/mail/rmailsum.el b/lisp/mail/rmailsum.el index d29115a9570..7f99ecdcf2c 100644 --- a/lisp/mail/rmailsum.el +++ b/lisp/mail/rmailsum.el @@ -974,8 +974,9 @@ a negative argument means to delete and move forward." (delete-char 1) (insert "D")) ;; Discard cached new summary line. - (with-current-buffer rmail-buffer - (aset rmail-summary-vector (1- n) nil)))) + (when n + (with-current-buffer rmail-buffer + (aset rmail-summary-vector (1- n) nil))))) (beginning-of-line)) (defun rmail-summary-update-line (n) -- cgit v1.2.3 From 5644ac41c42fde4a4434131e45110aa1e909e0b2 Mon Sep 17 00:00:00 2001 From: Mauro Aranda Date: Sat, 30 Jan 2021 07:47:34 +0100 Subject: Add source to sgml-empty-tags * lisp/textmodes/sgml-mode.el (html-mode): Add "source" as an empty tag to fix indentation when this element is present (bug#46181). --- lisp/textmodes/sgml-mode.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'lisp') diff --git a/lisp/textmodes/sgml-mode.el b/lisp/textmodes/sgml-mode.el index 8465e82b02a..c50c544cb54 100644 --- a/lisp/textmodes/sgml-mode.el +++ b/lisp/textmodes/sgml-mode.el @@ -2402,9 +2402,9 @@ To work around that, do: (setq-local sgml-empty-tags ;; From HTML-4.01's loose.dtd, parsed with - ;; `sgml-parse-dtd', plus manual addition of "wbr". + ;; `sgml-parse-dtd', plus manual additions of "source" and "wbr". '("area" "base" "basefont" "br" "col" "frame" "hr" "img" "input" - "isindex" "link" "meta" "param" "wbr")) + "isindex" "link" "meta" "source" "param" "wbr")) (setq-local sgml-unclosed-tags ;; From HTML-4.01's loose.dtd, parsed with `sgml-parse-dtd'. '("body" "colgroup" "dd" "dt" "head" "html" "li" "option" -- cgit v1.2.3 From cc2d3a62c2a1f5be7907eda55d3c678e1149eb7b Mon Sep 17 00:00:00 2001 From: Jeff Spencer Date: Sat, 30 Jan 2021 08:12:57 +0100 Subject: Fix interaction between two dired cleanup variables * lisp/dired.el (dired-clean-up-after-deletion): Kill the buffers if you have `dired-clean-up-buffers-too' set and `dired-clean-confirm-killing-deleted-buffers' nil (bug#38037). Copyright-paperwork-exempt: yes --- etc/NEWS | 6 ++++++ lisp/dired.el | 21 ++++++++++++--------- 2 files changed, 18 insertions(+), 9 deletions(-) (limited to 'lisp') diff --git a/etc/NEWS b/etc/NEWS index 8e233f8f196..a6fd51b8a2a 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -504,6 +504,12 @@ time zones will use a form like "+0100" instead of "CET". ** Dired +--- +*** Behaviour change on 'dired-clean-confirm-killing-deleted-buffers'. +Previously, if 'dired-clean-up-buffers-too' was non-nil, and +'dired-clean-confirm-killing-deleted-buffers' was nil, the buffers +wouldn't be killed. This combination will now kill the buffers. + +++ *** New user option 'dired-switches-in-mode-line'. This user option controls how 'ls' switches are displayed in the mode diff --git a/lisp/dired.el b/lisp/dired.el index 3f119363314..fe6ac1e2591 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -3532,18 +3532,21 @@ confirmation. To disable the confirmation, see (when (and (featurep 'dired-x) dired-clean-up-buffers-too) (let ((buf (get-file-buffer fn))) (and buf - (and dired-clean-confirm-killing-deleted-buffers - (funcall #'y-or-n-p - (format "Kill buffer of %s, too? " - (file-name-nondirectory fn)))) + (or (and dired-clean-confirm-killing-deleted-buffers + (funcall #'y-or-n-p + (format "Kill buffer of %s, too? " + (file-name-nondirectory fn)))) + (not dired-clean-confirm-killing-deleted-buffers)) (kill-buffer buf))) (let ((buf-list (dired-buffers-for-dir (expand-file-name fn)))) (and buf-list - (and dired-clean-confirm-killing-deleted-buffers - (y-or-n-p (format (ngettext "Kill Dired buffer of %s, too? " - "Kill Dired buffers of %s, too? " - (length buf-list)) - (file-name-nondirectory fn)))) + (or (and dired-clean-confirm-killing-deleted-buffers + (y-or-n-p (format + (ngettext "Kill Dired buffer of %s, too? " + "Kill Dired buffers of %s, too? " + (length buf-list)) + (file-name-nondirectory fn)))) + (not dired-clean-confirm-killing-deleted-buffers)) (dolist (buf buf-list) (kill-buffer buf)))))) -- cgit v1.2.3 From 32dc433dbb83a5c38650769dc064c082bf79ee8c Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sat, 30 Jan 2021 08:59:48 +0100 Subject: Fix vc-hg-rename-file on file names like ~/foo/bar * lisp/vc/vc-hg.el (vc-hg-rename-file): Use absolute file names, because hg doesn't like getting file names like "~/foo/bar" (bug#36932). --- lisp/vc/vc-hg.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/vc/vc-hg.el b/lisp/vc/vc-hg.el index c4b82ab11eb..1d163a64ab2 100644 --- a/lisp/vc/vc-hg.el +++ b/lisp/vc/vc-hg.el @@ -1166,7 +1166,8 @@ hg binary." ;; Modeled after the similar function in vc-bzr.el (defun vc-hg-rename-file (old new) "Rename file from OLD to NEW using `hg mv'." - (vc-hg-command nil 0 new "mv" old)) + (vc-hg-command nil 0 (expand-file-name new) "mv" + (expand-file-name old))) (defun vc-hg-register (files &optional _comment) "Register FILES under hg. COMMENT is ignored." -- cgit v1.2.3 From bb652f68fd4e996d58f731a0dba1be18fd4e03d7 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 30 Jan 2021 11:26:07 +0200 Subject: New Rmail option 'rmail-show-message-set-modified' * lisp/mail/rmail.el (rmail-show-message-set-modified): New option. (rmail-show-message-1): If 'rmail-show-message-set-modified' is non-nil, don't reset the buffer's modified state. (Bug#45941) * etc/NEWS: Announce the new option. --- etc/NEWS | 5 +++++ lisp/mail/rmail.el | 8 ++++++++ 2 files changed, 13 insertions(+) (limited to 'lisp') diff --git a/etc/NEWS b/etc/NEWS index a6fd51b8a2a..11fca4fecb6 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1138,6 +1138,11 @@ bindings, will be aborted, and Emacs will not ask you whether to enlarge 'max-specpdl-size' to complete the rendering. The default is t, which preserves the original behavior. +--- +*** New user option 'rmail-show-message-set-modified'. +If set non-nil, showing an unseen message will set the Rmail buffer's +modified flag. + ** Apropos *** New commands 'apropos-next-symbol' and 'apropos-previous-symbol'. diff --git a/lisp/mail/rmail.el b/lisp/mail/rmail.el index 29460cc20f5..9f95b62d870 100644 --- a/lisp/mail/rmail.el +++ b/lisp/mail/rmail.el @@ -2723,6 +2723,12 @@ See also `unrmail-mbox-format'." :version "24.4" :group 'rmail-files) +(defcustom rmail-show-message-set-modified nil + "If non-nil, displaying an unseen message marks the Rmail buffer as modified." + :type 'boolean + :group 'rmail + :version "28.1") + (defun rmail-show-message-1 (&optional msg) "Show message MSG (default: current message) using `rmail-view-buffer'. Return text to display in the minibuffer if MSG is out of @@ -2750,6 +2756,8 @@ The current mail message becomes the message displayed." ;; Mark the message as seen, but preserve buffer modified flag. (let ((modiff (buffer-modified-p))) (rmail-set-attribute rmail-unseen-attr-index nil) + (and rmail-show-message-set-modified + (setq modiff t)) (unless modiff (restore-buffer-modified-p modiff))) ;; bracket the message in the mail -- cgit v1.2.3 From 0e2e1caa0bc87c5972ca1bbe6893a56d4db1df0a Mon Sep 17 00:00:00 2001 From: Jared Finder Date: Mon, 7 Dec 2020 22:44:32 -0800 Subject: * lisp/tab-line.el (tab-line-new-tab): Use tty menus when supported. --- lisp/tab-line.el | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/tab-line.el b/lisp/tab-line.el index 2726947a4c2..9209f2d46ec 100644 --- a/lisp/tab-line.el +++ b/lisp/tab-line.el @@ -651,7 +651,9 @@ corresponding to the switched buffer." (if (functionp tab-line-new-tab-choice) (funcall tab-line-new-tab-choice) (let ((tab-line-tabs-buffer-groups mouse-buffer-menu-mode-groups)) - (if (and (listp mouse-event) window-system) ; (display-popup-menus-p) + (if (and (listp mouse-event) + (display-popup-menus-p) + (not tty-menu-open-use-tmm)) (mouse-buffer-menu mouse-event) ; like (buffer-menu-open) ;; tty menu doesn't support mouse clicks, so use tmm (tmm-prompt (mouse-buffer-menu-keymap)))))) -- cgit v1.2.3 From ed2f2cc5577d5d9b61db7a5b61e93e79d678be41 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sat, 30 Jan 2021 11:10:26 +0100 Subject: auth-source-search doc string fix * lisp/auth-source.el (auth-source-search): Fix example (bug#36286). --- lisp/auth-source.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/auth-source.el b/lisp/auth-source.el index ad3b690dfa6..2494040457b 100644 --- a/lisp/auth-source.el +++ b/lisp/auth-source.el @@ -588,7 +588,7 @@ Here's an example: \(let ((auth-source-creation-defaults \\='((user . \"defaultUser\") (A . \"default A\"))) (auth-source-creation-prompts - \\='((password . \"Enter IMAP password for %h:%p: \")))) + \\='((secret . \"Enter IMAP password for %h:%p: \")))) (auth-source-search :host \\='(\"nonesuch\" \"twosuch\") :type \\='netrc :max 1 :P \"pppp\" :Q \"qqqq\" :create \\='(A B Q))) -- cgit v1.2.3 From 96f20120c97a0a329fff81a0cc3747082a8a2c55 Mon Sep 17 00:00:00 2001 From: Dmitry Gutov Date: Sat, 30 Jan 2021 15:42:19 +0200 Subject: Also highlight 'conflict' with the warning face * lisp/vc/vc-git.el (vc-git-dir-printer): Also highlight 'conflict' with the warning face, like vc-default-dir-printer does already. --- lisp/vc/vc-git.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'lisp') diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 94fac3a83b8..d00c2c2133c 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -479,8 +479,8 @@ or an empty string if none." (propertize (format "%-12s" state) 'face (cond ((eq state 'up-to-date) 'font-lock-builtin-face) - ((eq state 'missing) 'font-lock-warning-face) - (t 'font-lock-variable-name-face)) + ((eq state '(missing conflict)) 'font-lock-warning-face) + (t 'font-lock-variable-name-face)) 'mouse-face 'highlight 'keymap vc-dir-status-mouse-map) " " (vc-git-permissions-as-string old-perm new-perm) -- cgit v1.2.3