commit 1f3995f65a065a28e108653128b31a2fb7eeb01c (HEAD, refs/remotes/origin/master) Author: Mattias EngdegÄrd Date: Sun Jul 30 18:42:13 2023 +0200 Avoid face attribute warnings in themes * etc/themes/deeper-blue-theme.el (class): * etc/themes/leuven-dark-theme.el (class): * etc/themes/leuven-theme.el (class): * etc/themes/manoj-dark-theme.el (manoj-dark): * etc/themes/whiteboard-theme.el (class): Use `unspecified` instead of `nil` as attribute for :background and :foreground to silence HANDLE_INVALID_NIL_VALUE warning. diff --git a/etc/themes/deeper-blue-theme.el b/etc/themes/deeper-blue-theme.el index 40d5f18a011..20da432c75a 100644 --- a/etc/themes/deeper-blue-theme.el +++ b/etc/themes/deeper-blue-theme.el @@ -64,8 +64,8 @@ deeper-blue `(ediff-fine-diff-B ((,class (:background "cyan4" :foreground "white")))) `(ediff-odd-diff-A ((,class (:background "Grey50" :foreground "White")))) `(error ((,class (:foreground "red")))) - `(flymake-errline ((,class (:background nil :underline "red")))) - `(flymake-warnline ((,class (:background nil :underline "magenta3")))) + `(flymake-errline ((,class (:background unspecified :underline "red")))) + `(flymake-warnline ((,class (:background unspecified :underline "magenta3")))) `(font-lock-builtin-face ((,class (:foreground "LightCoral")))) `(font-lock-comment-delimiter-face ((,class (:foreground "gray50")))) `(font-lock-comment-face ((,class (:foreground "gray50")))) @@ -84,7 +84,7 @@ deeper-blue `(highlight ((,class (:background "DodgerBlue4")))) `(ido-first-match ((,class (:weight normal :foreground "orange")))) `(ido-only-match ((,class (:foreground "green")))) - `(ido-subdir ((,class (:foreground nil :inherit font-lock-keyword-face)))) + `(ido-subdir ((,class (:foreground unspecified :inherit font-lock-keyword-face)))) `(image-dired-thumb-flagged ((,class (:background "Red1")))) `(image-dired-thumb-mark ((,class (:background "dodgerblue3")))) `(info-header-node ((,class (:foreground "DeepSkyBlue1")))) @@ -98,7 +98,7 @@ deeper-blue `(match ((,class (:background "DeepPink4")))) `(minibuffer-prompt ((,class (:foreground "CadetBlue1")))) `(mode-line ((,class (:background "gray75" :foreground "black" :box (:line-width 1 :style released-button))))) - `(mode-line-buffer-id ((,class (:weight bold :background nil :foreground "blue4")))) + `(mode-line-buffer-id ((,class (:weight bold :background unspecified :foreground "blue4")))) `(mode-line-inactive ((,class (:background "gray40" :foreground "black" :box (:line-width 1 :color "gray40" :style nil))))) `(outline-1 ((,class (:foreground "SkyBlue1")))) `(outline-2 ((,class (:foreground "CadetBlue1")))) diff --git a/etc/themes/leuven-dark-theme.el b/etc/themes/leuven-dark-theme.el index fda00f1282f..bfe5256ab97 100644 --- a/etc/themes/leuven-dark-theme.el +++ b/etc/themes/leuven-dark-theme.el @@ -621,11 +621,11 @@ leuven-dark `(helm-source-header ((,class (:weight bold :box (:line-width 1 :color "#3d3842") :background "#433e48" :foreground "#ffffff")))) `(helm-swoop-target-line-block-face ((,class (:background "#3833ff" :foreground "#e0dde3")))) `(helm-swoop-target-line-face ((,class (:background "#38330b")))) - `(helm-swoop-target-word-face ((,class (:weight bold :foreground nil :background "#0742d2")))) + `(helm-swoop-target-word-face ((,class (:weight bold :foreground unspecified :background "#0742d2")))) `(helm-visible-mark ((,class ,marked-line))) `(helm-w3m-bookmarks-face ((,class (:underline t :foreground "#ff010b")))) - `(highlight-changes ((,class (:foreground nil)))) ;; blue "#d4f754" - `(highlight-changes-delete ((,class (:strike-through nil :foreground nil)))) ;; red "#4ff7d7" + `(highlight-changes ((,class (:foreground unspecified)))) ;; blue "#d4f754" + `(highlight-changes-delete ((,class (:strike-through nil :foreground unspecified)))) ;; red "#4ff7d7" `(highlight-symbol-face ((,class (:background "#252080")))) `(hl-line ((,class ,highlight-yellow))) ; Highlight current line. `(hl-tags-face ((,class ,highlight-current-tag))) ; ~ Pair highlighting (matching tags). @@ -643,7 +643,7 @@ leuven-dark `(info-file ((,class (:family "Sans Serif" :height 1.8 :weight bold :box (:line-width 1 :color "#ffff3d") :foreground "#9f6a1c" :background "#563c2a")))) `(info-header-node ((,class (:underline t :foreground "#065aff")))) ; nodes in header `(info-header-xref ((,class (:underline t :foreground "#e46f0b")))) ; cross references in header - `(info-index-match ((,class (:weight bold :foreground nil :background "#0742d2")))) ; when using `i' + `(info-index-match ((,class (:weight bold :foreground unspecified :background "#0742d2")))) ; when using `i' `(info-menu-header ((,class ,ol2))) ; menu titles (headers) -- major topics `(info-menu-star ((,class (:foreground "#ffffff")))) ; every 3rd menu item `(info-node ((,class (:underline t :foreground "#ffff0b")))) ; node names diff --git a/etc/themes/leuven-theme.el b/etc/themes/leuven-theme.el index 7747d1e7315..f7d454381d7 100644 --- a/etc/themes/leuven-theme.el +++ b/etc/themes/leuven-theme.el @@ -618,11 +618,11 @@ leuven `(helm-source-header ((,class (:weight bold :box (:line-width 1 :color "#C7C7C7") :background "#DEDEDE" :foreground "black")))) `(helm-swoop-target-line-block-face ((,class (:background "#CCCC00" :foreground "#222222")))) `(helm-swoop-target-line-face ((,class (:background "#CCCCFF")))) - `(helm-swoop-target-word-face ((,class (:weight bold :foreground nil :background "#FDBD33")))) + `(helm-swoop-target-word-face ((,class (:weight bold :foreground unspecified :background "#FDBD33")))) `(helm-visible-mark ((,class ,marked-line))) `(helm-w3m-bookmarks-face ((,class (:underline t :foreground "cyan1")))) - `(highlight-changes ((,class (:foreground nil)))) ;; blue "#2E08B5" - `(highlight-changes-delete ((,class (:strike-through nil :foreground nil)))) ;; red "#B5082E" + `(highlight-changes ((,class (:foreground unspecified)))) ;; blue "#2E08B5" + `(highlight-changes-delete ((,class (:strike-through nil :foreground unspecified)))) ;; red "#B5082E" `(highlight-symbol-face ((,class (:background "#FFFFA0")))) `(hl-line ((,class ,highlight-yellow))) ; Highlight current line. `(hl-tags-face ((,class ,highlight-current-tag))) ; ~ Pair highlighting (matching tags). @@ -642,7 +642,7 @@ leuven `(info-file ((,class (:family "Sans Serif" :height 1.8 :weight bold :box (:line-width 1 :color "#0000CC") :foreground "cornflower blue" :background "LightSteelBlue1")))) `(info-header-node ((,class (:underline t :foreground "orange")))) ; nodes in header `(info-header-xref ((,class (:underline t :foreground "dodger blue")))) ; cross references in header - `(info-index-match ((,class (:weight bold :foreground nil :background "#FDBD33")))) ; when using `i' + `(info-index-match ((,class (:weight bold :foreground unspecified :background "#FDBD33")))) ; when using `i' `(info-menu-header ((,class ,ol2))) ; menu titles (headers) -- major topics `(info-menu-star ((,class (:foreground "black")))) ; every 3rd menu item `(info-node ((,class (:underline t :foreground "blue")))) ; node names diff --git a/etc/themes/manoj-dark-theme.el b/etc/themes/manoj-dark-theme.el index 1c3e23908d1..26627a29c70 100644 --- a/etc/themes/manoj-dark-theme.el +++ b/etc/themes/manoj-dark-theme.el @@ -526,8 +526,8 @@ manoj-dark '(widget-mouse-face ((t (:background "darkseagreen2" :foreground "blue")))) '(highlight-beyond-fill-column-face ((t (:underline t)))) - '(highlight-changes ((t (:foreground nil :background "#382f2f")))) - '(highlight-changes-delete ((t (:foreground nil :background "#916868")))) + '(highlight-changes ((t (:foreground unspecified :background "#382f2f")))) + '(highlight-changes-delete ((t (:foreground unspecified :background "#916868")))) '(holiday ((t (:background "chocolate4")))) '(holiday-face ((t (:background "chocolate4")))) diff --git a/etc/themes/whiteboard-theme.el b/etc/themes/whiteboard-theme.el index adbd69f1c6f..b52996c24c0 100644 --- a/etc/themes/whiteboard-theme.el +++ b/etc/themes/whiteboard-theme.el @@ -44,8 +44,8 @@ whiteboard `(cursor ((,class (:background "Green4")))) `(default ((,class (:background "whitesmoke" :foreground "black")))) `(dired-marked ((,class (:background "dodgerblue3" :foreground "white")))) - `(flymake-errline ((,class (:background nil :underline "red")))) - `(flymake-warnline ((,class (:background nil :underline "magenta3")))) + `(flymake-errline ((,class (:background unspecified :underline "red")))) + `(flymake-warnline ((,class (:background unspecified :underline "magenta3")))) `(font-lock-builtin-face ((,class (:foreground "DarkOrange3")))) `(font-lock-comment-delimiter-face ((,class (:foreground "gray50")))) `(font-lock-comment-face ((,class (:foreground "gray50")))) @@ -65,7 +65,7 @@ whiteboard `(highlight ((,class (:background "SkyBlue1")))) `(ido-first-match ((,class (:weight normal :foreground "DarkOrange3")))) `(ido-only-match ((,class (:foreground "SeaGreen4")))) - `(ido-subdir ((,class (:foreground nil :inherit font-lock-keyword-face)))) + `(ido-subdir ((,class (:foreground unspecified :inherit font-lock-keyword-face)))) `(image-dired-thumb-flagged ((,class :background "Red1"))) `(image-dired-thumb-mark ((,class :background "dodgerblue3"))) `(info-header-node ((,class (:foreground "DeepSkyBlue1")))) @@ -79,7 +79,7 @@ whiteboard `(match ((,class (:background "LightPink1")))) `(minibuffer-prompt ((,class (:foreground "DodgerBlue4")))) `(mode-line ((,class (:background "gray75" :foreground "black" :box (:line-width 1 :style released-button))))) - `(mode-line-buffer-id ((,class (:weight bold :background nil :foreground "blue4")))) + `(mode-line-buffer-id ((,class (:weight bold :background unspecified :foreground "blue4")))) `(mode-line-inactive ((,class (:background "gray40" :foreground "black" :box (:line-width 1 :color "gray40" :style nil))))) `(outline-1 ((,class (:foreground "Blue3")))) `(outline-2 ((,class (:foreground "DodgerBlue")))) commit 5f5d668ac7917d61e9366fe0c3efd7b542671c3d Author: Mattias EngdegÄrd Date: Sun Jul 30 15:30:38 2023 +0200 Fix rx wrong-code bug: ranges starting with ^ (rx (in (?^ . ?a))) was incorrectly translated to "[^-a]". Change it so that we get "[_-a^]" instead. * lisp/emacs-lisp/rx.el (rx--generate-alt): Split ranges starting with `^` occurring first in a non-negated character alternative. * test/lisp/emacs-lisp/rx-tests.el (rx-any): Add and adapt tests. diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el index f1eb3e308a2..19c82d9b23d 100644 --- a/lisp/emacs-lisp/rx.el +++ b/lisp/emacs-lisp/rx.el @@ -445,13 +445,19 @@ rx--generate-alt (setcar dash-l ?.)) ; Reduce --x to .-x (setq items (nconc items '((?- . ?-)))))) - ;; Deal with leading ^ and range ^-x. - (when (and (consp (car items)) - (eq (caar items) ?^) - (cdr items)) - ;; Move ^ and ^-x to second place. - (setq items (cons (cadr items) - (cons (car items) (cddr items))))) + ;; Deal with leading ^ and range ^-x in non-negated set. + (when (and (eq (car-safe (car items)) ?^) + (not negated)) + (if (eq (cdar items) ?^) + ;; single leading ^ + (when (cdr items) + ;; Move the ^ to second place. + (setq items (cons (cadr items) + (cons (car items) (cddr items))))) + ;; Split ^-x to _-x^ + (setq items (cons (cons ?_ (cdar items)) + (cons '(?^ . ?^) + (cdr items)))))) (cond ;; Empty set: if negated, any char, otherwise match-nothing. diff --git a/test/lisp/emacs-lisp/rx-tests.el b/test/lisp/emacs-lisp/rx-tests.el index 995d297ff08..4928d5adf9d 100644 --- a/test/lisp/emacs-lisp/rx-tests.el +++ b/test/lisp/emacs-lisp/rx-tests.el @@ -122,23 +122,33 @@ rx-any (should (equal (rx (any "]" "^") (any "]" "-") (any "-" "^") (not (any "]" "^")) (not (any "]" "-")) (not (any "-" "^"))) - "[]^][]-][-^][^]^][^]-][^-^]")) + "[]^][]-][-^][^]^][^]-][^^-]")) (should (equal (rx (any "]" "^" "-") (not (any "]" "^" "-"))) "[]^-][^]^-]")) + (should (equal (rx (any "^-f") (any "^-f" "-") + (any "^-f" "z") (any "^-f" "z" "-")) + "[_-f^][_-f^-][_-f^z][_-f^z-]")) + (should (equal (rx (not (any "^-f")) (not (any "^-f" "-")) + (not (any "^-f" "z")) (not (any "^-f" "z" "-"))) + "[^^-f][^^-f-][^^-fz][^^-fz-]")) + (should (equal (rx (any "^-f" word) (any "^-f" "-" word)) + "[_-f^[:word:]][_-f^[:word:]-]")) + (should (equal (rx (not (any "^-f" word)) (not (any "^-f" "-" word))) + "[^^-f[:word:]][^^-f[:word:]-]")) (should (equal (rx (any "-" ascii) (any "^" ascii) (any "]" ascii)) "[[:ascii:]-][[:ascii:]^][][:ascii:]]")) (should (equal (rx (not (any "-" ascii)) (not (any "^" ascii)) (not (any "]" ascii))) - "[^[:ascii:]-][^[:ascii:]^][^][:ascii:]]")) + "[^[:ascii:]-][^^[:ascii:]][^][:ascii:]]")) (should (equal (rx (any "-]" ascii) (any "^]" ascii) (any "-^" ascii)) "[][:ascii:]-][]^[:ascii:]][[:ascii:]^-]")) (should (equal (rx (not (any "-]" ascii)) (not (any "^]" ascii)) (not (any "-^" ascii))) - "[^][:ascii:]-][^]^[:ascii:]][^[:ascii:]^-]")) + "[^][:ascii:]-][^]^[:ascii:]][^^[:ascii:]-]")) (should (equal (rx (any "-]^" ascii) (not (any "-]^" ascii))) "[]^[:ascii:]-][^]^[:ascii:]-]")) (should (equal (rx (any "^" lower upper) (not (any "^" lower upper))) - "[[:lower:]^[:upper:]][^[:lower:]^[:upper:]]")) + "[[:lower:]^[:upper:]][^^[:lower:][:upper:]]")) (should (equal (rx (any "-" lower upper) (not (any "-" lower upper))) "[[:lower:][:upper:]-][^[:lower:][:upper:]-]")) (should (equal (rx (any "]" lower upper) (not (any "]" lower upper))) @@ -153,7 +163,7 @@ rx-any "[]-a-][^]-a-]")) (should (equal (rx (any "--]") (not (any "--]")) (any "-" "^-a") (not (any "-" "^-a"))) - "[].-\\-][^].-\\-][-^-a][^-^-a]")) + "[].-\\-][^].-\\-][_-a^-][^^-a-]")) (should (equal (rx (not (any "!a" "0-8" digit nonascii))) "[^!0-8a[:digit:][:nonascii:]]")) (should (equal (rx (any) (not (any))) commit 060766cf2c67314539e3002078add7f3fe3c6f86 Author: Michael Albinus Date: Sun Jul 30 16:53:37 2023 +0200 ; Fixh last change * lisp/net/tramp-message.el (tramp-file-name-host-port) (tramp-file-name-user-domain): Declare. (tramp-message): Remove declare form. Add `tramp-suppress-trace' function property. * lisp/net/tramp.el (tramp-file-name-user-domain) (tramp-file-name-host-port): Remove ;;;###tramp-autoload cookie. (tramp-file-name-unify, tramp-dissect-file-name) (tramp-ensure-dissected-file-name): Remove declare form. Add `tramp-suppress-trace' function property. diff --git a/lisp/net/tramp-message.el b/lisp/net/tramp-message.el index 98f202102dd..cf90db1d6b1 100644 --- a/lisp/net/tramp-message.el +++ b/lisp/net/tramp-message.el @@ -52,6 +52,8 @@ (declare-function tramp-compat-string-replace "tramp-compat") (declare-function tramp-file-name-equal-p "tramp") +(declare-function tramp-file-name-host-port "tramp") +(declare-function tramp-file-name-user-domain "tramp") (declare-function tramp-get-default-directory "tramp") (defvar tramp-compat-temporary-file-directory) @@ -304,7 +306,6 @@ tramp-message Calls functions `message' and `tramp-debug-message' with FMT-STRING as control string and the remaining ARGUMENTS to actually emit the message (if applicable)." - (declare (tramp-suppress-trace t)) (ignore-errors (when (<= level tramp-verbose) ;; Display only when there is a minimum level, and the progress @@ -345,6 +346,9 @@ tramp-message (concat (format "(%d) # " level) fmt-string) arguments)))))) +;; We cannot declare our private symbols in loaddefs. +(function-put 'tramp-message 'tramp-suppress-trace t) + (defsubst tramp-backtrace (&optional vec-or-proc force) "Dump a backtrace into the debug buffer. If VEC-OR-PROC is nil, the buffer *debug tramp* is used. FORCE diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 34ecd383621..76674e5207f 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -1448,7 +1448,6 @@ tramp-null-hop (make-tramp-file-name :user (user-login-name) :host tramp-system-name) "Connection hop which identifies the virtual hop before the first one.") -;;;###tramp-autoload (defun tramp-file-name-user-domain (vec) "Return user and domain components of VEC." (declare (tramp-suppress-trace t)) @@ -1458,7 +1457,6 @@ tramp-file-name-user-domain tramp-prefix-domain-format) (tramp-file-name-domain vec)))) -;;;###tramp-autoload (defun tramp-file-name-host-port (vec) "Return host and port components of VEC." (declare (tramp-suppress-trace t)) @@ -1482,7 +1480,6 @@ tramp-file-name-unify LOCALNAME is a relative file name, return `tramp-cache-undefined'. Objects returned by this function compare `equal' if they refer to the same connection. Make a copy in order to avoid side effects." - (declare (tramp-suppress-trace t)) (if (and (stringp localname) (not (file-name-absolute-p localname))) (setq vec tramp-cache-undefined) @@ -1494,6 +1491,9 @@ tramp-file-name-unify (tramp-file-name-hop vec) nil)) vec)) +;; We cannot declare our private symbols in loaddefs. +(function-put 'tramp-file-name-unify 'tramp-suppress-trace t) + ;; Comparison of file names is performed by `tramp-equal-remote'. (defun tramp-file-name-equal-p (vec1 vec2) "Check, whether VEC1 and VEC2 denote the same `tramp-file-name'. @@ -1635,7 +1635,6 @@ tramp-dissect-file-name Unless NODEFAULT is non-nil, method, user and host are expanded to their default values. For the other file name parts, no default values are used." - (declare (tramp-suppress-trace t)) (save-match-data (unless (tramp-tramp-file-p name) (tramp-user-error nil "Not a Tramp file name: \"%s\"" name)) @@ -1692,18 +1691,23 @@ tramp-dissect-file-name (tramp-user-error v "Method `%s' is not supported for multi-hops" method))))))) +;; We cannot declare our private symbols in loaddefs. +(function-put 'tramp-dissect-file-name 'tramp-suppress-trace t) + ;;;###tramp-autoload (defun tramp-ensure-dissected-file-name (vec-or-filename) "Return a `tramp-file-name' structure for VEC-OR-FILENAME. VEC-OR-FILENAME may be either a string or a `tramp-file-name'. If it's not a Tramp filename, return nil." - (declare (tramp-suppress-trace t)) (cond ((tramp-file-name-p vec-or-filename) vec-or-filename) ((tramp-tramp-file-p vec-or-filename) (tramp-dissect-file-name vec-or-filename)))) +;; We cannot declare our private symbols in loaddefs. +(function-put 'tramp-ensure-dissected-file-name 'tramp-suppress-trace t) + (defun tramp-dissect-hop-name (name &optional nodefault) "Return a `tramp-file-name' structure of `hop' part of NAME. See `tramp-dissect-file-name' for details." commit 19777b7c864f17248f279210545579001a2c99fd Author: Earl Hyatt Date: Thu Jul 20 21:44:41 2023 -0400 Allow default values in 'map-let' and the pcase 'map' form * lisp/emacs-lisp/map.el (map-let, map) (map--make-pcase-bindings): Add a third argument for specifying a default value, like in 'map-elt'. (Bug#49407) * lisp/emacs-lisp/map.el (map--make-pcase-bindings): Clarify that keys that aren't found aren't ignored, they actually get the value nil (unless the new default value is given). The overall pattern can still fail to match if the sub-pattern for the unfound key doesn't match nil. * test/lisp/emacs-lisp/map-tests.el (test-map-let-default) (test-map-plist-pcase-default, test-map-pcase-matches): Add tests, including for the above item. diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el index 7a48ba47434..b55eb431668 100644 --- a/lisp/emacs-lisp/map.el +++ b/lisp/emacs-lisp/map.el @@ -50,18 +50,20 @@ map ARGS is a list of elements to be matched in the map. -Each element of ARGS can be of the form (KEY PAT), in which case KEY is -evaluated and searched for in the map. The match fails if for any KEY -found in the map, the corresponding PAT doesn't match the value -associated with the KEY. +Each element of ARGS can be of the form (KEY PAT [DEFAULT]), +which looks up KEY in the map and matches the associated value +against `pcase' pattern PAT. DEFAULT specifies the fallback +value to use when KEY is not present in the map. If omitted, it +defaults to nil. Both KEY and DEFAULT are evaluated. Each element can also be a SYMBOL, which is an abbreviation of a (KEY PAT) tuple of the form (\\='SYMBOL SYMBOL). When SYMBOL is a keyword, it is an abbreviation of the form (:SYMBOL SYMBOL), useful for binding plist values. -Keys in ARGS not found in the map are ignored, and the match doesn't -fail." +An element of ARGS fails to match if PAT does not match the +associated value or the default value. The overall pattern fails +to match if any element of ARGS fails to match." `(and (pred mapp) ,@(map--make-pcase-bindings args))) @@ -71,12 +73,13 @@ map-let KEYS can be a list of symbols, in which case each element will be bound to the looked up value in MAP. -KEYS can also be a list of (KEY VARNAME) pairs, in which case -KEY is an unquoted form. +KEYS can also be a list of (KEY VARNAME [DEFAULT]) sublists, in +which case KEY and DEFAULT are unquoted forms. MAP can be an alist, plist, hash-table, or array." (declare (indent 2) - (debug ((&rest &or symbolp ([form symbolp])) form body))) + (debug ((&rest &or symbolp ([form symbolp &optional form])) + form body))) `(pcase-let ((,(map--make-pcase-patterns keys) ,map)) ,@body)) @@ -595,11 +598,21 @@ map-into (map-into \\='((1 . 3)) \\='(hash-table :test eql))" (map--into-hash map (cdr type))) +(defmacro map--pcase-map-elt (key default map) + "A macro to make MAP the last argument to `map-elt'. + +This allows using default values for `map-elt', which can't be +done using `pcase--flip'. + +KEY is the key sought in the map. DEFAULT is the default value." + `(map-elt ,map ,key ,default)) + (defun map--make-pcase-bindings (args) "Return a list of pcase bindings from ARGS to the elements of a map." (mapcar (lambda (elt) (cond ((consp elt) - `(app (pcase--flip map-elt ,(car elt)) ,(cadr elt))) + `(app (map--pcase-map-elt ,(car elt) ,(caddr elt)) + ,(cadr elt))) ((keywordp elt) (let ((var (intern (substring (symbol-name elt) 1)))) `(app (pcase--flip map-elt ,elt) ,var))) diff --git a/test/lisp/emacs-lisp/map-tests.el b/test/lisp/emacs-lisp/map-tests.el index 86c0e9e0503..2204743f794 100644 --- a/test/lisp/emacs-lisp/map-tests.el +++ b/test/lisp/emacs-lisp/map-tests.el @@ -577,6 +577,13 @@ test-map-let (should (= b 2)) (should-not c))) +(ert-deftest test-map-let-default () + (map-let (('foo a 3) + ('baz b 4)) + '((foo . 1)) + (should (equal a 1)) + (should (equal b 4)))) + (ert-deftest test-map-merge () "Test `map-merge'." (should (equal (sort (map-merge 'list '(a 1) '((b . 2) (c . 3)) @@ -617,6 +624,58 @@ test-map-plist-pcase (list one two)) '(1 2))))) +(ert-deftest test-map-plist-pcase-default () + (let ((plist '(:two 2))) + (should (equal (pcase-let (((map (:two two 33) + (:three three 44)) + plist)) + (list two three)) + '(2 44))))) + +(ert-deftest test-map-pcase-matches () + (let ((plist '(:two 2))) + (should (equal (pcase plist + ((map (:two two 33) + (:three three)) + (list two three)) + (_ 'fail)) + '(2 nil))) + + (should (equal (pcase plist + ((map (:two two 33) + (:three three 44)) + (list two three)) + (_ 'fail)) + '(2 44))) + + (should (equal (pcase plist + ((map (:two two 33) + (:three `(,a . ,b) '(11 . 22))) + (list two a b)) + (_ 'fail)) + '(2 11 22))) + + (should (equal 'fail + (pcase plist + ((map (:two two 33) + (:three `(,a . ,b) 44)) + (list two a b)) + (_ 'fail)))) + + (should (equal 'fail + (pcase plist + ((map (:two two 33) + (:three `(,a . ,b) nil)) + (list two a b)) + (_ 'fail)))) + + (should (equal 'fail + (pcase plist + ((map (:two two 33) + (:three `(,a . ,b))) + (list two a b)) + (_ 'fail)))))) + (ert-deftest test-map-setf-alist-insert-key () (let ((alist)) (should (equal (setf (map-elt alist 'key) 'value) commit da608160366aaa59567b4a45b3aabb34a2370594 Author: Michael Albinus Date: Sun Jul 30 15:10:48 2023 +0200 Finish Tramp reorganization * lisp/net/tramp-compat.el (subr-x): Don't require. (top): Use `function-put' but `put'. * lisp/net/tramp-gvfs.el (tramp-dbus-function): Add declare form. * lisp/net/tramp-message.el (tramp-byte-run--set-suppress-trace): New function. Add it to `defun-declarations-alist'. (tramp-setup-debug-buffer, tramp-debug-buffer-name) (tramp-get-debug-buffer, tramp-get-debug-file-name) (tramp-trace-buffer-name, tramp-debug-message, tramp-message): Add declare form. (tramp-debug-buffer-name): Use `tramp-string-empty-or-nil-p'. (tramp-test-message): New defun. * lisp/net/tramp.el (top): Use `function-put' but `put'. (tramp-file-name-user-domain, tramp-file-name-host-port) (tramp-file-name-port-or-default, tramp-file-name-unify) (tramp-dissect-file-name, tramp-ensure-dissected-file-name) (tramp-dissect-hop-name, tramp-make-tramp-file-name) (tramp-signal-hook-function, tramp-post-process-creation) (tramp-read-passwd, tramp-read-passwd-without-cache) (tramp-clear-passwd): Add declare form. (tramp-string-empty-or-nil-p): Add ;;;###tramp-autoload cookie. (tramp-test-message): Move to tramp-message.el. diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index 61359562ee3..85ddb81f398 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -34,7 +34,6 @@ (require 'format-spec) (require 'parse-time) (require 'shell) -(require 'subr-x) (require 'xdg) (declare-function tramp-error "tramp") @@ -307,7 +306,7 @@ 'tramp-compat-auth-source-netrc-parse-all "List of characters equivalent to trailing colon in \"password\" prompts.")) (dolist (elt (all-completions "tramp-compat-" obarray 'functionp)) - (put (intern elt) 'tramp-suppress-trace t)) + (function-put (intern elt) 'tramp-suppress-trace t)) (add-hook 'tramp-unload-hook (lambda () diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 72cf4a6a4b3..71ef8215ab0 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -951,14 +951,13 @@ tramp-gvfs-stringify-dbus-message (defun tramp-dbus-function (vec func args) "Apply a D-Bus function FUNC from dbus.el. The call will be traced by Tramp with trace level 6." + (declare (tramp-suppress-trace t)) (let (result) (tramp-message vec 6 "%s" (cons func args)) (setq result (apply func args)) (tramp-message vec 6 "%s" (tramp-gvfs-stringify-dbus-message result)) result)) -(put #'tramp-dbus-function 'tramp-suppress-trace t) - (defmacro with-tramp-dbus-call-method (vec synchronous bus service path interface method &rest args) "Apply a D-Bus call on bus BUS. diff --git a/lisp/net/tramp-message.el b/lisp/net/tramp-message.el index bfefd95096d..98f202102dd 100644 --- a/lisp/net/tramp-message.el +++ b/lisp/net/tramp-message.el @@ -55,6 +55,16 @@ (declare-function tramp-get-default-directory "tramp") (defvar tramp-compat-temporary-file-directory) +(eval-and-compile + (defalias 'tramp-byte-run--set-suppress-trace + #'(lambda (f _args val) + (list 'function-put (list 'quote f) + ''tramp-suppress-trace val))) + + (add-to-list + 'defun-declarations-alist + (list 'tramp-suppress-trace #'tramp-byte-run--set-suppress-trace))) + ;;;###tramp-autoload (defcustom tramp-verbose 3 "Verbosity level for Tramp messages. @@ -122,8 +132,6 @@ tramp-debug-outline-level The outline level is equal to the verbosity of the Tramp message." (1+ (string-to-number (match-string 3)))) -(put #'tramp-debug-outline-level 'tramp-suppress-trace t) - ;; This function takes action since Emacs 28.1, when ;; `read-extended-command-predicate' is set to ;; `command-completion-default-include-p'. @@ -135,11 +143,11 @@ tramp-debug-buffer-command-completion-p (buffer-substring (point-min) (min (+ (point-min) 10) (point-max))) ";; Emacs:"))) -(put #'tramp-debug-buffer-command-completion-p 'tramp-suppress-trace t) - (defun tramp-setup-debug-buffer () "Function to setup debug buffers." - ;; (declare (completion tramp-debug-buffer-command-completion-p)) + (declare (tramp-suppress-trace t)) + ;; (declare (completion tramp-debug-buffer-command-completion-p) + ;; (tramp-suppress-trace t)) (interactive) (set-buffer-file-coding-system 'utf-8) (setq buffer-undo-list t) @@ -165,46 +173,40 @@ tramp-setup-debug-buffer (local-set-key "\M-n" 'clone-buffer) (add-hook 'clone-buffer-hook #'tramp-setup-debug-buffer nil 'local)) -(put #'tramp-setup-debug-buffer 'tramp-suppress-trace t) - (function-put #'tramp-setup-debug-buffer 'completion-predicate #'tramp-debug-buffer-command-completion-p) (defun tramp-debug-buffer-name (vec) "A name for the debug buffer of VEC." + (declare (tramp-suppress-trace t)) (let ((method (tramp-file-name-method vec)) (user-domain (tramp-file-name-user-domain vec)) (host-port (tramp-file-name-host-port vec))) - (if (or (null user-domain) (string-empty-p user-domain)) + (if (tramp-string-empty-or-nil-p user-domain) (format "*debug tramp/%s %s*" method host-port) (format "*debug tramp/%s %s@%s*" method user-domain host-port)))) -(put #'tramp-debug-buffer-name 'tramp-suppress-trace t) - (defun tramp-get-debug-buffer (vec) "Get the debug buffer of VEC." + (declare (tramp-suppress-trace t)) (with-current-buffer (get-buffer-create (tramp-debug-buffer-name vec)) (when (bobp) (tramp-setup-debug-buffer)) (current-buffer))) -(put #'tramp-get-debug-buffer 'tramp-suppress-trace t) - (defun tramp-get-debug-file-name (vec) "Get the debug file name for VEC." + (declare (tramp-suppress-trace t)) (expand-file-name (tramp-compat-string-replace "/" " " (tramp-debug-buffer-name vec)) tramp-compat-temporary-file-directory)) -(put #'tramp-get-debug-file-name 'tramp-suppress-trace t) - (defun tramp-trace-buffer-name (vec) "A name for the trace buffer for VEC." + (declare (tramp-suppress-trace t)) (tramp-compat-string-replace "*debug" "*trace" (tramp-debug-buffer-name vec))) -(put #'tramp-trace-buffer-name 'tramp-suppress-trace t) - (defvar tramp-trace-functions nil "A list of non-Tramp functions to be traced with `tramp-verbose' > 10.") @@ -212,6 +214,7 @@ tramp-debug-message "Append message to debug buffer of VEC. Message is formatted with FMT-STRING as control string and the remaining ARGUMENTS to actually emit the message (if applicable)." + (declare (tramp-suppress-trace t)) (let ((inhibit-message t) create-lockfiles file-name-handler-alist message-log-max signal-hook-function) @@ -287,8 +290,6 @@ tramp-debug-message (write-region point (point-max) (tramp-get-debug-file-name vec) 'append)))))))) -(put #'tramp-debug-message 'tramp-suppress-trace t) - ;;;###tramp-autoload (defun tramp-message (vec-or-proc level fmt-string &rest arguments) "Emit a message depending on verbosity level. @@ -303,6 +304,7 @@ tramp-message Calls functions `message' and `tramp-debug-message' with FMT-STRING as control string and the remaining ARGUMENTS to actually emit the message (if applicable)." + (declare (tramp-suppress-trace t)) (ignore-errors (when (<= level tramp-verbose) ;; Display only when there is a minimum level, and the progress @@ -453,14 +455,24 @@ tramp-with-demoted-errors (progn ,@body) (error (tramp-message ,vec-or-proc 3 ,format ,err) nil)))) +(defun tramp-test-message (fmt-string &rest arguments) + "Emit a Tramp message according `default-directory'." + (declare (tramp-suppress-trace t)) + (cond + ((tramp-tramp-file-p default-directory) + (apply #'tramp-message + (tramp-dissect-file-name default-directory) 0 fmt-string arguments)) + ((tramp-file-name-p (car tramp-current-connection)) + (apply #'tramp-message + (car tramp-current-connection) 0 fmt-string arguments)) + (t (apply #'message fmt-string arguments)))) + (defun tramp-debug-button-action (button) "Goto the linked message in debug buffer at place." (when (mouse-event-p last-input-event) (mouse-set-point last-input-event)) (when-let ((point (button-get button 'position))) (goto-char point))) -(put #'tramp-debug-button-action 'tramp-suppress-trace t) - (define-button-type 'tramp-debug-button-type 'follow-link t 'mouse-face 'highlight @@ -492,8 +504,6 @@ tramp-debug-link-messages 'position (set-marker (make-marker) beg1) 'help-echo "mouse-2, RET: goto entry message")))) -(put #'tramp-debug-link-messages 'tramp-suppress-trace t) - (defvar tramp-debug-nesting "" "Indicator for debug messages nested level. This shouldn't be changed globally, but let-bind where needed.") @@ -515,8 +525,6 @@ tramp-debug-message-buttonize :type 'help-function-def 'help-args (list fun (symbol-file fun)))))) -(put #'tramp-debug-message-buttonize 'tramp-suppress-trace t) - ;; This is used in `tramp-file-name-handler' and `tramp-*-maybe-open-connection'. (defmacro with-tramp-debug-message (vec message &rest body) "Execute BODY, embedded with MESSAGE in the debug buffer of VEC. diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 1de0e84c3db..34ecd383621 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -1435,13 +1435,13 @@ tramp-foreign-file-name-handler-alist (cl-defstruct (tramp-file-name (:type list) :named) method user domain host port localname hop)) -(put #'tramp-file-name-method 'tramp-suppress-trace t) -(put #'tramp-file-name-user 'tramp-suppress-trace t) -(put #'tramp-file-name-domain 'tramp-suppress-trace t) -(put #'tramp-file-name-host 'tramp-suppress-trace t) -(put #'tramp-file-name-port 'tramp-suppress-trace t) -(put #'tramp-file-name-localname 'tramp-suppress-trace t) -(put #'tramp-file-name-hop 'tramp-suppress-trace t) +(function-put #'tramp-file-name-method 'tramp-suppress-trace t) +(function-put #'tramp-file-name-user 'tramp-suppress-trace t) +(function-put #'tramp-file-name-domain 'tramp-suppress-trace t) +(function-put #'tramp-file-name-host 'tramp-suppress-trace t) +(function-put #'tramp-file-name-port 'tramp-suppress-trace t) +(function-put #'tramp-file-name-localname 'tramp-suppress-trace t) +(function-put #'tramp-file-name-hop 'tramp-suppress-trace t) ;; Needed for `tramp-read-passwd' and `tramp-get-remote-null-device'. (defconst tramp-null-hop @@ -1451,33 +1451,30 @@ tramp-null-hop ;;;###tramp-autoload (defun tramp-file-name-user-domain (vec) "Return user and domain components of VEC." + (declare (tramp-suppress-trace t)) (when (or (tramp-file-name-user vec) (tramp-file-name-domain vec)) (concat (tramp-file-name-user vec) (and (tramp-file-name-domain vec) tramp-prefix-domain-format) (tramp-file-name-domain vec)))) -(put #'tramp-file-name-user-domain 'tramp-suppress-trace t) - ;;;###tramp-autoload (defun tramp-file-name-host-port (vec) "Return host and port components of VEC." + (declare (tramp-suppress-trace t)) (when (or (tramp-file-name-host vec) (tramp-file-name-port vec)) (concat (tramp-file-name-host vec) (and (tramp-file-name-port vec) tramp-prefix-port-format) (tramp-file-name-port vec)))) -(put #'tramp-file-name-host-port 'tramp-suppress-trace t) - (defun tramp-file-name-port-or-default (vec) "Return port component of VEC. If nil, return `tramp-default-port'." + (declare (tramp-suppress-trace t)) (or (tramp-file-name-port vec) (tramp-get-method-parameter vec 'tramp-default-port))) -(put #'tramp-file-name-port-or-default 'tramp-suppress-trace t) - ;;;###tramp-autoload (defun tramp-file-name-unify (vec &optional localname) "Unify VEC by removing localname and hop from `tramp-file-name' structure. @@ -1485,6 +1482,7 @@ tramp-file-name-unify LOCALNAME is a relative file name, return `tramp-cache-undefined'. Objects returned by this function compare `equal' if they refer to the same connection. Make a copy in order to avoid side effects." + (declare (tramp-suppress-trace t)) (if (and (stringp localname) (not (file-name-absolute-p localname))) (setq vec tramp-cache-undefined) @@ -1496,8 +1494,6 @@ tramp-file-name-unify (tramp-file-name-hop vec) nil)) vec)) -(put #'tramp-file-name-unify 'tramp-suppress-trace t) - ;; Comparison of file names is performed by `tramp-equal-remote'. (defun tramp-file-name-equal-p (vec1 vec2) "Check, whether VEC1 and VEC2 denote the same `tramp-file-name'. @@ -1539,8 +1535,6 @@ tramp-tramp-file-p (string-match-p tramp-file-name-regexp name) t)) -(put #'tramp-tramp-file-p 'tramp-suppress-trace t) - ;; This function bypasses the file name handler approach. It is NOT ;; recommended to use it in any package if not absolutely necessary. ;; However, it is more performant than `file-local-name', and might be @@ -1590,8 +1584,6 @@ tramp-find-method result (propertize result 'tramp-default t)))) -(put #'tramp-find-method 'tramp-suppress-trace t) - (defun tramp-find-user (method user host) "Return the right user string to use depending on METHOD and HOST. This is USER, if non-nil. Otherwise, do a lookup in @@ -1613,8 +1605,6 @@ tramp-find-user result (propertize result 'tramp-default t)))) -(put #'tramp-find-user 'tramp-suppress-trace t) - (defun tramp-find-host (method user host) "Return the right host string to use depending on METHOD and USER. This is HOST, if non-nil. Otherwise, do a lookup in @@ -1636,8 +1626,6 @@ tramp-find-host result (propertize result 'tramp-default t)))) -(put #'tramp-find-host 'tramp-suppress-trace t) - ;;;###tramp-autoload (defun tramp-dissect-file-name (name &optional nodefault) "Return a `tramp-file-name' structure of NAME, a remote file name. @@ -1647,6 +1635,7 @@ tramp-dissect-file-name Unless NODEFAULT is non-nil, method, user and host are expanded to their default values. For the other file name parts, no default values are used." + (declare (tramp-suppress-trace t)) (save-match-data (unless (tramp-tramp-file-p name) (tramp-user-error nil "Not a Tramp file name: \"%s\"" name)) @@ -1703,24 +1692,22 @@ tramp-dissect-file-name (tramp-user-error v "Method `%s' is not supported for multi-hops" method))))))) -(put #'tramp-dissect-file-name 'tramp-suppress-trace t) - ;;;###tramp-autoload (defun tramp-ensure-dissected-file-name (vec-or-filename) "Return a `tramp-file-name' structure for VEC-OR-FILENAME. VEC-OR-FILENAME may be either a string or a `tramp-file-name'. If it's not a Tramp filename, return nil." + (declare (tramp-suppress-trace t)) (cond ((tramp-file-name-p vec-or-filename) vec-or-filename) ((tramp-tramp-file-p vec-or-filename) (tramp-dissect-file-name vec-or-filename)))) -(put #'tramp-ensure-dissected-file-name 'tramp-suppress-trace t) - (defun tramp-dissect-hop-name (name &optional nodefault) "Return a `tramp-file-name' structure of `hop' part of NAME. See `tramp-dissect-file-name' for details." + (declare (tramp-suppress-trace t)) (let ((v (tramp-dissect-file-name (concat tramp-prefix-format (replace-regexp-in-string @@ -1735,8 +1722,7 @@ tramp-dissect-hop-name ;; Return result. v)) -(put #'tramp-dissect-hop-name 'tramp-suppress-trace t) - +;;;###tramp-autoload (defsubst tramp-string-empty-or-nil-p (string) "Check whether STRING is empty or nil." (or (null string) (string= string ""))) @@ -1750,20 +1736,13 @@ tramp-buffer-name (format "*tramp/%s %s*" method host-port) (format "*tramp/%s %s@%s*" method user-domain host-port)))) -(put #'tramp-buffer-name 'tramp-suppress-trace t) - ;;;###tramp-autoload (defun tramp-make-tramp-file-name (&rest args) "Construct a Tramp file name from ARGS. - -ARGS could have two different signatures. The first one is of -type (VEC &optional LOCALNAME). If LOCALNAME is nil, the value in VEC is used. If it is a symbol, a null localname will be used. Otherwise, LOCALNAME is -expected to be a string, which will be used. - -The other signature exists for backward compatibility. It has -the form (METHOD USER DOMAIN HOST PORT LOCALNAME &optional HOP)." +expected to be a string, which will be used." + (declare (advertised-calling-convention (vec &optional localname) "29.1")) (let (method user domain host port localname hop) (cond ((tramp-file-name-p (car args)) @@ -1816,9 +1795,6 @@ tramp-make-tramp-file-name tramp-postfix-host-format localname))) -(set-advertised-calling-convention - #'tramp-make-tramp-file-name '(vec &optional localname) "29.1") - (defun tramp-make-tramp-hop-name (vec) "Construct a Tramp hop name from VEC." (concat @@ -1948,33 +1924,19 @@ tramp-barf-if-file-missing (tramp-error ,vec 'file-missing ,filename) (signal (car ,err) (cdr ,err))))))) -(defun tramp-test-message (fmt-string &rest arguments) - "Emit a Tramp message according `default-directory'." - (cond - ((tramp-tramp-file-p default-directory) - (apply #'tramp-message - (tramp-dissect-file-name default-directory) 0 fmt-string arguments)) - ((tramp-file-name-p (car tramp-current-connection)) - (apply #'tramp-message - (car tramp-current-connection) 0 fmt-string arguments)) - (t (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) "Function to be called via `signal-hook-function'." ;; `custom-initialize-*' functions provoke `void-variable' errors. ;; We don't want to see them in the backtrace. + (declare (tramp-suppress-trace t)) (unless (eq error-symbol 'void-variable) (let ((inhibit-message t)) (tramp-error (car tramp-current-connection) error-symbol (mapconcat (lambda (x) (format "%s" x)) data " "))))) -(put #'tramp-signal-hook-function 'tramp-suppress-trace t) - (defmacro with-parsed-tramp-file-name (filename var &rest body) "Parse a Tramp filename and make components available in the body. @@ -4664,6 +4626,7 @@ tramp-expand-args (defun tramp-post-process-creation (proc vec) "Apply actions after creation of process PROC." + (declare (tramp-suppress-trace t)) (process-put proc 'tramp-vector vec) (process-put proc 'adjust-window-size-function #'ignore) (set-process-query-on-exit-flag proc nil) @@ -4671,8 +4634,6 @@ tramp-post-process-creation (when (process-command proc) (tramp-message vec 6 "%s" (string-join (process-command proc) " ")))) -(put #'tramp-post-process-creation 'tramp-suppress-trace t) - (defun tramp-direct-async-process-p (&rest args) "Whether direct async `make-process' can be called." (let ((v (tramp-dissect-file-name default-directory)) @@ -6392,6 +6353,7 @@ tramp-process-running-p (defun tramp-read-passwd (proc &optional prompt) "Read a password from user (compat function). Consults the auth-source package." + (declare (tramp-suppress-trace t)) (let* (;; If `auth-sources' contains "~/.authinfo.gpg", and ;; `exec-path' contains a relative file name like ".", it ;; could happen that the "gpg" command is not found. So we @@ -6454,11 +6416,10 @@ tramp-read-passwd (setq tramp-password-save-function nil)) (tramp-set-connection-property vec "first-password-request" nil)))) -(put #'tramp-read-passwd 'tramp-suppress-trace t) - (defun tramp-read-passwd-without-cache (proc &optional prompt) "Read a password from user (compat function)." ;; We suspend the timers while reading the password. + (declare (tramp-suppress-trace t)) (let (tramp-dont-suspend-timers) (with-tramp-suspended-timers (password-read @@ -6467,10 +6428,9 @@ tramp-read-passwd-without-cache (tramp-check-for-regexp proc tramp-password-prompt-regexp) (match-string 0))))))) -(put #'tramp-read-passwd-without-cache 'tramp-suppress-trace t) - (defun tramp-clear-passwd (vec) "Clear password cache for connection related to VEC." + (declare (tramp-suppress-trace t)) (let ((method (tramp-file-name-method vec)) (user-domain (tramp-file-name-user-domain vec)) (host-port (tramp-file-name-host-port vec)) @@ -6483,8 +6443,6 @@ tramp-clear-passwd :host ,host-port :port ,method)) (password-cache-remove (tramp-make-tramp-file-name vec 'noloc)))) -(put #'tramp-clear-passwd 'tramp-suppress-trace t) - (defun tramp-time-diff (t1 t2) "Return the difference between the two times, in seconds. T1 and T2 are time values (as returned by `current-time' for example)."