From unknown Sat Aug 16 16:13:40 2025 X-Loop: help-debbugs@gnu.org Subject: bug#58531: 29.0.50; Wrong predicate used by map-elt gv getter Resent-From: "Basil L. Contovounesios" Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Fri, 14 Oct 2022 21:46:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: report 58531 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: To: 58531@debbugs.gnu.org X-Debbugs-Original-To: bug-gnu-emacs@gnu.org Received: via spool by submit@debbugs.gnu.org id=B.16657839183093 (code B ref -1); Fri, 14 Oct 2022 21:46:02 +0000 Received: (at submit) by debbugs.gnu.org; 14 Oct 2022 21:45:18 +0000 Received: from localhost ([127.0.0.1]:38853 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ojSUX-0000np-Dt for submit@debbugs.gnu.org; Fri, 14 Oct 2022 17:45:17 -0400 Received: from lists.gnu.org ([209.51.188.17]:44046) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ojSUV-0000nh-3L for submit@debbugs.gnu.org; Fri, 14 Oct 2022 17:45:15 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:42280) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1ojSUT-0003px-Q8 for bug-gnu-emacs@gnu.org; Fri, 14 Oct 2022 17:45:14 -0400 Received: from mail-ej1-x636.google.com ([2a00:1450:4864:20::636]:39690) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1ojSUQ-00013w-KE for bug-gnu-emacs@gnu.org; Fri, 14 Oct 2022 17:45:13 -0400 Received: by mail-ej1-x636.google.com with SMTP id b2so13183139eja.6 for ; Fri, 14 Oct 2022 14:45:06 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=tcd.ie; s=google21; h=mime-version:message-id:date:subject:to:from:from:to:cc:subject :date:message-id:reply-to; bh=s2i9MZkYujSsLiD1jtDVUcJ/1XL4Q2191lRpRr3sENI=; b=XW4EpWVer6wW1kxT9BMaJykw8kwVjh3Aqc7uBmu2dtiKhLfFVEOUk9nS0yb9UKcb4f 7Rlh4wl+NYLcTb4vBPC/NnPj0ydL3mrKb309xyo+pc2moXR/ykBS0fV7yk9mhPc+CHMP 2s3w3TQshieStL0htjhLf/tLWWp/S5MAkP8QI9e1dAyJJ5HAfDUha5BehaPNnfoZceWh /vnzguxeDz5HTcyJaqT+VEXjHHHVMc3DjmoTFt/yQ3rMsa7oKMgzfrAHqghX4AJJzWVM wp4CGk3O3AL+oEkHFPTylcvPGU7YrxdLBIAi+YmJkhYN8PvEtALZ9JG1KPzTe/vhnWCh +p9g== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=mime-version:message-id:date:subject:to:from:x-gm-message-state :from:to:cc:subject:date:message-id:reply-to; bh=s2i9MZkYujSsLiD1jtDVUcJ/1XL4Q2191lRpRr3sENI=; b=uSgkdvzLIPeU0waR9CQlffNGVqA0GAqljHjRKMyON5X1MkSxWMFQZeCVWjdSfYBSsD +TvOv1Txf2V/OIwgG7deKkga2nfWQW+Upy7/Gd/qdePosGzA4LTQ2zLFlnjMm9s04fIF qO2QRERV3Tr14VDhuHaC1e/tjObogWOLHtSEoYwpHODzxizJbCqf3HmHqQdiva+sMEJq TMmssKeuJKcw1YynHeoJyivEXOmsVc8ssaTvS26bD1ZwLOSSH2Cqrg4bfcHCeR6XfeUq 4luY/8VBPm5bseofcp/TdgYG9w1k+rCJonm0r2YLeZIXL2YpMPJw4c0ki5TXOaXhWexw h9rw== X-Gm-Message-State: ACrzQf1V01Jh063a1nmfab8BnzDVfF3TDqARVLuCHdMp0JTmVCINc/kO O+3NXUDLSmYEF6Gyq5hKlx/RFnoWIgeE5g== X-Google-Smtp-Source: AMsMyM7LvDV6Swwlc2OGsZA5eYz1GY3p4/ilEIE7DMXnmmySg7YF9Ytw11xU0XFbOOGfyZQmaOZqKg== X-Received: by 2002:a17:907:6088:b0:78d:8e24:40d0 with SMTP id ht8-20020a170907608800b0078d8e2440d0mr7391ejc.590.1665783904893; Fri, 14 Oct 2022 14:45:04 -0700 (PDT) Received: from localhost ([2a02:587:321f:7e8a:d9:365a:ced1:b3d1]) by smtp.gmail.com with ESMTPSA id u18-20020a170906951200b0072ed9efc9dfsm2136927ejx.48.2022.10.14.14.45.03 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Fri, 14 Oct 2022 14:45:03 -0700 (PDT) From: "Basil L. Contovounesios" Date: Sat, 15 Oct 2022 00:45:02 +0300 Message-ID: <87r0zaxeox.fsf@tcd.ie> MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Received-SPF: pass client-ip=2a00:1450:4864:20::636; envelope-from=contovob@tcd.ie; helo=mail-ej1-x636.google.com X-Spam_score_int: -20 X-Spam_score: -2.1 X-Spam_bar: -- X-Spam_report: (-2.1 / 5.0 requ) BAYES_00=-1.9, DKIM_SIGNED=0.1, DKIM_VALID=-0.1, DKIM_VALID_AU=-0.1, DKIM_VALID_EF=-0.1, RCVD_IN_DNSWL_NONE=-0.0001, SPF_HELO_NONE=0.001, SPF_PASS=-0.001 autolearn=ham autolearn_force=no X-Spam_action: no action X-Spam-Score: -1.4 (-) X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -2.4 (--) --=-=-= Content-Type: text/plain 0. emacs -Q 1. M-x load-library RET map RET 2. (let ((l (list (cons 'a 1)))) (setf (map-elt l "a" nil #'string=) 2) l) C-j This correctly gives ((a . 2)). 3. (let ((l (list (cons 'a 1)))) (cl-incf (map-elt l "a" nil #'string=)) l) C-j This gives the following backtrace: --=-=-= Content-Type: text/plain Content-Disposition: inline; filename=backtrace.txt Debugger entered--Lisp error: (wrong-type-argument number-or-marker-p nil) +(nil 1) (let* ((v (+ (map-elt l "a" nil) 1))) (condition-case nil (with-no-warnings (map-put! l "a" v #'string=)) (map-not-inplace (setq l (map-insert l "a" v)) v))) (let ((l (list (cons 'a 1)))) (let* ((v (+ (map-elt l "a" nil) 1))) (condition-case nil (with-no-warnings (map-put! l "a" v #'string=)) (map-not-inplace (setq l (map-insert l "a" v)) v))) l) (progn (let ((l (list (cons 'a 1)))) (let* ((v (+ (map-elt l "a" nil) 1))) (condition-case nil (with-no-warnings (map-put! l "a" v #'string=)) (map-not-inplace (setq l (map-insert l "a" v)) v))) l)) eval((progn (let ((l (list (cons 'a 1)))) (let* ((v (+ (map-elt l "a" nil) 1))) (condition-case nil (with-no-warnings (map-put! l "a" v #'string=)) (map-not-inplace (setq l (map-insert l "a" v)) v))) l)) t) elisp--eval-last-sexp(t) eval-last-sexp(t) eval-print-last-sexp(nil) funcall-interactively(eval-print-last-sexp nil) call-interactively(eval-print-last-sexp nil nil) command-execute(eval-print-last-sexp) --=-=-= Content-Type: text/plain Whereas it should give the same result as step 2. Patch to follow. Thanks, -- Basil In GNU Emacs 29.0.50 (build 1, x86_64-pc-linux-gnu, X toolkit, cairo version 1.16.0, Xaw3d scroll bars) of 2022-10-14 built on tia Repository revision: cbd04ad3d572850775f18bde868c71abcde733ed Repository branch: master Windowing system distributor 'The X.Org Foundation', version 11.0.12101004 System Description: Debian GNU/Linux bookworm/sid Configured using: 'configure 'CFLAGS=-Og -ggdb3' -C --prefix=/home/blc/.local --enable-checking=structs --with-file-notification=yes --with-x-toolkit=lucid --with-x' Configured features: ACL CAIRO DBUS FREETYPE GIF GLIB GMP GNUTLS GPM GSETTINGS HARFBUZZ JPEG JSON LCMS2 LIBOTF LIBSELINUX LIBSYSTEMD LIBXML2 M17N_FLT MODULES NOTIFY INOTIFY PDUMPER PNG RSVG SECCOMP SOUND SQLITE3 THREADS TIFF TOOLKIT_SCROLL_BARS WEBP X11 XAW3D XDBE XIM XINPUT2 XPM LUCID ZLIB Important settings: value of $LANG: en_IE.UTF-8 value of $XMODIFIERS: @im=ibus locale-coding-system: utf-8-unix Major mode: Debugger Minor modes in effect: tooltip-mode: t global-eldoc-mode: t show-paren-mode: t electric-indent-mode: t mouse-wheel-mode: t tool-bar-mode: t menu-bar-mode: t file-name-shadow-mode: t global-font-lock-mode: t font-lock-mode: t blink-cursor-mode: t buffer-read-only: t line-number-mode: t indent-tabs-mode: t transient-mark-mode: t auto-composition-mode: t auto-encryption-mode: t auto-compression-mode: t Load-path shadows: None found. Features: (shadow sort mail-extr emacsbug message mailcap yank-media puny dired dired-loaddefs rfc822 mml mml-sec password-cache epa derived epg rfc6068 epg-config gnus-util text-property-search time-date subr-x mm-decode mm-bodies mm-encode mail-parse rfc2231 mailabbrev gmm-utils mailheader sendmail rfc2047 rfc2045 ietf-drums mm-util mail-prsvr mail-utils help-fns radix-tree cl-print debug backtrace help-mode cl-macs map byte-opt gv bytecomp byte-compile cconv thingatpt cl-loaddefs cl-lib find-func rmc iso-transl tooltip eldoc paren electric uniquify ediff-hook vc-hooks lisp-float-type elisp-mode mwheel term/x-win x-win term/common-win x-dnd tool-bar dnd fontset image regexp-opt fringe tabulated-list replace newcomment text-mode lisp-mode prog-mode register page tab-bar menu-bar rfn-eshadow isearch easymenu timer select scroll-bar mouse jit-lock font-lock syntax font-core term/tty-colors frame minibuffer nadvice seq simple cl-generic indonesian philippine cham georgian utf-8-lang misc-lang vietnamese tibetan thai tai-viet lao korean japanese eucjp-ms cp51932 hebrew greek romanian slovak czech european ethiopic indian cyrillic chinese composite emoji-zwj charscript charprop case-table epa-hook jka-cmpr-hook help abbrev obarray oclosure cl-preloaded button loaddefs faces cus-face macroexp files window text-properties overlay sha1 md5 base64 format env code-pages mule custom widget keymap hashtable-print-readable backquote threads dbusbind inotify lcms2 dynamic-setting system-font-setting font-render-setting cairo x-toolkit xinput2 x multi-tty make-network-process emacs) Memory information: ((conses 16 51573 5638) (symbols 48 6489 0) (strings 32 18774 1872) (string-bytes 1 537756) (vectors 16 12706) (vector-slots 8 181823 10539) (floats 8 29 46) (intervals 56 370 2) (buffers 1000 11)) --=-=-=-- From unknown Sat Aug 16 16:13:40 2025 X-Loop: help-debbugs@gnu.org Subject: bug#58531: 29.0.50; Wrong predicate used by map-elt gv getter Resent-From: "Basil L. Contovounesios" Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Fri, 14 Oct 2022 21:55:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 58531 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: To: 58531@debbugs.gnu.org Received: via spool by 58531-submit@debbugs.gnu.org id=B58531.16657844774181 (code B ref 58531); Fri, 14 Oct 2022 21:55:02 +0000 Received: (at 58531) by debbugs.gnu.org; 14 Oct 2022 21:54:37 +0000 Received: from localhost ([127.0.0.1]:38872 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ojSdW-00015E-8u for submit@debbugs.gnu.org; Fri, 14 Oct 2022 17:54:36 -0400 Received: from mail-ej1-f43.google.com ([209.85.218.43]:38792) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ojSdO-00014i-RK for 58531@debbugs.gnu.org; Fri, 14 Oct 2022 17:54:29 -0400 Received: by mail-ej1-f43.google.com with SMTP id fy4so13223511ejc.5 for <58531@debbugs.gnu.org>; Fri, 14 Oct 2022 14:54:26 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=tcd.ie; s=google21; h=mime-version:user-agent:message-id:date:references:in-reply-to :subject:to:from:from:to:cc:subject:date:message-id:reply-to; bh=Gd+nAULpW+bfEB0ylPo0AS/Mir+aRglfAt6koijxS3I=; b=CQB5Y9UCvxQalB9lMmydDIY3+lUyHE1SSjMX2hiRQhl4YKvmWG6ydKpJOV9qc+4U2J qhPlIsn6q60n51XCaOMxLt0DIMx9yE3CJwKHfHBcjb5XrsmxD1YGGk7jINxfNO5+L27O a8nd9aWAd0gLT1/tJ6MfAL/1i38xE+KI7lnW8Y9VCZs7SYiFg1aRz/IWqXEaEdZLGq81 V3/anwscbdjFSFWFrwRTTIID0HfLR1QHUex7t+BprvfAwqhJMukB9GKudDGluf9JtMqi +9tej5ySRJh6TWx6HukgL7d2qOD0Frdca40MZJ/7506mQH3PzpuIrrI+H5NtCu3l+0CL n6EA== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=mime-version:user-agent:message-id:date:references:in-reply-to :subject:to:from:x-gm-message-state:from:to:cc:subject:date :message-id:reply-to; bh=Gd+nAULpW+bfEB0ylPo0AS/Mir+aRglfAt6koijxS3I=; b=m1OTrD1+aGe6D2YQq0vGlqL7EvT1hHboIWK8npAtqJXrbEblZ3LGZ9ZiKE9zT8oJu1 NsJ/cBKvK3gTlnK+ltm+PUksEJaPsYYMgRbB9DuiBrs5Dii/jZ2Yskj0dBHX/cszQd7s Bb/CPl3jTwyPvYk/hH/MMf4pgMyt5DFYCwT8l2iga/ErENkZewA8xWgSvWiEW+k+lhUt OvMOWN4OYdxb2Tx7V9wXZGfeFniPRBZrQEjri3P0uG4KZyrNymT64FNKcGnAF2vJ3EPD vBqMNVrY/uLezJDD5+EzXNjYqLItoCkYg6CTXrpgl40uNxSK+Sf+EPJse9Ca25LlBo5Y 17XQ== X-Gm-Message-State: ACrzQf050ptkzt0IlYSXyswZ5oWzV24uTzsuRM3kBBPzGW7ljMfhDLfG 6DfXhrS7AAqzdQggwJ1KsKrT/Ph3NPMdFg== X-Google-Smtp-Source: AMsMyM7GFDs7vaHw00IKVvJgZZ1RdPZzdWEglEPfIazObknXisHSXV4YAO/eUZJYTu/lztWfx19SCQ== X-Received: by 2002:a17:906:2699:b0:781:a473:9791 with SMTP id t25-20020a170906269900b00781a4739791mr26840ejc.644.1665784460873; Fri, 14 Oct 2022 14:54:20 -0700 (PDT) Received: from localhost ([2a02:587:321f:7e8a:d9:365a:ced1:b3d1]) by smtp.gmail.com with ESMTPSA id gw22-20020a170906f15600b0073d7ab84375sm2150688ejb.92.2022.10.14.14.54.19 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Fri, 14 Oct 2022 14:54:20 -0700 (PDT) From: "Basil L. Contovounesios" In-Reply-To: <87r0zaxeox.fsf@tcd.ie> (Basil L. Contovounesios" via "Bug reports for GNU Emacs, the Swiss army knife of text editors's message of "Sat, 15 Oct 2022 00:45:02 +0300") References: <87r0zaxeox.fsf@tcd.ie> Date: Sat, 15 Oct 2022 00:54:18 +0300 Message-ID: <874jw6xe9h.fsf@tcd.ie> User-Agent: Gnus/5.13 (Gnus v5.13) MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Spam-Score: -0.0 (/) X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) --=-=-= Content-Type: text/plain tags 58531 + patch quit Basil L. Contovounesios" via "Bug reports for GNU Emacs, the Swiss army knife of text editors [2022-10-15 00:45 +0300] wrote: > Patch to follow. Now attached. In addition to the OP, the patch also addresses: - The plist-get gv, as discussed in https://bugs.gnu.org/47425#91 - The gv-tests.el no-byte-compile cookie from https://bugs.gnu.org/24402 - The predicate in plist-get & co. being called with flipped arguments compared to assoc & alist-get WDYT? Thanks, -- Basil --=-=-= Content-Type: text/x-diff Content-Disposition: attachment; filename=0001-Audit-some-plist-uses-with-new-predicate-argument.patch >From e3d6fe61e0a72af0f93b9434f20c1fa345cfb981 Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Sat, 20 Aug 2022 16:32:33 +0300 Subject: [PATCH] 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--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. Use predicate when given a plist. (map-put): Avoid gratuitous warnings when called without the hidden predicate argument. Improve obsoletion message. (map-contains-key, map-put!): Use predicate when given a plist. * 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-put!-plist) (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. --- doc/lispref/lists.texi | 8 +- lisp/emacs-lisp/cl-extra.el | 4 +- lisp/emacs-lisp/gv.el | 7 +- lisp/emacs-lisp/map.el | 71 ++++++++-- lisp/files-x.el | 11 +- lisp/net/eudc.el | 62 ++++----- src/fns.c | 97 +++++++------ test/lisp/apropos-tests.el | 17 +-- test/lisp/emacs-lisp/cl-extra-tests.el | 24 +++- test/lisp/emacs-lisp/gv-tests.el | 71 ++++------ test/lisp/emacs-lisp/map-tests.el | 184 +++++++++++++++++++++++-- test/lisp/net/eudc-tests.el | 155 +++++++++++++++++++++ test/lisp/subr-tests.el | 5 +- test/src/fns-tests.el | 70 +++++----- 14 files changed, 588 insertions(+), 198 deletions(-) create mode 100644 test/lisp/net/eudc-tests.el 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 @@ Plist Access @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 @@ Plist Access @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 @@ Plist Access @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 @@ cl-getf ,(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 @@ alist-get ,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..851588bc00 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. @@ -100,16 +100,64 @@ map-let (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, @@ -121,7 +169,8 @@ map-elt (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 @@ -138,7 +187,7 @@ map-elt ;; Can't use `cl-defmethod' with `advertised-calling-convention'. (map--dispatch map :list (if (map--plist-p map) - (let ((res (plist-member map key))) + (let ((res (map--plist-member map key testfn))) (if res (cadr res) default)) (alist-get key map default nil (or testfn #'equal))) :hash-table (gethash key map default) @@ -154,8 +203,12 @@ map-put 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) @@ -346,7 +399,7 @@ map-contains-key If MAP is an alist, TESTFN defaults to `equal'. If MAP is a plist, `plist-member' is used instead." (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))))))) @@ -466,7 +519,7 @@ map-put! :list (progn (if (map--plist-p map) - (plist-put map key value) + (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) diff --git a/lisp/files-x.el b/lisp/files-x.el index f6d5d6cc27..ffc8b2f717 100644 --- a/lisp/files-x.el +++ b/lisp/files-x.el @@ -621,13 +621,10 @@ connection-local-criteria-alist (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 @@ eudc--using-bbdb-3-or-newer-p ;; 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 @@ DEFUN ("plist-get", Fplist_get, Splist_get, 2, 3, 0, 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 @@ DEFUN ("plist-get", Fplist_get, Splist_get, 2, 3, 0, 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 @@ DEFUN ("plist-put", Fplist_put, Splist_put, 3, 4, 0, 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 @@ DEFUN ("plist-put", Fplist_put, Splist_put, 3, 4, 0, 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 @@ DEFUN ("put", Fput, Sput, 3, 3, 0, (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 @@ DEFUN ("require", Frequire, Srequire, 1, 3, 0, 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 @@ apropos-tests-true-hit (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 @@ cl-get (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 @@ gv-setter-edebug (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'. + (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")))) - ;; 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'. + (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")))) - ;; 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"))) + ;; 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..290f99dd5b 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,14 +87,86 @@ test-map-elt-default (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))) @@ -144,6 +219,18 @@ test-map-put!-alist (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-alist-new-key () "Regression test for Bug#23105." (let ((alist (list (cons 0 'a)))) @@ -398,6 +485,8 @@ test-map-contains-key-testfn (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)))) @@ -515,19 +604,19 @@ test-map-setf-alist-insert-key (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 +624,14 @@ test-map-setf-plist-overwrite-key (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 +640,79 @@ test-setf-map-with-function (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 @@ test-plistp (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 5d5d497c99..737b6e9dc5 100644 --- a/test/src/fns-tests.el +++ b/test/src/fns-tests.el @@ -843,6 +843,14 @@ test-cycle-reverse (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)) @@ -897,30 +905,47 @@ test-cycle-plist-put (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 @@ -1336,23 +1361,6 @@ fns-append (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)))) -- 2.35.1 --=-=-=-- From unknown Sat Aug 16 16:13:40 2025 X-Loop: help-debbugs@gnu.org Subject: bug#58531: 29.0.50; Wrong predicate used by map-elt gv getter Resent-From: Lars Ingebrigtsen Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Sat, 15 Oct 2022 10:34:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 58531 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: patch To: "Basil L. Contovounesios" Cc: Stefan Monnier , 58531@debbugs.gnu.org Received: via spool by 58531-submit@debbugs.gnu.org id=B58531.166583003722747 (code B ref 58531); Sat, 15 Oct 2022 10:34:01 +0000 Received: (at 58531) by debbugs.gnu.org; 15 Oct 2022 10:33:57 +0000 Received: from localhost ([127.0.0.1]:39586 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ojeUP-0005up-0Z for submit@debbugs.gnu.org; Sat, 15 Oct 2022 06:33:57 -0400 Received: from quimby.gnus.org ([95.216.78.240]:56450) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ojeUM-0005uW-HJ for 58531@debbugs.gnu.org; Sat, 15 Oct 2022 06:33:55 -0400 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=gnus.org; s=20200322; h=Content-Type:MIME-Version:Message-ID:Date:References: In-Reply-To:Subject:Cc:To:From:Sender:Reply-To:Content-Transfer-Encoding: Content-ID:Content-Description:Resent-Date:Resent-From:Resent-Sender: Resent-To:Resent-Cc:Resent-Message-ID:List-Id:List-Help:List-Unsubscribe: List-Subscribe:List-Post:List-Owner:List-Archive; bh=lrcLpMTxZQBI54ER3Sk6WBnDnZtQlmodNwIXghoiMMU=; b=qqOMlTqSM4GAoifCp/K/w6jwsO QzJnr+5ykkA8d6RIptKvB0HFOWPT5A+LnKwToGR/8wpgPE7Dkk/PszwVr2grTm4tUObeVBYWUtU3e GEWGAhzJy7YD65pz3SkGdBYjLX+A9Vl126fDRQ0D5YWWHBkob18wbxUZmZIQg07M0DZ8=; Received: from [84.212.220.105] (helo=downe) by quimby.gnus.org with esmtpsa (TLS1.3:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1ojeUC-0007AA-3A; Sat, 15 Oct 2022 12:33:47 +0200 From: Lars Ingebrigtsen In-Reply-To: <874jw6xe9h.fsf@tcd.ie> (Basil L. Contovounesios's message of "Sat, 15 Oct 2022 00:54:18 +0300") References: <87r0zaxeox.fsf@tcd.ie> <874jw6xe9h.fsf@tcd.ie> X-Now-Playing: Tess Parks's _Tess Parks an Those Who Were Seen Dancing_: "Wow" Date: Sat, 15 Oct 2022 12:33:43 +0200 Message-ID: <87bkqd4bqw.fsf@gnus.org> User-Agent: Gnus/5.13 (Gnus v5.13) MIME-Version: 1.0 Content-Type: text/plain X-Spam-Report: Spam detection software, running on the system "quimby.gnus.org", has NOT identified this incoming email as spam. The original message has been attached to this so you can view it or label similar future email. If you have any questions, see @@CONTACT_ADDRESS@@ for details. Content preview: "Basil L. Contovounesios" writes: > Now attached. > > In addition to the OP, the patch also addresses: > - The plist-get gv, as discussed in https://bugs.gnu.org/47425#91 > - The gv-tests.el no-byte-compile cookie from https://bugs.gn [...] Content analysis details: (-2.9 points, 5.0 required) pts rule name description ---- ---------------------- -------------------------------------------------- -1.0 ALL_TRUSTED Passed through trusted hosts only via SMTP -1.9 BAYES_00 BODY: Bayes spam probability is 0 to 1% [score: 0.0000] X-Spam-Score: -2.3 (--) X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -3.3 (---) "Basil L. Contovounesios" writes: > Now attached. > > In addition to the OP, the patch also addresses: > - The plist-get gv, as discussed in https://bugs.gnu.org/47425#91 > - The gv-tests.el no-byte-compile cookie from https://bugs.gnu.org/24402 Perhaps Stefan has comments; added to the CCs; > - The predicate in plist-get & co. being called with flipped arguments > compared to assoc & alist-get Hm... the latter sounds like something that could lead to obscure bugs in callers out there. From unknown Sat Aug 16 16:13:40 2025 X-Loop: help-debbugs@gnu.org Subject: bug#58531: 29.0.50; Wrong predicate used by map-elt gv getter Resent-From: "Basil L. Contovounesios" Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Sat, 15 Oct 2022 13:20:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 58531 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: patch To: Lars Ingebrigtsen Cc: Stefan Monnier , 58531@debbugs.gnu.org Received: via spool by 58531-submit@debbugs.gnu.org id=B58531.166583994424799 (code B ref 58531); Sat, 15 Oct 2022 13:20:01 +0000 Received: (at 58531) by debbugs.gnu.org; 15 Oct 2022 13:19:04 +0000 Received: from localhost ([127.0.0.1]:39774 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ojh4C-0006Rv-E9 for submit@debbugs.gnu.org; Sat, 15 Oct 2022 09:19:04 -0400 Received: from mail-ej1-f49.google.com ([209.85.218.49]:46616) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ojh4A-0006RQ-0b for 58531@debbugs.gnu.org; Sat, 15 Oct 2022 09:19:03 -0400 Received: by mail-ej1-f49.google.com with SMTP id bj12so15772318ejb.13 for <58531@debbugs.gnu.org>; Sat, 15 Oct 2022 06:19:01 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=tcd.ie; s=google21; h=mime-version:user-agent:message-id:date:references:in-reply-to :subject:cc:to:from:from:to:cc:subject:date:message-id:reply-to; bh=TvPqsyu3rCoht6L3ESLj2KdlfhFJ9StKTvj3jLyRP24=; b=Wyh71yoSeRCe14xGUzOKx/PRKkUkpR9RYzMkAPo0e96DKvdx3DQ6c3JSHtgG6anrVI 492hpOZuZLIxHKA4zQ1/x8hR3ayNpvA+SJm/GVQaiKhiZ7PUP0rqStWl4y8paSQ1ZROC QtN3E3Yn35ECN7BISjV5Q0tII4n2DnKhcCYkVjjHAb8EjCA5D1D8rQE2srVIJAk/FCnr jIbRfHBmnfjfiSclt90ToZyaTm6bysrnkkpSzinVfjCOWyNcWs9vOFLhQcOE81fOvMD1 mmvfVPlNgJ4kla3oIrmnK4C22CdVLyfwcTSueInxk1tf0aGtvaISR7zxCs9vNAAL3cp7 1UCQ== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=mime-version:user-agent:message-id:date:references:in-reply-to :subject:cc:to:from:x-gm-message-state:from:to:cc:subject:date :message-id:reply-to; bh=TvPqsyu3rCoht6L3ESLj2KdlfhFJ9StKTvj3jLyRP24=; b=RJNv3naFN4t1HP3bKn0sDS/7k9+itY7a7g4w7ZUF8Z6p44f8YHiWX1YoimdR+Bnx7q jEvEt4sf7DPK//ynF+AFaYM4W2p1jphtqp8hf2kglbFpw9tws+GdEeI3F11J/sxETM/P bg54n76aSoAOP2MzmNcs8BBWgL14AV9iQxGTktw1094pKV7rJXRUJ03p0l7unF6JxLt2 JATB62q75wyPp/kI9WlfmJYIINHJM+54yQpYt5f8144ULVw5uMJN9/wexXjPhW5R1cbX PQzk/MJvHHcBYFsTBS4/2XsBcFLyDU+lqR9GWksSdLwyzcylgLk5g3i/Iaa1Gpn55bmP UzVQ== X-Gm-Message-State: ACrzQf0HbPd8j/3R1Q8fu99tWfvWAzGBEJhazNZHXp4tYBZnzntRAKxc rNRXwM/LkJTpQlsD6eGaC7yY/g== X-Google-Smtp-Source: AMsMyM4NNthyID3wEH45OPdGhrBD3GgP5RHHOjqzUzTJrRA1pKssOi4riqOdNaQXk+J6ikm2HQAO0g== X-Received: by 2002:a17:907:3e11:b0:78d:9918:217f with SMTP id hp17-20020a1709073e1100b0078d9918217fmr1949292ejc.742.1665839935952; Sat, 15 Oct 2022 06:18:55 -0700 (PDT) Received: from localhost ([2a02:587:321f:7e8a:d9:365a:ced1:b3d1]) by smtp.gmail.com with ESMTPSA id f17-20020a50fc91000000b00458f077aecasm3646557edq.17.2022.10.15.06.18.55 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Sat, 15 Oct 2022 06:18:55 -0700 (PDT) From: "Basil L. Contovounesios" In-Reply-To: <87bkqd4bqw.fsf@gnus.org> (Lars Ingebrigtsen's message of "Sat, 15 Oct 2022 12:33:43 +0200") References: <87r0zaxeox.fsf@tcd.ie> <874jw6xe9h.fsf@tcd.ie> <87bkqd4bqw.fsf@gnus.org> Date: Sat, 15 Oct 2022 16:18:54 +0300 Message-ID: <8735bpw7gh.fsf@tcd.ie> User-Agent: Gnus/5.13 (Gnus v5.13) MIME-Version: 1.0 Content-Type: text/plain X-Spam-Score: 0.0 (/) X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) Lars Ingebrigtsen [2022-10-15 12:33 +0200] wrote: > "Basil L. Contovounesios" writes: > >> - The predicate in plist-get & co. being called with flipped arguments >> compared to assoc & alist-get > > Hm... the latter sounds like something that could lead to obscure bugs > in callers out there. How so? The predicate argument is new in Emacs 29, and the order of its arguments is undocumented, so no-one should be relying on it yet. I just didn't see a reason why it should differ between plist-get and assoc when Emacs 29 is released. -- Basil From unknown Sat Aug 16 16:13:40 2025 X-Loop: help-debbugs@gnu.org Subject: bug#58531: 29.0.50; Wrong predicate used by map-elt gv getter Resent-From: Stefan Monnier Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Sat, 15 Oct 2022 15:53:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 58531 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: patch To: "Basil L. Contovounesios" Cc: 58531@debbugs.gnu.org Received: via spool by 58531-submit@debbugs.gnu.org id=B58531.166584916511187 (code B ref 58531); Sat, 15 Oct 2022 15:53:01 +0000 Received: (at 58531) by debbugs.gnu.org; 15 Oct 2022 15:52:45 +0000 Received: from localhost ([127.0.0.1]:42552 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ojjSv-0002uN-2s for submit@debbugs.gnu.org; Sat, 15 Oct 2022 11:52:45 -0400 Received: from mailscanner.iro.umontreal.ca ([132.204.25.50]:61033) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ojjSm-0002u0-MX for 58531@debbugs.gnu.org; Sat, 15 Oct 2022 11:52:43 -0400 Received: from pmg3.iro.umontreal.ca (localhost [127.0.0.1]) by pmg3.iro.umontreal.ca (Proxmox) with ESMTP id EF8F54408AC; Sat, 15 Oct 2022 11:52:29 -0400 (EDT) Received: from mail01.iro.umontreal.ca (unknown [172.31.2.1]) by pmg3.iro.umontreal.ca (Proxmox) with ESMTP id 6C9E44407D7; Sat, 15 Oct 2022 11:52:28 -0400 (EDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=iro.umontreal.ca; s=mail; t=1665849148; bh=t5ENjMfjets5+3DTTbWXxENpahUXMu8RG1GBiUktdQ0=; h=From:To:Cc:Subject:In-Reply-To:References:Date:From; b=pi1wA2VoqQvDoNt1I6bkDPsCZMK3vsxrh4mjlQSXafSFojZh/bxZ1+rNmMFuEYh4U LapkbqxjWVAOS1rKulQW2wuX3zaYiBpaiOFfc+xz0X4JeDiHJneX0rkwb1cFPRDPc9 ZKmA+UexRVLyAI3Bv/qh27W850dkzRlipJWLxzgvWxG4P97/IGdv0/2jxbqR5XZ+fR QdQVetpn1OrDpDWB8+ctqE0OT5mox+QZXvVfECrNJCNwbK0tBY20HgVj0QKPzwGhfY rFXI07BxL/jNfeI27tMYL0+Pr//o7qEqg7I0B95QBVr4eBEpX9o4fOYMw4tS/BqTF+ MWcgymlIAqH9w== Received: from pastel (65-110-220-202.cpe.pppoe.ca [65.110.220.202]) by mail01.iro.umontreal.ca (Postfix) with ESMTPSA id 2EA72120E9E; Sat, 15 Oct 2022 11:52:28 -0400 (EDT) From: Stefan Monnier In-Reply-To: <874jw6xe9h.fsf@tcd.ie> (Basil L. Contovounesios's message of "Sat, 15 Oct 2022 00:54:18 +0300") Message-ID: References: <87r0zaxeox.fsf@tcd.ie> <874jw6xe9h.fsf@tcd.ie> Date: Sat, 15 Oct 2022 11:52:27 -0400 User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/29.0.50 (gnu/linux) MIME-Version: 1.0 Content-Type: text/plain X-SPAM-INFO: Spam detection results: 0 ALL_TRUSTED -1 Passed through trusted hosts only via SMTP AWL -0.055 Adjusted score from AWL reputation of From: address BAYES_00 -1.9 Bayes spam probability is 0 to 1% DKIM_SIGNED 0.1 Message has a DKIM or DK signature, not necessarily valid DKIM_VALID -0.1 Message has at least one valid DKIM or DK signature DKIM_VALID_AU -0.1 Message has a valid DKIM or DK signature from author's domain X-SPAM-LEVEL: X-Spam-Score: -2.3 (--) X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -3.3 (---) > (defun map--plist-delete (map key) > (let ((tail map) last) > @@ -346,7 +399,7 @@ map-contains-key > If MAP is an alist, TESTFN defaults to `equal'. > If MAP is a plist, `plist-member' is used instead." > (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))))))) Hmmm looks like we forgot to mark the `testfn` arg obsolete here with `advertised-calling-convention` like we did for `map-elt`. Could you fix that oversight in your patch while you're at it? > -(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)) The current error is poor (it doesn't include the offending plist, for example), so I think changing it (e.g. using the usual `wrong-type-argument` error) would be for the better. I do wonder whether it's worth the trouble keeping the error here, tho, instead of just using `plist-member` directly. Stefan From unknown Sat Aug 16 16:13:40 2025 X-Loop: help-debbugs@gnu.org Subject: bug#58531: 29.0.50; Wrong predicate used by map-elt gv getter Resent-From: "Basil L. Contovounesios" Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Sat, 15 Oct 2022 22:43:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 58531 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: patch To: Stefan Monnier Cc: Thomas Fitzsimmons , 58531@debbugs.gnu.org Received: via spool by 58531-submit@debbugs.gnu.org id=B58531.16658737326309 (code B ref 58531); Sat, 15 Oct 2022 22:43:01 +0000 Received: (at 58531) by debbugs.gnu.org; 15 Oct 2022 22:42:12 +0000 Received: from localhost ([127.0.0.1]:42764 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ojpr9-0001dh-Vc for submit@debbugs.gnu.org; Sat, 15 Oct 2022 18:42:12 -0400 Received: from mail-ej1-f53.google.com ([209.85.218.53]:36793) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ojpr6-0001dR-BJ for 58531@debbugs.gnu.org; Sat, 15 Oct 2022 18:42:10 -0400 Received: by mail-ej1-f53.google.com with SMTP id 13so17562420ejn.3 for <58531@debbugs.gnu.org>; Sat, 15 Oct 2022 15:42:08 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=tcd.ie; s=google21; h=mime-version:user-agent:message-id:date:references:in-reply-to :subject:cc:to:from:from:to:cc:subject:date:message-id:reply-to; bh=XnVQhEG2zyYV901C4uAeuOZ7juiPtMx632whJDixO4A=; b=Ewd0kuKSYhz+cT5no/aQb8rE4OLMB03cG29d4w85oNuheLFpkbi/Cl21w0Q9xicOZN 30YRJshmGsWeCFBFYT2IvcRNu7oEsKuYbo8qVf2rRbbzLBhBUSEH8IuzTy+IKXImCLPC SS+w9h+7CKTBuy8ZuqBHDfOittv1S4qeIpwnLZIuMmQ8xJ+uLCq6JqGZhJ3hBZAdjpQe 5yXgOQCuz5tDQUQax+Tnk9pzlKCz2w1OI8bOmqXdZzN3r6evFm7J2jyekpjfNNIvYmi1 2yLh4l/G0AE796CtpxnsOZ0r5F4kzJbYxvvufPBG6EX0AhSAAKxz3moCzdSgK88GV0lf W2UQ== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=mime-version:user-agent:message-id:date:references:in-reply-to :subject:cc:to:from:x-gm-message-state:from:to:cc:subject:date :message-id:reply-to; bh=XnVQhEG2zyYV901C4uAeuOZ7juiPtMx632whJDixO4A=; b=H+Is18mrGFV2ISy7BYWJtS9IOfVSFmIx+f9hHDwxBMuFr3j4OmcgfftE2toH8nZeUk BfnExECQu0iorp4vy1pRcxSunIw+Np9THHtC3XJwsuvVOyfXEjrZFS6QFFozutW0qMK2 xXFfJGgSK76GmzvSZJ3zD9orTMq7qnxO98ZeXtExjPU+VS2Qiw7MSFijbT8SSQmmru5/ Ss0nODNfzzzRh+u1Sk0enhImkc66dfOtgyYwmosk+Yd3E7yN64rqPy4yapDzr3TpiJR3 8vDrDPBhStoLMYHu3x8xelmeJCGkeHG2OSajn1QNKdY4pRgsT+sVvAQ3UviOusXnvu8k ucPA== X-Gm-Message-State: ACrzQf2LFd6uHZTERGh+YM09oBCSBaUgHoK3k3NP/by2Xb3mVl6OFKWO Bg/SepTox8ujwULxh0CTW8zDsw== X-Google-Smtp-Source: AMsMyM7o/NOw4aoRm8RIzVkX6hHyzF+o2vdn0in5yADGy+8w7NvB+syKBmopwpFyrHHxhN6U4x1Y0A== X-Received: by 2002:a17:907:2701:b0:78d:cb12:6d94 with SMTP id w1-20020a170907270100b0078dcb126d94mr3546159ejk.344.1665873722436; Sat, 15 Oct 2022 15:42:02 -0700 (PDT) Received: from localhost ([2a02:587:321f:7e8a:d9:365a:ced1:b3d1]) by smtp.gmail.com with ESMTPSA id k10-20020a170906578a00b007306a4ecc9dsm3797102ejq.18.2022.10.15.15.42.01 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Sat, 15 Oct 2022 15:42:01 -0700 (PDT) From: "Basil L. Contovounesios" In-Reply-To: (Stefan Monnier's message of "Sat, 15 Oct 2022 11:52:27 -0400") References: <87r0zaxeox.fsf@tcd.ie> <874jw6xe9h.fsf@tcd.ie> Date: Sun, 16 Oct 2022 01:41:54 +0300 Message-ID: <87wn906765.fsf@tcd.ie> User-Agent: Gnus/5.13 (Gnus v5.13) MIME-Version: 1.0 Content-Type: text/plain X-Spam-Score: 0.0 (/) X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) Stefan Monnier [2022-10-15 11:52 -0400] wrote: >> (defun map--plist-delete (map key) >> (let ((tail map) last) >> @@ -346,7 +399,7 @@ map-contains-key >> If MAP is an alist, TESTFN defaults to `equal'. >> If MAP is a plist, `plist-member' is used instead." >> (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))))))) > > Hmmm looks like we forgot to mark the `testfn` arg obsolete here with > `advertised-calling-convention` like we did for `map-elt`. > Could you fix that oversight in your patch while you're at it? Sure, but generic functions don't play well with advertised-calling-convention: each subsequent cl-defmethod overwrites the preceding symbol-function, so any existing entry in advertised-signature-table is no longer found after that. What would you propose doing? Call set-advertised-calling-convention after the last cl-defmethod in map.el and hope no third-party code defines a new method? It's not ideal, but it's better than what we currently have. Or is there some other trick we can employ that works in Emacs 26+? >> -(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)) > > The current error is poor (it doesn't include the offending plist, for > example), so I think changing it (e.g. using the usual > `wrong-type-argument` error) would be for the better. > I do wonder whether it's worth the trouble keeping the error here, tho, > instead of just using `plist-member` directly. I was just being conservative, because I don't know where EUDC might get its data from, or how important it is to catch dubious plists red-handed. I'd be happy to simplify the code, but let's see if Thomas (CCed) has any comments. Thomas, the patch touching eudc.el can be found at: https://bugs.gnu.org/58531#8. Thanks, -- Basil From unknown Sat Aug 16 16:13:40 2025 X-Loop: help-debbugs@gnu.org Subject: bug#58531: 29.0.50; Wrong predicate used by map-elt gv getter Resent-From: Stefan Monnier Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Sat, 15 Oct 2022 23:32:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 58531 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: patch To: "Basil L. Contovounesios" Cc: Thomas Fitzsimmons , 58531@debbugs.gnu.org Received: via spool by 58531-submit@debbugs.gnu.org id=B58531.166587669011662 (code B ref 58531); Sat, 15 Oct 2022 23:32:01 +0000 Received: (at 58531) by debbugs.gnu.org; 15 Oct 2022 23:31:30 +0000 Received: from localhost ([127.0.0.1]:42783 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ojqcs-000322-1u for submit@debbugs.gnu.org; Sat, 15 Oct 2022 19:31:30 -0400 Received: from mailscanner.iro.umontreal.ca ([132.204.25.50]:7554) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ojqcq-00031p-V7 for 58531@debbugs.gnu.org; Sat, 15 Oct 2022 19:31:29 -0400 Received: from pmg1.iro.umontreal.ca (localhost.localdomain [127.0.0.1]) by pmg1.iro.umontreal.ca (Proxmox) with ESMTP id 2F2C410013B; Sat, 15 Oct 2022 19:31:23 -0400 (EDT) Received: from mail01.iro.umontreal.ca (unknown [172.31.2.1]) by pmg1.iro.umontreal.ca (Proxmox) with ESMTP id C85381000F2; Sat, 15 Oct 2022 19:31:21 -0400 (EDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=iro.umontreal.ca; s=mail; t=1665876681; bh=MK07ygqmuGGkV+HlkJv52uWtzC2lMKRYixGjn87aXdA=; h=From:To:Cc:Subject:In-Reply-To:References:Date:From; b=GwuxlFCIGZEt2PNFenESnVv0OQBuznZ4V4016go7SYYcdQbQE8cvtQHy+dRR+8nLJ Cnand9Q9gx2LuuR/UcxlFjeno/88CiD++LBHMpltlkF2Awn9xjRFwJPx2XYJe6Yn5s XUkcCQr2hypi3yuoNgOqW7FB9/gvL8LFCY+lEguhBXyM+Zu/Dkoh6s/EQMys3MU8Gn V0bJTvCTtUXh70DWNqCPnzIiMBUIfgP8cBpjaABxCMxmfRkjnU0ceErnqj2obEjbHE F8v1Ucmf3kQOW6atdW2gLg6iPA4WaTyM43Ll90xybzbvt269IMgdcg3XQ/codKbuDA DkNw49fxqMowQ== Received: from pastel (65-110-220-202.cpe.pppoe.ca [65.110.220.202]) by mail01.iro.umontreal.ca (Postfix) with ESMTPSA id 8E86A120422; Sat, 15 Oct 2022 19:31:21 -0400 (EDT) From: Stefan Monnier In-Reply-To: <87wn906765.fsf@tcd.ie> (Basil L. Contovounesios's message of "Sun, 16 Oct 2022 01:41:54 +0300") Message-ID: References: <87r0zaxeox.fsf@tcd.ie> <874jw6xe9h.fsf@tcd.ie> <87wn906765.fsf@tcd.ie> Date: Sat, 15 Oct 2022 19:31:20 -0400 User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/29.0.50 (gnu/linux) MIME-Version: 1.0 Content-Type: text/plain X-SPAM-INFO: Spam detection results: 0 ALL_TRUSTED -1 Passed through trusted hosts only via SMTP AWL -0.071 Adjusted score from AWL reputation of From: address BAYES_00 -1.9 Bayes spam probability is 0 to 1% DKIM_SIGNED 0.1 Message has a DKIM or DK signature, not necessarily valid DKIM_VALID -0.1 Message has at least one valid DKIM or DK signature DKIM_VALID_AU -0.1 Message has a valid DKIM or DK signature from author's domain X-SPAM-LEVEL: X-Spam-Score: -2.3 (--) X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -3.3 (---) >> Hmmm looks like we forgot to mark the `testfn` arg obsolete here with >> `advertised-calling-convention` like we did for `map-elt`. >> Could you fix that oversight in your patch while you're at it? > > Sure, but generic functions don't play well with > advertised-calling-convention: each subsequent cl-defmethod overwrites > the preceding symbol-function, so any existing entry in > advertised-signature-table is no longer found after that. Good point. Not a reason not to add an `advertised-calling-convention`, but indeed we should fix that. Could you make a bug report for that? Stefan From unknown Sat Aug 16 16:13:40 2025 X-Loop: help-debbugs@gnu.org Subject: bug#58531: 29.0.50; Wrong predicate used by map-elt gv getter Resent-From: Lars Ingebrigtsen Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Sun, 16 Oct 2022 07:42:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 58531 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: patch To: "Basil L. Contovounesios" Cc: Stefan Monnier , 58531@debbugs.gnu.org Received: via spool by 58531-submit@debbugs.gnu.org id=B58531.166590610114905 (code B ref 58531); Sun, 16 Oct 2022 07:42:01 +0000 Received: (at 58531) by debbugs.gnu.org; 16 Oct 2022 07:41:41 +0000 Received: from localhost ([127.0.0.1]:43238 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ojyHF-0003sL-K4 for submit@debbugs.gnu.org; Sun, 16 Oct 2022 03:41:41 -0400 Received: from quimby.gnus.org ([95.216.78.240]:41074) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ojyHB-0003rz-58 for 58531@debbugs.gnu.org; Sun, 16 Oct 2022 03:41:39 -0400 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=gnus.org; s=20200322; h=Content-Type:MIME-Version:Message-ID:Date:References: In-Reply-To:Subject:Cc:To:From:Sender:Reply-To:Content-Transfer-Encoding: Content-ID:Content-Description:Resent-Date:Resent-From:Resent-Sender: Resent-To:Resent-Cc:Resent-Message-ID:List-Id:List-Help:List-Unsubscribe: List-Subscribe:List-Post:List-Owner:List-Archive; bh=jlaL6kfD2huUScfBDAqprKW1afWVzLxdC5xF5GrJffI=; b=hUj/nCl5+v9+6B+ysjV0EtMDWD htQEsMdmHbLirlb36IOuexCbxeW/U7gedpmdOz/EMH79xI5kLBpxprO0PBnmeuLGNOo9/iHejCNQN gyGsbLj/2zmfGFSqHvLFJU02w9pt45/SfS90sDryB3r/z31lNlfliPnvkWjksG+m6B/g=; Received: from [84.212.220.105] (helo=downe) by quimby.gnus.org with esmtpsa (TLS1.3:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1ojyGz-0003ZS-TH; Sun, 16 Oct 2022 09:41:28 +0200 From: Lars Ingebrigtsen In-Reply-To: <8735bpw7gh.fsf@tcd.ie> (Basil L. Contovounesios's message of "Sat, 15 Oct 2022 16:18:54 +0300") References: <87r0zaxeox.fsf@tcd.ie> <874jw6xe9h.fsf@tcd.ie> <87bkqd4bqw.fsf@gnus.org> <8735bpw7gh.fsf@tcd.ie> Face: iVBORw0KGgoAAAANSUhEUgAAADAAAAAwBAMAAAClLOS0AAAABGdBTUEAALGPC/xhBQAAACBj SFJNAAB6JgAAgIQAAPoAAACA6AAAdTAAAOpgAAA6mAAAF3CculE8AAAAMFBMVEX+/v7r5ufa0dOT eoOIbHeecXKrnJ5NPD5KOEM2JzFJMTprVV4dEx7DtrmAO0X///8iZEbjAAAAAWJLR0QPGLoA2QAA AAd0SU1FB+YKEAcoKHvHDdQAAAEpSURBVDjL1dO/T4NAFMBx/A96XZxLnFxxc70QE+ZObpZcE4Mz rYwuYpnUICBOGvkRF1PSlr6OxpT0TR10MGz+IaLjg+72u35yL3eXPEnaylibMSZXdQgcdHsKNwd2 9EjgEMYKP7cH6ROBfv7e48mz+LwlcDR3uzx5aO2+EcgtYfJ4Kqx7Ak7wccyD1/YeHeWgZWnJtdin sChMAamXDWuwMgQkaBU39FaF2gcs0F4R0Gcu6FgJBQ20DNKrOKZfMr9UfT/jnKsEZqOT0wAqmFCY yF9/Jyjko/G0AK7UADz0cuBaRuEiDJcGcAAKDtqIkDWBHiJAGtdguV4gmMldDdy1UeQYRRReAn+I mh19nxEof+swmTFpS2ptAlGW60aoNqf5dTuMbZz2X/oBFFCMQmahl5wAAAAldEVYdGRhdGU6Y3Jl YXRlADIwMjItMTAtMTZUMDc6NDA6NDArMDA6MDDafE2zAAAAJXRFWHRkYXRlOm1vZGlmeQAyMDIy LTEwLTE2VDA3OjQwOjQwKzAwOjAwqyH1DwAAAABJRU5ErkJggg== X-Now-Playing: Pet Shop Boys's _Behaviour_: "Being boring" Date: Sun, 16 Oct 2022 09:41:25 +0200 Message-ID: <87sfjo2p22.fsf@gnus.org> User-Agent: Gnus/5.13 (Gnus v5.13) MIME-Version: 1.0 Content-Type: text/plain X-Spam-Report: Spam detection software, running on the system "quimby.gnus.org", has NOT identified this incoming email as spam. The original message has been attached to this so you can view it or label similar future email. If you have any questions, see @@CONTACT_ADDRESS@@ for details. Content preview: "Basil L. Contovounesios" writes: > How so? The predicate argument is new in Emacs 29, and the order of its > arguments is undocumented, so no-one should be relying on it yet. Oh, OK -- I'd forgotten that it was new. Then flipping the order to match the other functions makes sense. Content analysis details: (-2.9 points, 5.0 required) pts rule name description ---- ---------------------- -------------------------------------------------- -1.0 ALL_TRUSTED Passed through trusted hosts only via SMTP -1.9 BAYES_00 BODY: Bayes spam probability is 0 to 1% [score: 0.0000] X-Spam-Score: -2.3 (--) X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -3.3 (---) "Basil L. Contovounesios" writes: > How so? The predicate argument is new in Emacs 29, and the order of its > arguments is undocumented, so no-one should be relying on it yet. Oh, OK -- I'd forgotten that it was new. Then flipping the order to match the other functions makes sense. From unknown Sat Aug 16 16:13:40 2025 X-Loop: help-debbugs@gnu.org Subject: bug#58531: 29.0.50; Wrong predicate used by map-elt gv getter Resent-From: "Basil L. Contovounesios" Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Sun, 16 Oct 2022 11:17:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 58531 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: patch To: Stefan Monnier Cc: 58531@debbugs.gnu.org Received: via spool by 58531-submit@debbugs.gnu.org id=B58531.166591897932061 (code B ref 58531); Sun, 16 Oct 2022 11:17:02 +0000 Received: (at 58531) by debbugs.gnu.org; 16 Oct 2022 11:16:19 +0000 Received: from localhost ([127.0.0.1]:43537 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ok1cu-0008L1-Eq for submit@debbugs.gnu.org; Sun, 16 Oct 2022 07:16:19 -0400 Received: from mail-wm1-f52.google.com ([209.85.128.52]:44663) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ok1cq-0008Kl-0E for 58531@debbugs.gnu.org; Sun, 16 Oct 2022 07:16:14 -0400 Received: by mail-wm1-f52.google.com with SMTP id bg9-20020a05600c3c8900b003bf249616b0so7516410wmb.3 for <58531@debbugs.gnu.org>; Sun, 16 Oct 2022 04:16:11 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=tcd.ie; s=google21; h=mime-version:user-agent:message-id:date:references:in-reply-to :subject:cc:to:from:from:to:cc:subject:date:message-id:reply-to; bh=mlufI84y/ov60DzuEAGMMMhB6hlqD7NIbloLOjsLQls=; b=bQb+USODiHEepZA68gyKEdmcWiv6sO1mqkC9cOADje7IWJSx22+M8iQgoioIWFHHlq H5HLdGpT3O8s2T6uBkhdyS6Uy+pdQXSyWn04DYkFSIe0/q6Xn0BnX2CYRbMJB9VxeGY8 KZDD8Xw/0lAq2+qBbHqXwDQMTd8f31mNsvV6u/P0X2Snqa97UP2shdqGCnYBT2j5jnrw eYtl2Umtd95x8RbGqOkXq1mf2v7JLf8wpSQUT58gNAF7gQh9yYWUXahvrWYj/SfCns61 dWT/JxV8G9FteNDpe9zngkmik7ggP5EddPBejG0lvWbvt2IsRkl/9rsHh4g1oVAVOzRA P/9w== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=mime-version:user-agent:message-id:date:references:in-reply-to :subject:cc:to:from:x-gm-message-state:from:to:cc:subject:date :message-id:reply-to; bh=mlufI84y/ov60DzuEAGMMMhB6hlqD7NIbloLOjsLQls=; b=4rf0zNqyrt36n+Hd/MNAJpxpAf5PNivfjdp38u5GRTVeHA0Z/gZPmxVz4i/uDvWGWv w8ov9cZ4dsOp/oLAS6+DAl2UJhzzj4trj3iTq01dbr/e1WyIgxIVqvWkiQGCvgKtJk+l Np0j+PqFTDAgAP7WghbtNcVKH2lOpQ59w179cVl6BIWHCPhdTP6stp9iNPcpSO7IGM+Q huArG8u60uJCu2VyL2CxlMyMqfCScC9hUs/hJFpHH+gk44zSxuHFbRi1kZ0GgDnTuIlE RzGDf6mdkcOZy0TMOPVs05H8o37FDMw0yEWNkwMMhdJcWiyQDNJiTYXo56yzg8Ek6qcK 2aHg== X-Gm-Message-State: ACrzQf0s0X7hnRI9NR8O45yy4j4Fva1hlKNHgePL+Pf6zKlpCp1uBtpo rOOi6xLYwc8i1Eu482Bt5hDDIg== X-Google-Smtp-Source: AMsMyM7qIyLP3CsSYds85EERaCoj47gJjYyOMzvewhApDo9tft7zL0jg3vnfgf3zRLJhZjGHWBSt2g== X-Received: by 2002:a05:600c:1e88:b0:3c3:ecf:ce3e with SMTP id be8-20020a05600c1e8800b003c30ecfce3emr15883094wmb.15.1665918965087; Sun, 16 Oct 2022 04:16:05 -0700 (PDT) Received: from localhost ([2a02:587:321f:7e8a:d9:365a:ced1:b3d1]) by smtp.gmail.com with ESMTPSA id g17-20020a05600c4ed100b003b4ac05a8a4sm16161604wmq.27.2022.10.16.04.16.03 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Sun, 16 Oct 2022 04:16:04 -0700 (PDT) From: "Basil L. Contovounesios" In-Reply-To: (Stefan Monnier's message of "Sat, 15 Oct 2022 19:31:20 -0400") References: <87r0zaxeox.fsf@tcd.ie> <874jw6xe9h.fsf@tcd.ie> <87wn906765.fsf@tcd.ie> Date: Sun, 16 Oct 2022 14:15:48 +0300 Message-ID: <87ilkkhvdn.fsf@tcd.ie> User-Agent: Gnus/5.13 (Gnus v5.13) MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Spam-Score: -0.0 (/) X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) --=-=-= Content-Type: text/plain Stefan Monnier [2022-10-15 19:31 -0400] wrote: >>> Hmmm looks like we forgot to mark the `testfn` arg obsolete here with >>> `advertised-calling-convention` like we did for `map-elt`. >>> Could you fix that oversight in your patch while you're at it? >> >> Sure, but generic functions don't play well with >> advertised-calling-convention: each subsequent cl-defmethod overwrites >> the preceding symbol-function, so any existing entry in >> advertised-signature-table is no longer found after that. > > Good point. Not a reason not to add an `advertised-calling-convention`, Updated patch attached. > but indeed we should fix that. Could you make a bug report for that? Done: https://bugs.gnu.org/58563. Thanks, -- Basil --=-=-= Content-Type: text/x-diff Content-Disposition: attachment; filename=0001-Audit-some-plist-uses-with-new-predicate-argument.patch >From 2b6a353a1dc631d6d6bd421f5da01fad96ca00bf Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Sat, 20 Aug 2022 16:32:33 +0300 Subject: [PATCH] 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--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. Set advertised-calling-convention after all cl-defmethods (bug#58563). * 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-put!-plist) (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. --- doc/lispref/lists.texi | 8 +- lisp/emacs-lisp/cl-extra.el | 4 +- lisp/emacs-lisp/gv.el | 7 +- lisp/emacs-lisp/map.el | 87 ++++++++++-- lisp/files-x.el | 11 +- lisp/net/eudc.el | 62 ++++----- src/fns.c | 97 +++++++------ test/lisp/apropos-tests.el | 17 +-- test/lisp/emacs-lisp/cl-extra-tests.el | 24 +++- test/lisp/emacs-lisp/gv-tests.el | 71 ++++------ test/lisp/emacs-lisp/map-tests.el | 185 +++++++++++++++++++++++-- test/lisp/net/eudc-tests.el | 155 +++++++++++++++++++++ test/lisp/subr-tests.el | 5 +- test/src/fns-tests.el | 70 +++++----- 14 files changed, 601 insertions(+), 202 deletions(-) create mode 100644 test/lisp/net/eudc-tests.el 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 @@ Plist Access @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 @@ Plist Access @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 @@ Plist Access @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 @@ cl-getf ,(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 @@ alist-get ,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..29c94bf1fb 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. @@ -100,16 +100,64 @@ map-let (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, @@ -121,7 +169,8 @@ map-elt (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 @@ -135,10 +184,11 @@ map-elt ,v))))))))) ;; `testfn' is deprecated. (advertised-calling-convention (map key &optional default) "27.1")) - ;; Can't use `cl-defmethod' with `advertised-calling-convention'. + ;; Can't use `cl-defmethod' with `advertised-calling-convention' + ;; (bug#58563). (map--dispatch map :list (if (map--plist-p map) - (let ((res (plist-member map key))) + (let ((res (map--plist-member map key testfn))) (if res (cadr res) default)) (alist-get key map default nil (or testfn #'equal))) :hash-table (gethash key map default) @@ -154,8 +204,12 @@ map-put 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) @@ -334,7 +388,7 @@ map-contains-key ;; FIXME: The test function to use generally depends on the map object, ;; so specifying `testfn' here is problematic: e.g. for hash-tables ;; we shouldn't use `gethash' unless `testfn' is the same as the map's own - ;; test function! + ;; test function! See also below for `advertised-calling-convention'. "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'." @@ -344,9 +398,9 @@ map-contains-key (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))))))) @@ -359,6 +413,12 @@ map-contains-key (let ((v '(nil))) (not (eq v (gethash key map v))))) +;; FIXME: This comes after all the `cl-defmethod's because they +;; overwrite the function, and the `advertised-calling-convention' is +;; lost. We can't prevent third-party `cl-defmethod's from having the +;; same effect, but it's better than nothing (bug#58531#25, bug#58563). +(set-advertised-calling-convention 'map-contains-key '(map key) "27.1") + (cl-defgeneric map-some (pred map) "Return the first non-nil (PRED key val) in MAP. Return nil if no such element is found. @@ -460,13 +520,14 @@ map-put! 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'. + ;; Can't use `cl-defmethod' with `advertised-calling-convention' + ;; (bug#58563). (map--dispatch map :list (progn (if (map--plist-p map) - (plist-put map key value) + (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) diff --git a/lisp/files-x.el b/lisp/files-x.el index 0131d495f2..da485a44a4 100644 --- a/lisp/files-x.el +++ b/lisp/files-x.el @@ -623,13 +623,10 @@ connection-local-criteria-alist (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 @@ eudc--using-bbdb-3-or-newer-p ;; 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 @@ DEFUN ("plist-get", Fplist_get, Splist_get, 2, 3, 0, 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 @@ DEFUN ("plist-get", Fplist_get, Splist_get, 2, 3, 0, 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 @@ DEFUN ("plist-put", Fplist_put, Splist_put, 3, 4, 0, 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 @@ DEFUN ("plist-put", Fplist_put, Splist_put, 3, 4, 0, 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 @@ DEFUN ("put", Fput, Sput, 3, 3, 0, (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 @@ DEFUN ("require", Frequire, Srequire, 1, 3, 0, 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 @@ apropos-tests-true-hit (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 @@ cl-get (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 @@ gv-setter-edebug (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'. + (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")))) - ;; 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'. + (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")))) - ;; 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"))) + ;; 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..8cc76612ab 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,14 +87,86 @@ test-map-elt-default (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))) @@ -144,6 +219,18 @@ test-map-put!-alist (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-alist-new-key () "Regression test for Bug#23105." (let ((alist (list (cons 0 'a)))) @@ -395,9 +482,12 @@ test-map-contains-key-testfn (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)))) @@ -515,19 +605,19 @@ test-map-setf-alist-insert-key (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 +625,14 @@ test-map-setf-plist-overwrite-key (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 +641,79 @@ test-setf-map-with-function (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 @@ test-plistp (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 @@ test-cycle-reverse (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 @@ test-cycle-plist-put (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 @@ fns-append (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)))) -- 2.35.1 --=-=-=-- From unknown Sat Aug 16 16:13:40 2025 X-Loop: help-debbugs@gnu.org Subject: bug#58531: 29.0.50; Wrong predicate used by map-elt gv getter Resent-From: Stefan Monnier Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Sun, 16 Oct 2022 16:07:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 58531 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: patch To: "Basil L. Contovounesios" Cc: 58531@debbugs.gnu.org Received: via spool by 58531-submit@debbugs.gnu.org id=B58531.166593638624875 (code B ref 58531); Sun, 16 Oct 2022 16:07:01 +0000 Received: (at 58531) by debbugs.gnu.org; 16 Oct 2022 16:06:26 +0000 Received: from localhost ([127.0.0.1]:45920 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ok69i-0006T9-Fp for submit@debbugs.gnu.org; Sun, 16 Oct 2022 12:06:26 -0400 Received: from mailscanner.iro.umontreal.ca ([132.204.25.50]:6556) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ok69h-0006Sw-0l for 58531@debbugs.gnu.org; Sun, 16 Oct 2022 12:06:25 -0400 Received: from pmg3.iro.umontreal.ca (localhost [127.0.0.1]) by pmg3.iro.umontreal.ca (Proxmox) with ESMTP id AD9B1440C0B; Sun, 16 Oct 2022 12:06:19 -0400 (EDT) Received: from mail01.iro.umontreal.ca (unknown [172.31.2.1]) by pmg3.iro.umontreal.ca (Proxmox) with ESMTP id 8DCB34409C3; Sun, 16 Oct 2022 12:06:18 -0400 (EDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=iro.umontreal.ca; s=mail; t=1665936378; bh=wDSH1l2ky8kJnohMwF9dy4W61iWuYtkvj8LxcuM40VA=; h=From:To:Cc:Subject:In-Reply-To:References:Date:From; b=psnfc4f9hDsgOqLJrhig+HHyWu5NYO7wCWUyFQGqp+pRm7QdgXzqvg4ry9ZhmmPjK 2L61ncgnJGzdpVUYynXdmSZI0Ho24U3SuRtczX7eAcA6s138dHhCMfXG/dGiCUmQdK U7lju5j8aG5u9BgP+tC7sJEYyElRuj2KuK9iMiav1F+uOtO1nxi4Q0bOGydTEZvzcj azuvyRKqTFZM6rwKskMKk7BCkAaqbhXouZhO8OdsG1GjMD7Y+pULelg24fEZmG1lQC 3K/jibhE3n4o7ibb2wM6Dt6fQoUupzE7hgoVzs1wxvqdwbVkByfH922u3hpspZCvX1 q/BHK08h5iODQ== Received: from pastel (65-110-220-202.cpe.pppoe.ca [65.110.220.202]) by mail01.iro.umontreal.ca (Postfix) with ESMTPSA id 603151203FE; Sun, 16 Oct 2022 12:06:18 -0400 (EDT) From: Stefan Monnier In-Reply-To: <87ilkkhvdn.fsf@tcd.ie> (Basil L. Contovounesios's message of "Sun, 16 Oct 2022 14:15:48 +0300") Message-ID: References: <87r0zaxeox.fsf@tcd.ie> <874jw6xe9h.fsf@tcd.ie> <87wn906765.fsf@tcd.ie> <87ilkkhvdn.fsf@tcd.ie> Date: Sun, 16 Oct 2022 12:06:17 -0400 User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/29.0.50 (gnu/linux) MIME-Version: 1.0 Content-Type: text/plain X-SPAM-INFO: Spam detection results: 0 ALL_TRUSTED -1 Passed through trusted hosts only via SMTP AWL -0.056 Adjusted score from AWL reputation of From: address BAYES_00 -1.9 Bayes spam probability is 0 to 1% DKIM_SIGNED 0.1 Message has a DKIM or DK signature, not necessarily valid DKIM_VALID -0.1 Message has at least one valid DKIM or DK signature DKIM_VALID_AU -0.1 Message has a valid DKIM or DK signature from author's domain X-SPAM-LEVEL: X-Spam-Score: -2.3 (--) X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -3.3 (---) > Updated patch attached. LGTM, feel free to push, thanks, Stefan From unknown Sat Aug 16 16:13:40 2025 X-Loop: help-debbugs@gnu.org Subject: bug#58531: 29.0.50; Wrong predicate used by map-elt gv getter Resent-From: "Basil L. Contovounesios" Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Sat, 22 Oct 2022 15:02:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 58531 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: patch To: Stefan Monnier Cc: 58531@debbugs.gnu.org Received: via spool by 58531-submit@debbugs.gnu.org id=B58531.16664509134543 (code B ref 58531); Sat, 22 Oct 2022 15:02:02 +0000 Received: (at 58531) by debbugs.gnu.org; 22 Oct 2022 15:01:53 +0000 Received: from localhost ([127.0.0.1]:42166 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1omG0W-0001BC-GC for submit@debbugs.gnu.org; Sat, 22 Oct 2022 11:01:53 -0400 Received: from mail-ed1-f43.google.com ([209.85.208.43]:38695) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1omG0S-0001Ay-Iy for 58531@debbugs.gnu.org; Sat, 22 Oct 2022 11:01:51 -0400 Received: by mail-ed1-f43.google.com with SMTP id l22so16074270edj.5 for <58531@debbugs.gnu.org>; Sat, 22 Oct 2022 08:01:48 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=tcd.ie; s=google21; h=mime-version:user-agent:message-id:date:references:in-reply-to :subject:cc:to:from:from:to:cc:subject:date:message-id:reply-to; bh=SQZXmqUwxKvnBuqmnKKcWionMSsnXOkRhtOkKDoVdrI=; b=PVOfQ5yyq0Ob3tSRYzjFFwMNpyXeqj2HkTwyWKAUs2K7NjQc5n64lk8KjQKa4a0D0F Z7ljfXMiXshMqTiSZDPvCd8prZKnlCv8MRq2fs6y7B1UOBm6WTrH8tso1gYnxJkpn+Jc PJFw0m8R+JtMvHEZT5LwLM1ED4A2y5gnkS6JWI2eYTUsog9sEhfhcai19lxWF9gTzoPH tvRXd6R5EM9P65tqr3dDazVDNfmNtdkkCWRhKWw/obnM7BNc0oR7I2rLvPO+ovPCtF5V hIIvGjvZRKbnb074liJhmo7r/NKJx0PHWO5pJsHfSEKXCHsZpCP3+AM8J193tEOSq+U7 /oTw== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=mime-version:user-agent:message-id:date:references:in-reply-to :subject:cc:to:from:x-gm-message-state:from:to:cc:subject:date :message-id:reply-to; bh=SQZXmqUwxKvnBuqmnKKcWionMSsnXOkRhtOkKDoVdrI=; b=iscoN6JVh9hYPJbljmmIJ4ejUQtdQgRTrmuXPYzD10seBL35nSDZaRxYLDPB3gcEqb yT+ySMaU5YOgxmY7mCjyqMB8VRqQa8QABXFYzZoOOdCSFKTOOG+5+3bPvE6FLUv8a5BE x7QhpLyxezl0CenAA+uNxxuqSOktX8j42f3IxQFFBu1T6iEJI17u5RZ1hZMdpO6jZq1u pl4c934LlwzbP+0LErpJXvIuPOpeT2Ur5+ehd/MDeY9ghKVfnFW0VXmgIB/hhJJxd3EE 9kOUZC952foyH/IQp17cpKPlygKK9aUosP5Y9EUrV4cg52l3iHP9vfYJNE1rzuW29Jri fQPw== X-Gm-Message-State: ACrzQf3KwXku6q2I49oVNEVpGtWjV9/cHq5sFnHBrDe8gKeZQXQns0bC fmH2vDcYz5N1aIlrSF6FVBhqw/89pvFfvQ== X-Google-Smtp-Source: AMsMyM5nZdcRVuncY/IqxvjZwEXW6GwyPJCB8+jBgl8jTR2LE9a/iV2IxRiUecZEJPsYWUBR65645A== X-Received: by 2002:a17:907:744:b0:741:36b9:d2cc with SMTP id xc4-20020a170907074400b0074136b9d2ccmr19416352ejb.613.1666450902575; Sat, 22 Oct 2022 08:01:42 -0700 (PDT) Received: from localhost ([2a02:587:321f:7e8a:d9:365a:ced1:b3d1]) by smtp.gmail.com with ESMTPSA id l20-20020a056402231400b00457c5637578sm15002170eda.63.2022.10.22.08.01.40 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Sat, 22 Oct 2022 08:01:41 -0700 (PDT) From: "Basil L. Contovounesios" In-Reply-To: (Stefan Monnier's message of "Sun, 16 Oct 2022 12:06:17 -0400") References: <87r0zaxeox.fsf@tcd.ie> <874jw6xe9h.fsf@tcd.ie> <87wn906765.fsf@tcd.ie> <87ilkkhvdn.fsf@tcd.ie> Date: Sat, 22 Oct 2022 18:01:38 +0300 Message-ID: <87eduz6gx9.fsf@tcd.ie> User-Agent: Gnus/5.13 (Gnus v5.13) MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Spam-Score: -0.0 (/) X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) --=-=-= Content-Type: text/plain Stefan Monnier [2022-10-16 12:06 -0400] wrote: >> Updated patch attached. > LGTM, feel free to push, thanks, WDYT of the attached additions now that bug#58563 is mostly addressed? Thanks, -- Basil --=-=-= Content-Type: text/x-diff Content-Disposition: attachment; filename=0002-Replace-remaining-map-dispatch-with-cl-defmethod.patch >From 21d8e5fd49043b1cb75691e2e2bad3cf6c37c192 Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Sat, 22 Oct 2022 16:54:19 +0300 Subject: [PATCH 2/2] Replace remaining map--dispatch with cl-defmethod * lisp/emacs-lisp/map.el (map--dispatch): Remove. (map--restore-advertised-signature): New convenience function. (map-elt, map-contains-key, map-put!): Break out map--dispatch clauses into corresponding cl-defmethods. Ensure original advertised-calling-convention is restored after them in older Emacs versions. (map--put): Group definition in file together with that of map-put!. * test/lisp/emacs-lisp/map-tests.el (test-map-elt-signature) (test-map-put!-signature, test-map-contains-key-signature): New tests for the assurances above. --- lisp/emacs-lisp/map.el | 138 +++++++++++++++++------------- test/lisp/emacs-lisp/map-tests.el | 19 ++++ 2 files changed, 96 insertions(+), 61 deletions(-) diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el index 29c94bf1fb..edcb93f3cf 100644 --- a/lisp/emacs-lisp/map.el +++ b/lisp/emacs-lisp/map.el @@ -80,25 +80,31 @@ map-let `(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") +(defun map--restore-advertised-signature (function signature when) + "Restore FUNCTION symbol's advertised SIGNATURE if necessary. +This should be called after the last `cl-defmethod' of a +`cl-defgeneric' that declares an `advertised-calling-convention', +to work around bug#58563. +The problem is that each `cl-defmethod' overwrites the function +and prior to Emacs 29 discarded any existing advertised +signature. This workaround does not prevent third-party +`cl-defmethod's from discarding the advertised signature, but +it's better than nothing. +SIGNATURE should be the same as that originally declared, even if +this is not always enforced." + (let* ((fn (symbol-function function)) + (osig (if (eval-when-compile + (fboundp 'get-advertised-calling-convention)) + (get-advertised-calling-convention fn) + (gethash fn advertised-signature-table t)))) + (if (listp osig) + (cl-assert (equal osig signature) t + (format "Tried changing %s signature from %%s to %%s" + function)) + (set-advertised-calling-convention function signature when)))) + (defsubst map--plist-p (list) "Return non-nil if LIST is the start of a nonempty plist map." (and (consp list) (atom (car list)))) @@ -163,6 +169,9 @@ map-elt In the base definition, MAP can be an alist, plist, hash-table, or array." (declare + ;; `testfn' is deprecated. Sync this with the + ;; `map--restore-advertised-signature' below. + (advertised-calling-convention (map key &optional default) "27.1") (gv-expander (lambda (do) (gv-letplace (mgetter msetter) `(gv-delay-error ,map) @@ -181,20 +190,24 @@ map-elt ,(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' - ;; (bug#58563). - (map--dispatch map - :list (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))) - :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)) + +;; This can be removed once we assume Emacs 29 or later. +(map--restore-advertised-signature 'map-elt '(map key &optional default) "27.1") (defmacro map-put (map key value &optional testfn) "Associate KEY with VALUE in MAP and return VALUE. @@ -388,10 +401,12 @@ map-contains-key ;; FIXME: The test function to use generally depends on the map object, ;; so specifying `testfn' here is problematic: e.g. for hash-tables ;; we shouldn't use `gethash' unless `testfn' is the same as the map's own - ;; test function! See also below for `advertised-calling-convention'. + ;; test function! "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'." + ;; Sync this with the `map--restore-advertised-signature' below. + (declare (advertised-calling-convention (map key) "27.1")) (unless testfn (setq testfn #'equal)) (map-some (lambda (k _v) (funcall testfn key k)) map)) @@ -413,11 +428,8 @@ map-contains-key (let ((v '(nil))) (not (eq v (gethash key map v))))) -;; FIXME: This comes after all the `cl-defmethod's because they -;; overwrite the function, and the `advertised-calling-convention' is -;; lost. We can't prevent third-party `cl-defmethod's from having the -;; same effect, but it's better than nothing (bug#58531#25, bug#58563). -(set-advertised-calling-convention 'map-contains-key '(map key) "27.1") +;; This can be removed once we assume Emacs 29 or later. +(map--restore-advertised-signature 'map-contains-key '(map key) "27.1") (cl-defgeneric map-some (pred map) "Return the first non-nil (PRED key val) in MAP. @@ -519,25 +531,34 @@ map-put! 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' - ;; (bug#58563). - (map--dispatch - map - :list - (progn - (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) - :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))) + ;; Sync this with the `map--restore-advertised-signature' below. + (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)) + +;; This can be removed once we assume Emacs 29 or later. +(map--restore-advertised-signature 'map-put! '(map key value) "27.1") + +;; 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. @@ -554,11 +575,6 @@ map-insert (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/test/lisp/emacs-lisp/map-tests.el b/test/lisp/emacs-lisp/map-tests.el index 8cc76612ab..75ebe59431 100644 --- a/test/lisp/emacs-lisp/map-tests.el +++ b/test/lisp/emacs-lisp/map-tests.el @@ -171,6 +171,12 @@ test-map-elt-gv (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) @@ -231,6 +237,12 @@ test-map-put!-plist (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)))) @@ -492,6 +504,13 @@ test-map-contains-key-testfn (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) -- 2.35.1 --=-=-=-- From unknown Sat Aug 16 16:13:40 2025 X-Loop: help-debbugs@gnu.org Subject: bug#58531: 29.0.50; Wrong predicate used by map-elt gv getter Resent-From: Stefan Monnier Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Sat, 22 Oct 2022 16:00:03 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 58531 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: patch To: "Basil L. Contovounesios" Cc: 58531@debbugs.gnu.org Received: via spool by 58531-submit@debbugs.gnu.org id=B58531.166645439710007 (code B ref 58531); Sat, 22 Oct 2022 16:00:03 +0000 Received: (at 58531) by debbugs.gnu.org; 22 Oct 2022 15:59:57 +0000 Received: from localhost ([127.0.0.1]:42202 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1omGui-0002bK-PJ for submit@debbugs.gnu.org; Sat, 22 Oct 2022 11:59:56 -0400 Received: from mailscanner.iro.umontreal.ca ([132.204.25.50]:19270) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1omGue-0002b5-JH for 58531@debbugs.gnu.org; Sat, 22 Oct 2022 11:59:56 -0400 Received: from pmg1.iro.umontreal.ca (localhost.localdomain [127.0.0.1]) by pmg1.iro.umontreal.ca (Proxmox) with ESMTP id BDF2E1002F0; Sat, 22 Oct 2022 11:59:45 -0400 (EDT) Received: from mail01.iro.umontreal.ca (unknown [172.31.2.1]) by pmg1.iro.umontreal.ca (Proxmox) with ESMTP id 4FE2610010F; Sat, 22 Oct 2022 11:59:44 -0400 (EDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=iro.umontreal.ca; s=mail; t=1666454384; bh=k/ks3qXVGC2SQTvyl0sxBcbvjFxSFttc7FEnnPDMsQQ=; h=From:To:Cc:Subject:In-Reply-To:References:Date:From; b=oPzDuSyf4eqllZip2L++nQmLaaZNbTeCYbeVBdug9YDBELcASXscfvvLNqjU4Uphe hEoXsAs4WG02zabo37dt5NicOVQr4ufeBeX1Kq671Kz3t+jkmjbwKkUuQ2Uvtx/25u yXOxkMjvYslWlgSJF4K8kYo20V+pCwmJ7OTqusUAiu98nyR9OnG2jlQxGzf6L42yme cMFqWG5WbqQ2PWWTTh3QCXGceWL67fEN9ljavLQM9pDXqEOVw8gcVD1UbkFh5OMR4P wJ0UzqeicK+0vlNFqzXOAfiXFkmoNcNrZLnQpgKqvQC9qA7SB/jjrW2/GXvSr+UKRJ 3TEygt3tEVtWA== Received: from pastel (65-110-220-202.cpe.pppoe.ca [65.110.220.202]) by mail01.iro.umontreal.ca (Postfix) with ESMTPSA id 1937B12065C; Sat, 22 Oct 2022 11:59:44 -0400 (EDT) From: Stefan Monnier In-Reply-To: <87eduz6gx9.fsf@tcd.ie> (Basil L. Contovounesios's message of "Sat, 22 Oct 2022 18:01:38 +0300") Message-ID: References: <87r0zaxeox.fsf@tcd.ie> <874jw6xe9h.fsf@tcd.ie> <87wn906765.fsf@tcd.ie> <87ilkkhvdn.fsf@tcd.ie> <87eduz6gx9.fsf@tcd.ie> Date: Sat, 22 Oct 2022 11:59:41 -0400 User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/29.0.50 (gnu/linux) MIME-Version: 1.0 Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable X-SPAM-INFO: Spam detection results: 0 ALL_TRUSTED -1 Passed through trusted hosts only via SMTP AWL -0.066 Adjusted score from AWL reputation of From: address BAYES_00 -1.9 Bayes spam probability is 0 to 1% DKIM_SIGNED 0.1 Message has a DKIM or DK signature, not necessarily valid DKIM_VALID -0.1 Message has at least one valid DKIM or DK signature DKIM_VALID_AU -0.1 Message has a valid DKIM or DK signature from author's domain X-SPAM-LEVEL: X-Spam-Score: -2.3 (--) X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -3.3 (---) > (map--restore-advertised-signature): New convenience function. I'm not convinced it's worth the trouble. This new code will mostly be used in Emacs=E2=89=A529 anyway (very few users explicitly install `map` and most packages which depend on `map` don't depend on a particularly recent version of `map` and hence won't trigger installation of `map` from GNU ELPA). The rest is fine by me. Stefan From debbugs-submit-bounces@debbugs.gnu.org Sat Oct 22 12:58:51 2022 Received: (at control) by debbugs.gnu.org; 22 Oct 2022 16:58:51 +0000 Received: from localhost ([127.0.0.1]:42230 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1omHpj-00042A-D5 for submit@debbugs.gnu.org; Sat, 22 Oct 2022 12:58:51 -0400 Received: from mail-ed1-f51.google.com ([209.85.208.51]:35474) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1omHpZ-00041Y-KS for control@debbugs.gnu.org; Sat, 22 Oct 2022 12:58:44 -0400 Received: by mail-ed1-f51.google.com with SMTP id t18so1210635edt.2 for ; Sat, 22 Oct 2022 09:58:41 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=tcd.ie; s=google21; h=content-transfer-encoding:mime-version:user-agent:message-id:date :references:in-reply-to:subject:cc:to:from:from:to:cc:subject:date :message-id:reply-to; bh=d39k2laWbk1DR2aFdlrJnq764XuN6MmeuH1WP0LYfmo=; b=a4qaaHxNPVPL621WrQLQgo3m7VtcfL5CbwOihQtLg7xIM+25qk1M66xra2QH/hq8aK YlNs85h0gh8ZpQofZVZNW91PKY0o+mT0Z+PNZKVFOvcvColTAeVs1DXB8ZGxY31QSSU2 MVCpkmxwPmA/MIJTAMTA+hXuRSkTdf3aIHMMj+xbHuBFCg50R1urKT9HoaG3if9LluyT QWfQhnpuf07lgG9JgpB5ueqWbCdbmJoLWVkvpwmTFs6iDx2GiHozdDVTGz34tyKBNerl Uq0K+SXasaxYFkyvspFrK5LhtRn4Mx4CkCOjGs8SDhksHk362PbKf027J8wK9MayLaCa Njmg== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=content-transfer-encoding:mime-version:user-agent:message-id:date :references:in-reply-to:subject:cc:to:from:x-gm-message-state:from :to:cc:subject:date:message-id:reply-to; bh=d39k2laWbk1DR2aFdlrJnq764XuN6MmeuH1WP0LYfmo=; b=0PKsH1Ap7AM0LJtuW3BvwEILuw+BBPBY8FRQq8B6+TMAnDKURpl5b7/H2Q1SdLde04 xlgxh2VWN/m+7S8BzW0v5SOtbKIHzVxNFhY53dRJj8QUIZiBHPMrlmbeA/Nx+iHi0o8B jNRYiSyNMAQS+9YuCE+Z8gT+8CdvahcBkd0IefdxqiEdaCZcXM+DzLV8OHm6ioFakPUY GaC6482zNv42eLkf0Lu302t5n0Np3HD3xmptWVj54KPCfdcym0ziC+FwNkfmIxzkBJ2q MFWNbwN2n/wn3RKPe4yQKajsW9eMAOEeoYBH+Ndv+gZw2arQnhZ8zpBoRyDeVAaXHu20 31ew== X-Gm-Message-State: ACrzQf3oXXn29c0xc9kDmaSbH5KEKbwc0WH2ha7axPNZQwEijx74BM4/ G4ao7bO2U/iVHGoTEByLIcfQuA== X-Google-Smtp-Source: AMsMyM7wixY8d+5/gDLW5TV5Vk/oJlyjZoBj+bKMpJ8AkkH0pVpBsZ3YN5y22p/xi1wOxuenrYK8hg== X-Received: by 2002:a05:6402:d62:b0:460:42c8:fc6d with SMTP id ec34-20020a0564020d6200b0046042c8fc6dmr13891660edb.182.1666457915816; Sat, 22 Oct 2022 09:58:35 -0700 (PDT) Received: from localhost ([2a02:587:321f:7e8a:d9:365a:ced1:b3d1]) by smtp.gmail.com with ESMTPSA id q8-20020a056402248800b00457c85bd890sm15260679eda.55.2022.10.22.09.58.34 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Sat, 22 Oct 2022 09:58:35 -0700 (PDT) From: "Basil L. Contovounesios" To: Stefan Monnier Subject: Re: bug#58531: 29.0.50; Wrong predicate used by map-elt gv getter In-Reply-To: (Stefan Monnier's message of "Sat, 22 Oct 2022 11:59:41 -0400") References: <87r0zaxeox.fsf@tcd.ie> <874jw6xe9h.fsf@tcd.ie> <87wn906765.fsf@tcd.ie> <87ilkkhvdn.fsf@tcd.ie> <87eduz6gx9.fsf@tcd.ie> Date: Sat, 22 Oct 2022 19:58:33 +0300 Message-ID: <87v8obeqx2.fsf@tcd.ie> User-Agent: Gnus/5.13 (Gnus v5.13) MIME-Version: 1.0 Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable X-Spam-Score: -0.0 (/) X-Debbugs-Envelope-To: control Cc: 58531-done@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) close 58531 29.1 quit Stefan Monnier [2022-10-22 11:59 -0400] wrote: >> (map--restore-advertised-signature): New convenience function. > > I'm not convinced it's worth the trouble. > This new code will mostly be used in Emacs=E2=89=A529 anyway (very few us= ers > explicitly install `map` and most packages which depend on `map` don't > depend on a particularly recent version of `map` and hence won't trigger > installation of `map` from GNU ELPA). OK, I did away with any nondeclarative advertised-calling-convention choreography. > The rest is fine by me. Thanks. Squashed, pushed, closing. Audit some plist uses with new predicate argument 9da2efb670 2022-10-22 19:33:12 +0300 https://git.sv.gnu.org/cgit/emacs.git/commit/?id=3D9da2efb670 --=20 Basil From unknown Sat Aug 16 16:13:40 2025 X-Loop: help-debbugs@gnu.org Subject: bug#58531: 29.0.50; Wrong predicate used by map-elt gv getter Resent-From: "Basil L. Contovounesios" Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Sat, 22 Oct 2022 18:05:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 58531 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: patch To: Stefan Monnier Cc: Thomas Fitzsimmons , 58531@debbugs.gnu.org Received: via spool by 58531-submit@debbugs.gnu.org id=B58531.166646188330223 (code B ref 58531); Sat, 22 Oct 2022 18:05:02 +0000 Received: (at 58531) by debbugs.gnu.org; 22 Oct 2022 18:04:43 +0000 Received: from localhost ([127.0.0.1]:42286 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1omIrS-0007rO-WE for submit@debbugs.gnu.org; Sat, 22 Oct 2022 14:04:43 -0400 Received: from mail-ed1-f53.google.com ([209.85.208.53]:46884) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1omIrL-0007r3-O8 for 58531@debbugs.gnu.org; Sat, 22 Oct 2022 14:04:41 -0400 Received: by mail-ed1-f53.google.com with SMTP id m15so17065731edb.13 for <58531@debbugs.gnu.org>; Sat, 22 Oct 2022 11:04:35 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=tcd.ie; s=google21; h=mime-version:user-agent:message-id:date:references:in-reply-to :subject:cc:to:from:from:to:cc:subject:date:message-id:reply-to; bh=HIxS5HQVkY7wxKaXvJ6vnDtBo+5wiA/OSFWK3mJJyz0=; b=a/a8+S6kuQYfJzaF9Lq8R94ME7WlbGGdXnNh7D+djdQykP1ftqy0p2XBtnmmJ9uznp WSzpKRGML4KxGhOMCeJoHLC31PFTweghuc33l0Nwtt1wFkwzdTkQaPakPNXzwu1iOkzK BMOhxX87nsLz9ANSxYlIsc6ZFV9rT9zLRwkPmfNTDLR6arX0tx40MOVuOuVOk86umefP XEkQ+bVNE6PLXyiSAS6ZAuyRHDYojPHdo/0Iw21+hDy2CcJRqWspZud/ktgR5LPVcgzn +lLUPIplrbmgpRv037xvf/ZsGq2Yu1+39/eWmBChFtvjQ3o1WdlAVnNf0ICMyfzucjEL joDQ== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=mime-version:user-agent:message-id:date:references:in-reply-to :subject:cc:to:from:x-gm-message-state:from:to:cc:subject:date :message-id:reply-to; bh=HIxS5HQVkY7wxKaXvJ6vnDtBo+5wiA/OSFWK3mJJyz0=; b=t8s8fFytVef4O5rlgi7Za0m1M6XbnvodYsT0H7dTPaTtBg75LFnYmKCu9cVwo8BgQP 1E2bs5N9nkb0TO24GvIglbl8Op4mRQbqvGInh2bkhY1H+nXCiOg1hU/YWkBwGctyuPEX fnuhxD+49GjS0OMuLM+DFnA3Dsz5p3i5CCTqho3DVrqlNYnV7O86oJc/qO0KOREQxjU8 j5lcUdwKxB8KKaIhZK8hzpmTuSkmyt01WOHwIPGALNnCt+8VkdujZ6XkbU6S1kmruH75 tTAOBHYQ8EZ/ovlunNL1ky3aG6S+B4zY6uRHNFv4o1Unk4e4UsI/sY//8K3inW51f+e9 8Amw== X-Gm-Message-State: ACrzQf3/3yzWuPfQ43gvrThHn2K9HEMWuT8cWwcUzgch3qsvlzU1+0SR hVM2gjsfXicRU/fVtqJJXPpYjw== X-Google-Smtp-Source: AMsMyM4/oOqn0Mrhgt8XTKNZwOsYm3xGS1YCvicX5iW48Mt037GPh6nCRhHl/65Wk+AkPkk6p41bAg== X-Received: by 2002:a17:907:2cea:b0:7a3:4ebe:5eb with SMTP id hz10-20020a1709072cea00b007a34ebe05ebmr1375056ejc.228.1666461869663; Sat, 22 Oct 2022 11:04:29 -0700 (PDT) Received: from localhost ([2a02:587:321f:7e8a:d9:365a:ced1:b3d1]) by smtp.gmail.com with ESMTPSA id i1-20020a170906250100b0077a11b79b9bsm13106350ejb.133.2022.10.22.11.04.28 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Sat, 22 Oct 2022 11:04:28 -0700 (PDT) From: "Basil L. Contovounesios" In-Reply-To: <87wn906765.fsf@tcd.ie> (Basil L. Contovounesios's message of "Sun, 16 Oct 2022 01:41:54 +0300") References: <87r0zaxeox.fsf@tcd.ie> <874jw6xe9h.fsf@tcd.ie> <87wn906765.fsf@tcd.ie> Date: Sat, 22 Oct 2022 21:04:27 +0300 Message-ID: <87czaju444.fsf@tcd.ie> User-Agent: Gnus/5.13 (Gnus v5.13) MIME-Version: 1.0 Content-Type: text/plain X-Spam-Score: -0.0 (/) X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) Basil L. Contovounesios [2022-10-16 01:41 +0300] wrote: > Stefan Monnier [2022-10-15 11:52 -0400] wrote: > >>> -(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)) >> >> The current error is poor (it doesn't include the offending plist, for >> example), so I think changing it (e.g. using the usual >> `wrong-type-argument` error) would be for the better. >> I do wonder whether it's worth the trouble keeping the error here, tho, >> instead of just using `plist-member` directly. > > I was just being conservative, because I don't know where EUDC might get > its data from, or how important it is to catch dubious plists > red-handed. > > I'd be happy to simplify the code, but let's see if Thomas (CCed) has > any comments. Thomas, the patch touching eudc.el can be found at: > https://bugs.gnu.org/58531#8. I've now moved this subdiscussion to https://bugs.gnu.org/58720. -- Basil