From 8d5dfafab7dc40d4b74dc0b56d1b314fd8cac390 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 22 Feb 2021 11:54:17 -0500 Subject: Prefer `declare` over a `put` of `list-indent-function`. While at it, I enabled lexical-binding in the affected files. * lisp/cedet/semantic/sb.el: Enable lexical-binding. (semantic-sb-with-tag-buffer): Use `declare`. * lisp/cedet/semantic/bovine/el.el: Enable lexical-binding. (semantic-elisp-setup-form-parser): Use `declare`. * lisp/emacs-lisp/ert.el: * lisp/emacs-lisp/ert-x.el: Remove redundant `put`. * lisp/emulation/cua-rect.el: Enable lexical-binding. (cua--rectangle-operation, cua--rectangle-aux-replace): Use `declare`. * lisp/mh-e/mh-acros.el: Enable lexical-binding. (mh-do-in-gnu-emacs, mh-do-in-xemacs, mh-funcall-if-exists, defun-mh) (defmacro-mh, with-mh-folder-updating, mh-in-show-buffer) (mh-do-at-event-location, mh-iterate-on-messages-in-region) (mh-iterate-on-range): Use `declare`. * lisp/mh-e/mh-compat.el: Enable lexical-binding. (mh-flet): Use `declare`. * lisp/mh-e/mh-e.el: Enable lexical-binding. (defgroup-mh, defcustom-mh, defface-mh): Use `declare`. * lisp/net/sieve.el: Enable lexical-binding. Remove redundant :group args. (sieve-activate, sieve-remove, sieve-edit-script): Remove unused arg from the interactive spec. (sieve-deactivate-all): Remove unused var `name`. (sieve-change-region): Use `declare`. * lisp/obsolete/fast-lock.el: Enable lexical-binding. Remove redundant :group args. Remove XEmacs compat code. (save-buffer-state): Remove macro. (fast-lock-add-properties): Use `with-silent-modifications` instead. * lisp/obsolete/lazy-lock.el: Enable lexical-binding. Remove redundant :group args. (do-while): Use `declare`. (save-buffer-state): Remove macro. (lazy-lock-fontify-rest-after-change, lazy-lock-defer-line-after-change) (lazy-lock-defer-rest-after-change, lazy-lock-after-fontify-buffer) (lazy-lock-after-unfontify-buffer, lazy-lock-fontify-region): Use `with-silent-modifications` instead. * lisp/obsolete/pgg.el: Enable lexical-binding. Remove XEmacs compat code. (pgg-save-coding-system, pgg-as-lbt, pgg-process-when-success): Use `declare`. (pgg-add-passphrase-to-cache): Remove unused var `new-timer`. (pgg-decrypt-region): Remove unused var `buf`. * lisp/org/org-agenda.el (org-let, org-let2): Move from org-macs and use `declare`. * lisp/org/org-macs.el (org-let, org-let2): Move these functions that are inherently harmful to your karma to the only package that uses them. (org-scroll): Use `pcase` to avoid `eval` and use more readable syntax for those integers standing for events. * lisp/progmodes/antlr-mode.el: Enable lexical-binding. (save-buffer-state-x): Use `declare` and `with-silent-modifications`. * lisp/international/mule-util.el (with-coding-priority): * lisp/cedet/ede/proj-comp.el (proj-comp-insert-variable-once): * lisp/org/org-element.el (org-element-map): * test/lisp/emacs-lisp/bytecomp-tests.el (test-byte-comp-compile-and-load): * test/lisp/emacs-lisp/generator-tests.el (cps-testcase): Use `declare`. --- test/lisp/emacs-lisp/bytecomp-tests.el | 2 +- test/lisp/emacs-lisp/generator-tests.el | 3 +-- 2 files changed, 2 insertions(+), 3 deletions(-) (limited to 'test/lisp/emacs-lisp') diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index 0b70c11b298..fb84596ad3f 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -495,6 +495,7 @@ Subtests signal errors if something goes wrong." (insert "\n")))) (defun test-byte-comp-compile-and-load (compile &rest forms) + (declare (indent 1)) (let ((elfile nil) (elcfile nil)) (unwind-protect @@ -513,7 +514,6 @@ Subtests signal errors if something goes wrong." (load elfile nil 'nomessage)) (when elfile (delete-file elfile)) (when elcfile (delete-file elcfile))))) -(put 'test-byte-comp-compile-and-load 'lisp-indent-function 1) (ert-deftest test-byte-comp-macro-expansion () (test-byte-comp-compile-and-load t diff --git a/test/lisp/emacs-lisp/generator-tests.el b/test/lisp/emacs-lisp/generator-tests.el index ffcd16ad094..a1b9f64fdb1 100644 --- a/test/lisp/emacs-lisp/generator-tests.el +++ b/test/lisp/emacs-lisp/generator-tests.el @@ -45,6 +45,7 @@ BODY twice: once using ordinary `eval' and once using lambda-generators. The test ensures that the two forms produce identical output." + (declare (indent 1)) `(progn (ert-deftest ,name () (should @@ -62,8 +63,6 @@ identical output." (let ((cps-inhibit-atomic-optimization t)) (iter-lambda () (iter-yield (progn ,@body))))))))))) -(put 'cps-testcase 'lisp-indent-function 1) - (defvar *cps-test-i* nil) (defun cps-get-test-i () *cps-test-i*) -- cgit v1.2.3 From d527bc4b7d2f69d8b3ae76be78fb9610419bd800 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 24 Feb 2021 18:12:18 -0500 Subject: * test/lisp/emacs-lisp/macroexp-tests.el (macroexp--tests-file-name): New test * test/lisp/emacs-lisp/macroexp-resources/m1.el: * test/lisp/emacs-lisp/macroexp-resources/m2.el: New files. --- test/lisp/emacs-lisp/macroexp-resources/m1.el | 33 +++++++++++++++++++++++++++ test/lisp/emacs-lisp/macroexp-resources/m2.el | 33 +++++++++++++++++++++++++++ test/lisp/emacs-lisp/macroexp-tests.el | 33 ++++++++++++++++++++++++++- 3 files changed, 98 insertions(+), 1 deletion(-) create mode 100644 test/lisp/emacs-lisp/macroexp-resources/m1.el create mode 100644 test/lisp/emacs-lisp/macroexp-resources/m2.el (limited to 'test/lisp/emacs-lisp') diff --git a/test/lisp/emacs-lisp/macroexp-resources/m1.el b/test/lisp/emacs-lisp/macroexp-resources/m1.el new file mode 100644 index 00000000000..a2fe6ecf2ed --- /dev/null +++ b/test/lisp/emacs-lisp/macroexp-resources/m1.el @@ -0,0 +1,33 @@ +;;; m1.el --- Some sample code for macroexp-tests -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; Author: Stefan Monnier +;; Keywords: + +;; This program 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. + +;; This program 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 this program. If not, see . + +;;; Commentary: + +;; + +;;; Code: + +(defconst macroexp--m1-tests-filename (macroexp-file-name)) + +(eval-when-compile + (defconst macroexp--m1-tests-comp-filename (macroexp-file-name))) + +(provide 'm1) +;;; m1.el ends here diff --git a/test/lisp/emacs-lisp/macroexp-resources/m2.el b/test/lisp/emacs-lisp/macroexp-resources/m2.el new file mode 100644 index 00000000000..4f2b96d8ca0 --- /dev/null +++ b/test/lisp/emacs-lisp/macroexp-resources/m2.el @@ -0,0 +1,33 @@ +;;; m2.el --- More sample code for macroexp-tests -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; Author: Stefan Monnier +;; Keywords: + +;; This program 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. + +;; This program 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 this program. If not, see . + +;;; Commentary: + +;; + +;;; Code: + +(defconst macroexp--m2-tests-filename (macroexp-file-name)) + +(byte-compile-file (expand-file-name + "m1.el" (file-name-directory macroexp--m2-tests-filename))) + +(provide 'm2) +;;; m2.el ends here diff --git a/test/lisp/emacs-lisp/macroexp-tests.el b/test/lisp/emacs-lisp/macroexp-tests.el index 1124e3b8d91..0b26f109b9e 100644 --- a/test/lisp/emacs-lisp/macroexp-tests.el +++ b/test/lisp/emacs-lisp/macroexp-tests.el @@ -1,6 +1,6 @@ ;;; macroexp-tests.el --- Tests for macroexp.el -*- lexical-binding: t; -*- -;; Copyright (C) 2021 Stefan Monnier +;; Copyright (C) 2021 Free Software Foundation, Inc. ;; Author: Stefan Monnier ;; Keywords: @@ -32,5 +32,36 @@ (should (equal (macroexp--fgrep '((x) (y)) '#2=([r] ((a x)) a b c d . #2#)) '((x))))) +(defconst macroexp--tests-filename (macroexp-file-name)) + +(ert-deftest macroexp--tests-file-name () + (should (string-match + "\\`macroexp-tests.elc?\\'" + (file-name-nondirectory macroexp--tests-filename))) + (let ((rsrc-dir (expand-file-name + "macroexp-resources" + (file-name-directory macroexp--tests-filename)))) + (with-current-buffer + (find-file-noselect (expand-file-name "m1.el" rsrc-dir)) + (defvar macroexp--m1-tests-filename) + ;; `macroexp-file-name' should work with `eval-buffer'. + (eval-buffer) + (should (equal "m1.el" + (file-name-nondirectory macroexp--m1-tests-filename))) + (search-forward "macroexp--m1-tests-filename") + (makunbound 'macroexp--m1-tests-filename) + ;; `macroexp-file-name' should also work with `eval-defun'. + (eval-defun nil) + (should (equal "m1.el" + (file-name-nondirectory macroexp--m1-tests-filename)))) + + ;; Test the case where we load a file which byte-compiles another. + (defvar macroexp--m1-tests-comp-filename) + (makunbound 'macroexp--m1-tests-comp-filename) + (load (expand-file-name "m2.el" rsrc-dir)) + (should (equal "m1.el" + (file-name-nondirectory macroexp--m1-tests-comp-filename))))) + + (provide 'macroexp-tests) ;;; macroexp-tests.el ends here -- cgit v1.2.3 From 8114a84b21b2463ea35db7f3a18fd3804396f47e Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 24 Feb 2021 18:39:06 -0500 Subject: * test/lisp/emacs-lisp/macroexp-tests.el (macroexp--tests-file-name): Add case Add use of `macroexp-file-name` from a macro called from within a function, which works thanks to eager-macroexpansion (so the macro is expanded which the file is being loaded rather than only later when the function is called). * test/lisp/emacs-lisp/macroexp-resources/m1.el (macroexp--m1-tests-file-name): New function. --- test/lisp/emacs-lisp/macroexp-resources/m1.el | 3 +++ test/lisp/emacs-lisp/macroexp-tests.el | 5 +++++ 2 files changed, 8 insertions(+) (limited to 'test/lisp/emacs-lisp') diff --git a/test/lisp/emacs-lisp/macroexp-resources/m1.el b/test/lisp/emacs-lisp/macroexp-resources/m1.el index a2fe6ecf2ed..96b5f7091af 100644 --- a/test/lisp/emacs-lisp/macroexp-resources/m1.el +++ b/test/lisp/emacs-lisp/macroexp-resources/m1.el @@ -29,5 +29,8 @@ (eval-when-compile (defconst macroexp--m1-tests-comp-filename (macroexp-file-name))) +(defun macroexp--m1-tests-file-name () + (macroexp--test-get-file-name)) + (provide 'm1) ;;; m1.el ends here diff --git a/test/lisp/emacs-lisp/macroexp-tests.el b/test/lisp/emacs-lisp/macroexp-tests.el index 0b26f109b9e..89d3882d1da 100644 --- a/test/lisp/emacs-lisp/macroexp-tests.el +++ b/test/lisp/emacs-lisp/macroexp-tests.el @@ -34,6 +34,8 @@ (defconst macroexp--tests-filename (macroexp-file-name)) +(defmacro macroexp--test-get-file-name () (macroexp-file-name)) + (ert-deftest macroexp--tests-file-name () (should (string-match "\\`macroexp-tests.elc?\\'" @@ -44,10 +46,13 @@ (with-current-buffer (find-file-noselect (expand-file-name "m1.el" rsrc-dir)) (defvar macroexp--m1-tests-filename) + (declare-function macroexp--m1-tests-file-name "m1" ()) ;; `macroexp-file-name' should work with `eval-buffer'. (eval-buffer) (should (equal "m1.el" (file-name-nondirectory macroexp--m1-tests-filename))) + (should (equal "m1.el" + (file-name-nondirectory (macroexp--m1-tests-file-name)))) (search-forward "macroexp--m1-tests-filename") (makunbound 'macroexp--m1-tests-filename) ;; `macroexp-file-name' should also work with `eval-defun'. -- cgit v1.2.3 From 70f2d658e42120c289c4a3c043b5d5b1331bc183 Mon Sep 17 00:00:00 2001 From: Mattias Engdegård Date: Fri, 26 Feb 2021 09:52:16 +0100 Subject: Fix pcase rx pattern bugs Two unrelated bugs: A missing type check caused an error in rx patterns for non-string match targets, and rx patterns did not work at all in pcase-let or pcase-let*. Second bug reported by Basil Contovounesios and Ag Ibragimov; fixes proposed by Stefan Monnier. Discussion and explanation in thread at https://lists.gnu.org/archive/html/emacs-devel/2021-02/msg01924.html * lisp/emacs-lisp/rx.el (rx): Add (pred stringp) to avoid type errors, and replace the `pred` clause for the actual match with something that works with pcase-let(*) without being optimised away. * test/lisp/emacs-lisp/rx-tests.el (rx-pcase): Add test cases. --- lisp/emacs-lisp/rx.el | 6 +++++- test/lisp/emacs-lisp/rx-tests.el | 12 +++++++++++- 2 files changed, 16 insertions(+), 2 deletions(-) (limited to 'test/lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el index 58584f300c9..ffc21951b64 100644 --- a/lisp/emacs-lisp/rx.el +++ b/lisp/emacs-lisp/rx.el @@ -1437,7 +1437,11 @@ following constructs: construct." (let* ((rx--pcase-vars nil) (regexp (rx--to-expr (rx--pcase-transform (cons 'seq regexps))))) - `(and (pred (string-match ,regexp)) + `(and (pred stringp) + ;; `pcase-let' takes a match for granted and discards all unnecessary + ;; conditions, which means that a `pred' clause cannot be used for + ;; the match condition. The following construct seems to survive. + (app (lambda (s) (string-match ,regexp s)) (pred identity)) ,@(let ((i 0)) (mapcar (lambda (name) (setq i (1+ i)) diff --git a/test/lisp/emacs-lisp/rx-tests.el b/test/lisp/emacs-lisp/rx-tests.el index 12bf4f7978e..fecdcf55aff 100644 --- a/test/lisp/emacs-lisp/rx-tests.el +++ b/test/lisp/emacs-lisp/rx-tests.el @@ -171,7 +171,17 @@ (should (equal (pcase "abc" ((rx (? (let x alpha)) (?? (let y alnum)) ?c) (list x y))) - '("a" "b")))) + '("a" "b"))) + (should (equal (pcase 'not-a-string + ((rx nonl) 'wrong) + (_ 'correct)) + 'correct)) + (should (equal (pcase-let (((rx ?B (let z nonl)) "ABC")) + (list 'ok z)) + '(ok "C"))) + (should (equal (pcase-let* (((rx ?E (let z nonl)) "DEF")) + (list 'ok z)) + '(ok "F")))) (ert-deftest rx-kleene () "Test greedy and non-greedy repetition operators." -- cgit v1.2.3 From bdea1883cc8feb8a607c3d05191e7dc8d12f0aa0 Mon Sep 17 00:00:00 2001 From: Mattias Engdegård Date: Sun, 28 Feb 2021 13:06:24 +0100 Subject: Fix pcase 'rx' pattern match-data bug The pcase 'rx' pattern would in some cases allow the match data to be clobbered before it is read. For example: (pcase "PQR" ((and (rx (let a nonl)) (rx ?z)) (list 'one a)) ((rx (let b ?Q)) (list 'two b))) The above returned (two "P") instead of the correct (two "Q"). This occurred because the calls to string-match and match-string were presented as separate patterns to pcase, which would interleave them with other patterns. As a remedy, combine string matching and match-data extraction into a single pcase pattern. This introduces a slight inefficiency for two or more submatches as they are grouped into a list structure which then has to be destructured. Found by Stefan Monnier. See discussion at https://lists.gnu.org/archive/html/emacs-devel/2021-02/msg02010.html * lisp/emacs-lisp/rx.el (rx--reduce-right): New helper. (rx [pcase macro]): Combine string-match and match-string calls into a single pcase pattern. * test/lisp/emacs-lisp/rx-tests.el (rx-pcase): Add test cases. --- lisp/emacs-lisp/rx.el | 37 +++++++++++++++++++++++++++---------- test/lisp/emacs-lisp/rx-tests.el | 8 ++++++++ 2 files changed, 35 insertions(+), 10 deletions(-) (limited to 'test/lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el index ffc21951b64..56e588ee0d5 100644 --- a/lisp/emacs-lisp/rx.el +++ b/lisp/emacs-lisp/rx.el @@ -1418,6 +1418,12 @@ into a plain rx-expression, collecting names into `rx--pcase-vars'." (cons head (mapcar #'rx--pcase-transform rest))) (_ rx))) +(defun rx--reduce-right (f l) + "Right-reduction on L by F. L must be non-empty." + (if (cdr l) + (funcall f (car l) (rx--reduce-right f (cdr l))) + (car l))) + ;;;###autoload (pcase-defmacro rx (&rest regexps) "A pattern that matches strings against `rx' REGEXPS in sexp form. @@ -1436,17 +1442,28 @@ following constructs: introduced by a previous (let REF ...) construct." (let* ((rx--pcase-vars nil) - (regexp (rx--to-expr (rx--pcase-transform (cons 'seq regexps))))) + (regexp (rx--to-expr (rx--pcase-transform (cons 'seq regexps)))) + (nvars (length rx--pcase-vars))) `(and (pred stringp) - ;; `pcase-let' takes a match for granted and discards all unnecessary - ;; conditions, which means that a `pred' clause cannot be used for - ;; the match condition. The following construct seems to survive. - (app (lambda (s) (string-match ,regexp s)) (pred identity)) - ,@(let ((i 0)) - (mapcar (lambda (name) - (setq i (1+ i)) - `(app (match-string ,i) ,name)) - (reverse rx--pcase-vars)))))) + ,(if (zerop nvars) + ;; No variables bound: a single predicate suffices. + `(pred (string-match ,regexp)) + ;; Pack the submatches into a dotted list which is then + ;; immediately destructured into individual variables again. + ;; This is of course slightly inefficient when NVARS > 1. + ;; A dotted list is used to reduce the number of conses + ;; to create and take apart. + `(app (lambda (s) + (and (string-match ,regexp s) + ,(rx--reduce-right + (lambda (a b) `(cons ,a ,b)) + (mapcar (lambda (i) `(match-string ,i s)) + (number-sequence 1 nvars))))) + ,(list '\` + (rx--reduce-right + #'cons + (mapcar (lambda (name) (list '\, name)) + (reverse rx--pcase-vars))))))))) ;; Obsolete internal symbol, used in old versions of the `flycheck' package. (define-obsolete-function-alias 'rx-submatch-n 'rx-to-string "27.1") diff --git a/test/lisp/emacs-lisp/rx-tests.el b/test/lisp/emacs-lisp/rx-tests.el index fecdcf55aff..2dd1bca22d1 100644 --- a/test/lisp/emacs-lisp/rx-tests.el +++ b/test/lisp/emacs-lisp/rx-tests.el @@ -156,6 +156,8 @@ "....."))) (ert-deftest rx-pcase () + (should (equal (pcase "i18n" ((rx (let x (+ digit))) (list 'ok x))) + '(ok "18"))) (should (equal (pcase "a 1 2 3 1 1 b" ((rx (let u (+ digit)) space (let v (+ digit)) space @@ -176,6 +178,12 @@ ((rx nonl) 'wrong) (_ 'correct)) 'correct)) + (should (equal (pcase "PQR" + ((and (rx (let a nonl)) (rx ?z)) + (list 'one a)) + ((rx (let b ?Q)) + (list 'two b))) + '(two "Q"))) (should (equal (pcase-let (((rx ?B (let z nonl)) "ABC")) (list 'ok z)) '(ok "C"))) -- cgit v1.2.3 From d56b1f9e7cee077011fa1256c2965c2984a17282 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 1 Mar 2021 14:07:05 -0500 Subject: * lisp/emacs-lisp/pcase.el (pcase--split-pred): Re-fix bug#14773 Adjust to calling convention of `macroexp--fgrep`. --- lisp/emacs-lisp/pcase.el | 2 +- test/lisp/emacs-lisp/pcase-tests.el | 8 ++++++++ 2 files changed, 9 insertions(+), 1 deletion(-) (limited to 'test/lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 95e5dd3ba01..b1e1305edfe 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -661,7 +661,7 @@ A and B can be one of: ;; run, but we don't have the environment in which `pat' will ;; run, so we can't do a reliable verification. But let's try ;; and catch at least the easy cases such as (bug#14773). - (not (macroexp--fgrep (mapcar #'car vars) (cadr upat))))) + (not (macroexp--fgrep vars (cadr upat))))) '(:pcase--succeed . :pcase--fail)) ;; In case PAT is of the form (pred (not PRED)) ((and (eq 'pred (car-safe pat)) (eq 'not (car-safe (cadr pat)))) diff --git a/test/lisp/emacs-lisp/pcase-tests.el b/test/lisp/emacs-lisp/pcase-tests.el index e6f4c097504..14384112b34 100644 --- a/test/lisp/emacs-lisp/pcase-tests.el +++ b/test/lisp/emacs-lisp/pcase-tests.el @@ -75,6 +75,14 @@ (ert-deftest pcase-tests-vectors () (should (equal (pcase [1 2] (`[,x] 1) (`[,x ,y] (+ x y))) 3))) +(ert-deftest pcase-tests-bug14773 () + (let ((f (lambda (x) + (pcase 'dummy + ((and (let var x) (guard var)) 'left) + ((and (let var (not x)) (guard var)) 'right))))) + (should (equal (funcall f t) 'left)) + (should (equal (funcall f nil) 'right)))) + ;; Local Variables: ;; no-byte-compile: t ;; End: -- cgit v1.2.3 From 0d827c7f52b92aaffe751cf937427938f1ac67de Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 1 Mar 2021 15:35:51 -0500 Subject: * lisp/emacs-lisp/pcase.el: Fix bug#46786 Revert commit a218c9861573b5ec4979ff2662f5c0343397e3ff, but in order to avoid the spurious warnings that this commit tried to squash, keep track of the vars used during the match so as to add corresponding annotations to explicitly silence the spurious warnings. To do this, we change the VARS used in `pcase-u` (and throughout the pcase code): they used to hold elements of the form (NAME . VAL) and now they hold elements of the form (NAME VAL . USED). (pcase--expand): Bind all vars instead of only those found via fgrep. (pcase-codegen): Silence "unused var" warnings for those vars that have already been referenced during the match itself. (pcase--funcall, pcase--eval): Record the vars that are used. (pcase--u1): Record the vars that are used via non-linear patterns. * lisp/textmodes/mhtml-mode.el (mhtml-forward): * lisp/vc/diff-mode.el (diff-goto-source): Silence newly discovered warnings. * test/lisp/emacs-lisp/pcase-tests.el (pcase-tests-bug46786): New test. --- lisp/emacs-lisp/pcase.el | 60 ++++++++++++++++++++++--------------- lisp/textmodes/mhtml-mode.el | 2 +- lisp/vc/diff-mode.el | 2 +- test/lisp/emacs-lisp/pcase-tests.el | 7 +++++ 4 files changed, 45 insertions(+), 26 deletions(-) (limited to 'test/lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index b1e1305edfe..0fa1b980a0f 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -328,8 +328,7 @@ of the elements of LIST is performed as if by `pcase-let'. (seen '()) (codegen (lambda (code vars) - (let ((vars (macroexp--fgrep vars code)) - (prev (assq code seen))) + (let ((prev (assq code seen))) (if (not prev) (let ((res (pcase-codegen code vars))) (push (list code vars res) seen) @@ -354,14 +353,14 @@ of the elements of LIST is performed as if by `pcase-let'. (push `(,bsym (lambda ,(mapcar #'car prevvars) ,@code)) defs) (setcar res 'funcall) - (setcdr res (cons bsym (mapcar #'cdr prevvars))) + (setcdr res (cons bsym (mapcar #'cadr prevvars))) (setcar (cddr prev) bsym) (setq res bsym))) (setq vars (copy-sequence vars)) (let ((args (mapcar (lambda (pa) (let ((v (assq (car pa) vars))) (setq vars (delq v vars)) - (cdr v))) + (cadr v))) prevvars))) ;; If some of `vars' were not found in `prevvars', that's ;; OK it just means those vars aren't present in all @@ -383,9 +382,7 @@ of the elements of LIST is performed as if by `pcase-let'. (if (pcase--small-branch-p (cdr case)) ;; Don't bother sharing multiple ;; occurrences of this leaf since it's small. - (lambda (code vars) - (pcase-codegen code - (macroexp--fgrep vars code))) + #'pcase-codegen codegen) (cdr case) vars)))) @@ -452,10 +449,15 @@ for the result of evaluating EXP (first arg to `pcase'). ;; Don't use let*, otherwise macroexp-let* may merge it with some surrounding ;; let* which might prevent the setcar/setcdr in pcase--expand's fancy ;; codegen from later metamorphosing this let into a funcall. - (if vars - `(let ,(mapcar (lambda (b) (list (car b) (cdr b))) vars) - ,@code) - `(progn ,@code))) + (if (null vars) + `(progn ,@code) + `(let ,(mapcar (lambda (b) (list (car b) (cadr b))) vars) + ;; Try and silence some of the most common spurious "unused + ;; var" warnings. + ,@(delq nil (mapcar (lambda (var) + (if (cddr var) `(ignore ,(car var)))) + vars)) + ,@code))) (defun pcase--small-branch-p (code) (and (= 1 (length code)) @@ -497,11 +499,14 @@ for the result of evaluating EXP (first arg to `pcase'). "Expand matcher for rules BRANCHES. Each BRANCH has the form (MATCH CODE . VARS) where CODE is the code generator for that branch. -VARS is the set of vars already bound by earlier matches. MATCH is the pattern that needs to be matched, of the form: (match VAR . PAT) (and MATCH ...) - (or MATCH ...)" + (or MATCH ...) +VARS is the set of vars already bound by earlier matches. +It is a list of (NAME VAL . USED) where NAME is the variable's symbol, +VAL is the expression to which it should be bound and USED is a boolean +recording whether the var has been referenced by earlier parts of the match." (when (setq branches (delq nil branches)) (let* ((carbranch (car branches)) (match (car carbranch)) (cdarbranch (cdr carbranch)) @@ -748,8 +753,11 @@ A and B can be one of: ((symbolp fun) `(,fun ,arg)) ((eq 'not (car-safe fun)) `(not ,(pcase--funcall (cadr fun) arg vars))) (t - (let* (;; `env' is an upper bound on the bindings we need. - (env (mapcar (lambda (x) (list (car x) (cdr x))) + (let* (;; `env' is hopefully an upper bound on the bindings we need, + ;; FIXME: See bug#46786 for a counter example :-( + (env (mapcar (lambda (x) + (setcdr (cdr x) 'used) + (list (car x) (cadr x))) (macroexp--fgrep vars fun))) (call (progn (when (assq arg env) @@ -757,7 +765,7 @@ A and B can be one of: (let ((newsym (gensym "x"))) (push (list newsym arg) env) (setq arg newsym))) - (if (functionp fun) + (if (or (functionp fun) (not (consp fun))) `(funcall #',fun ,arg) `(,@fun ,arg))))) (if (null env) @@ -770,10 +778,12 @@ A and B can be one of: (defun pcase--eval (exp vars) "Build an expression that will evaluate EXP." (let* ((found (assq exp vars))) - (if found (cdr found) + (if found (progn (setcdr (cdr found) 'used) (cadr found)) (let* ((env (macroexp--fgrep vars exp))) (if env - (macroexp-let* (mapcar (lambda (x) (list (car x) (cdr x))) + (macroexp-let* (mapcar (lambda (x) + (setcdr (cdr x) 'used) + (list (car x) (cadr x))) env) exp) exp))))) @@ -865,12 +875,14 @@ Otherwise, it defers to REST which is a list of branches of the form (pcase--u else-rest)))) ((and (symbolp upat) upat) (pcase--mark-used sym) - (if (not (assq upat vars)) - (pcase--u1 matches code (cons (cons upat sym) vars) rest) - ;; Non-linear pattern. Turn it into an `eq' test. - (pcase--u1 (cons `(match ,sym . (pred (eql ,(cdr (assq upat vars))))) - matches) - code vars rest))) + (let ((v (assq upat vars))) + (if (not v) + (pcase--u1 matches code (cons (list upat sym) vars) rest) + ;; Non-linear pattern. Turn it into an `eq' test. + (setq (cddr v) 'used) + (pcase--u1 (cons `(match ,sym . (pred (eql ,(cadr v)))) + matches) + code vars rest)))) ((eq (car-safe upat) 'app) ;; A upat of the form (app FUN PAT) (pcase--mark-used sym) diff --git a/lisp/textmodes/mhtml-mode.el b/lisp/textmodes/mhtml-mode.el index 32542d0400f..25905385685 100644 --- a/lisp/textmodes/mhtml-mode.el +++ b/lisp/textmodes/mhtml-mode.el @@ -313,7 +313,7 @@ Prefix arg specifies how many times to move (default 1)." (interactive "P") (pcase (get-text-property (point) 'mhtml-submode) ('nil (sgml-skip-tag-forward arg)) - (submode (forward-sexp arg)))) + (_submode (forward-sexp arg)))) ;;;###autoload (define-derived-mode mhtml-mode html-mode diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index 8bbab467af3..342b4cc32b1 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -2003,7 +2003,7 @@ revision of the file otherwise." (if event (posn-set-point (event-end event))) (let ((buffer (when event (current-buffer))) (reverse (not (save-excursion (beginning-of-line) (looking-at "[-<]"))))) - (pcase-let ((`(,buf ,line-offset ,pos ,src ,_dst ,switched) + (pcase-let ((`(,buf ,_line-offset ,pos ,src ,_dst ,_switched) (diff-find-source-location other-file reverse))) (pop-to-buffer buf) (goto-char (+ (car pos) (cdr src))) diff --git a/test/lisp/emacs-lisp/pcase-tests.el b/test/lisp/emacs-lisp/pcase-tests.el index 14384112b34..6ddeb7b622b 100644 --- a/test/lisp/emacs-lisp/pcase-tests.el +++ b/test/lisp/emacs-lisp/pcase-tests.el @@ -83,6 +83,13 @@ (should (equal (funcall f t) 'left)) (should (equal (funcall f nil) 'right)))) +(ert-deftest pcase-tests-bug46786 () + (let ((self 'outer)) + (should (equal (cl-macrolet ((show-self () `(list 'self self))) + (pcase-let ((`(,self ,self2) '(inner "2"))) + (show-self))) + '(self inner))))) + ;; Local Variables: ;; no-byte-compile: t ;; End: -- cgit v1.2.3 From 165353674e5fe7109ba9cbf526de0333902b7851 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 1 Mar 2021 23:57:34 -0500 Subject: * lisp/emacs-lisp/pcase.el: Bind all the vars in `or` patterns Improve the handling of `or` patterns where not all sub-patterns bind the same set of variables. This used to be "unsupported" and behaved in somewhat unpredictable ways. (pcase--expand): Rewrite. (pcase-codegen): Delete. * doc/lispref/control.texi (pcase Macro): Adjust accordingly. Also remove the warning about "at least two" sub patterns. These work fine, AFAICT, and if not we should fix it. * test/lisp/emacs-lisp/pcase-tests.el (pcase-tests-or-vars): New test. --- doc/lispref/control.texi | 12 +-- etc/NEWS | 5 ++ lisp/emacs-lisp/pcase.el | 141 +++++++++++++++++------------------- test/lisp/emacs-lisp/pcase-tests.el | 14 +++- 4 files changed, 86 insertions(+), 86 deletions(-) (limited to 'test/lisp/emacs-lisp') diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi index 80e9eb7dd8e..3388102f694 100644 --- a/doc/lispref/control.texi +++ b/doc/lispref/control.texi @@ -617,17 +617,13 @@ match, @code{and} matches. @item (or @var{pattern1} @var{pattern2}@dots{}) Attempts to match @var{pattern1}, @var{pattern2}, @dots{}, in order, until one of them succeeds. In that case, @code{or} likewise matches, -and the rest of the sub-patterns are not tested. (Note that there -must be at least two sub-patterns. -Simply @w{@code{(or @var{pattern1})}} signals error.) -@c Issue: Is this correct and intended? -@c Are there exceptions, qualifications? -@c (Btw, ``Please avoid it'' is a poor error message.) +and the rest of the sub-patterns are not tested. To present a consistent environment (@pxref{Intro Eval}) to @var{body-forms} (thus avoiding an evaluation error on match), -if any of the sub-patterns let-binds a set of symbols, -they @emph{must} all bind the same set of symbols. +the set of variables bound by the pattern is the union of the +variables bound by each sub-pattern. If a variable is not bound by +the sub-pattern that matched, then it is bound to @code{nil}. @ifnottex @anchor{rx in pcase} diff --git a/etc/NEWS b/etc/NEWS index d01b532193d..73f136cfa7a 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -387,6 +387,11 @@ in text mode. The cursor still only actually blinks in GUI frames. *** New macro 'bindat-spec' to define specs, with Edebug support ** pcase ++++ +*** The 'or' pattern now binds the union of the vars of its sub-patterns +If a variable is not bound by the subpattern that matched, it gets bound +to nil. This was already sometimes the case, but it is now guaranteed. + +++ *** The 'pred' pattern can now take the form '(pred (not FUN))'. This is like '(pred (lambda (x) (not (FUN x))))' but results diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 0fa1b980a0f..c565687896a 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -326,69 +326,76 @@ of the elements of LIST is performed as if by `pcase-let'. (macroexp-let2 macroexp-copyable-p val exp (let* ((defs ()) (seen '()) - (codegen - (lambda (code vars) - (let ((prev (assq code seen))) - (if (not prev) - (let ((res (pcase-codegen code vars))) - (push (list code vars res) seen) - res) - ;; Since we use a tree-based pattern matching - ;; technique, the leaves (the places that contain the - ;; code to run once a pattern is matched) can get - ;; copied a very large number of times, so to avoid - ;; code explosion, we need to keep track of how many - ;; times we've used each leaf and move it - ;; to a separate function if that number is too high. - ;; - ;; We've already used this branch. So it is shared. - (let* ((code (car prev)) (cdrprev (cdr prev)) - (prevvars (car cdrprev)) (cddrprev (cdr cdrprev)) - (res (car cddrprev))) - (unless (symbolp res) - ;; This is the first repeat, so we have to move - ;; the branch to a separate function. - (let ((bsym - (make-symbol (format "pcase-%d" (length defs))))) - (push `(,bsym (lambda ,(mapcar #'car prevvars) ,@code)) - defs) - (setcar res 'funcall) - (setcdr res (cons bsym (mapcar #'cadr prevvars))) - (setcar (cddr prev) bsym) - (setq res bsym))) - (setq vars (copy-sequence vars)) - (let ((args (mapcar (lambda (pa) - (let ((v (assq (car pa) vars))) - (setq vars (delq v vars)) - (cadr v))) - prevvars))) - ;; If some of `vars' were not found in `prevvars', that's - ;; OK it just means those vars aren't present in all - ;; branches, so they can be used within the pattern - ;; (e.g. by a `guard/let/pred') but not in the branch. - ;; FIXME: But if some of `prevvars' are not in `vars' we - ;; should remove them from `prevvars'! - `(funcall ,res ,@args))))))) - (used-cases ()) (main (pcase--u - (mapcar (lambda (case) - `(,(pcase--match val (pcase--macroexpand (car case))) - ,(lambda (vars) - (unless (memq case used-cases) - ;; Keep track of the cases that are used. - (push case used-cases)) - (funcall - (if (pcase--small-branch-p (cdr case)) - ;; Don't bother sharing multiple - ;; occurrences of this leaf since it's small. - #'pcase-codegen - codegen) - (cdr case) - vars)))) - cases)))) + (mapcar + (lambda (case) + `(,(pcase--match val (pcase--macroexpand (car case))) + ,(lambda (vars) + (let ((prev (assq case seen)) + (code (cdr case))) + (unless prev + ;; Keep track of the cases that are used. + (push (setq prev (list case)) seen)) + (if (member code '(nil (nil))) nil + ;; Put `code' in the cdr just so that not all + ;; branches look identical (to avoid things like + ;; `macroexp--if' optimizing them too optimistically). + (let ((ph (list 'pcase--placeholder code))) + (setcdr prev (cons (cons vars ph) (cdr prev))) + ph)))))) + cases)))) + ;; Take care of the place holders now. + (dolist (branch seen) + (let ((code (cdar branch)) + (uses (cdr branch))) + ;; Find all the vars that are in scope (the union of the + ;; vars provided in each use case). + (let* ((allvarinfo '()) + (_ (dolist (use uses) + (dolist (v (car use)) + (let ((vi (assq (car v) allvarinfo))) + (if vi + (if (cddr v) (setcdr vi 'used)) + (push (cons (car v) (cddr v)) allvarinfo)))))) + (allvars (mapcar #'car allvarinfo)) + (ignores (mapcar (lambda (vi) (when (cdr vi) `(ignore ,(car vi)))) + allvarinfo))) + ;; Since we use a tree-based pattern matching + ;; technique, the leaves (the places that contain the + ;; code to run once a pattern is matched) can get + ;; copied a very large number of times, so to avoid + ;; code explosion, we need to keep track of how many + ;; times we've used each leaf and move it + ;; to a separate function if that number is too high. + (if (or (null (cdr uses)) (pcase--small-branch-p code)) + (dolist (use uses) + (let ((vars (car use)) + (placeholder (cdr use))) + ;; (cl-assert (eq (car placeholder) 'pcase--placeholder)) + (setcar placeholder 'let) + (setcdr placeholder + `(,(mapcar (lambda (v) (list v (cadr (assq v vars)))) + allvars) + ;; Try and silence some of the most common + ;; spurious "unused var" warnings. + ,@ignores + ,@code)))) + ;; Several occurrence of this non-small branch in the output. + (let ((bsym + (make-symbol (format "pcase-%d" (length defs))))) + (push `(,bsym (lambda ,allvars ,@ignores ,@code)) defs) + (dolist (use uses) + (let ((vars (car use)) + (placeholder (cdr use))) + ;; (cl-assert (eq (car placeholder) 'pcase--placeholder)) + (setcar placeholder 'funcall) + (setcdr placeholder + `(,bsym + ,@(mapcar (lambda (v) (cadr (assq v vars))) + allvars)))))))))) (dolist (case cases) - (unless (or (memq case used-cases) + (unless (or (assq case seen) (memq (car case) pcase--dontwarn-upats)) (message "pcase pattern %S shadowed by previous pcase pattern" (car case)))) @@ -445,20 +452,6 @@ for the result of evaluating EXP (first arg to `pcase'). (t `(match ,val . ,upat)))) -(defun pcase-codegen (code vars) - ;; Don't use let*, otherwise macroexp-let* may merge it with some surrounding - ;; let* which might prevent the setcar/setcdr in pcase--expand's fancy - ;; codegen from later metamorphosing this let into a funcall. - (if (null vars) - `(progn ,@code) - `(let ,(mapcar (lambda (b) (list (car b) (cadr b))) vars) - ;; Try and silence some of the most common spurious "unused - ;; var" warnings. - ,@(delq nil (mapcar (lambda (var) - (if (cddr var) `(ignore ,(car var)))) - vars)) - ,@code))) - (defun pcase--small-branch-p (code) (and (= 1 (length code)) (or (not (consp (car code))) diff --git a/test/lisp/emacs-lisp/pcase-tests.el b/test/lisp/emacs-lisp/pcase-tests.el index 6ddeb7b622b..2120139ec18 100644 --- a/test/lisp/emacs-lisp/pcase-tests.el +++ b/test/lisp/emacs-lisp/pcase-tests.el @@ -85,13 +85,19 @@ (ert-deftest pcase-tests-bug46786 () (let ((self 'outer)) + (ignore self) (should (equal (cl-macrolet ((show-self () `(list 'self self))) - (pcase-let ((`(,self ,self2) '(inner "2"))) + (pcase-let ((`(,self ,_self2) '(inner "2"))) (show-self))) '(self inner))))) -;; Local Variables: -;; no-byte-compile: t -;; End: +(ert-deftest pcase-tests-or-vars () + (let ((f (lambda (v) + (pcase v + ((or (and 'b1 (let x1 4) (let x2 5)) + (and 'b2 (let y1 8) (let y2 9))) + (list x1 x2 y1 y2)))))) + (should (equal (funcall f 'b1) '(4 5 nil nil))) + (should (equal (funcall f 'b2) '(nil nil 8 9))))) ;;; pcase-tests.el ends here. -- cgit v1.2.3 From 2b069c67d7410703898dfab8b337359322fcf123 Mon Sep 17 00:00:00 2001 From: Pip Cet Date: Sun, 28 Feb 2021 19:43:09 +0000 Subject: Compile closures that modify their bound vars correctly (Bug#46834) * lisp/emacs-lisp/bytecomp.el (byte-compile--reify-function): Don't move let bindings into the lambda. Don't reverse list of bindings. (byte-compile): Evaluate the return value if it was previously reified. * test/lisp/emacs-lisp/bytecomp-tests.el (bytecomp-reify-function): Add tests. --- lisp/emacs-lisp/bytecomp.el | 46 +++++++++++++++++----------------- test/lisp/emacs-lisp/bytecomp-tests.el | 23 +++++++++++++++++ 2 files changed, 46 insertions(+), 23 deletions(-) (limited to 'test/lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index a2fe37a1ee5..4e00fe6121e 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2785,16 +2785,12 @@ FUN should be either a `lambda' value or a `closure' value." (dolist (binding env) (cond ((consp binding) - ;; We check shadowing by the args, so that the `let' can be moved - ;; within the lambda, which can then be unfolded. FIXME: Some of those - ;; bindings might be unused in `body'. - (unless (memq (car binding) args) ;Shadowed. - (push `(,(car binding) ',(cdr binding)) renv))) + (push `(,(car binding) ',(cdr binding)) renv)) ((eq binding t)) (t (push `(defvar ,binding) body)))) (if (null renv) `(lambda ,args ,@preamble ,@body) - `(lambda ,args ,@preamble (let ,(nreverse renv) ,@body))))) + `(let ,renv (lambda ,args ,@preamble ,@body))))) ;;;###autoload (defun byte-compile (form) @@ -2819,23 +2815,27 @@ If FORM is a lambda or a macro, byte-compile it as a function." (if (symbolp form) form "provided")) fun) (t - (when (or (symbolp form) (eq (car-safe fun) 'closure)) - ;; `fun' is a function *value*, so try to recover its corresponding - ;; source code. - (setq lexical-binding (eq (car fun) 'closure)) - (setq fun (byte-compile--reify-function fun))) - ;; Expand macros. - (setq fun (byte-compile-preprocess fun)) - (setq fun (byte-compile-top-level fun nil 'eval)) - (if (symbolp form) - ;; byte-compile-top-level returns an *expression* equivalent to the - ;; `fun' expression, so we need to evaluate it, tho normally - ;; this is not needed because the expression is just a constant - ;; byte-code object, which is self-evaluating. - (setq fun (eval fun t))) - (if macro (push 'macro fun)) - (if (symbolp form) (fset form fun)) - fun)))))) + (let (final-eval) + (when (or (symbolp form) (eq (car-safe fun) 'closure)) + ;; `fun' is a function *value*, so try to recover its corresponding + ;; source code. + (setq lexical-binding (eq (car fun) 'closure)) + (setq fun (byte-compile--reify-function fun)) + (setq final-eval t)) + ;; Expand macros. + (setq fun (byte-compile-preprocess fun)) + (setq fun (byte-compile-top-level fun nil 'eval)) + (if (symbolp form) + ;; byte-compile-top-level returns an *expression* equivalent to the + ;; `fun' expression, so we need to evaluate it, tho normally + ;; this is not needed because the expression is just a constant + ;; byte-code object, which is self-evaluating. + (setq fun (eval fun t))) + (if final-eval + (setq fun (eval fun t))) + (if macro (push 'macro fun)) + (if (symbolp form) (fset form fun)) + fun))))))) (defun byte-compile-sexp (sexp) "Compile and return SEXP." diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index fb84596ad3f..03c267ccd0f 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -1199,6 +1199,29 @@ interpreted and compiled." (should (equal (funcall (eval fun t)) '(c d))) (should (equal (funcall (byte-compile fun)) '(c d)))))) +(ert-deftest bytecomp-reify-function () + "Check that closures that modify their bound variables are +compiled correctly." + (cl-letf ((lexical-binding t) + ((symbol-function 'counter) nil)) + (let ((x 0)) + (defun counter () (cl-incf x)) + (should (equal (counter) 1)) + (should (equal (counter) 2)) + ;; byte compiling should not cause counter to always return the + ;; same value (bug#46834) + (byte-compile 'counter) + (should (equal (counter) 3)) + (should (equal (counter) 4))) + (let ((x 0)) + (let ((x 1)) + (defun counter () x) + (should (equal (counter) 1)) + ;; byte compiling should not cause the outer binding to shadow + ;; the inner one (bug#46834) + (byte-compile 'counter) + (should (equal (counter) 1)))))) + ;; Local Variables: ;; no-byte-compile: t ;; End: -- cgit v1.2.3 From 986bf7ac0dbfee0522cbe1e89872309d3a4f182c Mon Sep 17 00:00:00 2001 From: Mauro Aranda Date: Thu, 4 Mar 2021 10:13:26 -0300 Subject: Remove duplicated tests in checkdoc-tests.el * test/lisp/emacs-lisp/checkdoc-tests.el (checkdoc-cl-defmethod-ok) (checkdoc-cl-defmethod-with-types-ok, checkdoc-cl-defun-with-key-ok) (checkdoc-cl-defun-with-allow-other-keys-ok) (checkdoc-cl-defun-with-default-optional-value-ok) (checkdoc-cl-defun-with-destructuring-ok): This tests were duplicated, so keep one copy of them. Checked by diffing two files with the suspected tests, and supported by the fact that running occur with the regexp "^(ert-deftest" reported 14 matches, while the tests being run were 8. --- test/lisp/emacs-lisp/checkdoc-tests.el | 45 ---------------------------------- 1 file changed, 45 deletions(-) (limited to 'test/lisp/emacs-lisp') diff --git a/test/lisp/emacs-lisp/checkdoc-tests.el b/test/lisp/emacs-lisp/checkdoc-tests.el index cf7baf4ce44..93015fbb105 100644 --- a/test/lisp/emacs-lisp/checkdoc-tests.el +++ b/test/lisp/emacs-lisp/checkdoc-tests.el @@ -82,51 +82,6 @@ (insert "(cl-defun foo ((a b &optional c) d) \"Return A+B+C+D.\")") (checkdoc-defun))) -(ert-deftest checkdoc-cl-defmethod-ok () - "Checkdoc should be happy with a simple correct cl-defmethod." - (with-temp-buffer - (emacs-lisp-mode) - (insert "(cl-defmethod foo (a) \"Return A.\")") - (checkdoc-defun))) - -(ert-deftest checkdoc-cl-defmethod-with-types-ok () - "Checkdoc should be happy with a cl-defmethod using types." - (with-temp-buffer - (emacs-lisp-mode) - ;; this method matches if A is the symbol `smthg' and if b is a list: - (insert "(cl-defmethod foo ((a (eql smthg)) (b list)) \"Return A+B.\")") - (checkdoc-defun))) - -(ert-deftest checkdoc-cl-defun-with-key-ok () - "Checkdoc should be happy with a cl-defun using &key." - (with-temp-buffer - (emacs-lisp-mode) - (insert "(cl-defun foo (&key a (b 27)) \"Return :A+:B.\")") - (checkdoc-defun))) - -(ert-deftest checkdoc-cl-defun-with-allow-other-keys-ok () - "Checkdoc should be happy with a cl-defun using &allow-other-keys." - (with-temp-buffer - (emacs-lisp-mode) - (insert "(cl-defun foo (&key a &allow-other-keys) \"Return :A.\")") - (checkdoc-defun))) - -(ert-deftest checkdoc-cl-defun-with-default-optional-value-ok () - "Checkdoc should be happy with a cl-defun using default values for optional args." - (with-temp-buffer - (emacs-lisp-mode) - ;; B is optional and equals 1+a if not provided. HAS-BS is non-nil - ;; if B was provided in the call: - (insert "(cl-defun foo (a &optional (b (1+ a) has-bs)) \"Return A + B.\")") - (checkdoc-defun))) - -(ert-deftest checkdoc-cl-defun-with-destructuring-ok () - "Checkdoc should be happy with a cl-defun destructuring its arguments." - (with-temp-buffer - (emacs-lisp-mode) - (insert "(cl-defun foo ((a b &optional c) d) \"Return A+B+C+D.\")") - (checkdoc-defun))) - (ert-deftest checkdoc-tests--next-docstring () "Checks that the one-argument form of `defvar' works. See the comments in Bug#24998." -- cgit v1.2.3 From fd9202304c8e08665c5dd468cdd56b523ffc7997 Mon Sep 17 00:00:00 2001 From: Mauro Aranda Date: Thu, 4 Mar 2021 08:34:58 -0300 Subject: Make checkdoc work with qualified methods * lisp/emacs-lisp/checkdoc.el (checkdoc--next-docstring): Handle cl-defmethod in a case of its own. Check for the presence of qualifiers, and skip them accordingly until the docstring. * test/lisp/emacs-lisp/checkdoc-tests.el (checkdoc-cl-defmethod-qualified-ok) (checkdoc-cl-defmethod-with-extra-qualifier-ok) (checkdoc-cl-defmethod-with-extra-and-nil-args-ok): Add tests for the fix. --- lisp/emacs-lisp/checkdoc.el | 21 ++++++++++++++++++++- test/lisp/emacs-lisp/checkdoc-tests.el | 27 +++++++++++++++++++++++++++ 2 files changed, 47 insertions(+), 1 deletion(-) (limited to 'test/lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index 75aefdc7ba0..213ab43184f 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -932,7 +932,7 @@ don't move point." ;; definition ends prematurely. (end-of-file))) (`(,(or 'defun 'defvar 'defcustom 'defmacro 'defconst 'defsubst 'defadvice - 'cl-defun 'cl-defgeneric 'cl-defmethod 'cl-defmacro) + 'cl-defun 'cl-defgeneric 'cl-defmacro) ,(pred symbolp) ;; Require an initializer, i.e. ignore single-argument `defvar' ;; forms, which never have a doc string. @@ -942,6 +942,25 @@ don't move point." ;; initializer or argument list. (forward-sexp 3) (skip-chars-forward " \n\t") + t) + (`(,'cl-defmethod + ,(pred symbolp) + . ,rest) + (down-list) + (forward-sexp (pcase (car rest) + ;; No qualifier, so skip like we would have skipped in + ;; the first clause of the outer `pcase'. + ((pred listp) 3) + (':extra + ;; Skip the :extra qualifier together with its string too. + ;; Skip any additional qualifier. + (if (memq (nth 2 rest) '(:around :before :after)) + 6 + 5)) + ;; Skip :before, :after or :around qualifier too. + ((or ':around ':before ':after) + 4))) + (skip-chars-forward " \n\t") t))) ;;;###autoload diff --git a/test/lisp/emacs-lisp/checkdoc-tests.el b/test/lisp/emacs-lisp/checkdoc-tests.el index 93015fbb105..7a7aa9fb3cd 100644 --- a/test/lisp/emacs-lisp/checkdoc-tests.el +++ b/test/lisp/emacs-lisp/checkdoc-tests.el @@ -52,6 +52,33 @@ (insert "(cl-defmethod foo ((a (eql smthg)) (b list)) \"Return A+B.\")") (checkdoc-defun))) +(ert-deftest checkdoc-cl-defmethod-qualified-ok () + "Checkdoc should be happy with a `cl-defmethod' using qualifiers." + (with-temp-buffer + (emacs-lisp-mode) + (insert "(cl-defmethod test :around ((a (eql smthg))) \"Return A.\")") + (checkdoc-defun))) + +(ert-deftest checkdoc-cl-defmethod-with-extra-qualifier-ok () + "Checkdoc should be happy with a :extra qualified `cl-defmethod'." + (with-temp-buffer + (emacs-lisp-mode) + (insert "(cl-defmethod foo :extra \"foo\" ((a (eql smthg))) \"Return A.\")") + (checkdoc-defun)) + + (with-temp-buffer + (emacs-lisp-mode) + (insert + "(cl-defmethod foo :extra \"foo\" :after ((a (eql smthg))) \"Return A.\")") + (checkdoc-defun))) + +(ert-deftest checkdoc-cl-defmethod-with-extra-qualifier-and-nil-args-ok () + "Checkdoc should be happy with a 0-arity :extra qualified `cl-defmethod'." + (with-temp-buffer + (emacs-lisp-mode) + (insert "(cl-defmethod foo :extra \"foo\" () \"Return A.\")") + (checkdoc-defun))) + (ert-deftest checkdoc-cl-defun-with-key-ok () "Checkdoc should be happy with a cl-defun using &key." (with-temp-buffer -- cgit v1.2.3 From 03ada27cb81dabb87eff38f2d66fe8fc4a02da46 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 5 Mar 2021 13:31:16 -0500 Subject: * lisp/emacs-lisp/bindat.el: Minor refactoring (bindat--unpack-str, bindat--unpack-strz, bindat--unpack-bits): New functions, extracted from `bindat--unpack-item`. (bindat--unpack-item): Use them. (bindat--align): New function. (bindat--unpack-group, bindat--length-group, bindat--pack-group): Use it. (bindat-get-field): Allow integers to index both lists (as returned by `repeat`) and vectors (as returned by `vec`). (bindat--pack-str, bindat--pack-bits): New functions, extracted from `bindat--pack-item`. (bindat--pack-item): Use them. * test/lisp/emacs-lisp/bindat-tests.el (struct-bindat): Place the fields in the order in which they appear in the structs. --- lisp/emacs-lisp/bindat.el | 139 ++++++++++++++++++----------------- test/lisp/emacs-lisp/bindat-tests.el | 26 +++---- 2 files changed, 83 insertions(+), 82 deletions(-) (limited to 'test/lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el index b1b2144e3de..830e61f8516 100644 --- a/lisp/emacs-lisp/bindat.el +++ b/lisp/emacs-lisp/bindat.el @@ -201,7 +201,7 @@ (defvar bindat-raw) (defvar bindat-idx) -(defun bindat--unpack-u8 () +(defsubst bindat--unpack-u8 () (prog1 (aref bindat-raw bindat-idx) (setq bindat-idx (1+ bindat-idx)))) @@ -230,47 +230,50 @@ (defun bindat--unpack-u64r () (logior (bindat--unpack-u32r) (ash (bindat--unpack-u32r) 32))) +(defun bindat--unpack-str (len) + (let ((s (substring bindat-raw bindat-idx (+ bindat-idx len)))) + (setq bindat-idx (+ bindat-idx len)) + (if (stringp s) s + (apply #'unibyte-string s)))) + +(defun bindat--unpack-strz (len) + (let ((i 0) s) + (while (and (< i len) (/= (aref bindat-raw (+ bindat-idx i)) 0)) + (setq i (1+ i))) + (setq s (substring bindat-raw bindat-idx (+ bindat-idx i))) + (setq bindat-idx (+ bindat-idx len)) + (if (stringp s) s + (apply #'unibyte-string s)))) + +(defun bindat--unpack-bits (len) + (let ((bits nil) (bnum (1- (* 8 len))) j m) + (while (>= bnum 0) + (if (= (setq m (bindat--unpack-u8)) 0) + (setq bnum (- bnum 8)) + (setq j 128) + (while (> j 0) + (if (/= 0 (logand m j)) + (setq bits (cons bnum bits))) + (setq bnum (1- bnum) + j (ash j -1))))) + bits)) + (defun bindat--unpack-item (type len &optional vectype) (if (eq type 'ip) (setq type 'vec len 4)) (pcase type - ((or 'u8 'byte) - (bindat--unpack-u8)) - ((or 'u16 'word 'short) - (bindat--unpack-u16)) + ((or 'u8 'byte) (bindat--unpack-u8)) + ((or 'u16 'word 'short) (bindat--unpack-u16)) ('u24 (bindat--unpack-u24)) - ((or 'u32 'dword 'long) - (bindat--unpack-u32)) + ((or 'u32 'dword 'long) (bindat--unpack-u32)) ('u64 (bindat--unpack-u64)) ('u16r (bindat--unpack-u16r)) ('u24r (bindat--unpack-u24r)) ('u32r (bindat--unpack-u32r)) ('u64r (bindat--unpack-u64r)) - ('bits - (let ((bits nil) (bnum (1- (* 8 len))) j m) - (while (>= bnum 0) - (if (= (setq m (bindat--unpack-u8)) 0) - (setq bnum (- bnum 8)) - (setq j 128) - (while (> j 0) - (if (/= 0 (logand m j)) - (setq bits (cons bnum bits))) - (setq bnum (1- bnum) - j (ash j -1))))) - bits)) - ('str - (let ((s (substring bindat-raw bindat-idx (+ bindat-idx len)))) - (setq bindat-idx (+ bindat-idx len)) - (if (stringp s) s - (apply #'unibyte-string s)))) - ('strz - (let ((i 0) s) - (while (and (< i len) (/= (aref bindat-raw (+ bindat-idx i)) 0)) - (setq i (1+ i))) - (setq s (substring bindat-raw bindat-idx (+ bindat-idx i))) - (setq bindat-idx (+ bindat-idx len)) - (if (stringp s) s - (apply #'unibyte-string s)))) + ('bits (bindat--unpack-bits len)) + ('str (bindat--unpack-str len)) + ('strz (bindat--unpack-strz len)) ('vec (let ((v (make-vector len 0)) (vlen 1)) (if (consp vectype) @@ -283,6 +286,9 @@ v)) (_ nil))) +(defsubst bindat--align (n len) + (* len (/ (+ n (1- len)) len))) ;Isn't there a simpler way? + (defun bindat--unpack-group (spec) (with-suppressed-warnings ((lexical struct last)) (defvar struct) (defvar last)) @@ -317,8 +323,7 @@ ('fill (setq bindat-idx (+ bindat-idx len))) ('align - (while (/= (% bindat-idx len) 0) - (setq bindat-idx (1+ bindat-idx)))) + (setq bindat-idx (bindat--align bindat-idx len))) ('struct (setq data (bindat--unpack-group (eval len t)))) ('repeat @@ -366,9 +371,8 @@ An integer value in the field list is taken as an array index, e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (while (and struct field) (setq struct (if (integerp (car field)) - (nth (car field) struct) - (let ((val (assq (car field) struct))) - (if (consp val) (cdr val))))) + (elt struct (car field)) + (cdr (assq (car field) struct)))) (setq field (cdr field))) struct) @@ -421,8 +425,7 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." ('fill (setq bindat-idx (+ bindat-idx len))) ('align - (while (/= (% bindat-idx len) 0) - (setq bindat-idx (1+ bindat-idx)))) + (setq bindat-idx (bindat--align bindat-idx len))) ('struct (bindat--length-group (if field (bindat-get-field struct field) struct) (eval len t))) @@ -460,7 +463,7 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." ;;;; Pack structured data into bindat-raw -(defun bindat--pack-u8 (v) +(defsubst bindat--pack-u8 (v) (aset bindat-raw bindat-idx (logand v 255)) (setq bindat-idx (1+ bindat-idx))) @@ -498,42 +501,41 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (bindat--pack-u32r v) (bindat--pack-u32r (ash v -32))) +(defun bindat--pack-str (len v) + (dotimes (i (min len (length v))) + (aset bindat-raw (+ bindat-idx i) (aref v i))) + (setq bindat-idx (+ bindat-idx len))) + +(defun bindat--pack-bits (len v) + (let ((bnum (1- (* 8 len))) j m) + (while (>= bnum 0) + (setq m 0) + (if (null v) + (setq bnum (- bnum 8)) + (setq j 128) + (while (> j 0) + (if (memq bnum v) + (setq m (logior m j))) + (setq bnum (1- bnum) + j (ash j -1)))) + (bindat--pack-u8 m)))) + (defun bindat--pack-item (v type len &optional vectype) (if (eq type 'ip) (setq type 'vec len 4)) (pcase type - ((guard (null v)) - (setq bindat-idx (+ bindat-idx len))) - ((or 'u8 'byte) - (bindat--pack-u8 v)) - ((or 'u16 'word 'short) - (bindat--pack-u16 v)) - ('u24 - (bindat--pack-u24 v)) - ((or 'u32 'dword 'long) - (bindat--pack-u32 v)) + ((guard (null v)) (setq bindat-idx (+ bindat-idx len))) + ((or 'u8 'byte) (bindat--pack-u8 v)) + ((or 'u16 'word 'short) (bindat--pack-u16 v)) + ('u24 (bindat--pack-u24 v)) + ((or 'u32 'dword 'long) (bindat--pack-u32 v)) ('u64 (bindat--pack-u64 v)) ('u16r (bindat--pack-u16r v)) ('u24r (bindat--pack-u24r v)) ('u32r (bindat--pack-u32r v)) ('u64r (bindat--pack-u64r v)) - ('bits - (let ((bnum (1- (* 8 len))) j m) - (while (>= bnum 0) - (setq m 0) - (if (null v) - (setq bnum (- bnum 8)) - (setq j 128) - (while (> j 0) - (if (memq bnum v) - (setq m (logior m j))) - (setq bnum (1- bnum) - j (ash j -1)))) - (bindat--pack-u8 m)))) - ((or 'str 'strz) - (dotimes (i (min len (length v))) - (aset bindat-raw (+ bindat-idx i) (aref v i))) - (setq bindat-idx (+ bindat-idx len))) + ('bits (bindat--pack-bits len v)) + ((or 'str 'strz) (bindat--pack-str len v)) ('vec (let ((l (length v)) (vlen 1)) (if (consp vectype) @@ -580,8 +582,7 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." ('fill (setq bindat-idx (+ bindat-idx len))) ('align - (while (/= (% bindat-idx len) 0) - (setq bindat-idx (1+ bindat-idx)))) + (setq bindat-idx (bindat--align bindat-idx len))) ('struct (bindat--pack-group (if field (bindat-get-field struct field) struct) (eval len t))) diff --git a/test/lisp/emacs-lisp/bindat-tests.el b/test/lisp/emacs-lisp/bindat-tests.el index 72883fc2ec7..9c417c855c7 100644 --- a/test/lisp/emacs-lisp/bindat-tests.el +++ b/test/lisp/emacs-lisp/bindat-tests.el @@ -1,4 +1,4 @@ -;;; bindat-tests.el --- tests for bindat.el -*- lexical-binding: t; coding: utf-8; -*- +;;; bindat-tests.el --- tests for bindat.el -*- lexical-binding: t -*- ;; Copyright (C) 2019-2021 Free Software Foundation, Inc. @@ -23,14 +23,14 @@ (require 'bindat) (require 'cl-lib) -(defvar header-bindat-spec +(defconst header-bindat-spec (bindat-spec (dest-ip ip) (src-ip ip) (dest-port u16) (src-port u16))) -(defvar data-bindat-spec +(defconst data-bindat-spec (bindat-spec (type u8) (opcode u8) @@ -39,7 +39,7 @@ (data vec (length)) (align 4))) -(defvar packet-bindat-spec +(defconst packet-bindat-spec (bindat-spec (header struct header-bindat-spec) (items u8) @@ -47,23 +47,23 @@ (item repeat (items) (struct data-bindat-spec)))) -(defvar struct-bindat +(defconst struct-bindat '((header (dest-ip . [192 168 1 100]) (src-ip . [192 168 1 101]) (dest-port . 284) (src-port . 5408)) (items . 2) - (item ((data . [1 2 3 4 5]) - (id . "ABCDEF") - (length . 5) + (item ((type . 2) (opcode . 3) - (type . 2)) - ((data . [6 7 8 9 10 11 12]) - (id . "BCDEFG") - (length . 7) + (length . 5) + (id . "ABCDEF") + (data . [1 2 3 4 5])) + ((type . 1) (opcode . 4) - (type . 1))))) + (length . 7) + (id . "BCDEFG") + (data . [6 7 8 9 10 11 12]))))) (ert-deftest bindat-test-pack () (should (equal -- cgit v1.2.3 From 1362a9fec4dff341a84c881ac17dbf1ee2cf82fd Mon Sep 17 00:00:00 2001 From: Mattias Engdegård Date: Fri, 5 Mar 2021 20:21:01 +0100 Subject: Make lambda-lifting work again * lisp/emacs-lisp/cconv.el (cconv--analyze-use): Fix typo. * test/lisp/emacs-lisp/cconv-tests.el (cconv-convert-lambda-lifted): Add test case. --- lisp/emacs-lisp/cconv.el | 2 +- test/lisp/emacs-lisp/cconv-tests.el | 9 ++++++++- 2 files changed, 9 insertions(+), 2 deletions(-) (limited to 'test/lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 50a8bebf4c0..bd0a3e87e64 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -612,7 +612,7 @@ FORM is the parent form that binds this var." (push (cons (cons binder form) :captured+mutated) cconv-var-classification)) (`(,(and binder `(,_ (function (lambda . ,_)))) nil nil nil t) - (push (cons (cons binder form) :lambda-candidates) + (push (cons (cons binder form) :lambda-candidate) cconv-var-classification)))) (defun cconv--analyze-function (args body env parentform) diff --git a/test/lisp/emacs-lisp/cconv-tests.el b/test/lisp/emacs-lisp/cconv-tests.el index 517373386e3..5aeed0cc155 100644 --- a/test/lisp/emacs-lisp/cconv-tests.el +++ b/test/lisp/emacs-lisp/cconv-tests.el @@ -182,7 +182,14 @@ (should (eq (cconv-tests-cl-defsubst) 'cl-defsubst-result))) (ert-deftest cconv-convert-lambda-lifted () - "Bug#30872." + ;; Verify that lambda-lifting is actually performed at all. + (should (equal (cconv-closure-convert + '#'(lambda (x) (let ((f #'(lambda () (+ x 1)))) + (funcall f)))) + '#'(lambda (x) (let ((f #'(lambda (x) (+ x 1)))) + (funcall f x))))) + + ;; Bug#30872. (should (equal (funcall (byte-compile -- cgit v1.2.3 From 533c659b6c73fd381231f25d0644c69729dd0aed Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 5 Mar 2021 19:56:31 -0500 Subject: Bindat: new macro-expansion based data layout language Thorough redesign of the Bindat system, which makes it possible to define new Bindat type forms, define recursive types, control the values returned when unpacking, freely mix arbitrary computations with type definitions, as well as support for arbitrary sized integers. This also reverts the recent addition of the `bindat-spec` macro and the support for 64bit integers in the old Bindat language since that is now considered obsolete anyway. * doc/lispref/processes.texi (Bindat Types): Rename from `Bindat Spec` and rewrite for the new sublanguage. (Bindat Functions): Adjust to the new terminology. (Bindat Computed Types): New node. * lisp/emacs-lisp/bindat.el (bindat--type): New type. (bindat--unpack-u64, bindat--unpack-u64r): Delete functions. (bindat--unpack-item, bindat--pack-item, bindat--fixed-length-alist): Revert addition of support for 64bit integers. (bindat--unpack-group, bindat--length-group, bindat--pack-group): Handle the new `bindat--type` values. (bindat-spec): Revert addition of this macro. (bindat--unpack-uint, bindat--unpack-uintr, bindat--pack-uint) (bindat--pack-uintr): New functions. (bindat-type, bindat-defmacro, bindat--pcase): New macros. (bindat-type): New Edebug elem. (bindat--type): New generic function. (bindat--primitives): New constant. (bindat--macroenv, bindat--op): New vars. (bindat--make-docstring, bindat--fun, bindat--makefun, bindat--toplevel): New functions. * test/lisp/emacs-lisp/bindat-tests.el: Use `bindat-type`. (ip): New Bindat type. (header-bindat-spec, data-bindat-spec, packet-bindat-spec): Adjust to new `bindat-type` macro. (bindat-test-unpack): Simplify now that the order of fields is preserved. (bindat-test--int-websocket-type, bindat-test--LEB128): New consts. (bindat-test--pack-val, bindat-test--sint, bindat-test--recursive): New tests. --- doc/lispref/elisp.texi | 3 +- doc/lispref/processes.texi | 278 +++++++++-------- etc/NEWS | 8 +- lisp/emacs-lisp/bindat.el | 567 +++++++++++++++++++++++++---------- test/lisp/emacs-lisp/bindat-tests.el | 107 +++++-- 5 files changed, 631 insertions(+), 332 deletions(-) (limited to 'test/lisp/emacs-lisp') diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi index 12255d122f9..dade8555187 100644 --- a/doc/lispref/elisp.texi +++ b/doc/lispref/elisp.texi @@ -1408,8 +1408,9 @@ Low-Level Network Access Packing and Unpacking Byte Arrays -* Bindat Spec:: Describing data layout. +* Bindat Types:: Describing data layout. * Bindat Functions:: Doing the unpacking and packing. +* Bindat Computed Types:: Advanced data layout specifications. Emacs Display diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi index bb4c57a6196..23111f7c5ce 100644 --- a/doc/lispref/processes.texi +++ b/doc/lispref/processes.texi @@ -3354,23 +3354,25 @@ To use the functions referred to in this section, load the direction is also known as @dfn{serializing} or @dfn{packing}. @menu -* Bindat Spec:: Describing data layout. -* Bindat Functions:: Doing the unpacking and packing. +* Bindat Types:: Describing data layout. +* Bindat Functions:: Doing the unpacking and packing. +* Bindat Computed Types:: Advanced data layout specifications. @end menu -@node Bindat Spec +@node Bindat Types @subsection Describing Data Layout To control unpacking and packing, you write a @dfn{data layout -specification}, a special nested list describing named and typed -@dfn{fields}. This specification controls the length of each field to be -processed, and how to pack or unpack it. We normally keep bindat specs -in variables whose names end in @samp{-bindat-spec}; that kind of name +specification}, also called a Bindat type expression. +This can be a base type or a composite type made of several fields, +where the specification controls the length of each field to be +processed, and how to pack or unpack it. We normally keep bindat type +values in variables whose names end in @samp{-bindat-spec}; that kind of name is automatically recognized as risky. -@defmac bindat-spec &rest specs -Creates a Bindat spec object according to the data layout -specification @var{specs}. +@defmac bindat-type &rest type +Creates a Bindat type @emph{value} object according to the Bindat type +@emph{expression} @var{type}. @end defmac @cindex endianness @@ -3391,44 +3393,27 @@ type values: @itemx byte Unsigned byte, with length 1. -@item u16 -@itemx word -@itemx short -Unsigned integer in network byte order, with length 2. +@item uint @var{bitlen} +Unsigned integer in network byte order, with @var{bitlen} bits. +@var{bitlen} has to be a multiple of 8. -@item u24 -Unsigned integer in network byte order, with length 3. - -@item u32 -@itemx dword -@itemx long -Unsigned integer in network byte order, with length 4. - -@item u64 -Unsigned integer in network byte order, with length 8. - -@item u16r -@itemx u24r -@itemx u32r -@itemx u64r -Unsigned integer in little endian order, with length 2, 3, 4, and -8, respectively. +@item uintr @var{bitlen} +Unsigned integer in little endian order, with @var{bitlen} bits. +@var{bitlen} has to be a multiple of 8. @item str @var{len} -String of length @var{len}. +String of bytes of length @var{len}. @item strz @var{len} -Zero-terminated string, in a fixed-size field with length @var{len}. +Zero-terminated string of bytes, in a fixed-size field with length @var{len}. @item vec @var{len} [@var{type}] Vector of @var{len} elements of type @var{type}, defaulting to bytes. -The @var{type} is any of the simple types above, or another vector -specified as a list of the form @code{(vec @var{len} [@var{type}])}. +The @var{type} can be any Bindat type expression. -@item ip -@c FIXME? IPv6? -Four-byte vector representing an Internet address. For example: -@code{[127 0 0 1]} for localhost. +@item repeat @var{len} [@var{type}] +Like @code{vec}, but it unpacks to and packs from lists, whereas +@code{vec} unpacks to vectors. @item bits @var{len} List of set bits in @var{len} bytes. The bytes are taken in big @@ -3437,121 +3422,59 @@ endian order and the bits are numbered starting with @code{8 * 2} unpacks @code{#x28} @code{#x1c} to @code{(2 3 4 11 13)} and @code{#x1c} @code{#x28} to @code{(3 5 10 11 12)}. -@item (eval @var{form}) -@var{form} is a Lisp expression evaluated at the moment the field is -unpacked or packed. The result of the evaluation should be one of the -above-listed type specifications. -@end table - -For a fixed-size field, the length @var{len} is given as an integer -specifying the number of bytes in the field. - -When the length of a field is not fixed, it typically depends on the -value of a preceding field. In this case, the length @var{len} can be -given either as a list @code{(@var{name} ...)} identifying a -@dfn{field name} in the format specified for @code{bindat-get-field} -below, or by an expression @code{(eval @var{form})} where @var{form} -should evaluate to an integer, specifying the field length. - -A field specification generally has the form @code{([@var{name}] -@var{handler})}, where @var{name} is optional. Don't use names that -are symbols meaningful as type specifications (above) or handler -specifications (below), since that would be ambiguous. @var{name} can -be a symbol or an expression @code{(eval @var{form})}, in which case -@var{form} should evaluate to a symbol. - -@var{handler} describes how to unpack or pack the field and can be one -of the following: - -@table @code -@item @var{type} -Unpack/pack this field according to the type specification @var{type}. - -@item eval @var{form} -Evaluate @var{form}, a Lisp expression, for side-effect only. If the -field name is specified, the value is bound to that field name. - @item fill @var{len} -Skip @var{len} bytes. In packing, this leaves them unchanged, -which normally means they remain zero. In unpacking, this means -they are ignored. +@var{len} bytes used as a mere filler. In packing, these bytes are +are left unchanged, which normally means they remain zero. +When unpacking, this just returns nil. @item align @var{len} -Skip to the next multiple of @var{len} bytes. - -@item struct @var{spec-name} -Process @var{spec-name} as a sub-specification. This describes a -structure nested within another structure. - -@item union @var{form} (@var{tag} @var{spec})@dots{} -@c ??? I don't see how one would actually use this. -@c ??? what kind of expression would be useful for @var{form}? -Evaluate @var{form}, a Lisp expression, find the first @var{tag} -that matches it, and process its associated data layout specification -@var{spec}. Matching can occur in one of three ways: - -@itemize -@item -If a @var{tag} has the form @code{(eval @var{expr})}, evaluate -@var{expr} with the variable @code{tag} dynamically bound to the value -of @var{form}. A non-@code{nil} result indicates a match. - -@item -@var{tag} matches if it is @code{equal} to the value of @var{form}. - -@item -@var{tag} matches unconditionally if it is @code{t}. -@end itemize - -@item repeat @var{count} @var{field-specs}@dots{} -Process the @var{field-specs} recursively, in order, then repeat -starting from the first one, processing all the specifications @var{count} -times overall. The @var{count} is given using the same formats as a -field length---if an @code{eval} form is used, it is evaluated just once. -For correct operation, each specification in @var{field-specs} must -include a name. +Same as @code{fill} except the number of bytes is that needed to skip +to the next multiple of @var{len} bytes. + +@item type @var{exp} +This lets you refer to a type indirectly: @var{exp} is a Lisp +expression which should return a Bindat type @emph{value}. + +@item unit @var{exp} +This is a trivial type which uses up 0 bits of space. @var{exp} +describes the value returned when we try to ``unpack'' such a field. + +@item struct @var{fields}... +Composite type made of several fields. Every field is of the form +@code{(@var{name} @var{type})} where @var{type} can be any Bindat +type expression. @var{name} can be @code{_} when the field's value +does not deserve to be named, as is often the case for @code{align} +and @code{fill} fields. +When the context makes it clear that this is a Bindat type expression, +the symbol @code{struct} can be omitted. @end table -For the @code{(eval @var{form})} forms used in a bindat specification, -the @var{form} can access and update these dynamically bound variables -during evaluation: +In the types above, @var{len} and @var{bitlen} are given as an integer +specifying the number of bytes (or bits) in the field. When the +length of a field is not fixed, it typically depends on the value of +preceding fields. For this reason, the length @var{len} does not have +to be a constant but can be any Lisp expression and it can refer to +the value of previous fields via their name. -@table @code -@item last -Value of the last field processed. - -@item bindat-raw -The data as a byte array. - -@item bindat-idx -Current index (within @code{bindat-raw}) for unpacking or packing. - -@item struct -The alist containing the structured data that have been unpacked so -far, or the entire structure being packed. You can use -@code{bindat-get-field} to access specific fields of this structure. - -@item count -@itemx index -Inside a @code{repeat} block, these contain the maximum number of -repetitions (as specified by the @var{count} parameter), and the -current repetition number (counting from 0). Setting @code{count} to -zero will terminate the inner-most repeat block after the current -repetition has completed. -@end table +For example, the specification of a data layout where a leading byte gives +the size of a subsequent vector of 16 bit integers could be: +@example +(bindat-type + (len u8) + (payload vec (1+ len) uint 16)) +@end example @node Bindat Functions @subsection Functions to Unpack and Pack Bytes - In the following documentation, @var{spec} refers to a Bindat spec -object as returned from @code{bindat-spec}, @code{raw} to a byte + In the following documentation, @var{type} refers to a Bindat type +value as returned from @code{bindat-type}, @code{raw} to a byte array, and @var{struct} to an alist representing unpacked field data. -@defun bindat-unpack spec raw &optional idx -@c FIXME? Again, no multibyte? +@defun bindat-unpack type raw &optional idx This function unpacks data from the unibyte string or byte array @var{raw} -according to @var{spec}. Normally, this starts unpacking at the +according to @var{type}. Normally, this starts unpacking at the beginning of the byte array, but if @var{idx} is non-@code{nil}, it specifies a zero-based starting position to use instead. @@ -3580,13 +3503,13 @@ both pieces of information contribute to its calculation. Likewise, the length of a string or array being unpacked may be longer than the data's total length as described by the specification. -@defun bindat-length spec struct +@defun bindat-length type struct This function returns the total length of the data in @var{struct}, -according to @var{spec}. +according to @var{type}. @end defun -@defun bindat-pack spec struct &optional raw idx -This function returns a byte array packed according to @var{spec} from +@defun bindat-pack type struct &optional raw idx +This function returns a byte array packed according to @var{type} from the data in the alist @var{struct}. It normally creates and fills a new byte array starting at the beginning. However, if @var{raw} is non-@code{nil}, it specifies a pre-allocated unibyte string or vector to @@ -3607,3 +3530,70 @@ dotted notation. @result{} "127.0.0.1" @end example @end defun + +@node Bindat Computed Types +@subsection Advanced data layout specifications + +Bindat type expressions are not limited to the types described +earlier. They can also be arbitrary Lisp forms returning Bindat +type expressions. For example, the type below describes data which +can either contain a 24bit error code or a vector of bytes: + +@example +(bindat-type + (len u8) + (payload . (if (zerop len) (uint 24) (vec (1- len))))) +@end example + +Furthermore, while composite types are normally unpacked to (and +packed from) association lists, this can be changed via the use of +the following special keyword arguments: + +@table @code +@item :unpack-val @var{exp} +When the list of fields end with this keyword argument, then the value +returned when unpacking is the value of @var{exp} instead of the +standard alist. @var{exp} can refer to all the previous fields by +their name. + +@item :pack-val @var{exp} +If a field's type is followed by this keyword argument, then the value +packed into this field is returned by @var{exp} instead of being +extracted from the alist. + +@item :pack-var @var{name} +If the list of fields is preceded by this keyword argument, then all +the subsequent @code{:pack-val} arguments can refer to the overall +value to pack into this composite type via the variable named +@var{name}. +@end table + +For example, one could describe a 16 bit signed integer as follows: + +@example +(defconst sint16-bindat-spec + (let* ((max (ash 1 15)) + (wrap (+ max max))) + (bindat-type :pack-var v + (n uint 16 :pack-val (if (< v 0) (+ v wrap) v)) + :unpack-val (if (>= n max) (- n wrap) n)))) +@end example + +Which would then behave as follows: +@example +(bindat-pack sint16-bindat-spec -8) + @result{} "\377\370" + +(bindat-unpack sint16-bindat-spec "\300\100") + @result{} -16320 +@end example + +Finally, you can define new Bindat type forms to use in Bindat type +expressions with @code{bindat-defmacro}: + +@defmac bindat-defmacro name args &rest body +Define a new Bindat type expression named @var{name} and taking +arguments @var{args}. Its behavior follows that of @code{defmacro}, +which the important difference that the new forms can only be used +within Bindat type expressions. +@end defmac diff --git a/etc/NEWS b/etc/NEWS index 3522fce03ae..15df9cdcda6 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -396,9 +396,11 @@ in text mode. The cursor still only actually blinks in GUI frames. ** Bindat +++ -*** New types 'u64' and 'u64r' -+++ -*** New macro 'bindat-spec' to define specs, with Edebug support +*** New 'Bindat type expression' description language. +This new system is provided by the new macro 'bindat-type' and +obsoletes the old data layout specifications. It supports +arbitrary-size integers, recursive types, and more. + ** pcase +++ diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el index 830e61f8516..adf2d672849 100644 --- a/lisp/emacs-lisp/bindat.el +++ b/lisp/emacs-lisp/bindat.el @@ -62,39 +62,40 @@ ;; struct data item[/* items */]; ;; }; ;; -;; The corresponding Lisp bindat specification looks like this: +;; The corresponding Lisp bindat specification could look like this: +;; +;; (bindat-defmacro ip () '(vec 4 byte)) ;; ;; (setq header-bindat-spec -;; (bindat-spec +;; (bindat-type ;; (dest-ip ip) ;; (src-ip ip) -;; (dest-port u16) -;; (src-port u16))) +;; (dest-port uint 16) +;; (src-port uint 16))) ;; ;; (setq data-bindat-spec -;; (bindat-spec +;; (bindat-type ;; (type u8) ;; (opcode u8) -;; (length u32r) ;; little endian order +;; (length uintr 32) ;; little endian order ;; (id strz 8) -;; (data vec (length)) -;; (align 4))) +;; (data vec length) +;; (_ align 4))) ;; ;; (setq packet-bindat-spec -;; (bindat-spec -;; (header struct header-bindat-spec) -;; (items u8) -;; (fill 3) -;; (item repeat (items) -;; (struct data-bindat-spec)))) -;; +;; (bindat-type +;; (header type header-bindat-spec) +;; (nitems u8) +;; (_ fill 3) +;; (items repeat nitems type data-bindat-spec))) ;; ;; A binary data representation may look like ;; [ 192 168 1 100 192 168 1 101 01 28 21 32 2 0 0 0 ;; 2 3 5 0 ?A ?B ?C ?D ?E ?F 0 0 1 2 3 4 5 0 0 0 ;; 1 4 7 0 ?B ?C ?D ?E ?F ?G 0 0 6 7 8 9 10 11 12 0 ] ;; -;; The corresponding decoded structure looks like +;; The corresponding decoded structure returned by `bindat-unpack' (or taken +;; by `bindat-pack') looks like: ;; ;; ((header ;; (dest-ip . [192 168 1 100]) @@ -114,90 +115,24 @@ ;; (type . 1)))) ;; ;; To access a specific value in this structure, use the function -;; bindat-get-field with the structure as first arg followed by a list +;; `bindat-get-field' with the structure as first arg followed by a list ;; of field names and array indexes, e.g. using the data above, ;; (bindat-get-field decoded-structure 'item 1 'id) ;; returns "BCDEFG". -;; Binary Data Structure Specification Format -;; ------------------------------------------ - -;; We recommend using names that end in `-bindat-spec'; such names -;; are recognized automatically as "risky" variables. - -;; The data specification is formatted as follows: - -;; SPEC ::= ( ITEM... ) - -;; ITEM ::= ( FIELD TYPE ) -;; | ( [FIELD] eval FORM ) -- eval FORM for side-effect only -;; | ( [FIELD] fill LEN ) -- skip LEN bytes -;; | ( [FIELD] align LEN ) -- skip to next multiple of LEN bytes -;; | ( [FIELD] struct SPEC_NAME ) -;; | ( [FIELD] union TAG_VAL (TAG SPEC)... [(t SPEC)] ) -;; | ( FIELD repeat ARG ITEM... ) - -;; -- In (eval EXPR), the value of the last field is available in -;; the dynamically bound variable `last' and all the previous -;; ones in the variable `struct'. - -;; TYPE ::= ( eval EXPR ) -- interpret result as TYPE -;; | u8 | byte -- length 1 -;; | u16 | word | short -- length 2, network byte order -;; | u24 -- 3-byte value -;; | u32 | dword | long -- length 4, network byte order -;; | u64 -- length 8, network byte order -;; | u16r | u24r | u32r | u64r - little endian byte order. -;; | str LEN -- LEN byte string -;; | strz LEN -- LEN byte (zero-terminated) string -;; | vec LEN [TYPE] -- vector of LEN items of TYPE (default: u8) -;; | ip -- 4 byte vector -;; | bits LEN -- bit vector using LEN bytes. -;; -;; -- Example: `bits 2' will unpack 0x28 0x1c to (2 3 4 11 13) -;; and 0x1c 0x28 to (3 5 10 11 12). - -;; FIELD ::= ( eval EXPR ) -- use result as NAME -;; | NAME - -;; LEN ::= ARG -;; | | nil -- LEN = 1 - - -;; TAG_VAL ::= ARG - -;; TAG ::= LISP_CONSTANT -;; | ( eval EXPR ) -- return non-nil if tag match; -;; current TAG_VAL in `tag'. - -;; ARG ::= ( eval EXPR ) -- interpret result as ARG -;; | INTEGER_CONSTANT -;; | DEREF - -;; DEREF ::= ( [NAME | INTEGER]... ) -- Field NAME or Array index relative -;; to current structure spec. -;; -- see bindat-get-field - -;; A `union' specification -;; ([FIELD] union TAG_VAL (TAG SPEC) ... [(t SPEC)]) -;; is interpreted by evalling TAG_VAL and then comparing that to -;; each TAG using equal; if a match is found, the corresponding SPEC -;; is used. -;; If TAG is a form (eval EXPR), EXPR is eval'ed with `tag' bound to the -;; value of TAG_VAL; the corresponding SPEC is used if the result is non-nil. -;; Finally, if TAG is t, the corresponding SPEC is used unconditionally. -;; -;; An `eval' specification -;; ([FIELD] eval FORM) -;; is interpreted by evalling FORM for its side effects only. -;; If FIELD is specified, the value is bound to that field. -;; The FORM may access and update `bindat-raw' and `bindat-idx' (see `bindat-unpack'). - ;;; Code: ;; Helper functions for structure unpacking. ;; Relies on dynamic binding of `bindat-raw' and `bindat-idx'. +(eval-when-compile (require 'cl-lib)) +(eval-when-compile (require 'subr-x)) ;For `named-let'. + +(cl-defstruct (bindat--type + (:predicate nil) + (:constructor bindat--make)) + le ue pe) + (defvar bindat-raw) (defvar bindat-idx) @@ -215,9 +150,6 @@ (defun bindat--unpack-u32 () (logior (ash (bindat--unpack-u16) 16) (bindat--unpack-u16))) -(defun bindat--unpack-u64 () - (logior (ash (bindat--unpack-u32) 32) (bindat--unpack-u32))) - (defun bindat--unpack-u16r () (logior (bindat--unpack-u8) (ash (bindat--unpack-u8) 8))) @@ -227,9 +159,6 @@ (defun bindat--unpack-u32r () (logior (bindat--unpack-u16r) (ash (bindat--unpack-u16r) 16))) -(defun bindat--unpack-u64r () - (logior (bindat--unpack-u32r) (ash (bindat--unpack-u32r) 32))) - (defun bindat--unpack-str (len) (let ((s (substring bindat-raw bindat-idx (+ bindat-idx len)))) (setq bindat-idx (+ bindat-idx len)) @@ -266,11 +195,9 @@ ((or 'u16 'word 'short) (bindat--unpack-u16)) ('u24 (bindat--unpack-u24)) ((or 'u32 'dword 'long) (bindat--unpack-u32)) - ('u64 (bindat--unpack-u64)) ('u16r (bindat--unpack-u16r)) ('u24r (bindat--unpack-u24r)) ('u32r (bindat--unpack-u32r)) - ('u64r (bindat--unpack-u64r)) ('bits (bindat--unpack-bits len)) ('str (bindat--unpack-str len)) ('strz (bindat--unpack-strz len)) @@ -290,6 +217,11 @@ (* len (/ (+ n (1- len)) len))) ;Isn't there a simpler way? (defun bindat--unpack-group (spec) + ;; FIXME: Introduce a new primitive so we can mark `bindat-unpack' + ;; as obsolete (maybe that primitive should be a macro which takes + ;; a bindat type *expression* as argument). + (if (cl-typep spec 'bindat--type) + (funcall (bindat--type-ue spec)) (with-suppressed-warnings ((lexical struct last)) (defvar struct) (defvar last)) (let (struct last) @@ -350,7 +282,7 @@ (setq struct (if field (cons (cons field data) struct) (append data struct)))))) - struct)) + struct))) (defun bindat-unpack (spec raw &optional idx) "Return structured data according to SPEC for binary data in RAW. @@ -383,10 +315,11 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (u16 . 2) (u16r . 2) (word . 2) (short . 2) (u24 . 3) (u24r . 3) (u32 . 4) (u32r . 4) (dword . 4) (long . 4) - (u64 . 8) (u64r . 8) (ip . 4))) (defun bindat--length-group (struct spec) + (if (cl-typep spec 'bindat--type) + (funcall (bindat--type-le spec) struct) (with-suppressed-warnings ((lexical struct last)) (defvar struct) (defvar last)) (let ((struct struct) last) @@ -452,7 +385,7 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (setq len (* len (cdr type)))) (if field (setq last (bindat-get-field struct field))) - (setq bindat-idx (+ bindat-idx len)))))))) + (setq bindat-idx (+ bindat-idx len))))))))) (defun bindat-length (spec struct) "Calculate `bindat-raw' length for STRUCT according to bindat SPEC." @@ -529,11 +462,9 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." ((or 'u16 'word 'short) (bindat--pack-u16 v)) ('u24 (bindat--pack-u24 v)) ((or 'u32 'dword 'long) (bindat--pack-u32 v)) - ('u64 (bindat--pack-u64 v)) ('u16r (bindat--pack-u16r v)) ('u24r (bindat--pack-u24r v)) ('u32r (bindat--pack-u32r v)) - ('u64r (bindat--pack-u64r v)) ('bits (bindat--pack-bits len v)) ((or 'str 'strz) (bindat--pack-str len v)) ('vec @@ -550,6 +481,8 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (setq bindat-idx (+ bindat-idx len))))) (defun bindat--pack-group (struct spec) + (if (cl-typep spec 'bindat--type) + (funcall (bindat--type-pe spec) struct) (with-suppressed-warnings ((lexical struct last)) (defvar struct) (defvar last)) (let ((struct struct) last) @@ -607,7 +540,7 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (_ (setq last (bindat-get-field struct field)) (bindat--pack-item last type len vectype) - )))))) + ))))))) (defun bindat-pack (spec struct &optional raw idx) "Return binary data packed according to SPEC for structured data STRUCT. @@ -623,52 +556,6 @@ Optional fourth arg IDX is the starting offset into RAW." (bindat--pack-group struct spec) (if raw nil bindat-raw))) -;;;; Debugging support - -(def-edebug-elem-spec 'bindat-spec '(&rest bindat-item)) - - -(def-edebug-elem-spec 'bindat--item-aux - ;; Field types which can come without a field label. - '(&or ["eval" form] - ["fill" bindat-len] - ["align" bindat-len] - ["struct" form] ;A reference to another bindat-spec. - ["union" bindat-tag-val &rest (bindat-tag bindat-spec)])) - -(def-edebug-elem-spec 'bindat-item - '((&or bindat--item-aux ;Without label.. - [bindat-field ;..or with label - &or bindat--item-aux - ["repeat" bindat-arg bindat-spec] - bindat-type]))) - -(def-edebug-elem-spec 'bindat-type - '(&or ("eval" form) - ["str" bindat-len] - ["strz" bindat-len] - ["vec" bindat-len &optional bindat-type] - ["bits" bindat-len] - symbolp)) - -(def-edebug-elem-spec 'bindat-field - '(&or ("eval" form) symbolp)) - -(def-edebug-elem-spec 'bindat-len '(&or [] "nil" bindat-arg)) - -(def-edebug-elem-spec 'bindat-tag-val '(bindat-arg)) - -(def-edebug-elem-spec 'bindat-tag '(&or ("eval" form) atom)) - -(def-edebug-elem-spec 'bindat-arg - '(&or ("eval" form) integerp (&rest symbolp integerp))) - -(defmacro bindat-spec (&rest fields) - "Build the bindat spec described by FIELDS." - (declare (indent 0) (debug (bindat-spec))) - ;; FIXME: We should really "compile" this to a triplet of functions! - `',fields) - ;;;; Misc. format conversions (defun bindat-format-vector (vect fmt sep &optional len) @@ -697,6 +584,384 @@ The port (if any) is omitted. IP can be a string, as well." (format "%d.%d.%d.%d" (aref ip 0) (aref ip 1) (aref ip 2) (aref ip 3)))) +;;;; New approach based on macro-expansion + +;; Further improvements suggested by reading websocket.el: +;; - Support for bit-sized fields? +;; +;; - Add some way to verify redundant/checksum fields's contents without +;; having to provide a complete `:unpack-val' expression. +;; The `:pack-val' thingy can work nicely to compute checksum fields +;; based on previous fields's contents (without impacting or being impacted +;; by the unpacked representation), but if we want to verify +;; those checksums when unpacking, we have to use the :unpack-val +;; and build the whole object by hand instead of being able to focus +;; just on the checksum field. +;; Maybe this could be related to `unit' type fields where we might like +;; to make sure that the "value" we write into it is the same as the +;; value it holds (tho those checks don't happen at the same time (pack +;; vs unpack). +;; +;; - Support for packing/unpacking to/from something else than +;; a unibyte string, e.g. from a buffer. Problems to do that are: +;; - the `str' and `strz' types which use `substring' rather than reading +;; one byte at a time. +;; - the `align' and `fill' which just want to skip without reading/writing +;; - the `pack-uint' case, which would prefer writing the LSB first. +;; - the `align' case needs to now the current position in order to know +;; how far to advance +;; +;; - Don't write triple code when the type is only ever used at a single place +;; (e.g. to unpack). + +(defun bindat--unpack-uint (bitlen) + (let ((v 0) (bitsdone 0)) + (while (< bitsdone bitlen) + (setq v (logior (ash v 8) (bindat--unpack-u8))) + (setq bitsdone (+ bitsdone 8))) + v)) + +(defun bindat--unpack-uintr (bitlen) + (let ((v 0) (bitsdone 0)) + (while (< bitsdone bitlen) + (setq v (logior v (ash (bindat--unpack-u8) bitsdone))) + (setq bitsdone (+ bitsdone 8))) + v)) + +(defun bindat--pack-uint (bitlen v) + (let* ((len (/ bitlen 8)) + (shift (- (* 8 (1- len))))) + (dotimes (_ len) + (bindat--pack-u8 (logand 255 (ash v shift))) + (setq shift (+ 8 shift))))) + +(defun bindat--pack-uintr (bitlen v) + (let* ((len (/ bitlen 8))) + (dotimes (_ len) + (bindat--pack-u8 (logand v 255)) + (setq v (ash v -8))))) + +(defmacro bindat--pcase (&rest args) + "Like `pcase' but optimize the code under the assumption that it's exhaustive." + (declare (indent 1) (debug pcase)) + `(pcase ,@args (pcase--dontcare nil))) + +(cl-defgeneric bindat--type (op head &rest args) + "Return the code for the operation OP of the Bindat type (HEAD . ARGS). +OP can be one of: unpack', (pack VAL), or (length VAL) where VAL +is the name of a variable that will hold the value we need to pack.") + +(cl-defmethod bindat--type (op (_ (eql byte))) + (bindat--pcase op + ('unpack `(bindat--unpack-u8)) + (`(length . ,_) `(cl-incf bindat-idx 1)) + (`(pack . ,args) `(bindat--pack-u8 . ,args)))) + +(cl-defmethod bindat--type (op (_ (eql uint)) n) + (if (eq n 8) (bindat--type op 'byte) + (bindat--pcase op + ('unpack `(bindat--unpack-uint ,n)) + (`(length . ,_) `(cl-incf bindat-idx (/ ,n 8))) + (`(pack . ,args) `(bindat--pack-uint ,n . ,args))))) + +(cl-defmethod bindat--type (op (_ (eql uintr)) n) + (if (eq n 8) (bindat--type op 'byte) + (bindat--pcase op + ('unpack `(bindat--unpack-uintr ,n)) + (`(length . ,_) `(cl-incf bindat-idx (/ ,n 8))) + (`(pack . ,args) `(bindat--pack-uintr ,n . ,args))))) + +(cl-defmethod bindat--type (op (_ (eql str)) len) + (bindat--pcase op + ('unpack `(bindat--unpack-str ,len)) + (`(length . ,_) `(cl-incf bindat-idx ,len)) + (`(pack . ,args) `(bindat--pack-str ,len . ,args)))) + +(cl-defmethod bindat--type (op (_ (eql strz)) len) + (bindat--pcase op + ('unpack `(bindat--unpack-strz ,len)) + (`(length . ,_) `(cl-incf bindat-idx ,len)) + ;; Here we don't add the terminating zero because we rely + ;; on the fact that `bindat-raw' was presumably initialized with + ;; all-zeroes before we started. + (`(pack . ,args) `(bindat--pack-str ,len . ,args)))) + +(cl-defmethod bindat--type (op (_ (eql bits)) len) + (bindat--pcase op + ('unpack `(bindat--unpack-bits ,len)) + (`(length . ,_) `(cl-incf bindat-idx ,len)) + (`(pack . ,args) `(bindat--pack-bits ,len . ,args)))) + +(cl-defmethod bindat--type (_op (_ (eql fill)) len) + `(progn (cl-incf bindat-idx ,len) nil)) + +(cl-defmethod bindat--type (_op (_ (eql align)) len) + `(progn (cl-callf bindat--align bindat-idx ,len) nil)) + +(cl-defmethod bindat--type (op (_ (eql type)) exp) + (bindat--pcase op + ('unpack `(funcall (bindat--type-ue ,exp))) + (`(length . ,args) `(funcall (bindat--type-le ,exp) . ,args)) + (`(pack . ,args) `(funcall (bindat--type-pe ,exp) . ,args)))) + +(cl-defmethod bindat--type (op (_ (eql vec)) count &rest type) + (unless type (setq type '(byte))) + (let ((fun (macroexpand-all (bindat--fun type) macroexpand-all-environment))) + (bindat--pcase op + ('unpack + `(let* ((bindat--len ,count) + (bindat--v (make-vector bindat--len 0))) + (dotimes (bindat--i bindat--len) + (aset bindat--v bindat--i (funcall ,fun))) + bindat--v)) + ((and `(length . ,_) + ;; FIXME: Improve the pattern match to recognize more complex + ;; "constant" functions? + (let `#'(lambda (,val) (setq bindat-idx (+ bindat-idx ,len))) fun) + (guard (not (macroexp--fgrep `((,val)) len)))) + ;; Optimize the case where the size of each element is constant. + `(cl-incf bindat-idx (* ,count ,len))) + ;; FIXME: It's tempting to use `(mapc (lambda (,val) ,exp) ,val)' + ;; which would be more efficient when `val' is a list, + ;; but that's only right if length of `val' is indeed `count'. + (`(,_ ,val) + `(dotimes (bindat--i ,count) + (funcall ,fun (elt ,val bindat--i))))))) + +(cl-defmethod bindat--type (op (_ (eql unit)) val) + (pcase op ('unpack val) (_ nil))) + +(cl-defmethod bindat--type (op (_ (eql struct)) &rest args) + (apply #'bindat--type op args)) + +(cl-defmethod bindat--type (op (_ (eql :pack-var)) var &rest fields) + (unless (consp (cdr fields)) + (error "`:pack-var VAR' needs to be followed by fields")) + (bindat--pcase op + ((or 'unpack (guard (null var))) + (apply #'bindat--type op fields)) + (`(,_ ,val) + `(let ((,var ,val)) ,(apply #'bindat--type op fields))))) + +(cl-defmethod bindat--type (op (field cons) &rest fields) + (named-let loop + ((fields (cons field fields)) + (labels ())) + (bindat--pcase fields + ('nil + (bindat--pcase op + ('unpack + (let ((exp ())) + (pcase-dolist (`(,label . ,labelvar) labels) + (setq exp + (if (eq label '_) + (if exp `(nconc ,labelvar ,exp) labelvar) + `(cons (cons ',label ,labelvar) ,exp)))) + exp)) + (_ nil))) + (`(:unpack-val ,exp) + ;; Make it so `:kwd nil' is the same as the absence of the keyword arg. + (if exp (pcase op ('unpack exp)) (loop nil labels))) + + (`((,label . ,type) . ,fields) + (let* ((get-field-val + (let ((tail (memq :pack-val type))) + ;; FIXME: This `TYPE.. :pack EXP' syntax doesn't work well + ;; when TYPE is a struct (a list of fields) or with extensions + ;; such as allowing TYPE to be `if ...'. + (if tail + (prog1 (cadr tail) + (setq type (butlast type (length tail))))))) + (fieldvar (make-symbol (format "field%d" (length fields)))) + (labelvar + (cond + ((eq label '_) fieldvar) + ((keywordp label) + (intern (substring (symbol-name label) 1))) + (t label))) + (field-fun (bindat--fun type)) + (rest-exp (loop fields `((,label . ,labelvar) . ,labels)))) + (bindat--pcase op + ('unpack + (let ((code + `(let ((,labelvar (funcall ,field-fun))) + ,rest-exp))) + (if (or (eq label '_) (not (assq label labels))) + code + (macroexp-warn-and-return + (format "Duplicate label: %S" label) + code)))) + (`(,_ ,val) + ;; `cdr-safe' is easier to optimize (can't signal an error). + `(let ((,fieldvar ,(or get-field-val + (if (eq label '_) val + `(cdr-safe (assq ',label ,val)))))) + (funcall ,field-fun ,fieldvar) + ,@(when rest-exp + `((let ,(unless (eq labelvar fieldvar) + `((,labelvar ,fieldvar))) + (ignore ,labelvar) + ,rest-exp)))))))) + (_ (error "Unrecognized format in bindat fields: %S" fields))))) + +(def-edebug-elem-spec 'bindat-struct + [[&rest (symbolp bindat-type &optional ":pack-val" def-form)] + &optional ":unpack-val" def-form]) + +(def-edebug-elem-spec 'bindat-type + '(&or ["uint" def-form] + ["uintr" def-form] + ["str" def-form] + ["strz" def-form] + ["bits" def-form] + ["fill" def-form] + ["align" def-form] + ["vec" def-form bindat-type] + ["repeat" def-form bindat-type] + ["type" def-form] + ["struct" bindat-struct] + ["unit" def-form] + [":pack-var" symbolp bindat-type] + symbolp ;; u8, u16, etc... + bindat-struct)) + +(defmacro bindat-type (&rest type) + "Return the Bindat type value to pack&unpack TYPE. +TYPE is a Bindat type expression. It can take the following forms: + + uint BITLEN - Big-endian unsigned integer + uintr BITLEN - Little-endian unsigned integer + str LEN - Byte string + strz LEN - Zero-terminated byte-string + bits LEN - Bit vector (LEN is counted in bytes) + fill LEN - Just a filler + align LEN - Fill up to the next multiple of LEN bytes + vec COUNT TYPE - COUNT repetitions of TYPE + type EXP - Indirection; EXP should return a Bindat type value + unit EXP - 0-width type holding the value returned by EXP + struct FIELDS... - A composite type + +When the context makes it clear, the symbol `struct' can be omitted. +A composite type is a list of FIELDS where each FIELD is of the form + + (LABEL TYPE) + +where LABEL can be `_' if the field should not deserve a name. + +Composite types get normally packed/unpacked to/from alists, but this can be +controlled in the following way: +- If the list of fields ends with `:unpack-val EXP', then unpacking will + return the value of EXP (which has the previous fields in its scope). +- If a field's TYPE is followed by `:pack-val EXP', then the value placed + into this field will be that returned by EXP instead of looking up the alist. +- If the list of fields is preceded with `:pack-var VAR' then the object to + be packed is bound to VAR when evaluating the EXPs of `:pack-val'. + +All the above BITLEN, LEN, COUNT, and EXP are ELisp expressions evaluated +in the current lexical context extended with the previous fields. + +TYPE can additionally be one of the Bindat type macros defined with +`bindat-defmacro' (and listed below) or an ELisp expression which returns +a bindat type expression." + (declare (indent 0) (debug (bindat-type))) + `(progn + (defvar bindat-idx) + (bindat--make :ue ,(bindat--toplevel 'unpack type) + :le ,(bindat--toplevel 'length type) + :pe ,(bindat--toplevel 'pack type)))) + +(eval-and-compile + (defconst bindat--primitives '(byte uint uintr str strz bits fill align + struct type vec unit))) + +(eval-and-compile + (defvar bindat--macroenv + (mapcar (lambda (s) (cons s (lambda (&rest args) + (bindat--makefun (cons s args))))) + bindat--primitives))) + +(defmacro bindat-defmacro (name args &rest body) + "Define a new Bindat type as a macro." + (declare (indent 2) (doc-string 3) (debug (&define name sexp def-body))) + (let ((leaders ())) + (while (and (cdr body) + (or (stringp (car body)) + (memq (car-safe (car body)) '(:documentation declare)))) + (push (pop body) leaders)) + ;; FIXME: Add support for Edebug decls to those macros. + `(eval-and-compile ;; Yuck! But needed to define types where you use them! + (setf (alist-get ',name bindat--macroenv) + (lambda ,args ,@(nreverse leaders) + (bindat--fun ,(macroexp-progn body))))))) + +(put 'bindat-type 'function-documentation '(bindat--make-docstring)) +(defun bindat--make-docstring () + ;; Largely inspired from `pcase--make-docstring'. + (let* ((main (documentation (symbol-function 'bindat-type) 'raw)) + (ud (help-split-fundoc main 'bindat-type))) + (require 'help-fns) + (declare-function help-fns--signature "help-fns") + (with-temp-buffer + (insert (or (cdr ud) main)) + (pcase-dolist (`(,name . ,me) (reverse bindat--macroenv)) + (unless (memq name bindat--primitives) + (let ((doc (documentation me 'raw))) + (insert "\n\n-- ") + (setq doc (help-fns--signature name doc me + (indirect-function me) + nil)) + (insert "\n" (or doc "Not documented."))))) + (let ((combined-doc (buffer-string))) + (if ud (help-add-fundoc-usage combined-doc (car ud)) combined-doc))))) + +(bindat-defmacro u8 () "Unsigned 8bit integer." '(byte)) +(bindat-defmacro sint (bitlen r) + "Signed integer of size BITLEN. +Bigendian if R is nil and little endian if not." + (let ((bl (make-symbol "bitlen")) + (max (make-symbol "max")) + (wrap (make-symbol "wrap"))) + `(let* ((,bl ,bitlen) + (,max (ash 1 (1- ,bl))) + (,wrap (+ ,max ,max))) + (struct :pack-var v + (n if ,r (uintr ,bl) (uint ,bl) + :pack-val (if (< v 0) (+ v ,wrap) v)) + :unpack-val (if (>= n ,max) (- n ,wrap) n))))) + +(bindat-defmacro repeat (count &rest type) + "Like `vec', but unpacks to a list rather than a vector." + `(:pack-var v + (v vec ,count ,@type :pack-val v) + :unpack-val (append v nil))) + +(defvar bindat--op nil + "The operation we're currently building. +This is a simple symbol and can be one of: `unpack', `pack', or `length'. +This is used during macroexpansion of `bindat-type' so that the +macros know which code to generate. +FIXME: this is closely related and very similar to the `op' argument passed +to `bindat--type', yet it's annoyingly different.") + +(defun bindat--fun (type) + (if (or (keywordp (car type)) (consp (car type))) (cons 'struct type) + type)) + +(defun bindat--makefun (type) + (let* ((v (make-symbol "v")) + (args (pcase bindat--op ('unpack ()) (_ (list v))))) + (pcase (apply #'bindat--type + (pcase bindat--op ('unpack 'unpack) (op `(,op . ,args))) + type) + (`(funcall ,f . ,(pred (equal args))) f) ;η-reduce. + (exp `(lambda ,args ,exp))))) + +(defun bindat--toplevel (op type) + (let* ((bindat--op op) + (env `(,@bindat--macroenv + ,@macroexpand-all-environment))) + (macroexpand-all (bindat--fun type) env))) + (provide 'bindat) ;;; bindat.el ends here diff --git a/test/lisp/emacs-lisp/bindat-tests.el b/test/lisp/emacs-lisp/bindat-tests.el index 9c417c855c7..911a5f0c7b1 100644 --- a/test/lisp/emacs-lisp/bindat-tests.el +++ b/test/lisp/emacs-lisp/bindat-tests.el @@ -23,29 +23,32 @@ (require 'bindat) (require 'cl-lib) +(bindat-defmacro ip () "An IPv4 address" '(vec 4 byte)) + (defconst header-bindat-spec - (bindat-spec + (bindat-type (dest-ip ip) (src-ip ip) - (dest-port u16) - (src-port u16))) + (dest-port uint 16) + (src-port uint 16))) (defconst data-bindat-spec - (bindat-spec + (bindat-type (type u8) (opcode u8) - (length u16r) ;; little endian order + (length uintr 16) ;; little endian order (id strz 8) - (data vec (length)) - (align 4))) + (data vec length) + (_ align 4))) + (defconst packet-bindat-spec - (bindat-spec - (header struct header-bindat-spec) + (bindat-type + (header type header-bindat-spec) (items u8) - (fill 3) - (item repeat (items) - (struct data-bindat-spec)))) + (_ fill 3) + (item repeat items + (_ type data-bindat-spec)))) (defconst struct-bindat '((header @@ -77,27 +80,7 @@ (should (equal (bindat-unpack packet-bindat-spec (bindat-pack packet-bindat-spec struct-bindat)) - '((item - ((data . - [1 2 3 4 5]) - (id . "ABCDEF") - (length . 5) - (opcode . 3) - (type . 2)) - ((data . - [6 7 8 9 10 11 12]) - (id . "BCDEFG") - (length . 7) - (opcode . 4) - (type . 1))) - (items . 2) - (header - (src-port . 5408) - (dest-port . 284) - (src-ip . - [192 168 1 101]) - (dest-ip . - [192 168 1 100])))))) + struct-bindat))) (ert-deftest bindat-test-pack/multibyte-string-fails () (should-error (bindat-pack nil nil "ö"))) @@ -121,4 +104,62 @@ (should (equal (bindat-ip-to-string [192 168 0 1]) "192.168.0.1")) (should (equal (bindat-ip-to-string "\300\250\0\1") "192.168.0.1"))) +(defconst bindat-test--int-websocket-type + (bindat-type + :pack-var value + (n1 u8 + :pack-val (if (< value 126) value (if (< value 65536) 126 127))) + (n2 uint (pcase n1 (127 64) (126 16) (_ 0)) + :pack-val value) + :unpack-val (if (< n1 126) n1 n2))) + +(ert-deftest bindat-test--pack-val () + ;; This is intended to test the :(un)pack-val feature that offers + ;; control over the unpacked representation of the data. + (dolist (n '(0 42 125 126 127 128 150 255 5000 65535 65536 8769786876)) + (should + (equal (bindat-unpack bindat-test--int-websocket-type + (bindat-pack bindat-test--int-websocket-type n)) + n)))) + +(ert-deftest bindat-test--sint () + (dotimes (kind 32) + (let ((bitlen (* 8 (/ kind 2))) + (r (zerop (% kind 2)))) + (dotimes (_ 100) + (let* ((n (random (ash 1 bitlen))) + (i (- n (ash 1 (1- bitlen))))) + (should (equal (bindat-unpack + (bindat-type sint bitlen r) + (bindat-pack (bindat-type sint bitlen r) i)) + i)) + (when (>= i 0) + (should (equal (bindat-pack + (bindat-type if r (uintr bitlen) (uint bitlen)) i) + (bindat-pack (bindat-type sint bitlen r) i))) + (should (equal (bindat-unpack + (bindat-type if r (uintr bitlen) (uint bitlen)) + (bindat-pack (bindat-type sint bitlen r) i)) + i)))))))) + +(defconst bindat-test--LEB128 + (bindat-type + letrec ((loop + (struct :pack-var n + (head u8 + :pack-val (+ (logand n 127) (if (> n 127) 128 0))) + (tail if (< head 128) (unit 0) loop + :pack-val (ash n -7)) + :unpack-val (+ (logand head 127) (ash tail 7))))) + loop)) + +(ert-deftest bindat-test--recursive () + (dotimes (n 10) + (let ((max (ash 1 (* n 10)))) + (dotimes (_ 10) + (let ((n (random max))) + (should (equal (bindat-unpack bindat-test--LEB128 + (bindat-pack bindat-test--LEB128 n)) + n))))))) + ;;; bindat-tests.el ends here -- cgit v1.2.3 From d925121b1e1cdf953705a5da43f8092f2a6e1d8c Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Wed, 24 Feb 2021 00:53:05 +0000 Subject: Various map.el improvements * lisp/emacs-lisp/seq.el (seq-do-indexed): Return nil as per doc. * lisp/emacs-lisp/map.el: Require Emacs >= 26 due to dependence on 5-arg alist-get. Bump package to version 3.0. Fix other headers. (Bug#46754) (map--plist-p): Detect list starting with nil as plist, not alist. (map-elt, map-filter, map-apply, map--make-pcase-bindings) (map--make-pcase-patterns): Simplify. (map-let, map-put, map-nested-elt, mapp): Update docstring for plist support. (map-delete): Fix OBOE on arrays. Split into cl-defmethods. (map-values, map-values-apply): Specialize for arrays. (map-pairs, map-keys-apply, map-put!): Improve docstring. (map-length): Clarify docstring w.r.t. duplicate keys. Split into cl-defmethods. Optimize default implementation. (map-copy): Use copy-alist on alists. Split into cl-defmethods. (map-contains-key): Add plist support. Clarify docstring w.r.t. optional argument. Simplify default implementation. (map-some, map-every-p, map-merge, map-merge-with, map--into-hash): Don't use map-apply for side effects. (map-into): Preserve plist ordering. Improve docstrings. (map-insert): Add hash-table and array support. (map-inplace): Remove unused error symbol. (map-do): Return nil as per doc. * etc/NEWS: Announce new user-visible behavior. * test/lisp/emacs-lisp/map-tests.el: Prefer should-not over (should (not ...)) in general. (with-maps-do): Fix docstring. (with-empty-maps-do): New macro. (test-map-elt-default, test-mapp, test-map-keys, test-map-values) (test-map-pairs, test-map-length, test-map-copy, test-map-apply) (test-map-do, test-map-keys-apply, test-map-values-apply) (test-map-filter, test-map-remove, test-map-empty-p) (test-map-contains-key, test-map-some, test-map-every-p): Use it. (test-map-plist-p, test-map-put!-new-keys, test-map-insert-empty) (test-map-insert, test-map-delete-empty, test-map-copy-alist) (test-map-contains-key-testfn, test-map-into-hash-test) (test-map-into-empty, test-map-merge, test-map-merge-empty): New tests. (test-map-elt): Test array key that is within bounds but not fixnum. (test-map-put!): Use map--plist-p. Remove redundant tests. (test-map-put-alist-new-key): Don't modify list literal. (test-map-put-testfn-alist, test-map-put-return-value): Silence obsoletion warnings. (test-map-delete): Check for OBOE on arrays. (test-map-delete-return-value): Remove test made redundant by test-map-delete. (test-map-nested-elt, test-map-into): Test plists too. --- etc/NEWS | 7 + lisp/emacs-lisp/map.el | 320 +++++++++++++------------ lisp/emacs-lisp/seq.el | 7 +- test/lisp/emacs-lisp/map-tests.el | 474 +++++++++++++++++++++++--------------- 4 files changed, 471 insertions(+), 337 deletions(-) (limited to 'test/lisp/emacs-lisp') diff --git a/etc/NEWS b/etc/NEWS index 6b4456e3de9..5487448eaeb 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1160,6 +1160,13 @@ effect. A pattern like '(map :sym)' binds the map's value for ':sym' to 'sym', equivalent to '(map (:sym sym))'. +--- +*** The function 'map-copy' now uses 'copy-alist' on alists. +This is a slightly deeper copy than the previous 'copy-sequence'. + +--- +*** The function 'map-contains-key' now supports plists. + ** Package +++ diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el index 46a1bd21a3d..c0cbc7b5a18 100644 --- a/lisp/emacs-lisp/map.el +++ b/lisp/emacs-lisp/map.el @@ -3,12 +3,10 @@ ;; Copyright (C) 2015-2021 Free Software Foundation, Inc. ;; Author: Nicolas Petton -;; Keywords: convenience, map, hash-table, alist, array -;; Version: 2.1 -;; Package-Requires: ((emacs "25")) -;; Package: map - ;; Maintainer: emacs-devel@gnu.org +;; Keywords: extensions, lisp +;; Version: 3.0 +;; Package-Requires: ((emacs "26")) ;; This file is part of GNU Emacs. @@ -27,8 +25,9 @@ ;;; Commentary: -;; map.el provides map-manipulation functions that work on alists, -;; hash-table and arrays. All functions are prefixed with "map-". +;; map.el provides generic map-manipulation functions that work on +;; alists, plists, hash-tables, and arrays. All functions are +;; prefixed with "map-". ;; ;; Functions taking a predicate or iterating over a map using a ;; function take the function as their first argument. All other @@ -54,7 +53,7 @@ ARGS is a list of elements to be matched in the map. Each element of ARGS can be of the form (KEY PAT), in which case KEY is evaluated and searched for in the map. The match fails if for any KEY found in the map, the corresponding PAT doesn't match the value -associated to the KEY. +associated with the KEY. Each element can also be a SYMBOL, which is an abbreviation of a (KEY PAT) tuple of the form (\\='SYMBOL SYMBOL). When SYMBOL @@ -75,7 +74,7 @@ bound to the looked up value in MAP. KEYS can also be a list of (KEY VARNAME) pairs, in which case KEY is an unquoted form. -MAP can be a list, hash-table or array." +MAP can be an alist, plist, hash-table, or array." (declare (indent 2) (debug ((&rest &or symbolp ([form symbolp])) form body))) `(pcase-let ((,(map--make-pcase-patterns keys) ,map)) @@ -101,7 +100,7 @@ Returns the result of evaluating the form associated with MAP-VAR's type." (define-error 'map-not-inplace "Cannot modify map in-place") (defsubst map--plist-p (list) - (and (consp list) (not (listp (car list))))) + (and (consp list) (atom (car list)))) (cl-defgeneric map-elt (map key &optional default testfn) "Lookup KEY in MAP and return its associated value. @@ -109,7 +108,8 @@ If KEY is not found, return DEFAULT which defaults to nil. TESTFN is deprecated. Its default depends on the MAP argument. -In the base definition, MAP can be an alist, hash-table, or array." +In the base definition, MAP can be an alist, plist, hash-table, +or array." (declare (gv-expander (lambda (do) @@ -127,26 +127,25 @@ In the base definition, MAP can be an alist, hash-table, or array." `(map-insert ,mgetter ,key ,v)))))))))) ;; `testfn' is deprecated. (advertised-calling-convention (map key &optional default) "27.1")) + ;; Can't use `cl-defmethod' with `advertised-calling-convention'. (map--dispatch map :list (if (map--plist-p map) - (let ((res (plist-get map key))) - (if (and default (null res) (not (plist-member map key))) - default - res)) + (let ((res (plist-member map key))) + (if res (cadr res) default)) (alist-get key map default nil testfn)) :hash-table (gethash key map default) - :array (if (and (>= key 0) (< key (seq-length map))) - (seq-elt map key) + :array (if (map-contains-key map key) + (aref map key) default))) (defmacro map-put (map key value &optional testfn) "Associate KEY with VALUE in MAP and return VALUE. If KEY is already present in MAP, replace the associated value with VALUE. -When MAP is a list, test equality with TESTFN if non-nil, +When MAP is an alist, test equality with TESTFN if non-nil, otherwise use `eql'. -MAP can be a list, hash-table or array." +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)) @@ -168,23 +167,30 @@ MAP can be a list, hash-table or array." (cl-defgeneric map-delete (map key) "Delete KEY in-place from MAP and return MAP. -No error is signaled if KEY is not a key of MAP. -If MAP is an array, store nil at the index KEY." - (map--dispatch map - ;; FIXME: Signal map-not-inplace i.s.o returning a different list? - :list (if (map--plist-p map) - (setq map (map--plist-delete map key)) - (setf (alist-get key map nil t) nil)) - :hash-table (remhash key map) - :array (and (>= key 0) - (<= key (seq-length map)) - (aset map key nil))) +Keys not present in MAP are ignored.") + +(cl-defmethod map-delete ((map list) key) + ;; FIXME: Signal map-not-inplace i.s.o returning a different list? + (if (map--plist-p map) + (map--plist-delete map key) + (setf (alist-get key map nil t) nil) + map)) + +(cl-defmethod map-delete ((map hash-table) key) + (remhash key map) + map) + +(cl-defmethod map-delete ((map array) key) + "Store nil at index KEY." + (when (map-contains-key map key) + (aset map key nil)) map) (defun map-nested-elt (map keys &optional default) "Traverse MAP using KEYS and return the looked up value or DEFAULT if nil. -Map can be a nested map composed of alists, hash-tables and arrays." +MAP can be a nested map composed of alists, plists, hash-tables, +and arrays." (or (seq-reduce (lambda (acc key) (when (mapp acc) (map-elt acc key))) @@ -202,30 +208,49 @@ The default implementation delegates to `map-apply'." The default implementation delegates to `map-apply'." (map-apply (lambda (_ value) value) map)) +(cl-defmethod map-values ((map array)) + "Convert MAP into a list." + (append map ())) + (cl-defgeneric map-pairs (map) - "Return the elements of MAP as key/value association lists. + "Return the key/value pairs in MAP as an alist. The default implementation delegates to `map-apply'." (map-apply #'cons map)) (cl-defgeneric map-length (map) ;; FIXME: Should we rename this to `map-size'? - "Return the number of elements in the map. -The default implementation counts `map-keys'." - (cond - ((hash-table-p map) (hash-table-count map)) - ((listp map) - ;; FIXME: What about repeated/shadowed keys? - (if (map--plist-p map) (/ (length map) 2) (length map))) - ((arrayp map) (length map)) - (t (length (map-keys map))))) + "Return the number of key/value pairs in MAP. +Note that this does not always reflect the number of unique keys. +The default implementation delegates to `map-do'." + (let ((size 0)) + (map-do (lambda (_k _v) (setq size (1+ size))) map) + size)) + +(cl-defmethod map-length ((map hash-table)) + (hash-table-count map)) + +(cl-defmethod map-length ((map list)) + (if (map--plist-p map) + (/ (length map) 2) + (length map))) + +(cl-defmethod map-length ((map array)) + (length map)) (cl-defgeneric map-copy (map) - "Return a copy of MAP." - ;; FIXME: Clarify how deep is the copy! - (map--dispatch map - :list (seq-copy map) ;FIXME: Probably not deep enough for alists! - :hash-table (copy-hash-table map) - :array (seq-copy map))) + "Return a copy of MAP.") + +(cl-defmethod map-copy ((map list)) + "Use `copy-alist' on alists and `copy-sequence' on plists." + (if (map--plist-p map) + (copy-sequence map) + (copy-alist map))) + +(cl-defmethod map-copy ((map hash-table)) + (copy-hash-table map)) + +(cl-defmethod map-copy ((map array)) + (copy-sequence map)) (cl-defgeneric map-apply (function map) "Apply FUNCTION to each element of MAP and return the result as a list. @@ -243,26 +268,28 @@ FUNCTION is called with two arguments, the key and the value.") (cl-defmethod map-do (function (map hash-table)) (maphash function map)) (cl-defgeneric map-keys-apply (function map) - "Return the result of applying FUNCTION to each key of MAP. + "Return the result of applying FUNCTION to each key in MAP. The default implementation delegates to `map-apply'." (map-apply (lambda (key _) (funcall function key)) map)) (cl-defgeneric map-values-apply (function map) - "Return the result of applying FUNCTION to each value of MAP. + "Return the result of applying FUNCTION to each value in MAP. The default implementation delegates to `map-apply'." (map-apply (lambda (_ val) (funcall function val)) map)) +(cl-defmethod map-values-apply (function (map array)) + (mapcar function map)) + (cl-defgeneric map-filter (pred map) "Return an alist of key/val pairs for which (PRED key val) is non-nil in MAP. The default implementation delegates to `map-apply'." (delq nil (map-apply (lambda (key val) - (if (funcall pred key val) - (cons key val) - nil)) + (and (funcall pred key val) + (cons key val))) map))) (cl-defgeneric map-remove (pred map) @@ -272,7 +299,7 @@ The default implementation delegates to `map-filter'." map)) (cl-defgeneric mapp (map) - "Return non-nil if MAP is a map (alist, hash-table, array, ...)." + "Return non-nil if MAP is a map (alist/plist, hash-table, array, ...)." (or (listp map) (hash-table-p map) (arrayp map))) @@ -292,56 +319,58 @@ The default implementation delegates to `map-length'." ;; 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-do'." +The default implementation delegates to `map-some'." (unless testfn (setq testfn #'equal)) - (catch 'map--catch - (map-do (lambda (k _v) - (if (funcall testfn key k) (throw 'map--catch t))) - map) - nil)) + (map-some (lambda (k _v) (funcall testfn key k)) map)) (cl-defmethod map-contains-key ((map list) key &optional testfn) - (let ((v '(nil))) - (not (eq v (alist-get key map v nil (or testfn #'equal)))))) + "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--plist-p map) + (plist-member map key) + (let ((v '(nil))) + (not (eq v (alist-get key map v nil (or testfn #'equal))))))) (cl-defmethod map-contains-key ((map array) key &optional _testfn) - (and (integerp key) - (>= key 0) - (< key (length map)))) + "Return non-nil if KEY is an index of MAP, ignoring TESTFN." + (and (natnump key) (< key (length map)))) (cl-defmethod map-contains-key ((map hash-table) key &optional _testfn) + "Return non-nil if MAP contains KEY, ignoring TESTFN." (let ((v '(nil))) (not (eq v (gethash key map v))))) (cl-defgeneric map-some (pred map) "Return the first non-nil (PRED key val) in MAP. -The default implementation delegates to `map-apply'." +Return nil if no such element is found. +The default implementation delegates to `map-do'." ;; FIXME: Not sure if there's much benefit to defining it as defgeneric, ;; since as defined, I can't think of a map-type where we could provide an ;; algorithmically more efficient algorithm than the default. (catch 'map--break - (map-apply (lambda (key value) - (let ((result (funcall pred key value))) - (when result - (throw 'map--break result)))) - map) + (map-do (lambda (key value) + (let ((result (funcall pred key value))) + (when result + (throw 'map--break result)))) + map) nil)) (cl-defgeneric map-every-p (pred map) "Return non-nil if (PRED key val) is non-nil for all elements of MAP. -The default implementation delegates to `map-apply'." +The default implementation delegates to `map-do'." ;; FIXME: Not sure if there's much benefit to defining it as defgeneric, ;; since as defined, I can't think of a map-type where we could provide an ;; algorithmically more efficient algorithm than the default. (catch 'map--break - (map-apply (lambda (key value) + (map-do (lambda (key value) (or (funcall pred key value) (throw 'map--break nil))) map) t)) (defun map-merge (type &rest maps) - "Merge into a map of type TYPE all the key/value pairs in MAPS. + "Merge into a map of TYPE all the key/value pairs in MAPS. See `map-into' for all supported values of TYPE." (let ((result (map-into (pop maps) type))) (while maps @@ -349,48 +378,57 @@ See `map-into' for all supported values of TYPE." ;; For small tables, this is fine, but for large tables, we ;; should probably use a hash-table internally which we convert ;; to an alist in the end. - (map-apply (lambda (key value) - (setf (map-elt result key) value)) - (pop maps))) + (map-do (lambda (key value) + (setf (map-elt result key) value)) + (pop maps))) result)) (defun map-merge-with (type function &rest maps) - "Merge into a map of type TYPE all the key/value pairs in MAPS. -When two maps contain the same key (`eql'), call FUNCTION on the two + "Merge into a map of TYPE all the key/value pairs in MAPS. +When two maps contain the same (`eql') key, call FUNCTION on the two values and use the value returned by it. -MAP can be a list, hash-table or array. +Each of MAPS can be an alist, plist, hash-table, or array. See `map-into' for all supported values of TYPE." (let ((result (map-into (pop maps) type)) - (not-found (cons nil nil))) + (not-found (list nil))) (while maps - (map-apply (lambda (key value) - (cl-callf (lambda (old) - (if (eql old not-found) - value - (funcall function old value))) - (map-elt result key not-found))) - (pop maps))) + (map-do (lambda (key value) + (cl-callf (lambda (old) + (if (eql old not-found) + value + (funcall function old value))) + (map-elt result key not-found))) + (pop maps))) result)) (cl-defgeneric map-into (map type) - "Convert the map MAP into a map of type TYPE.") + "Convert MAP into a map of TYPE.") + ;; FIXME: I wish there was a way to avoid this η-redex! -(cl-defmethod map-into (map (_type (eql list))) (map-pairs map)) -(cl-defmethod map-into (map (_type (eql alist))) (map-pairs map)) +(cl-defmethod map-into (map (_type (eql list))) + "Convert MAP into an alist." + (map-pairs map)) + +(cl-defmethod map-into (map (_type (eql alist))) + "Convert MAP into an alist." + (map-pairs map)) + (cl-defmethod map-into (map (_type (eql plist))) - (let ((plist '())) - (map-do (lambda (k v) (setq plist `(,k ,v ,@plist))) map) - plist)) + "Convert MAP into a plist." + (let (plist) + (map-do (lambda (k v) (setq plist `(,v ,k ,@plist))) map) + (nreverse plist))) (cl-defgeneric map-put! (map key value &optional testfn) "Associate KEY with VALUE in MAP. If KEY is already present in MAP, replace the associated value with VALUE. This operates by modifying MAP in place. -If it cannot do that, it signals the `map-not-inplace' error. -If you want to insert an element without modifying MAP, use `map-insert'." +If it cannot do that, it signals a `map-not-inplace' error. +To insert an element without modifying MAP, use `map-insert'." ;; `testfn' only exists for backward compatibility with `map-put'! (declare (advertised-calling-convention (map key value) "27.1")) + ;; Can't use `cl-defmethod' with `advertised-calling-convention'. (map--dispatch map :list (if (map--plist-p map) @@ -404,18 +442,20 @@ If you want to insert an element without modifying MAP, use `map-insert'." ;; and let `map-insert' grow the array? :array (aset map key value))) -(define-error 'map-inplace "Can only modify map in place") - (cl-defgeneric map-insert (map key value) "Return a new map like MAP except that it associates KEY with VALUE. This does not modify MAP. -If you want to insert an element in place, use `map-put!'." - (if (listp map) - (if (map--plist-p map) - `(,key ,value ,@map) - (cons (cons key value) map)) - ;; FIXME: Should we signal an error or use copy+put! ? - (signal 'map-inplace (list map)))) +If you want to insert an element in place, use `map-put!'. +The default implementation defaults to `map-copy' and `map-put!'." + (let ((copy (map-copy map))) + (map-put! copy key value) + copy)) + +(cl-defmethod map-insert ((map list) key value) + "Cons KEY and VALUE to the front of MAP." + (if (map--plist-p map) + (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 @@ -425,11 +465,9 @@ If you want to insert an element in place, use `map-put!'." (cl-defmethod map-apply (function (map list)) (if (map--plist-p map) (cl-call-next-method) - (seq-map (lambda (pair) - (funcall function - (car pair) - (cdr pair))) - map))) + (mapcar (lambda (pair) + (funcall function (car pair) (cdr pair))) + map))) (cl-defmethod map-apply (function (map hash-table)) (let (result) @@ -439,46 +477,40 @@ If you want to insert an element in place, use `map-put!'." (nreverse result))) (cl-defmethod map-apply (function (map array)) - (let ((index 0)) - (seq-map (lambda (elt) - (prog1 - (funcall function index elt) - (setq index (1+ index)))) - map))) + (seq-map-indexed (lambda (elt index) + (funcall function index elt)) + map)) (cl-defmethod map-do (function (map list)) - "Private function used to iterate over ALIST using FUNCTION." (if (map--plist-p map) (while map (funcall function (pop map) (pop map))) - (seq-do (lambda (pair) - (funcall function - (car pair) - (cdr pair))) - map))) + (mapc (lambda (pair) + (funcall function (car pair) (cdr pair))) + map) + nil)) -(cl-defmethod map-do (function (array array)) - "Private function used to iterate over ARRAY using FUNCTION." +(cl-defmethod map-do (function (map array)) (seq-do-indexed (lambda (elt index) - (funcall function index elt)) - array)) + (funcall function index elt)) + map)) (defun map--into-hash (map keyword-args) "Convert MAP into a hash-table. KEYWORD-ARGS are forwarded to `make-hash-table'." (let ((ht (apply #'make-hash-table keyword-args))) - (map-apply (lambda (key value) - (setf (gethash key ht) value)) - map) + (map-do (lambda (key value) + (puthash key value ht)) + map) ht)) (cl-defmethod map-into (map (_type (eql hash-table))) - "Convert MAP into a hash-table." - (map--into-hash map (list :size (map-length map) :test 'equal))) + "Convert MAP into a hash-table with keys compared with `equal'." + (map--into-hash map (list :size (map-length map) :test #'equal))) (cl-defmethod map-into (map (type (head hash-table))) "Convert MAP into a hash-table. -TYPE is a list where the car is `hash-table' and the cdr are the +TYPE is a list whose car is `hash-table' and cdr a list of keyword-args forwarded to `make-hash-table'. Example: @@ -487,23 +519,23 @@ Example: (defun map--make-pcase-bindings (args) "Return a list of pcase bindings from ARGS to the elements of a map." - (seq-map (lambda (elt) - (cond ((consp elt) - `(app (pcase--flip map-elt ,(car elt)) ,(cadr elt))) - ((keywordp elt) - (let ((var (intern (substring (symbol-name elt) 1)))) - `(app (pcase--flip map-elt ,elt) ,var))) - (t `(app (pcase--flip map-elt ',elt) ,elt)))) - args)) + (mapcar (lambda (elt) + (cond ((consp elt) + `(app (pcase--flip map-elt ,(car elt)) ,(cadr elt))) + ((keywordp elt) + (let ((var (intern (substring (symbol-name elt) 1)))) + `(app (pcase--flip map-elt ,elt) ,var))) + (t `(app (pcase--flip map-elt ',elt) ,elt)))) + args)) (defun map--make-pcase-patterns (args) "Return a list of `(map ...)' pcase patterns built from ARGS." (cons 'map - (seq-map (lambda (elt) - (if (and (consp elt) (eq 'map (car elt))) - (map--make-pcase-patterns elt) - elt)) - args))) + (mapcar (lambda (elt) + (if (eq (car-safe elt) 'map) + (map--make-pcase-patterns elt) + elt)) + args))) (provide 'map) ;;; map.el ends here diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index adfce950176..2b8807faad5 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -134,9 +134,10 @@ Unlike `seq-map', FUNCTION takes two arguments: the element of the sequence, and its index within the sequence." (let ((index 0)) (seq-do (lambda (elt) - (funcall function elt index) - (setq index (1+ index))) - sequence))) + (funcall function elt index) + (setq index (1+ index))) + sequence)) + nil) (cl-defgeneric seqp (object) "Return non-nil if OBJECT is a sequence, nil otherwise." diff --git a/test/lisp/emacs-lisp/map-tests.el b/test/lisp/emacs-lisp/map-tests.el index 9a2cd42a211..67666d8e7e7 100644 --- a/test/lisp/emacs-lisp/map-tests.el +++ b/test/lisp/emacs-lisp/map-tests.el @@ -22,7 +22,7 @@ ;;; Commentary: -;; Tests for map.el +;; Tests for map.el. ;;; Code: @@ -30,12 +30,10 @@ (require 'map) (defmacro with-maps-do (var &rest body) - "Successively bind VAR to an alist, vector and hash-table. + "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)). -Evaluate BODY for each created map. - -\(fn (var map) body)" + \\='((0 . 3) (1 . 4) (2 . 5)). +Evaluate BODY for each created map." (declare (indent 1) (debug (symbolp body))) (let ((alist (make-symbol "alist")) (plist (make-symbol "plist")) @@ -53,43 +51,62 @@ Evaluate BODY for each created map. (dolist (,var (list ,alist ,plist ,vec ,ht)) ,@body)))) +(defmacro with-empty-maps-do (var &rest body) + "Like `with-maps-do', but with empty maps." + (declare (indent 1) (debug (symbolp body))) + `(dolist (,var (list (list) (vector) (make-hash-table))) + ,@body)) + +(ert-deftest test-map-plist-p () + "Test `map--plist-p'." + (with-empty-maps-do map + (should-not (map--plist-p map))) + (should-not (map--plist-p "")) + (should-not (map--plist-p '((())))) + (should (map--plist-p '(:a))) + (should (map--plist-p '(a))) + (should (map--plist-p '(nil))) + (should (map--plist-p '("")))) + (ert-deftest test-map-elt () (with-maps-do map (should (= 3 (map-elt map 0))) (should (= 4 (map-elt map 1))) (should (= 5 (map-elt map 2))) - (should (null (map-elt map -1))) - (should (null (map-elt map 4))))) + (should-not (map-elt map -1)) + (should-not (map-elt map 4)) + (should-not (map-elt map 0.1)))) (ert-deftest test-map-elt-default () (with-maps-do map - (should (= 5 (map-elt map 7 5))))) + (should (= 5 (map-elt map 7 5))) + (should (= 5 (map-elt map 0.1 5)))) + (with-empty-maps-do map + (should (= 5 (map-elt map 0 5))))) (ert-deftest test-map-elt-testfn () (let ((map (list (cons "a" 1) (cons "b" 2))) ;; Make sure to use a non-eq "a", even when compiled. (noneq-key (string ?a))) (should-not (map-elt map noneq-key)) - (should (map-elt map noneq-key nil 'equal)))) + (should (map-elt map noneq-key nil #'equal)))) (ert-deftest test-map-elt-with-nil-value () - (should (null (map-elt '((a . 1) - (b)) - 'b - '2)))) + (should-not (map-elt '((a . 1) (b)) 'b 2))) (ert-deftest test-map-put! () (with-maps-do map (setf (map-elt map 2) 'hello) (should (eq (map-elt map 2) 'hello))) (with-maps-do map - (map-put map 2 'hello) + (with-suppressed-warnings ((obsolete map-put)) + (map-put map 2 'hello)) (should (eq (map-elt map 2) 'hello))) (with-maps-do map (map-put! map 2 'hello) (should (eq (map-elt map 2) 'hello)) (if (not (or (hash-table-p map) - (and (listp map) (not (listp (car map)))))) ;plist! + (map--plist-p map))) (should-error (map-put! map 5 'value) ;; For vectors, it could arguably signal ;; map-not-inplace as well, but it currently doesn't. @@ -97,49 +114,88 @@ Evaluate BODY for each created map. 'map-not-inplace 'error)) (map-put! map 5 'value) - (should (eq (map-elt map 5) 'value)))) - (let ((ht (make-hash-table))) - (setf (map-elt ht 2) 'a) - (should (eq (map-elt ht 2) - 'a))) - (let ((alist '((0 . a) (1 . b) (2 . c)))) - (setf (map-elt alist 2) 'a) - (should (eq (map-elt alist 2) - 'a))) - (let ((vec [3 4 5])) - (should-error (setf (map-elt vec 3) 6)))) + (should (eq (map-elt map 5) 'value))))) + +(ert-deftest test-map-put!-new-keys () + "Test `map-put!' with new keys." + (with-maps-do map + (let ((size (map-length map))) + (if (arrayp map) + (progn + (should-error (setf (map-elt map 'k) 'v)) + (should-error (setf (map-elt map size) 'v))) + (setf (map-elt map 'k) 'v) + (should (eq (map-elt map 'k) 'v)) + (setf (map-elt map size) 'v) + (should (eq (map-elt map size) 'v)))))) (ert-deftest test-map-put-alist-new-key () "Regression test for Bug#23105." - (let ((alist '((0 . a)))) - (map-put alist 2 'b) - (should (eq (map-elt alist 2) - 'b)))) + (let ((alist (list (cons 0 'a)))) + (with-suppressed-warnings ((obsolete map-put)) + (map-put alist 2 'b)) + (should (eq (map-elt alist 2) 'b)))) (ert-deftest test-map-put-testfn-alist () (let ((alist (list (cons "a" 1) (cons "b" 2))) ;; Make sure to use a non-eq "a", even when compiled. (noneq-key (string ?a))) - (map-put alist noneq-key 3 #'equal) - (should-not (cddr alist)) - (map-put alist noneq-key 9 #'eql) - (should (cddr alist)))) + (with-suppressed-warnings ((obsolete map-put)) + (map-put alist noneq-key 3 #'equal) + (should-not (cddr alist)) + (map-put alist noneq-key 9 #'eql) + (should (cddr alist))))) (ert-deftest test-map-put-return-value () (let ((ht (make-hash-table))) - (should (eq (map-put ht 'a 'hello) 'hello)))) + (with-suppressed-warnings ((obsolete map-put)) + (should (eq (map-put ht 'a 'hello) 'hello))))) + +(ert-deftest test-map-insert-empty () + "Test `map-insert' on empty maps." + (with-empty-maps-do map + (if (arrayp map) + (should-error (map-insert map 0 6)) + (let ((new (map-insert map 0 6))) + (should-not (eq map new)) + (should-not (map-pairs map)) + (should (= (map-elt new 0) 6)))))) + +(ert-deftest test-map-insert () + "Test `map-insert'." + (with-maps-do map + (let ((pairs (map-pairs map)) + (size (map-length map)) + (new (map-insert map 0 6))) + (should-not (eq map new)) + (should (equal (map-pairs map) pairs)) + (should (= (map-elt new 0) 6)) + (if (arrayp map) + (should-error (map-insert map size 7)) + (setq new (map-insert map size 7)) + (should-not (eq map new)) + (should (equal (map-pairs map) pairs)) + (should (= (map-elt new size) 7)))))) (ert-deftest test-map-delete () (with-maps-do map - (map-delete map 1) - (should (null (map-elt map 1)))) + (should (map-elt map 1)) + (should (eq map (map-delete map 1))) + (should-not (map-elt map 1))) (with-maps-do map - (map-delete map -2) - (should (null (map-elt map -2))))) + (should-not (map-elt map -2)) + (should (eq map (map-delete map -2))) + (should-not (map-elt map -2))) + (with-maps-do map + ;; Check for OBOE. + (let ((key (map-length map))) + (should-not (map-elt map key)) + (should (eq map (map-delete map key))) + (should-not (map-elt map key))))) -(ert-deftest test-map-delete-return-value () - (let ((ht (make-hash-table))) - (should (eq (map-delete ht 'a) ht)))) +(ert-deftest test-map-delete-empty () + (with-empty-maps-do map + (should (eq map (map-delete map t))))) (ert-deftest test-map-nested-elt () (let ((vec [a b [c d [e f]]])) @@ -149,8 +205,9 @@ Evaluate BODY for each created map. (d . 3) (e . ((f . 4) (g . 5)))))))) - (should (eq (map-nested-elt alist '(b e f)) - 4))) + (should (eq (map-nested-elt alist '(b e f)) 4))) + (let ((plist '(a 1 b (c 2 d 3 e (f 4 g 5))))) + (should (eq (map-nested-elt plist '(b e f)) 4))) (let ((ht (make-hash-table))) (setf (map-elt ht 'a) 1) (setf (map-elt ht 'b) (make-hash-table)) @@ -160,214 +217,238 @@ Evaluate BODY for each created map. (ert-deftest test-map-nested-elt-default () (let ((vec [a b [c d]])) - (should (null (map-nested-elt vec '(2 3)))) - (should (null (map-nested-elt vec '(2 1 1)))) + (should-not (map-nested-elt vec '(2 3))) + (should-not (map-nested-elt vec '(2 1 1))) (should (= 4 (map-nested-elt vec '(2 1 1) 4))))) (ert-deftest test-mapp () - (should (mapp nil)) - (should (mapp '((a . b) (c . d)))) - (should (mapp '(a b c d))) - (should (mapp [])) - (should (mapp [1 2 3])) - (should (mapp (make-hash-table))) + (with-empty-maps-do map + (should (mapp map))) + (with-maps-do map + (should (mapp map))) + (should (mapp "")) (should (mapp "hello")) - (should (not (mapp 1))) - (should (not (mapp 'hello)))) + (should-not (mapp 1)) + (should-not (mapp 'hello))) (ert-deftest test-map-keys () (with-maps-do map (should (equal (map-keys map) '(0 1 2)))) - (should (null (map-keys nil))) - (should (null (map-keys [])))) + (with-empty-maps-do map + (should-not (map-keys map)))) (ert-deftest test-map-values () (with-maps-do map - (should (equal (map-values map) '(3 4 5))))) + (should (equal (map-values map) '(3 4 5)))) + (with-empty-maps-do map + (should-not (map-values map)))) (ert-deftest test-map-pairs () (with-maps-do map - (should (equal (map-pairs map) '((0 . 3) - (1 . 4) - (2 . 5)))))) + (should (equal (map-pairs map) + '((0 . 3) + (1 . 4) + (2 . 5))))) + (with-empty-maps-do map + (should-not (map-pairs map)))) (ert-deftest test-map-length () - (let ((ht (make-hash-table))) - (puthash 'a 1 ht) - (puthash 'b 2 ht) - (puthash 'c 3 ht) - (puthash 'd 4 ht) - (should (= 0 (map-length nil))) - (should (= 0 (map-length []))) - (should (= 0 (map-length (make-hash-table)))) - (should (= 5 (map-length [0 1 2 3 4]))) - (should (= 2 (map-length '((a . 1) (b . 2))))) - (should (= 4 (map-length ht))))) + (with-empty-maps-do map + (should (zerop (map-length map)))) + (with-maps-do map + (should (= 3 (map-length map)))) + (should (= 1 (map-length '(nil 1)))) + (should (= 2 (map-length '(nil 1 t 2)))) + (should (= 2 (map-length '((a . 1) (b . 2))))) + (should (= 5 (map-length [0 1 2 3 4]))) + (should (= 4 (map-length #s(hash-table data (a 1 b 2 c 3 d 4)))))) (ert-deftest test-map-copy () (with-maps-do map (let ((copy (map-copy map))) - (should (equal (map-keys map) (map-keys copy))) - (should (equal (map-values map) (map-values copy))) - (should (not (eq map copy)))))) + (should (equal (map-pairs map) (map-pairs copy))) + (should-not (eq map copy)) + (map-put! map 0 0) + (should-not (equal (map-pairs map) (map-pairs copy))))) + (with-empty-maps-do map + (should-not (map-pairs (map-copy map))))) + +(ert-deftest test-map-copy-alist () + "Test use of `copy-alist' for alists." + (let* ((cons (list 'a 1 2)) + (alist (list cons)) + (copy (map-copy alist))) + (setcar cons 'b) + (should (equal alist '((b 1 2)))) + (should (equal copy '((a 1 2)))) + (setcar (cdr cons) 0) + (should (equal alist '((b 0 2)))) + (should (equal copy '((a 0 2)))) + (setcdr cons 3) + (should (equal alist '((b . 3)))) + (should (equal copy '((a 0 2)))))) (ert-deftest test-map-apply () - (with-maps-do map - (should (equal (map-apply (lambda (k v) (cons (int-to-string k) v)) - map) - '(("0" . 3) ("1" . 4) ("2" . 5))))) - (let ((vec [a b c])) - (should (equal (map-apply (lambda (k v) (cons (1+ k) v)) - vec) - '((1 . a) - (2 . b) - (3 . c)))))) + (let ((fn (lambda (k v) (cons (number-to-string k) v)))) + (with-maps-do map + (should (equal (map-apply fn map) + '(("0" . 3) ("1" . 4) ("2" . 5))))) + (with-empty-maps-do map + (should-not (map-apply fn map))))) (ert-deftest test-map-do () - (with-maps-do map - (let ((result nil)) - (map-do (lambda (k v) - (push (list (int-to-string k) v) result)) - map) - (should (equal result '(("2" 5) ("1" 4) ("0" 3))))))) + (let* (res + (fn (lambda (k v) + (push (list (number-to-string k) v) res)))) + (with-empty-maps-do map + (should-not (map-do fn map)) + (should-not res)) + (with-maps-do map + (setq res nil) + (should-not (map-do fn map)) + (should (equal res '(("2" 5) ("1" 4) ("0" 3))))))) (ert-deftest test-map-keys-apply () (with-maps-do map - (should (equal (map-keys-apply (lambda (k) (int-to-string k)) - map) - '("0" "1" "2")))) - (let ((vec [a b c])) - (should (equal (map-keys-apply (lambda (k) (1+ k)) - vec) - '(1 2 3))))) + (should (equal (map-keys-apply #'1+ map) '(1 2 3)))) + (with-empty-maps-do map + (let (ks) + (should-not (map-keys-apply (lambda (k) (push k ks)) map)) + (should-not ks)))) (ert-deftest test-map-values-apply () (with-maps-do map - (should (equal (map-values-apply (lambda (v) (1+ v)) - map) - '(4 5 6)))) - (let ((vec [a b c])) - (should (equal (map-values-apply (lambda (v) (symbol-name v)) - vec) - '("a" "b" "c"))))) + (should (equal (map-values-apply #'1+ map) '(4 5 6)))) + (with-empty-maps-do map + (let (vs) + (should-not (map-values-apply (lambda (v) (push v vs)) map)) + (should-not vs)))) (ert-deftest test-map-filter () (with-maps-do map - (should (equal (map-keys (map-filter (lambda (_k v) - (<= 4 v)) - map)) - '(1 2))) - (should (null (map-filter (lambda (k _v) - (eq 'd k)) - map)))) - (should (null (map-filter (lambda (_k v) - (eq 3 v)) - [1 2 4 5]))) - (should (equal (map-filter (lambda (k _v) - (eq 3 k)) - [1 2 4 5]) - '((3 . 5))))) + (should (equal (map-filter (lambda (_k v) (> v 3)) map) + '((1 . 4) (2 . 5)))) + (should (equal (map-filter #'always map) (map-pairs map))) + (should-not (map-filter #'ignore map))) + (with-empty-maps-do map + (should-not (map-filter #'always map)) + (should-not (map-filter #'ignore map)))) (ert-deftest test-map-remove () (with-maps-do map - (should (equal (map-keys (map-remove (lambda (_k v) - (>= v 4)) - map)) - '(0))) - (should (equal (map-keys (map-remove (lambda (k _v) - (eq 'd k)) - map)) - (map-keys map)))) - (should (equal (map-remove (lambda (_k v) - (eq 3 v)) - [1 2 4 5]) - '((0 . 1) - (1 . 2) - (2 . 4) - (3 . 5)))) - (should (null (map-remove (lambda (k _v) - (>= k 0)) - [1 2 4 5])))) + (should (equal (map-remove (lambda (_k v) (> v 3)) map) + '((0 . 3)))) + (should (equal (map-remove #'ignore map) (map-pairs map))) + (should-not (map-remove #'always map))) + (with-empty-maps-do map + (should-not (map-remove #'always map)) + (should-not (map-remove #'ignore map)))) (ert-deftest test-map-empty-p () - (should (map-empty-p nil)) - (should (not (map-empty-p '((a . b) (c . d))))) - (should (map-empty-p [])) - (should (not (map-empty-p [1 2 3]))) - (should (map-empty-p (make-hash-table))) - (should (not (map-empty-p "hello"))) - (should (map-empty-p ""))) + (with-empty-maps-do map + (should (map-empty-p map))) + (should (map-empty-p "")) + (should-not (map-empty-p '((a . b) (c . d)))) + (should-not (map-empty-p [1 2 3])) + (should-not (map-empty-p "hello"))) (ert-deftest test-map-contains-key () - (should (map-contains-key '((a . 1) (b . 2)) 'a)) - (should (not (map-contains-key '((a . 1) (b . 2)) 'c))) - (should (map-contains-key '(("a" . 1)) "a")) - (should (not (map-contains-key '(("a" . 1)) "a" #'eq))) - (should (map-contains-key [a b c] 2)) - (should (not (map-contains-key [a b c] 3)))) + (with-empty-maps-do map + (should-not (map-contains-key map -1)) + (should-not (map-contains-key map 0)) + (should-not (map-contains-key map 1)) + (should-not (map-contains-key map (map-length map)))) + (with-maps-do map + (should-not (map-contains-key map -1)) + (should (map-contains-key map 0)) + (should (map-contains-key map 1)) + (should-not (map-contains-key map (map-length map))))) + +(ert-deftest test-map-contains-key-testfn () + "Test `map-contains-key' under different equalities." + (let ((key (string ?a)) + (plist '("a" 1 a 2)) + (alist '(("a" . 1) (a . 2)))) + (should (map-contains-key alist 'a)) + (should (map-contains-key plist 'a)) + (should (map-contains-key alist 'a #'eq)) + (should (map-contains-key plist 'a #'eq)) + (should (map-contains-key alist key)) + (should-not (map-contains-key plist key)) + (should-not (map-contains-key alist key #'eq)) + (should-not (map-contains-key plist key #'eq)))) (ert-deftest test-map-some () (with-maps-do map - (should (map-some (lambda (k _v) - (eq 1 k)) - map)) - (should-not (map-some (lambda (k _v) - (eq 'd k)) - map))) - (let ((vec [a b c])) - (should (map-some (lambda (k _v) - (> k 1)) - vec)) - (should-not (map-some (lambda (k _v) - (> k 3)) - vec)))) + (should (eq (map-some (lambda (k _v) (and (= k 1) 'found)) map) + 'found)) + (should-not (map-some #'ignore map))) + (with-empty-maps-do map + (should-not (map-some #'always map)) + (should-not (map-some #'ignore map)))) (ert-deftest test-map-every-p () (with-maps-do map - (should (map-every-p (lambda (k _v) - k) - map)) - (should (not (map-every-p (lambda (_k _v) - nil) - map)))) - (let ((vec [a b c])) - (should (map-every-p (lambda (k _v) - (>= k 0)) - vec)) - (should (not (map-every-p (lambda (k _v) - (> k 3)) - vec))))) + (should (map-every-p #'always map)) + (should-not (map-every-p #'ignore map)) + (should-not (map-every-p (lambda (k _v) (zerop k)) map))) + (with-empty-maps-do map + (should (map-every-p #'always map)) + (should (map-every-p #'ignore map)) + (should (map-every-p (lambda (k _v) (zerop k)) map)))) (ert-deftest test-map-into () - (let* ((alist '((a . 1) (b . 2))) + (let* ((plist '(a 1 b 2)) + (alist '((a . 1) (b . 2))) (ht (map-into alist 'hash-table)) (ht2 (map-into alist '(hash-table :test equal)))) (should (hash-table-p ht)) - (should (equal (map-into (map-into alist 'hash-table) 'list) - alist)) - (should (listp (map-into ht 'list))) - (should (equal (map-keys (map-into (map-into ht 'list) 'hash-table)) - (map-keys ht))) - (should (equal (map-values (map-into (map-into ht 'list) 'hash-table)) - (map-values ht))) + (should (equal (map-into ht 'list) alist)) + (should (equal (map-pairs (map-into (map-into ht 'list) 'hash-table)) + (map-pairs ht))) (should (equal (map-into ht 'alist) (map-into ht2 'alist))) - (should (eq (hash-table-test ht2) 'equal)) - (should (null (map-into nil 'list))) - (should (map-empty-p (map-into nil 'hash-table))) - (should-error (map-into [1 2 3] 'string)))) + (should (equal (map-into alist 'list) alist)) + (should (equal (map-into alist 'alist) alist)) + (should (equal (map-into alist 'plist) plist)) + (should (equal (map-into plist 'alist) alist)) + (should (equal (map-into plist 'plist) plist))) + (should-error (map-into [1 2 3] 'string) :type 'cl-no-applicable-method)) + +(ert-deftest test-map-into-hash-test () + "Test `map-into' with different hash-table test functions." + (should (eq (hash-table-test (map-into () 'hash-table)) #'equal)) + (should (eq (hash-table-test (map-into () '(hash-table))) #'eql)) + (should (eq (hash-table-test (map-into () '(hash-table :test eq))) #'eq)) + (should (eq (hash-table-test (map-into () '(hash-table :test eql))) #'eql)) + (should (eq (hash-table-test (map-into () '(hash-table :test equal))) + #'equal))) + +(ert-deftest test-map-into-empty () + "Test `map-into' with empty maps." + (with-empty-maps-do map + (should-not (map-into map 'list)) + (should-not (map-into map 'alist)) + (should-not (map-into map 'plist)) + (should (map-empty-p (map-into map 'hash-table))))) (ert-deftest test-map-let () (map-let (foo bar baz) '((foo . 1) (bar . 2)) (should (= foo 1)) (should (= bar 2)) - (should (null baz))) + (should-not baz)) (map-let (('foo a) ('bar b) ('baz c)) '((foo . 1) (bar . 2)) (should (= a 1)) (should (= b 2)) - (should (null c)))) + (should-not c))) + +(ert-deftest test-map-merge () + "Test `map-merge'." + (should (equal (map-merge 'list '(a 1) '((b . 2) (c . 3)) + #s(hash-table data (c 4))) + '((c . 4) (b . 2) (a . 1))))) (ert-deftest test-map-merge-with () (should (equal (map-merge-with 'list #'+ @@ -376,6 +457,19 @@ Evaluate BODY for each created map. '((1 . 1) (2 . 5) (3 . 0))) '((3 . 0) (2 . 9) (1 . 6))))) +(ert-deftest test-map-merge-empty () + "Test merging of empty maps." + (should-not (map-merge 'list)) + (should-not (map-merge 'alist)) + (should-not (map-merge 'plist)) + (should-not (map-merge-with 'list #'+)) + (should-not (map-merge-with 'alist #'+)) + (should-not (map-merge-with 'plist #'+)) + (should (map-empty-p (map-merge 'hash-table))) + (should (map-empty-p (map-merge-with 'hash-table #'+))) + (should-error (map-merge 'array) :type 'cl-no-applicable-method) + (should-error (map-merge-with 'array #'+) :type 'cl-no-applicable-method)) + (ert-deftest test-map-plist-pcase () (let ((plist '(:one 1 :two 2))) (should (equal (pcase-let (((map :one (:two two)) plist)) -- cgit v1.2.3