commit a01bd1a208a5199fd1d76baade373f7f12f912a2 (HEAD, refs/remotes/origin/master) Author: Po Lu Date: Sun Oct 23 14:12:02 2022 +0800 Reduce duplicate code for creating "special windows" * src/xterm.c (x_create_special_window): Define on all non-GTK builds and all builds with XFixes. (x_update_frame_user_time_window): Use x_create_special_window. Also write a comment explaining what user time windows are. * src/xterm.h: Fix style of `x_parse_color' prototype. diff --git a/src/xterm.c b/src/xterm.c index fecfc50ab5..06c84e2b53 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -7735,6 +7735,28 @@ x_set_gtk_user_time (struct frame *f, Time time) #endif +#if !defined USE_GTK || defined HAVE_XFIXES + +/* Create and return a special window for receiving events such as + selection notify events, and reporting user time. The window is an + 1x1 unmapped override-redirect InputOnly window at -1, -1 relative + to the parent, which should prevent it from doing anything. */ + +static Window +x_create_special_window (struct x_display_info *dpyinfo, + Window parent_window) +{ + XSetWindowAttributes attrs; + + attrs.override_redirect = True; + + return XCreateWindow (dpyinfo->display, parent_window, + -1, -1, 1, 1, 0, CopyFromParent, InputOnly, + CopyFromParent, CWOverrideRedirect, &attrs); +} + +#endif + /* Not needed on GTK because GTK handles reporting the user time itself. */ @@ -7745,7 +7767,6 @@ x_update_frame_user_time_window (struct frame *f) { struct x_output *output; struct x_display_info *dpyinfo; - XSetWindowAttributes attrs; output = FRAME_X_OUTPUT (f); dpyinfo = FRAME_DISPLAY_INFO (f); @@ -7787,12 +7808,16 @@ x_update_frame_user_time_window (struct frame *f) if (output->user_time_window == FRAME_OUTER_WINDOW (f) || output->user_time_window == None) { - memset (&attrs, 0, sizeof attrs); + /* Create a "user time" window that is used to report user + activity on a given frame. This is used in preference to + _NET_WM_USER_TIME, as using a separate window allows the + window manager to express interest in other properties + while only reading the user time when necessary, thereby + improving battery life by not involving the window + manager in each key press. */ output->user_time_window - = XCreateWindow (dpyinfo->display, FRAME_X_WINDOW (f), - -1, -1, 1, 1, 0, 0, InputOnly, - CopyFromParent, 0, &attrs); + = x_create_special_window (dpyinfo, FRAME_X_WINDOW (f)); XDeleteProperty (dpyinfo->display, FRAME_OUTER_WINDOW (f), dpyinfo->Xatom_net_wm_user_time); @@ -28802,27 +28827,6 @@ xi_check_toolkit (Display *display) #endif -#ifdef HAVE_XFIXES - -/* Create and return a special window for receiving events such as - selection notify events. The window is an 1x1 unmapped - override-redirect InputOnly window at -1, -1, which should prevent - it from doing anything. */ - -static Window -x_create_special_window (struct x_display_info *dpyinfo) -{ - XSetWindowAttributes attrs; - - attrs.override_redirect = True; - - return XCreateWindow (dpyinfo->display, dpyinfo->root_window, - -1, -1, 1, 1, 0, CopyFromParent, InputOnly, - CopyFromParent, CWOverrideRedirect, &attrs); -} - -#endif - /* Open a connection to X display DISPLAY_NAME, and return the structure that describes the open display. If obtaining the XCB connection or toolkit-specific display fails, return NULL. Signal @@ -29838,7 +29842,7 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) dpyinfo->n_monitored_selections = num_fast_selections; dpyinfo->selection_tracking_window - = x_create_special_window (dpyinfo); + = x_create_special_window (dpyinfo, dpyinfo->root_window); dpyinfo->monitored_selections = xmalloc (num_fast_selections * sizeof *dpyinfo->monitored_selections); diff --git a/src/xterm.h b/src/xterm.h index 0f00dc42f7..2967d105ea 100644 --- a/src/xterm.h +++ b/src/xterm.h @@ -295,8 +295,7 @@ struct xi_device_t }; #endif -Status x_parse_color (struct frame *f, const char *color_name, - XColor *color); +extern Status x_parse_color (struct frame *, const char *, XColor *); struct x_failable_request { commit 1dbc2bda58f9534e1fda90ab83f7c278df38da3c Merge: 681367412e f1f4a0c9d2 Author: Stefan Kangas Date: Sun Oct 23 06:31:19 2022 +0200 Merge from origin/emacs-28 f1f4a0c9d2 ; * doc/lispref/display.texi (Progress): Correct typo. (B... commit 681367412e97974109ebd8e1c223e22d87f7e9b4 Merge: 731cbf9fc4 ee9a9fbf0f Author: Stefan Kangas Date: Sun Oct 23 06:31:19 2022 +0200 ; Merge from origin/emacs-28 The following commit was skipped: ee9a9fbf0f ; cperl-mode.el: Fix one match-count in my commit 2021-09-14 commit 731cbf9fc4196dde1e552519a7921700ea6c8862 Merge: 9db7b11cf7 626525c29f Author: Stefan Kangas Date: Sun Oct 23 06:31:19 2022 +0200 Merge from origin/emacs-28 626525c29f ; Remove reference to non-existent Flymake function from m... commit 9db7b11cf7fa5d6cf624a467f966a14b347e4429 Author: Basil L. Contovounesios Date: Sat Oct 22 20:25:54 2022 +0300 Improve error reporting of EUDC plist functions * lisp/net/eudc.el (eudc--plist-member): Signal a more informative wrong-type-argument instead of a generic error (bug#58531#19, bug#58720). * test/lisp/net/eudc-tests.el (eudc--plist-member) (eudc-plist-member, eudc-plist-get, eudc-lax-plist-get): Update tests accordingly. diff --git a/lisp/net/eudc.el b/lisp/net/eudc.el index 0283b04574..5f9e78fc7f 100644 --- a/lisp/net/eudc.el +++ b/lisp/net/eudc.el @@ -108,9 +108,8 @@ (defun eudc--plist-member (plist prop &optional predicate) "Like `plist-member', but signal on invalid PLIST." - ;; Could also use `plistp', but that would change the error. - (or (zerop (% (length plist) 2)) - (error "Malformed plist")) + (or (plistp plist) + (signal 'wrong-type-argument `(plistp ,plist))) (plist-member plist prop predicate)) (defun eudc-plist-member (plist prop) diff --git a/test/lisp/net/eudc-tests.el b/test/lisp/net/eudc-tests.el index 219c250bf0..915006a97c 100644 --- a/test/lisp/net/eudc-tests.el +++ b/test/lisp/net/eudc-tests.el @@ -26,9 +26,9 @@ (dolist (obj '(a (a . a) (a a . a))) (should-error (eudc--plist-member obj nil) :type 'wrong-type-argument)) (dolist (plist '((nil) (a) (a a a))) - (dolist (key '(nil a)) - (should (equal (should-error (eudc--plist-member plist key)) - '(error "Malformed plist"))))) + (let ((err `(wrong-type-argument plistp ,(copy-sequence plist)))) + (dolist (key '(nil a)) + (should (equal err (should-error (eudc--plist-member plist key))))))) (let ((-nil (string ?n ?i ?l)) (-a (string ?a))) (should-not (eudc--plist-member () nil)) @@ -56,9 +56,9 @@ (dolist (obj '(a (a . a) (a a . a))) (should-error (eudc-plist-member obj nil) :type 'wrong-type-argument)) (dolist (plist '((nil) (a) (a a a))) - (dolist (key '(nil a)) - (should (equal (should-error (eudc-plist-member plist key)) - '(error "Malformed plist"))))) + (let ((err `(wrong-type-argument plistp ,(copy-sequence plist)))) + (dolist (key '(nil a)) + (should (equal err (should-error (eudc-plist-member plist key))))))) (let ((-nil (string ?n ?i ?l)) (-a (string ?a))) (should-not (eudc-plist-member () nil)) @@ -86,9 +86,9 @@ (dolist (obj '(a (a . a) (a a . a))) (should-error (eudc-plist-get obj nil) :type 'wrong-type-argument)) (dolist (plist '((nil) (a) (a a a))) - (dolist (key '(nil a)) - (should (equal (should-error (eudc-plist-get plist key)) - '(error "Malformed plist"))))) + (let ((err `(wrong-type-argument plistp ,(copy-sequence plist)))) + (dolist (key '(nil a)) + (should (equal err (should-error (eudc-plist-get plist key))))))) (let ((-nil (string ?n ?i ?l)) (-a (string ?a))) (should-not (eudc-plist-get () nil)) @@ -120,9 +120,9 @@ (dolist (obj '(a (a . a) (a a . a))) (should-error (eudc-lax-plist-get obj nil) :type 'wrong-type-argument)) (dolist (plist '((nil) (a) (a a a))) - (dolist (key '(nil a)) - (should (equal (should-error (eudc-lax-plist-get plist key)) - '(error "Malformed plist"))))) + (let ((err `(wrong-type-argument plistp ,(copy-sequence plist)))) + (dolist (key '(nil a)) + (should (equal err (should-error (eudc-lax-plist-get plist key))))))) (let ((-nil (string ?n ?i ?l)) (-a (string ?a))) (should-not (eudc-lax-plist-get () nil)) commit e25a108b09d12502527620ec379a0950cb577311 Author: Eli Zaretskii Date: Sat Oct 22 22:05:50 2022 +0300 ; * doc/emacs/text.texi (Outline Mode): Fix markup and wording. diff --git a/doc/emacs/text.texi b/doc/emacs/text.texi index 28fea5b654..0f1c4da0c6 100644 --- a/doc/emacs/text.texi +++ b/doc/emacs/text.texi @@ -998,13 +998,14 @@ major mode's special commands. (The variable @vindex outline-minor-mode-use-buttons If @code{outline-minor-mode-use-buttons} is non-@code{nil}, Outline -minor mode will use buttons at the start of the heading lines in -addition to ellipsis to show that a section is hidden. Then clicking -on the button with a mouse will toggle displaying the section. If its -value is @code{insert}, the buttons are inserted directly to the -buffer, so @kbd{RET} will toggle displaying the section. If the value -is @code{in-margins}, Outline minor mode will use the window margins -to show that a section is hidden. +minor mode will use buttons at the beginning of the heading lines, in +addition to ellipsis, to show that a section is hidden. Clicking the +mouse on the button toggles display of the section. If the value of +this variable is @code{insert}, the buttons are inserted directly into +the buffer text, so @key{RET} on the button will also toggle display +of the section, like a mouse click does. If the value is +@code{in-margins}, Outline minor mode will use the window margins to +indicate that a section is hidden. @vindex outline-minor-mode-cycle If the @code{outline-minor-mode-cycle} user option is commit 8bde7d40a400780a23eb8b3ba97a41c9539d17b6 Author: Juri Linkov Date: Sat Oct 22 21:57:40 2022 +0300 * lisp/outline.el: Use 'outline-cycle' on buttons for 'RET' like 'TAB' uses. (outline--make-button-overlay, outline--make-margin-overlay): Use overlay keymap where RET and mouse-2 are bound to outline-cycle. (outline--insert-open-button, outline--insert-close-button): Move overlay keymap to outline--make-button-overlay and replace bindings outline-hide-subtree/outline-show-subtree with outline-cycle. diff --git a/lisp/outline.el b/lisp/outline.el index dcc4fbc80a..fd11e496ca 100644 --- a/lisp/outline.el +++ b/lisp/outline.el @@ -1647,6 +1647,10 @@ With a prefix argument, show headings up to that LEVEL." (overlay-put o 'evaporate t) (overlay-put o 'follow-link 'mouse-face) (overlay-put o 'mouse-face 'highlight) + (overlay-put o 'keymap + (define-keymap + "RET" #'outline-cycle + "" #'outline-cycle)) (overlay-put o 'outline-button t)) (let ((icon (icon-elements (if (eq type 'close) (if outline--use-rtl @@ -1679,6 +1683,10 @@ With a prefix argument, show headings up to that LEVEL." (unless o (setq o (make-overlay (point) (1+ (point)))) (overlay-put o 'evaporate t) + (overlay-put o 'keymap + (define-keymap + "RET" #'outline-cycle + "" #'outline-cycle)) (overlay-put o 'outline-margin t)) (let ((icon (icon-elements (if (eq type 'close) (if outline--use-rtl @@ -1705,11 +1713,7 @@ With a prefix argument, show headings up to that LEVEL." (insert " ") (beginning-of-line))) (let ((o (outline--make-button-overlay 'open))) - (overlay-put o 'help-echo "Click to hide") - (overlay-put o 'keymap - (define-keymap - "RET" #'outline-hide-subtree - "" #'outline-hide-subtree))))))) + (overlay-put o 'help-echo "Click to hide")))))) (defun outline--insert-close-button () (with-silent-modifications @@ -1722,11 +1726,7 @@ With a prefix argument, show headings up to that LEVEL." (insert " ") (beginning-of-line))) (let ((o (outline--make-button-overlay 'close))) - (overlay-put o 'help-echo "Click to show") - (overlay-put o 'keymap - (define-keymap - "RET" #'outline-show-subtree - "" #'outline-show-subtree))))))) + (overlay-put o 'help-echo "Click to show")))))) (defun outline--fix-up-all-buttons (&optional from to) (when outline-minor-mode-use-buttons commit fab208495699907891bd8df2379efeb317e5d446 Author: Juri Linkov Date: Sat Oct 22 21:37:56 2022 +0300 Unify outline-minor-mode-use-buttons with in-margins/insert values (bug#57813) * doc/emacs/text.texi (Outline Mode): Remove outline-minor-mode-use-margins. Document the values insert/in-margins of outline-minor-mode-use-buttons. * lisp/help.el (describe-bindings): Set outline-minor-mode-use-buttons to 'insert'. * lisp/textmodes/emacs-news-mode.el (emacs-news--mode-common): Set outline-minor-mode-use-buttons to 'in-margins'. * lisp/outline.el (outline-minor-mode-use-buttons): Change :type from 'buffer-predicate' to choice of const values nil/in-margins/t. (outline--use-buttons, outline-minor-mode-insert-buttons) (outline-minor-mode-use-margins, outline--use-margins): Remove variables. (outline-minor-mode-highlight-buffer): Change overlay name 'outline-overlay' to 'outline-highlight'. (outline-minor-mode): Simplify to handle possible values of 'outline-minor-mode-use-buttons' instead of using many variables. (outline--make-button-overlay): Use value 'insert' of 'outline-minor-mode-use-buttons'. (outline--insert-open-button, outline--insert-close-button) (outline--fix-up-all-buttons, outline--fix-buttons-after-change): Handle values of outline-minor-mode-use-buttons instead of using many variables. diff --git a/doc/emacs/text.texi b/doc/emacs/text.texi index b103e22e39..28fea5b654 100644 --- a/doc/emacs/text.texi +++ b/doc/emacs/text.texi @@ -998,15 +998,13 @@ major mode's special commands. (The variable @vindex outline-minor-mode-use-buttons If @code{outline-minor-mode-use-buttons} is non-@code{nil}, Outline -minor mode will use buttons (at the start of the header lines) in -addition to ellipsis to show that a section is hidden. Using -@kbd{RET} (or clicking on the button with a mouse) will toggle -displaying the section. - -@vindex outline-minor-mode-use-margins - If @code{outline-minor-mode-use-margins} is non-@code{nil}, Outline -minor mode will use the window margins in addition to ellipsis to show -that a section is hidden. +minor mode will use buttons at the start of the heading lines in +addition to ellipsis to show that a section is hidden. Then clicking +on the button with a mouse will toggle displaying the section. If its +value is @code{insert}, the buttons are inserted directly to the +buffer, so @kbd{RET} will toggle displaying the section. If the value +is @code{in-margins}, Outline minor mode will use the window margins +to show that a section is hidden. @vindex outline-minor-mode-cycle If the @code{outline-minor-mode-cycle} user option is diff --git a/etc/NEWS b/etc/NEWS index f1a0662f55..aacad8bc4d 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1036,15 +1036,11 @@ or is itself too long. +++ *** New user option 'outline-minor-mode-use-buttons'. If non-nil, Outline Minor Mode will use buttons to hide/show outlines -in addition to the ellipsis. The default is nil in editing modes, but -non-nil in 'help-mode' and its derivatives. - -+++ -*** New user option 'outline-minor-mode-use-margins'. -If non-nil, Outline Minor Mode will use the window margins to -hide/show outlines in addition to the ellipsis. The default is -non-nil in 'special-mode' and its derivatives, and it can be used in -editing modes. +in addition to the ellipsis. The default is nil, but in 'help-mode' +it has the value 'insert' that inserts the buttons directly to the +buffer where you can use 'RET' to cycle outline visibility. When +the value is 'in-margins', Outline Minor Mode uses the window margins +to hide/show outlines. ** Windows @@ -1637,7 +1633,7 @@ This mode adds some highlighting, fixes the 'M-q' command, and has commands for doing maintenance of the Emacs NEWS files. In addition, this mode turns on 'outline-minor-mode', and thus displays customizable icons (see 'icon-preference') in the margins. To -disable these icons, customize 'outline-minor-mode-use-margins' to a +disable these icons, set 'outline-minor-mode-use-buttons' to a nil value. --- diff --git a/lisp/help.el b/lisp/help.el index 0f5342b77d..d48b866938 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -745,7 +745,7 @@ or a buffer name." (setq-local outline-level (lambda () 1)) (setq-local outline-minor-mode-cycle t outline-minor-mode-highlight t - outline-minor-mode-insert-buttons t) + outline-minor-mode-use-buttons 'insert) (outline-minor-mode 1) (save-excursion (goto-char (point-min)) diff --git a/lisp/outline.el b/lisp/outline.el index 2209964577..dcc4fbc80a 100644 --- a/lisp/outline.el +++ b/lisp/outline.el @@ -281,40 +281,27 @@ This option is only in effect when `outline-minor-mode-cycle' is non-nil." [outline-1 outline-2 outline-3 outline-4 outline-5 outline-6 outline-7 outline-8]) -(defcustom outline-minor-mode-use-buttons '(derived-mode . help-mode) +(defcustom outline-minor-mode-use-buttons nil "Whether to display clickable buttons on the headings. -The value should be a `buffer-match-p' condition. - These buttons can be used to hide and show the body under the heading. -Note that this feature is not meant to be used in editing -buffers (yet) -- that will be amended in a future version." - :type 'buffer-predicate - :safe #'booleanp +When the value is `insert', additional placeholders for buttons are +inserted to the buffer, so buttons are not only clickable, +but also typing `RET' on them can hide and show the body. +When the value is `in-margins', then clickable buttons are +displayed in the margins before the headings. +When the value is `t', clickable buttons are displayed +in the buffer before the headings. The values `t' and +`in-margins' can be used in editing buffers because they +don't modify the buffer." + :type '(choice (const :tag "Do not use outline buttons" nil) + (const :tag "Show outline buttons in margins" in-margins) + (const :tag "Show outline buttons in buffer" t)) + :safe #'symbolp :version "29.1") -(defvar-local outline--use-buttons nil - "Non-nil when buffer displays clickable buttons on the headings.") - -(defvar-local outline-minor-mode-insert-buttons nil - "Non-nil when it's allowed to modify buffer to insert buttons.") - (defvar-local outline--use-rtl nil "Non-nil when direction of clickable buttons is right-to-left.") -(defcustom outline-minor-mode-use-margins '(and (derived-mode . special-mode) - (not (derived-mode . help-mode))) - "Whether to display clickable buttons in the margins. -The value should be a `buffer-match-p' condition. - -These buttons can be used to hide and show the body under the heading. -Note that this feature is meant to be used in editing buffers." - :type 'buffer-predicate - :safe #'booleanp - :version "29.1") - -(defvar-local outline--use-margins nil - "Non-nil when buffer displays clickable buttons in the margins.") - (define-icon outline-open nil '((image "outline-open.svg" "outline-open.pbm" :height (0.8 . em)) (emoji "🔽") @@ -487,7 +474,7 @@ outline font-lock faces to those of major mode." (let ((regexp (concat "^\\(?:" outline-regexp "\\).*$"))) (while (re-search-forward regexp nil t) (let ((overlay (make-overlay (match-beginning 0) (match-end 0)))) - (overlay-put overlay 'outline-overlay t) + (overlay-put overlay 'outline-highlight t) ;; FIXME: Is it possible to override all underlying face attributes? (when (or (memq outline-minor-mode-highlight '(append override)) (and (eq outline-minor-mode-highlight t) @@ -511,25 +498,19 @@ See the command `outline-mode' for more information on this mode." (key-description outline-minor-mode-prefix) outline-mode-prefix-map) (if outline-minor-mode (progn - (cond - ((buffer-match-p outline-minor-mode-use-margins (current-buffer)) - (setq-local outline--use-margins t)) - ((buffer-match-p outline-minor-mode-use-buttons (current-buffer)) - (setq-local outline--use-buttons t))) - (when (and (or outline--use-buttons outline--use-margins) - (eq (current-bidi-paragraph-direction) 'right-to-left)) - (setq-local outline--use-rtl t)) - (when outline--use-margins - (if outline--use-rtl - (setq-local right-margin-width (1+ right-margin-width)) - (setq-local left-margin-width (1+ left-margin-width))) - (setq-local fringes-outside-margins t) - ;; Force display of margins - (when (eq (current-buffer) (window-buffer)) - (set-window-buffer nil (window-buffer)))) - (when (or outline--use-buttons outline--use-margins) + (when outline-minor-mode-use-buttons (add-hook 'after-change-functions - #'outline--fix-buttons-after-change nil t)) + #'outline--fix-buttons-after-change nil t) + (when (eq (current-bidi-paragraph-direction) 'right-to-left) + (setq-local outline--use-rtl t)) + (when (eq outline-minor-mode-use-buttons 'in-margins) + (if outline--use-rtl + (setq-local right-margin-width (1+ right-margin-width)) + (setq-local left-margin-width (1+ left-margin-width))) + (setq-local fringes-outside-margins t) + ;; Force display of margins + (when (eq (current-buffer) (window-buffer)) + (set-window-buffer nil (window-buffer))))) (when outline-minor-mode-highlight (if (and global-font-lock-mode (font-lock-specified-p major-mode)) (progn @@ -554,18 +535,18 @@ See the command `outline-mode' for more information on this mode." (if font-lock-fontified (font-lock-remove-keywords nil outline-font-lock-keywords)) (font-lock-flush) - (remove-overlays nil nil 'outline-overlay t)) - (when outline--use-buttons - (remove-overlays nil nil 'outline-button t)) - (when outline--use-margins - (remove-overlays nil nil 'outline-margin t) - (if outline--use-rtl - (setq-local right-margin-width (1- right-margin-width)) - (setq-local left-margin-width (1- left-margin-width))) - (setq-local fringes-outside-margins nil) - ;; Force removal of margins - (when (eq (current-buffer) (window-buffer)) - (set-window-buffer nil (window-buffer)))))) + (remove-overlays nil nil 'outline-highlight t)) + (when outline-minor-mode-use-buttons + (if (not (eq outline-minor-mode-use-buttons 'in-margins)) + (remove-overlays nil nil 'outline-button t) + (remove-overlays nil nil 'outline-margin t) + (if outline--use-rtl + (setq-local right-margin-width (1- right-margin-width)) + (setq-local left-margin-width (1- left-margin-width))) + (setq-local fringes-outside-margins nil) + ;; Force removal of margins + (when (eq (current-buffer) (window-buffer)) + (set-window-buffer nil (window-buffer))))))) (defvar-local outline-heading-alist () "Alist associating a heading for every possible level. @@ -1675,7 +1656,7 @@ With a prefix argument, show headings up to that LEVEL." ;; In editing buffers we use overlays only, but in other buffers ;; we use a mix of text properties, text and overlays to make ;; movement commands work more logically. - (if outline-minor-mode-insert-buttons + (if (eq outline-minor-mode-use-buttons 'insert) (let ((inhibit-read-only t)) (put-text-property (point) (1+ (point)) 'face (plist-get icon 'face)) (if-let ((image (plist-get icon 'image))) @@ -1713,13 +1694,13 @@ With a prefix argument, show headings up to that LEVEL." (plist-get icon 'string)))))) o)) -(defun outline--insert-open-button (&optional use-margins) +(defun outline--insert-open-button () (with-silent-modifications (save-excursion (beginning-of-line) - (if use-margins + (if (eq outline-minor-mode-use-buttons 'in-margins) (outline--make-margin-overlay 'open) - (when outline-minor-mode-insert-buttons + (when (eq outline-minor-mode-use-buttons 'insert) (let ((inhibit-read-only t)) (insert " ") (beginning-of-line))) @@ -1730,13 +1711,13 @@ With a prefix argument, show headings up to that LEVEL." "RET" #'outline-hide-subtree "" #'outline-hide-subtree))))))) -(defun outline--insert-close-button (&optional use-margins) +(defun outline--insert-close-button () (with-silent-modifications (save-excursion (beginning-of-line) - (if use-margins + (if (eq outline-minor-mode-use-buttons 'in-margins) (outline--make-margin-overlay 'close) - (when outline-minor-mode-insert-buttons + (when (eq outline-minor-mode-use-buttons 'insert) (let ((inhibit-read-only t)) (insert " ") (beginning-of-line))) @@ -1748,7 +1729,7 @@ With a prefix argument, show headings up to that LEVEL." "" #'outline-show-subtree))))))) (defun outline--fix-up-all-buttons (&optional from to) - (when (or outline--use-buttons outline--use-margins) + (when outline-minor-mode-use-buttons (when from (save-excursion (goto-char from) @@ -1759,17 +1740,16 @@ With a prefix argument, show headings up to that LEVEL." (outline-end-of-heading) (seq-some (lambda (o) (eq (overlay-get o 'invisible) 'outline)) (overlays-at (point)))) - (outline--insert-close-button outline--use-margins) - (outline--insert-open-button outline--use-margins))) + (outline--insert-close-button) + (outline--insert-open-button))) (or from (point-min)) (or to (point-max))))) (defun outline--fix-buttons-after-change (beg end _len) ;; Handle whole lines (save-excursion (goto-char beg) (setq beg (pos-bol))) (save-excursion (goto-char end) (setq end (pos-eol))) - (when outline--use-buttons - (remove-overlays beg end 'outline-button t)) - (when outline--use-margins + (if (not (eq outline-minor-mode-use-buttons 'in-margins)) + (remove-overlays beg end 'outline-button t) (remove-overlays beg end 'outline-margin t)) (outline--fix-up-all-buttons beg end)) diff --git a/lisp/textmodes/emacs-news-mode.el b/lisp/textmodes/emacs-news-mode.el index d57d053a7a..ebb31da9cf 100644 --- a/lisp/textmodes/emacs-news-mode.el +++ b/lisp/textmodes/emacs-news-mode.el @@ -75,7 +75,7 @@ (setq-local font-lock-defaults '(emacs-news-mode-font-lock-keywords t)) (setq-local outline-minor-mode-cycle t outline-minor-mode-highlight 'append - outline-minor-mode-use-margins t) + outline-minor-mode-use-buttons 'in-margins) (outline-minor-mode) (setq-local imenu-generic-expression outline-imenu-generic-expression) (emacs-etc--hide-local-variables)) commit b82159a234e0ecaaf77c2cbf65ed5d0ccf332e4b Author: Juri Linkov Date: Sat Oct 22 20:46:10 2022 +0300 * lisp/info.el (Info-toc-build): Remove message not needed anymore (bug#58634) diff --git a/lisp/info.el b/lisp/info.el index fabba2734a..d74cbaaac0 100644 --- a/lisp/info.el +++ b/lisp/info.el @@ -2481,7 +2481,6 @@ Table of contents is created from the tree structure of menus." (sections '(("Top" "Top"))) nodes subfiles) (while (or main-file subfiles) - ;; (or main-file (message "Searching subfile %s..." (car subfiles))) (erase-buffer) (info-insert-file-contents (or main-file (car subfiles))) (goto-char (point-min)) @@ -2540,7 +2539,6 @@ Table of contents is created from the tree structure of menus." (setq subfiles (nreverse subfiles) main-file nil)) (setq subfiles (cdr subfiles)))) - (message "") (nreverse nodes)))) (defun Info-toc-nodes (filename) commit 9da2efb670574b473ab864ae0456b4f1b38e680b Author: Basil L. Contovounesios Date: Sat Aug 20 16:32:33 2022 +0300 Audit some plist uses with new predicate argument * doc/lispref/lists.texi (Plist Access): Improve description of default predicate. * lisp/emacs-lisp/cl-extra.el (cl-getf, cl--set-getf): Assume plist-member always returns a cons. * lisp/emacs-lisp/gv.el (plist-get): Support new optional predicate argument (bug#47425#91). * lisp/emacs-lisp/map.el: Bump minor version. (map--dispatch): Remove now that bug#58563 is fixed. Break two remaining uses out into corresponding cl-defmethods. (map--plist-p): Add docstring. (map--plist-has-predicate, map--plist-member-1, map--plist-member) (map--plist-put-1, map--plist-put): New definitions for supporting predicate argument backward compatibly. (map-elt): Fix generalized variable getter under a predicate (bug#58531). Use predicate when given a plist. (map-put): Avoid gratuitous warnings when called without the hidden predicate argument. Improve obsoletion message. (map-put!): Use predicate when given a plist. (map-contains-key): Ditto. Declare forgotten advertised-calling-convention (bug#58531#19). (map--put): Group definition in file together with that of map-put!. * lisp/files-x.el (connection-local-normalize-criteria): Simplify using mapcan + plist-get. * lisp/net/eudc.el (eudc--plist-member): New convenience function. (eudc-plist-member, eudc-plist-get, eudc-lax-plist-get): Use it instead of open-coding plist-member. * src/fns.c (Fplist_get, plist_get, Fplist_put, plist_put): Pass the plist element as the first argument to the predicate, for consistency with assoc + alist-get. (Fplist_member, plist_member): Move from widget to plist section. Open-code the EQ case in plist_member, and call it from Fplist_member in that case, rather than the other way around. * test/lisp/apropos-tests.el (apropos-tests-format-plist): Avoid polluting obarray. * test/lisp/emacs-lisp/cl-extra-tests.el (cl-getf): Extend test with generalized variables, degenerate plists, and improper lists. * test/lisp/emacs-lisp/gv-tests.el: Byte-compile file; in the meantime bug#24402 seems to have been fixed or worked around. (gv-setter-edebug): Inhibit printing messages. (gv-plist-get): Avoid modifying constant literals. Also test with a predicate argument. * test/lisp/emacs-lisp/map-tests.el (with-maps-do): Simplify docstring. (test-map-elt-testfn): Rename... (test-map-elt-testfn-alist): ...to this. Also test with a predicate argument. (test-map-elt-testfn-plist, test-map-elt-gv, test-map-elt-signature) (test-map-put!-plist, test-map-put!-signature) (test-map-contains-key-signature, test-map-plist-member) (test-map-plist-put): New tests. (test-map-contains-key-testfn): Also test with a predicate argument. (test-map-setf-alist-overwrite-key, test-map-setf-plist-insert-key) (test-map-setf-plist-overwrite-key): Avoid modifying constant literals. (test-hash-table-setf-insert-key) (test-hash-table-setf-overwrite-key): Fix indentation. (test-setf-map-with-function): Make test more precise. * test/lisp/net/eudc-tests.el: New file. * test/lisp/subr-tests.el (test-plistp): Extend test with circular list. * test/src/fns-tests.el (test-cycle-equal, test-cycle-nconc): Move from plist section to circular list section. (plist-put/odd-number-of-elements): Avoid modifying constant literals. (plist-member/improper-list): Simplify. (test-plist): Move to plist section. Also test with a predicate argument. diff --git a/doc/lispref/lists.texi b/doc/lispref/lists.texi index 5c5c615f85..30f65e359a 100644 --- a/doc/lispref/lists.texi +++ b/doc/lispref/lists.texi @@ -1961,12 +1961,12 @@ and later discarded; this is not possible with a property list. @cindex accessing plist properties The following functions can be used to manipulate property lists. -They all compare property names using @code{eq}. +They all default to comparing property names using @code{eq}. @defun plist-get plist property &optional predicate This returns the value of the @var{property} property stored in the property list @var{plist}. Comparisons are done with @var{predicate}, -and defaults to @code{eq}. It accepts a malformed @var{plist} +which defaults to @code{eq}. It accepts a malformed @var{plist} argument. If @var{property} is not found in the @var{plist}, it returns @code{nil}. For example, @@ -1985,7 +1985,7 @@ returns @code{nil}. For example, @defun plist-put plist property value &optional predicate This stores @var{value} as the value of the @var{property} property in the property list @var{plist}. Comparisons are done with @var{predicate}, -and defaults to @code{eq}. It may modify @var{plist} destructively, +which defaults to @code{eq}. It may modify @var{plist} destructively, or it may construct a new list structure without altering the old. The function returns the modified property list, so you can store that back in the place where you got @var{plist}. For example, @@ -2012,7 +2012,7 @@ compares properties using @code{equal} instead of @code{eq}. @defun plist-member plist property &optional predicate This returns non-@code{nil} if @var{plist} contains the given -@var{property}. Comparisons are done with @var{predicate}, and +@var{property}. Comparisons are done with @var{predicate}, which defaults to @code{eq}. Unlike @code{plist-get}, this allows you to distinguish between a missing property and a property with the value @code{nil}. The value is actually the tail of @var{plist} whose diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 7c7f027d77..66b214554e 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -615,12 +615,12 @@ PROPLIST is a list of the sort returned by `symbol-plist'. ,(funcall setter `(cl--set-getf ,getter ,k ,val)) ,val))))))))) - (let ((val-tail (cdr-safe (plist-member plist tag)))) + (let ((val-tail (cdr (plist-member plist tag)))) (if val-tail (car val-tail) def))) ;;;###autoload (defun cl--set-getf (plist tag val) - (let ((val-tail (cdr-safe (plist-member plist tag)))) + (let ((val-tail (cdr (plist-member plist tag)))) (if val-tail (progn (setcar val-tail val) plist) (cl-list* tag val plist)))) diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index a96fa19a3f..11251d7a96 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -445,16 +445,17 @@ The return value is the last VAL in the list. ,v)))))))))) (gv-define-expander plist-get - (lambda (do plist prop) + (lambda (do plist prop &optional predicate) (macroexp-let2 macroexp-copyable-p key prop (gv-letplace (getter setter) plist - (macroexp-let2 nil p `(cdr (plist-member ,getter ,key)) + (macroexp-let2 nil p `(cdr (plist-member ,getter ,key ,predicate)) (funcall do `(car ,p) (lambda (val) `(if ,p (setcar ,p ,val) - ,(funcall setter `(cons ,key (cons ,val ,getter))))))))))) + ,(funcall setter + `(cons ,key (cons ,val ,getter))))))))))) ;;; Some occasionally handy extensions. diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el index 8c67d7c7a2..8e3b698d37 100644 --- a/lisp/emacs-lisp/map.el +++ b/lisp/emacs-lisp/map.el @@ -5,7 +5,7 @@ ;; Author: Nicolas Petton ;; Maintainer: emacs-devel@gnu.org ;; Keywords: extensions, lisp -;; Version: 3.2.1 +;; Version: 3.3.1 ;; Package-Requires: ((emacs "26")) ;; This file is part of GNU Emacs. @@ -80,48 +80,82 @@ MAP can be an alist, plist, hash-table, or array." `(pcase-let ((,(map--make-pcase-patterns keys) ,map)) ,@body)) -(eval-when-compile - (defmacro map--dispatch (map-var &rest args) - "Evaluate one of the forms specified by ARGS based on the type of MAP-VAR. - -The following keyword types are meaningful: `:list', -`:hash-table' and `:array'. - -An error is thrown if MAP-VAR is neither a list, hash-table nor array. - -Returns the result of evaluating the form associated with MAP-VAR's type." - (declare (debug t) (indent 1)) - `(cond ((listp ,map-var) ,(plist-get args :list)) - ((hash-table-p ,map-var) ,(plist-get args :hash-table)) - ((arrayp ,map-var) ,(plist-get args :array)) - (t (error "Unsupported map type `%S': %S" - (type-of ,map-var) ,map-var))))) - (define-error 'map-not-inplace "Cannot modify map in-place") (defsubst map--plist-p (list) + "Return non-nil if LIST is the start of a nonempty plist map." (and (consp list) (atom (car list)))) +(defconst map--plist-has-predicate + (condition-case nil + (with-no-warnings (plist-get () nil #'eq) t) + (wrong-number-of-arguments)) + "Non-nil means `plist-get' & co. accept a predicate in Emacs 29+. +Note that support for this predicate in map.el is patchy and +deprecated.") + +(defun map--plist-member-1 (plist prop &optional predicate) + "Compatibility shim for the PREDICATE argument of `plist-member'. +Assumes non-nil PLIST satisfies `map--plist-p'." + (if (or (memq predicate '(nil eq)) (null plist)) + (plist-member plist prop) + (let ((tail plist) found) + (while (and (not (setq found (funcall predicate (car tail) prop))) + (consp (setq tail (cdr tail))) + (consp (setq tail (cdr tail))))) + (and tail (not found) + (signal 'wrong-type-argument `(plistp ,plist))) + tail))) + +(defalias 'map--plist-member + (if map--plist-has-predicate #'plist-member #'map--plist-member-1) + "Compatibility shim for `plist-member' in Emacs 29+. +\n(fn PLIST PROP &optional PREDICATE)") + +(defun map--plist-put-1 (plist prop val &optional predicate) + "Compatibility shim for the PREDICATE argument of `plist-put'. +Assumes non-nil PLIST satisfies `map--plist-p'." + (if (or (memq predicate '(nil eq)) (null plist)) + (plist-put plist prop val) + (let ((tail plist) prev found) + (while (and (consp (cdr tail)) + (not (setq found (funcall predicate (car tail) prop))) + (consp (setq prev tail tail (cddr tail))))) + (cond (found (setcar (cdr tail) val)) + (tail (signal 'wrong-type-argument `(plistp ,plist))) + (prev (setcdr (cdr prev) (cons prop (cons val (cddr prev))))) + ((setq plist (cons prop (cons val plist))))) + plist))) + +(defalias 'map--plist-put + (if map--plist-has-predicate #'plist-put #'map--plist-put-1) + "Compatibility shim for `plist-put' in Emacs 29+. +\n(fn PLIST PROP VAL &optional PREDICATE)") + (cl-defgeneric map-elt (map key &optional default testfn) "Look up KEY in MAP and return its associated value. If KEY is not found, return DEFAULT which defaults to nil. TESTFN is the function to use for comparing keys. It is deprecated because its default and valid values depend on the MAP -argument. Generally, alist keys are compared with `equal', plist -keys with `eq', and hash-table keys with the hash-table's test +argument, and it was never consistently supported by the map.el +API. Generally, alist keys are compared with `equal', plist keys +with `eq', and hash-table keys with the hash-table's test function. In the base definition, MAP can be an alist, plist, hash-table, or array." (declare + ;; `testfn' is deprecated. + (advertised-calling-convention (map key &optional default) "27.1") (gv-expander (lambda (do) (gv-letplace (mgetter msetter) `(gv-delay-error ,map) (macroexp-let2* nil ;; Eval them once and for all in the right order. ((key key) (default default) (testfn testfn)) - (funcall do `(map-elt ,mgetter ,key ,default) + (funcall do + `(map-elt ,mgetter ,key ,default ,@(and testfn `(,testfn))) (lambda (v) (macroexp-let2 nil v v `(condition-case nil @@ -132,19 +166,21 @@ or array." ,(funcall msetter `(map-insert ,mgetter ,key ,v)) ;; Always return the value. - ,v))))))))) - ;; `testfn' is deprecated. - (advertised-calling-convention (map key &optional default) "27.1")) - ;; Can't use `cl-defmethod' with `advertised-calling-convention'. - (map--dispatch map - :list (if (map--plist-p map) - (let ((res (plist-member map key))) - (if res (cadr res) default)) - (alist-get key map default nil (or testfn #'equal))) - :hash-table (gethash key map default) - :array (if (map-contains-key map key) - (aref map key) - default))) + ,v))))))))))) + +(cl-defmethod map-elt ((map list) key &optional default testfn) + (if (map--plist-p map) + (let ((res (map--plist-member map key testfn))) + (if res (cadr res) default)) + (alist-get key map default nil (or testfn #'equal)))) + +(cl-defmethod map-elt ((map hash-table) key &optional default _testfn) + (gethash key map default)) + +(cl-defmethod map-elt ((map array) key &optional default _testfn) + (if (map-contains-key map key) + (aref map key) + default)) (defmacro map-put (map key value &optional testfn) "Associate KEY with VALUE in MAP and return VALUE. @@ -154,8 +190,12 @@ When MAP is an alist, test equality with TESTFN if non-nil, otherwise use `equal'. MAP can be an alist, plist, hash-table, or array." - (declare (obsolete "use map-put! or (setf (map-elt ...) ...) instead" "27.1")) - `(setf (map-elt ,map ,key nil ,testfn) ,value)) + (declare + (obsolete "use `map-put!' or `(setf (map-elt ...) ...)' instead." "27.1")) + (if testfn + `(with-no-warnings + (setf (map-elt ,map ,key nil ,testfn) ,value)) + `(setf (map-elt ,map ,key) ,value))) (defun map--plist-delete (map key) (let ((tail map) last) @@ -338,15 +378,16 @@ The default implementation delegates to `map-length'." "Return non-nil if and only if MAP contains KEY. TESTFN is deprecated. Its default depends on MAP. The default implementation delegates to `map-some'." + (declare (advertised-calling-convention (map key) "27.1")) (unless testfn (setq testfn #'equal)) (map-some (lambda (k _v) (funcall testfn key k)) map)) (cl-defmethod map-contains-key ((map list) key &optional testfn) "Return non-nil if MAP contains KEY. If MAP is an alist, TESTFN defaults to `equal'. -If MAP is a plist, `plist-member' is used instead." +If MAP is a plist, TESTFN defaults to `eq'." (if (map--plist-p map) - (plist-member map key) + (map--plist-member map key testfn) (let ((v '(nil))) (not (eq v (alist-get key map v nil (or testfn #'equal))))))) @@ -459,24 +500,30 @@ This operates by modifying MAP in place. If it cannot do that, it signals a `map-not-inplace' error. To insert an element without modifying MAP, use `map-insert'." ;; `testfn' only exists for backward compatibility with `map-put'! - (declare (advertised-calling-convention (map key value) "27.1")) - ;; Can't use `cl-defmethod' with `advertised-calling-convention'. - (map--dispatch - map - :list - (progn - (if (map--plist-p map) - (plist-put map key value) - (let ((oldmap map)) - (setf (alist-get key map key nil (or testfn #'equal)) value) - (unless (eq oldmap map) - (signal 'map-not-inplace (list oldmap))))) - ;; Always return the value. - value) - :hash-table (puthash key value map) - ;; FIXME: If `key' is too large, should we signal `map-not-inplace' - ;; and let `map-insert' grow the array? - :array (aset map key value))) + (declare (advertised-calling-convention (map key value) "27.1"))) + +(cl-defmethod map-put! ((map list) key value &optional testfn) + (if (map--plist-p map) + (map--plist-put map key value testfn) + (let ((oldmap map)) + (setf (alist-get key map key nil (or testfn #'equal)) value) + (unless (eq oldmap map) + (signal 'map-not-inplace (list oldmap))))) + ;; Always return the value. + value) + +(cl-defmethod map-put! ((map hash-table) key value &optional _testfn) + (puthash key value map)) + +(cl-defmethod map-put! ((map array) key value &optional _testfn) + ;; FIXME: If `key' is too large, should we signal `map-not-inplace' + ;; and let `map-insert' grow the array? + (aset map key value)) + +;; There shouldn't be old source code referring to `map--put', yet we do +;; need to keep it for backward compatibility with .elc files where the +;; expansion of `setf' may call this function. +(define-obsolete-function-alias 'map--put #'map-put! "27.1") (cl-defgeneric map-insert (map key value) "Return a new map like MAP except that it associates KEY with VALUE. @@ -493,11 +540,6 @@ The default implementation defaults to `map-copy' and `map-put!'." (cons key (cons value map)) (cons (cons key value) map))) -;; There shouldn't be old source code referring to `map--put', yet we do -;; need to keep it for backward compatibility with .elc files where the -;; expansion of `setf' may call this function. -(define-obsolete-function-alias 'map--put #'map-put! "27.1") - (cl-defmethod map-apply (function (map list)) (if (map--plist-p map) (cl-call-next-method) diff --git a/lisp/files-x.el b/lisp/files-x.el index 3516592fc3..7199db3e44 100644 --- a/lisp/files-x.el +++ b/lisp/files-x.el @@ -635,13 +635,10 @@ of `with-connection-local-variables'.") (defsubst connection-local-normalize-criteria (criteria) "Normalize plist CRITERIA according to properties. Return a reordered plist." - (apply - #'append - (mapcar - (lambda (property) - (when (and (plist-member criteria property) (plist-get criteria property)) - (list property (plist-get criteria property)))) - '(:application :protocol :user :machine)))) + (mapcan (lambda (property) + (let ((value (plist-get criteria property))) + (and value (list property value)))) + '(:application :protocol :user :machine))) (defsubst connection-local-get-profiles (criteria) "Return the connection profiles list for CRITERIA. diff --git a/lisp/net/eudc.el b/lisp/net/eudc.el index 40cb25fca2..0283b04574 100644 --- a/lisp/net/eudc.el +++ b/lisp/net/eudc.el @@ -106,44 +106,40 @@ ;; Split the string just in case. (version<= "3" (car (split-string bbdb-version))))) -(defun eudc-plist-member (plist prop) - "Return t if PROP has a value specified in PLIST." - (if (not (= 0 (% (length plist) 2))) +(defun eudc--plist-member (plist prop &optional predicate) + "Like `plist-member', but signal on invalid PLIST." + ;; Could also use `plistp', but that would change the error. + (or (zerop (% (length plist) 2)) (error "Malformed plist")) - (catch 'found - (while plist - (if (eq prop (car plist)) - (throw 'found t)) - (setq plist (cdr (cdr plist)))) - nil)) + (plist-member plist prop predicate)) -;; Emacs's plist-get lacks third parameter +(defun eudc-plist-member (plist prop) + "Return t if PROP has a value specified in PLIST. +Signal an error if PLIST is not a valid property list." + (and (eudc--plist-member plist prop) t)) + +;; Emacs's `plist-get' lacks a default parameter, and CL-Lib's +;; `cl-getf' doesn't accept a predicate or signal an error. (defun eudc-plist-get (plist prop &optional default) - "Extract a value from a property list. -PLIST is a property list, which is a list of the form -\(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value -corresponding to the given PROP, or DEFAULT if PROP is not -one of the properties on the list." - (if (eudc-plist-member plist prop) - (plist-get plist prop) - default)) + "Extract the value of PROP in property list PLIST. +PLIST is a list of the form (PROP1 VALUE1 PROP2 VALUE2...). +This function returns the first value corresponding to the given +PROP, or DEFAULT if PROP is not one of the properties in the +list. The comparison with PROP is done using `eq'. If PLIST is +not a valid property list, this function signals an error." + (let ((tail (eudc--plist-member plist prop))) + (if tail (cadr tail) default))) (defun eudc-lax-plist-get (plist prop &optional default) - "Extract a value from a lax property list. - -PLIST is a lax property list, which is a list of the form (PROP1 -VALUE1 PROP2 VALUE2...), where comparisons between properties are done -using `equal' instead of `eq'. This function returns the value -corresponding to PROP, or DEFAULT if PROP is not one of the -properties on the list." - (if (not (= 0 (% (length plist) 2))) - (error "Malformed plist")) - (catch 'found - (while plist - (if (equal prop (car plist)) - (throw 'found (car (cdr plist)))) - (setq plist (cdr (cdr plist)))) - default)) + "Extract the value of PROP from lax property list PLIST. +PLIST is a list of the form (PROP1 VALUE1 PROP2 VALUE2...), where +comparisons between properties are done using `equal' instead of +`eq'. This function returns the first value corresponding to +PROP, or DEFAULT if PROP is not one of the properties in the +list. If PLIST is not a valid property list, this function +signals an error." + (let ((tail (eudc--plist-member plist prop #'equal))) + (if tail (cadr tail) default))) (defun eudc-replace-in-string (str regexp newtext) "Replace all matches in STR for REGEXP with NEWTEXT. diff --git a/src/fns.c b/src/fns.c index 4055792382..940fb680fc 100644 --- a/src/fns.c +++ b/src/fns.c @@ -2473,15 +2473,15 @@ with PROP is done using PREDICATE, which defaults to `eq'. This function doesn't signal an error if PLIST is invalid. */) (Lisp_Object plist, Lisp_Object prop, Lisp_Object predicate) { - Lisp_Object tail = plist; if (NILP (predicate)) return plist_get (plist, prop); + Lisp_Object tail = plist; FOR_EACH_TAIL_SAFE (tail) { if (! CONSP (XCDR (tail))) break; - if (!NILP (call2 (predicate, prop, XCAR (tail)))) + if (!NILP (call2 (predicate, XCAR (tail), prop))) return XCAR (XCDR (tail)); tail = XCDR (tail); } @@ -2489,7 +2489,7 @@ This function doesn't signal an error if PLIST is invalid. */) return Qnil; } -/* Faster version of the above that works with EQ only */ +/* Faster version of Fplist_get that works with EQ only. */ Lisp_Object plist_get (Lisp_Object plist, Lisp_Object prop) { @@ -2498,7 +2498,7 @@ plist_get (Lisp_Object plist, Lisp_Object prop) { if (! CONSP (XCDR (tail))) break; - if (EQ (prop, XCAR (tail))) + if (EQ (XCAR (tail), prop)) return XCAR (XCDR (tail)); tail = XCDR (tail); } @@ -2532,15 +2532,15 @@ use `(setq x (plist-put x prop val))' to be sure to use the new value. The PLIST is modified by side effects. */) (Lisp_Object plist, Lisp_Object prop, Lisp_Object val, Lisp_Object predicate) { - Lisp_Object prev = Qnil, tail = plist; if (NILP (predicate)) return plist_put (plist, prop, val); + Lisp_Object prev = Qnil, tail = plist; FOR_EACH_TAIL (tail) { if (! CONSP (XCDR (tail))) break; - if (!NILP (call2 (predicate, prop, XCAR (tail)))) + if (!NILP (call2 (predicate, XCAR (tail), prop))) { Fsetcar (XCDR (tail), val); return plist; @@ -2558,6 +2558,7 @@ The PLIST is modified by side effects. */) return plist; } +/* Faster version of Fplist_put that works with EQ only. */ Lisp_Object plist_put (Lisp_Object plist, Lisp_Object prop, Lisp_Object val) { @@ -2567,7 +2568,7 @@ plist_put (Lisp_Object plist, Lisp_Object prop, Lisp_Object val) if (! CONSP (XCDR (tail))) break; - if (EQ (prop, XCAR (tail))) + if (EQ (XCAR (tail), prop)) { Fsetcar (XCDR (tail), val); return plist; @@ -2595,6 +2596,51 @@ It can be retrieved with `(get SYMBOL PROPNAME)'. */) (symbol, plist_put (XSYMBOL (symbol)->u.s.plist, propname, value)); return value; } + +DEFUN ("plist-member", Fplist_member, Splist_member, 2, 3, 0, + doc: /* Return non-nil if PLIST has the property PROP. +PLIST is a property list, which is a list of the form +\(PROP1 VALUE1 PROP2 VALUE2 ...). + +The comparison with PROP is done using PREDICATE, which defaults to +`eq'. + +Unlike `plist-get', this allows you to distinguish between a missing +property and a property with the value nil. +The value is actually the tail of PLIST whose car is PROP. */) + (Lisp_Object plist, Lisp_Object prop, Lisp_Object predicate) +{ + if (NILP (predicate)) + return plist_member (plist, prop); + Lisp_Object tail = plist; + FOR_EACH_TAIL (tail) + { + if (!NILP (call2 (predicate, XCAR (tail), prop))) + return tail; + tail = XCDR (tail); + if (! CONSP (tail)) + break; + } + CHECK_TYPE (NILP (tail), Qplistp, plist); + return Qnil; +} + +/* Faster version of Fplist_member that works with EQ only. */ +Lisp_Object +plist_member (Lisp_Object plist, Lisp_Object prop) +{ + Lisp_Object tail = plist; + FOR_EACH_TAIL (tail) + { + if (EQ (XCAR (tail), prop)) + return tail; + tail = XCDR (tail); + if (! CONSP (tail)) + break; + } + CHECK_TYPE (NILP (tail), Qplistp, plist); + return Qnil; +} DEFUN ("eql", Feql, Seql, 2, 2, 0, doc: /* Return t if the two args are `eq' or are indistinguishable numbers. @@ -3388,43 +3434,6 @@ FILENAME are suppressed. */) bottleneck of Widget operation. Here is their translation to C, for the sole reason of efficiency. */ -DEFUN ("plist-member", Fplist_member, Splist_member, 2, 3, 0, - doc: /* Return non-nil if PLIST has the property PROP. -PLIST is a property list, which is a list of the form -\(PROP1 VALUE1 PROP2 VALUE2 ...). - -The comparison with PROP is done using PREDICATE, which defaults to -`eq'. - -Unlike `plist-get', this allows you to distinguish between a missing -property and a property with the value nil. -The value is actually the tail of PLIST whose car is PROP. */) - (Lisp_Object plist, Lisp_Object prop, Lisp_Object predicate) -{ - Lisp_Object tail = plist; - if (NILP (predicate)) - predicate = Qeq; - FOR_EACH_TAIL (tail) - { - if (!NILP (call2 (predicate, XCAR (tail), prop))) - return tail; - tail = XCDR (tail); - if (! CONSP (tail)) - break; - } - CHECK_TYPE (NILP (tail), Qplistp, plist); - return Qnil; -} - -/* plist_member isn't used much in the Emacs sources, so just provide - a shim so that the function name follows the same pattern as - plist_get/plist_put. */ -Lisp_Object -plist_member (Lisp_Object plist, Lisp_Object prop) -{ - return Fplist_member (plist, prop, Qnil); -} - DEFUN ("widget-put", Fwidget_put, Swidget_put, 3, 3, 0, doc: /* In WIDGET, set PROPERTY to VALUE. The value can later be retrieved with `widget-get'. */) diff --git a/test/lisp/apropos-tests.el b/test/lisp/apropos-tests.el index 289700abf7..917c08b911 100644 --- a/test/lisp/apropos-tests.el +++ b/test/lisp/apropos-tests.el @@ -120,14 +120,15 @@ (should (apropos-true-hit "foo bar baz" '("foo" "bar")))) (ert-deftest apropos-tests-format-plist () - (setplist 'foo '(a 1 b (2 3) c nil)) - (apropos-parse-pattern '("b")) - (should (equal (apropos-format-plist 'foo ", ") - "a 1, b (2 3), c nil")) - (should (equal (apropos-format-plist 'foo ", " t) - "b (2 3)")) - (apropos-parse-pattern '("d")) - (should-not (apropos-format-plist 'foo ", " t))) + (let ((foo (make-symbol "foo"))) + (setplist foo '(a 1 b (2 3) c nil)) + (apropos-parse-pattern '("b")) + (should (equal (apropos-format-plist foo ", ") + "a 1, b (2 3), c nil")) + (should (equal (apropos-format-plist foo ", " t) + "b (2 3)")) + (apropos-parse-pattern '("d")) + (should-not (apropos-format-plist foo ", " t)))) (provide 'apropos-tests) ;;; apropos-tests.el ends here diff --git a/test/lisp/emacs-lisp/cl-extra-tests.el b/test/lisp/emacs-lisp/cl-extra-tests.el index 297e413d85..6a34cd681e 100644 --- a/test/lisp/emacs-lisp/cl-extra-tests.el +++ b/test/lisp/emacs-lisp/cl-extra-tests.el @@ -32,8 +32,28 @@ (ert-deftest cl-getf () (let ((plist '(x 1 y nil))) (should (eq (cl-getf plist 'x) 1)) - (should (eq (cl-getf plist 'y :none) nil)) - (should (eq (cl-getf plist 'z :none) :none)))) + (should-not (cl-getf plist 'y :none)) + (should (eq (cl-getf plist 'z :none) :none)) + (should (eq (cl-incf (cl-getf plist 'x 10) 2) 3)) + (should (equal plist '(x 3 y nil))) + (should-error (cl-incf (cl-getf plist 'y 10) 4) :type 'wrong-type-argument) + (should (equal plist '(x 3 y nil))) + (should (eq (cl-incf (cl-getf plist 'z 10) 5) 15)) + (should (equal plist '(z 15 x 3 y nil)))) + (let ((plist '(x 1 y))) + (should (eq (cl-getf plist 'x) 1)) + (should (eq (cl-getf plist 'y :none) :none)) + (should (eq (cl-getf plist 'z :none) :none)) + (should (eq (cl-incf (cl-getf plist 'x 10) 2) 3)) + (should (equal plist '(x 3 y))) + (should (eq (cl-incf (cl-getf plist 'y 10) 4) 14)) + (should (equal plist '(y 14 x 3 y)))) + (let ((plist '(x 1 y . 2))) + (should (eq (cl-getf plist 'x) 1)) + (should (eq (cl-incf (cl-getf plist 'x 10) 2) 3)) + (should (equal plist '(x 3 y . 2))) + (should-error (cl-getf plist 'y :none) :type 'wrong-type-argument) + (should-error (cl-getf plist 'z :none) :type 'wrong-type-argument))) (ert-deftest cl-extra-test-mapc () (let ((lst '(a b c)) diff --git a/test/lisp/emacs-lisp/gv-tests.el b/test/lisp/emacs-lisp/gv-tests.el index 0757e3c7aa..69a7bcf7dd 100644 --- a/test/lisp/emacs-lisp/gv-tests.el +++ b/test/lisp/emacs-lisp/gv-tests.el @@ -157,55 +157,42 @@ its getter (Bug#41853)." (push 123 (gv-setter-edebug-get 'gv-setter-edebug 'gv-setter-edebug-prop)))) (print form (current-buffer))) - ;; Only check whether evaluation works in general. - (eval-buffer))) + ;; Silence "Edebug: foo" messages. + (let ((inhibit-message t)) + ;; Only check whether evaluation works in general. + (eval-buffer)))) (should (equal (get 'gv-setter-edebug 'gv-setter-edebug-prop) '(123)))) (ert-deftest gv-plist-get () - (require 'cl-lib) - - ;; Simple setf usage for plist-get. - (should (equal (let ((target '(:a "a" :b "b" :c "c"))) - (setf (plist-get target :b) "modify") - target) - '(:a "a" :b "modify" :c "c"))) - - ;; Other function (cl-rotatef) usage for plist-get. - (should (equal (let ((target '(:a "a" :b "b" :c "c"))) - (cl-rotatef (plist-get target :b) (plist-get target :c)) - target) - '(:a "a" :b "c" :c "b"))) - - ;; Add new key value pair at top of list if setf for missing key. - (should (equal (let ((target '(:a "a" :b "b" :c "c"))) - (setf (plist-get target :d) "modify") - target) - '(:d "modify" :a "a" :b "b" :c "c"))) + ;; Simple `setf' usage for `plist-get'. + (let ((target (list :a "a" :b "b" :c "c"))) + (setf (plist-get target :b) "modify") + (should (equal target '(:a "a" :b "modify" :c "c"))) + (setf (plist-get target ":a" #'string=) "mogrify") + (should (equal target '(:a "mogrify" :b "modify" :c "c")))) + + ;; Other function (`cl-rotatef') usage for `plist-get'. + (let ((target (list :a "a" :b "b" :c "c"))) + (cl-rotatef (plist-get target :b) (plist-get target :c)) + (should (equal target '(:a "a" :b "c" :c "b"))) + (cl-rotatef (plist-get target ":a" #'string=) + (plist-get target ":b" #'string=)) + (should (equal target '(:a "c" :b "a" :c "b")))) + + ;; Add new key value pair at top of list if `setf' for missing key. + (let ((target (list :a "a" :b "b" :c "c"))) + (setf (plist-get target :d) "modify") + (should (equal target '(:d "modify" :a "a" :b "b" :c "c"))) + (setf (plist-get target :e #'string=) "mogrify") + (should (equal target '(:e "mogrify" :d "modify" :a "a" :b "b" :c "c")))) ;; Rotate with missing value. ;; The value corresponding to the missing key is assumed to be nil. - (should (equal (let ((target '(:a "a" :b "b" :c "c"))) - (cl-rotatef (plist-get target :b) (plist-get target :d)) - target) - '(:d "b" :a "a" :b nil :c "c"))) - - ;; Simple setf usage for plist-get. (symbol plist) - (should (equal (let ((target '(a "a" b "b" c "c"))) - (setf (plist-get target 'b) "modify") - target) - '(a "a" b "modify" c "c"))) - - ;; Other function (cl-rotatef) usage for plist-get. (symbol plist) - (should (equal (let ((target '(a "a" b "b" c "c"))) - (cl-rotatef (plist-get target 'b) (plist-get target 'c)) - target) - '(a "a" b "c" c "b")))) - -;; `ert-deftest' messes up macroexpansion when the test file itself is -;; compiled (see Bug #24402). - -;; Local Variables: -;; no-byte-compile: t -;; End: + (let ((target (list :a "a" :b "b" :c "c"))) + (cl-rotatef (plist-get target :b) (plist-get target :d)) + (should (equal target '(:d "b" :a "a" :b nil :c "c"))) + (cl-rotatef (plist-get target ":e" #'string=) + (plist-get target ":d" #'string=)) + (should (equal target '(":e" "b" :d nil :a "a" :b nil :c "c"))))) ;;; gv-tests.el ends here diff --git a/test/lisp/emacs-lisp/map-tests.el b/test/lisp/emacs-lisp/map-tests.el index 314a1c9e30..75ebe59431 100644 --- a/test/lisp/emacs-lisp/map-tests.el +++ b/test/lisp/emacs-lisp/map-tests.el @@ -29,10 +29,13 @@ (require 'ert) (require 'map) +(eval-when-compile + (require 'cl-lib)) + (defmacro with-maps-do (var &rest body) "Successively bind VAR to an alist, plist, vector, and hash-table. Each map is built from the following alist data: - \\='((0 . 3) (1 . 4) (2 . 5)). + ((0 . 3) (1 . 4) (2 . 5)) Evaluate BODY for each created map." (declare (indent 1) (debug (symbolp body))) (let ((alist (make-symbol "alist")) @@ -84,18 +87,96 @@ Evaluate BODY for each created map." (with-empty-maps-do map (should (= 5 (map-elt map 0 5))))) -(ert-deftest test-map-elt-testfn () +(ert-deftest test-map-elt-testfn-alist () + "Test the default alist predicate of `map-elt'." (let* ((a (string ?a)) (map `((,a . 0) (,(string ?b) . 1)))) - (should (= (map-elt map a) 0)) - (should (= (map-elt map "a") 0)) - (should (= (map-elt map (string ?a)) 0)) - (should (= (map-elt map "b") 1)) - (should (= (map-elt map (string ?b)) 1)))) + (should (= 0 (map-elt map a))) + (should (= 0 (map-elt map "a"))) + (should (= 0 (map-elt map (string ?a)))) + (should (= 1 (map-elt map "b"))) + (should (= 1 (map-elt map (string ?b)))) + (with-suppressed-warnings ((callargs map-elt)) + (should (= 0 (map-elt map 'a nil #'string=))) + (should (= 1 (map-elt map 'b nil #'string=)))))) + +(ert-deftest test-map-elt-testfn-plist () + "Test the default plist predicate of `map-elt'." + (let* ((a (string ?a)) + (map `(,a 0 "b" 1))) + (should-not (map-elt map "a")) + (should-not (map-elt map "b")) + (should-not (map-elt map (string ?a))) + (should-not (map-elt map (string ?b))) + (should (= 0 (map-elt map a))) + (with-suppressed-warnings ((callargs map-elt)) + (should (= 0 (map-elt map a nil #'equal))) + (should (= 0 (map-elt map "a" nil #'equal))) + (should (= 0 (map-elt map (string ?a) nil #'equal))) + (should (= 1 (map-elt map "b" nil #'equal))) + (should (= 1 (map-elt map (string ?b) nil #'equal)))))) + +(ert-deftest test-map-elt-gv () + "Test the generalized variable `map-elt'." + (let ((sort (lambda (map) (sort (map-pairs map) #'car-less-than-car)))) + (with-empty-maps-do map + ;; Empty map, without default. + (should-error (cl-incf (map-elt map 1)) :type 'wrong-type-argument) + (with-suppressed-warnings ((callargs map-elt)) + (should-error (cl-incf (map-elt map 1.0 nil #'=)) + :type 'wrong-type-argument)) + (should (map-empty-p map)) + ;; Empty map, with default. + (if (vectorp map) + (progn + (should-error (cl-incf (map-elt map 1 3)) :type 'args-out-of-range) + (with-suppressed-warnings ((callargs map-elt)) + (should-error (cl-incf (map-elt map 1 3 #'=)) + :type 'args-out-of-range)) + (should (map-empty-p map))) + (should (= (cl-incf (map-elt map 1 3) 10) 13)) + (with-suppressed-warnings ((callargs map-elt)) + (should (= (cl-incf (map-elt map 2.0 5 #'=) 12) 17))) + (should (equal (funcall sort map) '((1 . 13) (2.0 . 17)))))) + (with-maps-do map + ;; Nonempty map, without predicate. + (should (= (cl-incf (map-elt map 1 3) 10) 14)) + (should (equal (funcall sort map) '((0 . 3) (1 . 14) (2 . 5)))) + ;; Nonempty map, with predicate. + (with-suppressed-warnings ((callargs map-elt)) + (pcase-exhaustive map + ((pred consp) + (should (= (cl-incf (map-elt map 2.0 6 #'=) 12) 17)) + (should (equal (funcall sort map) '((0 . 3) (1 . 14) (2 . 17)))) + (should (= (cl-incf (map-elt map 0 7 #'=) 13) 16)) + (should (equal (funcall sort map) '((0 . 16) (1 . 14) (2 . 17))))) + ((pred vectorp) + (should-error (cl-incf (map-elt map 2.0 6 #'=)) + :type 'wrong-type-argument) + (should (equal (funcall sort map) '((0 . 3) (1 . 14) (2 . 5)))) + (should (= (cl-incf (map-elt map 2 6 #'=) 12) 17)) + (should (equal (funcall sort map) '((0 . 3) (1 . 14) (2 . 17)))) + (should (= (cl-incf (map-elt map 0 7 #'=) 13) 16)) + (should (equal (funcall sort map) '((0 . 16) (1 . 14) (2 . 17))))) + ((pred hash-table-p) + (should (= (cl-incf (map-elt map 2.0 6 #'=) 12) 18)) + (should (member (funcall sort map) + '(((0 . 3) (1 . 14) (2 . 5) (2.0 . 18)) + ((0 . 3) (1 . 14) (2.0 . 18) (2 . 5))))) + (should (= (cl-incf (map-elt map 0 7 #'=) 13) 16)) + (should (member (funcall sort map) + '(((0 . 16) (1 . 14) (2 . 5) (2.0 . 18)) + ((0 . 16) (1 . 14) (2.0 . 18) (2 . 5))))))))))) (ert-deftest test-map-elt-with-nil-value () (should-not (map-elt '((a . 1) (b)) 'b 2))) +(ert-deftest test-map-elt-signature () + "Test that `map-elt' has the right advertised signature. +See bug#58531#25 and bug#58563." + (should (equal (get-advertised-calling-convention (symbol-function 'map-elt)) + '(map key &optional default)))) + (ert-deftest test-map-put! () (with-maps-do map (setf (map-elt map 2) 'hello) @@ -144,6 +225,24 @@ Evaluate BODY for each created map." (should (equal map '(("a" . 1)))) (should-error (map-put! map (string ?a) val #'eq) :type 'map-not-inplace))) +(ert-deftest test-map-put!-plist () + "Test `map-put!' predicate on plists." + (let* ((a (string ?a)) + (map (list a 0))) + (map-put! map a -1) + (should (equal map '("a" -1))) + (map-put! map 'a 2) + (should (equal map '("a" -1 a 2))) + (with-suppressed-warnings ((callargs map-put!)) + (map-put! map 'a -3 #'string=)) + (should (equal map '("a" -3 a 2))))) + +(ert-deftest test-map-put!-signature () + "Test that `map-put!' has the right advertised signature. +See bug#58531#25 and bug#58563." + (should (equal (get-advertised-calling-convention (symbol-function 'map-put!)) + '(map key value)))) + (ert-deftest test-map-put-alist-new-key () "Regression test for Bug#23105." (let ((alist (list (cons 0 'a)))) @@ -395,13 +494,23 @@ Evaluate BODY for each created map." (alist '(("a" . 1) (a . 2)))) (should (map-contains-key alist 'a)) (should (map-contains-key plist 'a)) + ;; FIXME: Why is no warning emitted for these (bug#58563#13)? (should (map-contains-key alist 'a #'eq)) (should (map-contains-key plist 'a #'eq)) (should (map-contains-key alist key)) + (should (map-contains-key alist "a")) + (should (map-contains-key plist (string ?a) #'equal)) (should-not (map-contains-key plist key)) (should-not (map-contains-key alist key #'eq)) (should-not (map-contains-key plist key #'eq)))) +(ert-deftest test-map-contains-key-signature () + "Test that `map-contains-key' has the right advertised signature. +See bug#58531#25 and bug#58563." + (should (equal (get-advertised-calling-convention + (symbol-function 'map-contains-key)) + '(map key)))) + (ert-deftest test-map-some () (with-maps-do map (should (eq (map-some (lambda (k _v) (and (= k 1) 'found)) map) @@ -515,19 +624,19 @@ Evaluate BODY for each created map." (should (equal alist '((key . value)))))) (ert-deftest test-map-setf-alist-overwrite-key () - (let ((alist '((key . value1)))) + (let ((alist (list (cons 'key 'value1)))) (should (equal (setf (map-elt alist 'key) 'value2) 'value2)) (should (equal alist '((key . value2)))))) (ert-deftest test-map-setf-plist-insert-key () - (let ((plist '(key value))) + (let ((plist (list 'key 'value))) (should (equal (setf (map-elt plist 'key2) 'value2) 'value2)) (should (equal plist '(key value key2 value2))))) (ert-deftest test-map-setf-plist-overwrite-key () - (let ((plist '(key value))) + (let ((plist (list 'key 'value))) (should (equal (setf (map-elt plist 'key) 'value2) 'value2)) (should (equal plist '(key value2))))) @@ -535,14 +644,14 @@ Evaluate BODY for each created map." (ert-deftest test-hash-table-setf-insert-key () (let ((ht (make-hash-table))) (should (equal (setf (map-elt ht 'key) 'value) - 'value)) + 'value)) (should (equal (map-elt ht 'key) 'value)))) (ert-deftest test-hash-table-setf-overwrite-key () (let ((ht (make-hash-table))) (puthash 'key 'value1 ht) (should (equal (setf (map-elt ht 'key) 'value2) - 'value2)) + 'value2)) (should (equal (map-elt ht 'key) 'value2)))) (ert-deftest test-setf-map-with-function () @@ -551,8 +660,79 @@ Evaluate BODY for each created map." (setf (map-elt map 'foo) (funcall (lambda () (cl-incf num)))) + (should (equal map '((foo . 1)))) ;; Check that the function is only called once. (should (= num 1)))) +(ert-deftest test-map-plist-member () + "Test `map--plist-member' and `map--plist-member-1'." + (dolist (mem '(map--plist-member map--plist-member-1)) + ;; Lambda exercises Lisp implementation. + (dolist (= `(nil ,(lambda (a b) (eq a b)))) + (should-not (funcall mem () 'a =)) + (should-not (funcall mem '(a) 'b =)) + (should-not (funcall mem '(a 1) 'b =)) + (should (equal (funcall mem '(a) 'a =) '(a))) + (should (equal (funcall mem '(a . 1) 'a =) '(a . 1))) + (should (equal (funcall mem '(a 1 . b) 'a =) '(a 1 . b))) + (should (equal (funcall mem '(a 1 b) 'a =) '(a 1 b))) + (should (equal (funcall mem '(a 1 b) 'b =) '(b))) + (should (equal (funcall mem '(a 1 b . 2) 'a =) '(a 1 b . 2))) + (should (equal (funcall mem '(a 1 b . 2) 'b =) '(b . 2))) + (should (equal (funcall mem '(a 1 b 2) 'a =) '(a 1 b 2))) + (should (equal (funcall mem '(a 1 b 2) 'b =) '(b 2))) + (should (equal (should-error (funcall mem '(a . 1) 'b =)) + '(wrong-type-argument plistp (a . 1)))) + (should (equal (should-error (funcall mem '(a 1 . b) 'b =)) + '(wrong-type-argument plistp (a 1 . b))))) + (should (equal (funcall mem '(a 1 b 2) "a" #'string=) '(a 1 b 2))) + (should (equal (funcall mem '(a 1 b 2) "b" #'string=) '(b 2))))) + +(ert-deftest test-map-plist-put () + "Test `map--plist-put' and `map--plist-put-1'." + (dolist (put '(map--plist-put map--plist-put-1)) + ;; Lambda exercises Lisp implementation. + (dolist (= `(nil ,(lambda (a b) (eq a b)))) + (let ((l ())) + (should (equal (funcall put l 'a 1 =) '(a 1))) + (should-not l)) + (let ((l (list 'a))) + (dolist (key '(a b)) + (should (equal (should-error (funcall put l key 1 =)) + '(wrong-type-argument plistp (a))))) + (should (equal l '(a)))) + (let ((l (cons 'a 1))) + (dolist (key '(a b)) + (should (equal (should-error (funcall put l key 1 =)) + '(wrong-type-argument plistp (a . 1))))) + (should (equal l '(a . 1)))) + (let ((l (cons 'a (cons 1 'b)))) + (should (equal (funcall put l 'a 2 =) '(a 2 . b))) + (dolist (key '(b c)) + (should (equal (should-error (funcall put l key 3 =)) + '(wrong-type-argument plistp (a 2 . b))))) + (should (equal l '(a 2 . b)))) + (let ((l (list 'a 1 'b))) + (should (equal (funcall put l 'a 2 =) '(a 2 b))) + (dolist (key '(b c)) + (should (equal (should-error (funcall put l key 3 =)) + '(wrong-type-argument plistp (a 2 b))))) + (should (equal l '(a 2 b)))) + (let ((l (cons 'a (cons 1 (cons 'b 2))))) + (should (equal (funcall put l 'a 3 =) '(a 3 b . 2))) + (dolist (key '(b c)) + (should (equal (should-error (funcall put l key 4 =)) + '(wrong-type-argument plistp (a 3 b . 2))))) + (should (equal l '(a 3 b . 2)))) + (let ((l (list 'a 1 'b 2))) + (should (equal (funcall put l 'a 3 =) '(a 3 b 2))) + (should (equal (funcall put l 'b 4 =) '(a 3 b 4))) + (should (equal (funcall put l 'c 5 =) '(a 3 b 4 c 5))) + (should (equal l '(a 3 b 4 c 5))))) + (let ((l (list 'a 1 'b 2))) + (should (equal (funcall put l "a" 3 #'string=) '(a 3 b 2))) + (should (equal (funcall put l "b" 4 #'string=) '(a 3 b 4))) + (should (equal (funcall put l "c" 5 #'string=) '(a 3 b 4 "c" 5)))))) + (provide 'map-tests) ;;; map-tests.el ends here diff --git a/test/lisp/net/eudc-tests.el b/test/lisp/net/eudc-tests.el new file mode 100644 index 0000000000..219c250bf0 --- /dev/null +++ b/test/lisp/net/eudc-tests.el @@ -0,0 +1,155 @@ +;;; eudc-tests.el --- tests for eudc.el -*- lexical-binding: t -*- + +;; Copyright (C) 2022 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 'eudc) + +(ert-deftest eudc--plist-member () + "Test `eudc--plist-member' behavior." + (dolist (obj '(a (a . a) (a a . a))) + (should-error (eudc--plist-member obj nil) :type 'wrong-type-argument)) + (dolist (plist '((nil) (a) (a a a))) + (dolist (key '(nil a)) + (should (equal (should-error (eudc--plist-member plist key)) + '(error "Malformed plist"))))) + (let ((-nil (string ?n ?i ?l)) + (-a (string ?a))) + (should-not (eudc--plist-member () nil)) + (should-not (eudc--plist-member () 'a)) + (should-not (eudc--plist-member '(nil nil) 'a)) + (should-not (eudc--plist-member '(nil a) 'a)) + (should-not (eudc--plist-member '(a nil) nil)) + (should-not (eudc--plist-member '(a a) nil)) + (should-not (eudc--plist-member '("nil" a) nil)) + (should-not (eudc--plist-member '("nil" a) -nil)) + (should-not (eudc--plist-member '("a" a) nil)) + (should-not (eudc--plist-member '("a" a) -a)) + (should-not (eudc--plist-member '(nil a nil a) 'a)) + (should-not (eudc--plist-member '(nil a "a" a) -a)) + (should (equal (eudc--plist-member '(nil nil) nil) '(nil nil))) + (should (equal (eudc--plist-member '(nil a) nil) '(nil a))) + (should (equal (eudc--plist-member '(a nil) 'a) '(a nil))) + (should (equal (eudc--plist-member '(a a) 'a) '(a a))) + (should (equal (eudc--plist-member '(nil nil a nil) 'a) '(a nil))) + (should (equal (eudc--plist-member '(nil a a a) 'a) '(a a))) + (should (equal (eudc--plist-member '(a a a a) 'a) '(a a a a))))) + +(ert-deftest eudc-plist-member () + "Test `eudc-plist-member' behavior." + (dolist (obj '(a (a . a) (a a . a))) + (should-error (eudc-plist-member obj nil) :type 'wrong-type-argument)) + (dolist (plist '((nil) (a) (a a a))) + (dolist (key '(nil a)) + (should (equal (should-error (eudc-plist-member plist key)) + '(error "Malformed plist"))))) + (let ((-nil (string ?n ?i ?l)) + (-a (string ?a))) + (should-not (eudc-plist-member () nil)) + (should-not (eudc-plist-member () 'a)) + (should-not (eudc-plist-member '(nil nil) 'a)) + (should-not (eudc-plist-member '(nil a) 'a)) + (should-not (eudc-plist-member '(a nil) nil)) + (should-not (eudc-plist-member '(a a) nil)) + (should-not (eudc-plist-member '("nil" a) nil)) + (should-not (eudc-plist-member '("nil" a) -nil)) + (should-not (eudc-plist-member '("a" a) nil)) + (should-not (eudc-plist-member '("a" a) -a)) + (should-not (eudc-plist-member '(nil a nil a) 'a)) + (should-not (eudc-plist-member '(nil a "a" a) -a)) + (should (eq t (eudc-plist-member '(nil nil) nil))) + (should (eq t (eudc-plist-member '(nil a) nil))) + (should (eq t (eudc-plist-member '(a nil) 'a))) + (should (eq t (eudc-plist-member '(a a) 'a))) + (should (eq t (eudc-plist-member '(nil nil a nil) 'a))) + (should (eq t (eudc-plist-member '(nil a a a) 'a))) + (should (eq t (eudc-plist-member '(a a a a) 'a))))) + +(ert-deftest eudc-plist-get () + "Test `eudc-plist-get' behavior." + (dolist (obj '(a (a . a) (a a . a))) + (should-error (eudc-plist-get obj nil) :type 'wrong-type-argument)) + (dolist (plist '((nil) (a) (a a a))) + (dolist (key '(nil a)) + (should (equal (should-error (eudc-plist-get plist key)) + '(error "Malformed plist"))))) + (let ((-nil (string ?n ?i ?l)) + (-a (string ?a))) + (should-not (eudc-plist-get () nil)) + (should-not (eudc-plist-get () 'a)) + (should-not (eudc-plist-get '(nil nil) nil)) + (should-not (eudc-plist-get '(nil nil) 'a)) + (should-not (eudc-plist-get '(nil a) 'a)) + (should-not (eudc-plist-get '(a nil) nil)) + (should-not (eudc-plist-get '(a nil) 'a)) + (should-not (eudc-plist-get '(a a) nil)) + (should-not (eudc-plist-get '("nil" a) nil)) + (should-not (eudc-plist-get '("nil" a) -nil)) + (should-not (eudc-plist-get '("a" a) nil)) + (should-not (eudc-plist-get '("a" a) -a)) + (should-not (eudc-plist-get '(nil nil nil a) nil)) + (should-not (eudc-plist-get '(nil a nil a) 'a)) + (should-not (eudc-plist-get '(nil a "a" a) -a)) + (should-not (eudc-plist-get '(a nil a a) 'a)) + (should (eq 'a (eudc-plist-get '(nil a) nil))) + (should (eq 'a (eudc-plist-get '(a a) 'a))) + (should (eq 'a (eudc-plist-get '(a a a nil) 'a))) + (should (eq 'b (eudc-plist-get () nil 'b))) + (should (eq 'b (eudc-plist-get () 'a 'b))) + (should (eq 'b (eudc-plist-get '(nil a "a" a) -a 'b))) + (should (eq 'b (eudc-plist-get '(a nil "nil" nil) -nil 'b))))) + +(ert-deftest eudc-lax-plist-get () + "Test `eudc-lax-plist-get' behavior." + (dolist (obj '(a (a . a) (a a . a))) + (should-error (eudc-lax-plist-get obj nil) :type 'wrong-type-argument)) + (dolist (plist '((nil) (a) (a a a))) + (dolist (key '(nil a)) + (should (equal (should-error (eudc-lax-plist-get plist key)) + '(error "Malformed plist"))))) + (let ((-nil (string ?n ?i ?l)) + (-a (string ?a))) + (should-not (eudc-lax-plist-get () nil)) + (should-not (eudc-lax-plist-get () 'a)) + (should-not (eudc-lax-plist-get '(nil nil) nil)) + (should-not (eudc-lax-plist-get '(nil nil) 'a)) + (should-not (eudc-lax-plist-get '(nil a) 'a)) + (should-not (eudc-lax-plist-get '(a nil) nil)) + (should-not (eudc-lax-plist-get '(a nil) 'a)) + (should-not (eudc-lax-plist-get '(a a) nil)) + (should-not (eudc-lax-plist-get '("nil" a) nil)) + (should-not (eudc-lax-plist-get '("nil" a) 'a)) + (should-not (eudc-lax-plist-get '("a" a) nil)) + (should-not (eudc-lax-plist-get '("a" a) 'a)) + (should-not (eudc-lax-plist-get '(nil nil nil a) nil)) + (should-not (eudc-lax-plist-get '(nil a nil a) 'a)) + (should-not (eudc-lax-plist-get '(nil a "a" a) 'a)) + (should-not (eudc-lax-plist-get '(a nil a a) 'a)) + (should (eq 'a (eudc-lax-plist-get '(nil a) nil))) + (should (eq 'a (eudc-lax-plist-get '(a a) 'a))) + (should (eq 'a (eudc-lax-plist-get '(a a a nil) 'a))) + (should (eq 'b (eudc-lax-plist-get () nil 'b))) + (should (eq 'b (eudc-lax-plist-get () 'a 'b))) + (should (eq 'a (eudc-lax-plist-get '("nil" a) -nil))) + (should (eq 'a (eudc-lax-plist-get '("a" a) -a))) + (should (eq 'a (eudc-lax-plist-get '(nil a "a" a) -a))) + (should (eq 'b (eudc-lax-plist-get '(nil a "a" a) 'a 'b))) + (should (eq 'b (eudc-lax-plist-get '(a nil "nil" nil) nil 'b))))) + +;;; eudc-tests.el ends here diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el index 347981e818..cc9610cd39 100644 --- a/test/lisp/subr-tests.el +++ b/test/lisp/subr-tests.el @@ -1139,7 +1139,10 @@ final or penultimate step during initialization.")) (should-not (plistp '(1 . 2))) (should (plistp '(1 2 3 4))) (should-not (plistp '(1 2 3))) - (should-not (plistp '(1 2 3 . 4)))) + (should-not (plistp '(1 2 3 . 4))) + (let ((cycle (list 1 2 3))) + (nconc cycle cycle) + (should-not (plistp cycle)))) (defun subr-tests--butlast-ref (list &optional n) "Reference implementation of `butlast'." diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el index fde5af38fc..7568d941d0 100644 --- a/test/src/fns-tests.el +++ b/test/src/fns-tests.el @@ -857,6 +857,14 @@ (should-error (reverse (dot1 1)) :type 'wrong-type-argument) (should-error (reverse (dot2 1 2)) :type 'wrong-type-argument)) +(ert-deftest test-cycle-equal () + (should-error (equal (cyc1 1) (cyc1 1))) + (should-error (equal (cyc2 1 2) (cyc2 1 2)))) + +(ert-deftest test-cycle-nconc () + (should-error (nconc (cyc1 1) 'tail) :type 'circular-list) + (should-error (nconc (cyc2 1 2) 'tail) :type 'circular-list)) + (ert-deftest test-cycle-plist-get () (let ((c1 (cyc1 1)) (c2 (cyc2 1 2)) @@ -911,30 +919,47 @@ (should-error (plist-put d1 3 3) :type 'wrong-type-argument) (should-error (plist-put d2 3 3) :type 'wrong-type-argument))) -(ert-deftest test-cycle-equal () - (should-error (equal (cyc1 1) (cyc1 1))) - (should-error (equal (cyc2 1 2) (cyc2 1 2)))) - -(ert-deftest test-cycle-nconc () - (should-error (nconc (cyc1 1) 'tail) :type 'circular-list) - (should-error (nconc (cyc2 1 2) 'tail) :type 'circular-list)) - (ert-deftest plist-get/odd-number-of-elements () "Test that `plist-get' doesn't signal an error on degenerate plists." (should-not (plist-get '(:foo 1 :bar) :bar))) (ert-deftest plist-put/odd-number-of-elements () - "Check for https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27726." - (should (equal (should-error (plist-put '(:foo 1 :bar) :zot 2) - :type 'wrong-type-argument) + "Check for bug#27726." + (should (equal (should-error (plist-put (list :foo 1 :bar) :zot 2)) '(wrong-type-argument plistp (:foo 1 :bar))))) (ert-deftest plist-member/improper-list () - "Check for https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27726." - (should (equal (should-error (plist-member '(:foo 1 . :bar) :qux) - :type 'wrong-type-argument) + "Check for bug#27726." + (should (equal (should-error (plist-member '(:foo 1 . :bar) :qux)) '(wrong-type-argument plistp (:foo 1 . :bar))))) +(ert-deftest test-plist () + (let ((plist (list :a "b"))) + (setq plist (plist-put plist :b "c")) + (should (equal (plist-get plist :b) "c")) + (should (equal (plist-member plist :b) '(:b "c")))) + + (let ((plist (list "1" "2" "a" "b"))) + (setq plist (plist-put plist (string ?a) "c")) + (should (equal plist '("1" "2" "a" "b" "a" "c"))) + (should-not (plist-get plist (string ?a))) + (should-not (plist-member plist (string ?a)))) + + (let ((plist (list "1" "2" "a" "b"))) + (setq plist (plist-put plist (string ?a) "c" #'equal)) + (should (equal plist '("1" "2" "a" "c"))) + (should (equal (plist-get plist (string ?a) #'equal) "c")) + (should (equal (plist-member plist (string ?a) #'equal) '("a" "c")))) + + (let ((plist (list :a 1 :b 2 :c 3))) + (setq plist (plist-put plist ":a" 4 #'string>)) + (should (equal plist '(:a 1 :b 4 :c 3))) + (should (equal (plist-get plist ":b" #'string>) 3)) + (should (equal (plist-member plist ":c" #'string<) plist)) + (dolist (fn '(plist-get plist-member)) + (should-not (funcall fn plist ":a" #'string<)) + (should-not (funcall fn plist ":c" #'string>))))) + (ert-deftest test-string-distance () "Test `string-distance' behavior." ;; ASCII characters are always fine @@ -1350,23 +1375,6 @@ (should-error (append loop '(end)) :type 'circular-list))) -(ert-deftest test-plist () - (let ((plist '(:a "b"))) - (setq plist (plist-put plist :b "c")) - (should (equal (plist-get plist :b) "c")) - (should (equal (plist-member plist :b) '(:b "c")))) - - (let ((plist '("1" "2" "a" "b"))) - (setq plist (plist-put plist (copy-sequence "a") "c")) - (should-not (equal (plist-get plist (copy-sequence "a")) "c")) - (should-not (equal (plist-member plist (copy-sequence "a")) '("a" "c")))) - - (let ((plist '("1" "2" "a" "b"))) - (setq plist (plist-put plist (copy-sequence "a") "c" #'equal)) - (should (equal (plist-get plist (copy-sequence "a") #'equal) "c")) - (should (equal (plist-member plist (copy-sequence "a") #'equal) - '("a" "c"))))) - (ert-deftest fns--string-to-unibyte-multibyte () (dolist (str (list "" "a" "abc" "a\x00\x7fz" "a\xaa\xbbz" "\x80\xdd\xff" (apply #'unibyte-string (number-sequence 0 255)))) commit f85bdb49923a60d3d0cc3bf66ad884555d92840c Author: Po Lu Date: Sat Oct 22 20:15:22 2022 +0800 Further fixes to menu event processing on no-toolkit builds * src/xdisp.c (note_mouse_highlight): Return if a popup is activated under the no-toolkit build as well. * src/xmenu.c (pop_down_menu): Clear popup_activated_flag when not on MS-DOS. (x_menu_show): Set popup_activated_flag under X. diff --git a/src/xdisp.c b/src/xdisp.c index e390de6a33..1f7ac269e4 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -34912,7 +34912,7 @@ note_mouse_highlight (struct frame *f, int x, int y) struct buffer *b; /* When a menu is active, don't highlight because this looks odd. */ -#if defined (USE_X_TOOLKIT) || (defined (USE_GTK) && !defined (HAVE_PGTK)) || defined (HAVE_NS) || defined (MSDOS) +#if defined (HAVE_X_WINDOWS) || defined (HAVE_NS) || defined (MSDOS) if (popup_activated ()) return; #endif diff --git a/src/xmenu.c b/src/xmenu.c index d9660a6910..756842c2fe 100644 --- a/src/xmenu.c +++ b/src/xmenu.c @@ -2540,6 +2540,8 @@ pop_down_menu (void *arg) } #endif + /* Decrement the popup_activated_flag. */ + popup_activated_flag = 0; #endif /* HAVE_X_WINDOWS */ unblock_input (); @@ -2791,6 +2793,12 @@ x_menu_show (struct frame *f, int x, int y, int menuflags, } #endif +#ifdef HAVE_X_WINDOWS + /* Increment the popup flag; this prevents nested popups from being + displayed by user Lisp code in help-echo callbacks, and also + prevents mouse face from being displayed. */ + popup_activated_flag = 1; +#endif status = XMenuActivate (FRAME_X_DISPLAY (f), menu, &pane, &selidx, x, y, ButtonReleaseMask, &datap, menu_help_callback); commit 636322cfe06daef07d8fe8a7650fbe27370aea22 Author: Stefan Kangas Date: Sat Oct 22 12:15:49 2022 +0200 * admin/notes/repo: Document feature and scratch branches. diff --git a/admin/notes/repo b/admin/notes/repo index c2d7f993a0..2185c5a003 100644 --- a/admin/notes/repo +++ b/admin/notes/repo @@ -42,6 +42,24 @@ yet another fun excursion into the exciting world of version control. https://lists.gnu.org/r/emacs-devel/2010-04/msg00086.html +* feature and scratch branches + +Besides the master branch, which is where development takes place, and +the "emacs-NN" release branches, we also have branches whose names +start with "scratch/" and "feature/". The "feature/" prefix is used +for feature branches that are intended to live for some time, while +"scratch/" is for one-off throw-away-after-use branches. + +We do not intend to "git merge" from scratch branches, so force-pushes +are tolerated, as well as commits with poor style, incomplete commit +messages, etc. + +We do expect to "git merge" from feature branches so: no force push, +and no commits that don't have a proper commit message. + +Automatic tests are run for feature/* branches on EMBA. +See: https://emba.gnu.org/emacs/emacs/-/pipelines + * Installing changes from gnulib Some of the files in Emacs are copied from gnulib. To synchronize commit f1f4a0c9d2b91c47eb31f419f6376a820526bf6a (refs/remotes/origin/emacs-28) Author: Matt Armstrong Date: Thu Oct 20 20:56:03 2022 -0700 ; * doc/lispref/display.texi (Progress): Correct typo. (Bug#58674) diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index 3861f89036..ac3179e2ce 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -544,7 +544,7 @@ previous example as follows: @end example @end defmac -@defmac dolist-with-progress-reporter (var count [result]) reporter-or-message body@dots{} +@defmac dolist-with-progress-reporter (var list [result]) reporter-or-message body@dots{} This is another convenience macro that works the same way as @code{dolist} does, but also reports loop progress using the functions described above. As in @code{dotimes-with-progress-reporter}, commit ee9a9fbf0fff9031cf8eb544f5670906ef3c7bb2 Author: Harald Jörg Date: Wed Nov 3 15:04:10 2021 +0100 ; cperl-mode.el: Fix one match-count in my commit 2021-09-14 * lisp/progmodes/cperl-mode.el (cperl-init-faces): Matching group needs to be adjusted according to the regexp change in my previous commit (cherry picked from commit a25e91593d48a541b5940a2ed707ddfaef5c953f) diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el index eaedf987c5..7d121cbf94 100644 --- a/lisp/progmodes/cperl-mode.el +++ b/lisp/progmodes/cperl-mode.el @@ -5946,7 +5946,7 @@ default function." (eval cperl--basic-identifier-rx))) (0+ blank) "(") ;; '("\\ Date: Thu Oct 20 08:59:18 2022 +0300 ; Remove reference to non-existent Flymake function from manual * doc/emacs/building.texi (Flymake): Replace reference to a delete command 'flymake-display-err-menu-for-current-line' with existing equivalents. (Bug#58649) diff --git a/doc/emacs/building.texi b/doc/emacs/building.texi index 5b68b1ef9f..be5f27eff3 100644 --- a/doc/emacs/building.texi +++ b/doc/emacs/building.texi @@ -514,10 +514,13 @@ C/C++ files this is usually the C compiler. Flymake can also use build tools such as @code{make} for checking complicated projects. To enable Flymake mode, type @kbd{M-x flymake-mode}. You can jump -to the errors that it finds by using @kbd{M-x flymake-goto-next-error} -and @kbd{M-x flymake-goto-prev-error}. To display any error messages -associated with the current line, type @kbd{M-x -flymake-display-err-menu-for-current-line}. +to the errors that it finds by using @w{@kbd{M-x +flymake-goto-next-error}} and @w{@kbd{M-x flymake-goto-prev-error}}. +To display a detailed overview of the diagnostics for the current +buffer, use the command @w{@kbd{M-x flymake-show-buffer-diagnostics}}; +to display a similar overview of diagnostics for the entire project +(@pxref{Projects}), use @w{@kbd{M-x +flymake-show-project-diagnostics}}. For more details about using Flymake, @ifnottex