bug#63671: Add function to test equality of hash tables

["Mattias Engdegård" <mattias.engdegard@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 553 bytes --]

24 maj 2023 kl. 19.27 skrev Joseph Turner <joseph@breatheoutbreathe.in>:

> Would extending `equal' to handle hash tables be generally useful?

It would, but doing so would be very risky at this point since it would change long-standing semantics.

We could make an augmented version of `equal` but what we really want is one that works for user-defined types (see Ihor's reference to a previous discussion).

Anyway, here's an old patch I had lying around, in case we decide that we do need a shoddy equality predicate for hash tables only.


[-- Attachment #2: hash-table-equal-p.diff --]
[-- Type: application/octet-stream, Size: 3636 bytes --]

diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el
index 9cd793d05c..17ca80a297 100644
--- a/lisp/emacs-lisp/subr-x.el
+++ b/lisp/emacs-lisp/subr-x.el
@@ -93,6 +93,28 @@ hash-table-values
   "Return a list of values in HASH-TABLE."
   (cl-loop for v being the hash-values of hash-table collect v))
 
+(defun hash-table-equal-p (h1 h2 &optional value-eq)
+  "Whether the hash tables H1 and H2 are equal with respect to VALUE-EQ.
+Equality means that the tables have the same equality predicate
+and the same set of key-value pairs where keys are compared by
+that predicate and values by VALUE-EQ, which defaults to `eq'."
+  (or (eq h1 h2)
+      (and (= (hash-table-count h1) (hash-table-count h2))
+           (eq (hash-table-test h1) (hash-table-test h2))
+           (progn
+             (unless value-eq
+               (setq value-eq #'eq))
+             ;; Loop over the physically smaller table.
+             (when (> (hash-table-size h1) (hash-table-size h2))
+               (cl-rotatef h1 h2))
+             (catch 'done
+               (maphash
+                (lambda (k v)
+                  (unless (funcall value-eq v (gethash k h2 (not v)))
+                    (throw 'done nil)))
+                h1)
+               t)))))
+
 (defsubst string-empty-p (string)
   "Check whether STRING is empty."
   (string= string ""))
diff --git a/test/lisp/emacs-lisp/subr-x-tests.el b/test/lisp/emacs-lisp/subr-x-tests.el
index 7f3916c2c0..923155eedb 100644
--- a/test/lisp/emacs-lisp/subr-x-tests.el
+++ b/test/lisp/emacs-lisp/subr-x-tests.el
@@ -743,6 +743,55 @@ test-with-buffer-unmodified-if-unchanged
           (with-current-buffer inner
             (should-not (buffer-modified-p))))))))
 
+(ert-deftest subr-x--hash-table-equal-p ()
+  (cl-flet ((hashtab (test &rest elts)
+              (let ((h (make-hash-table :test test)))
+                (while elts
+                  (let* ((key (pop elts))
+                         (val (pop elts)))
+                    (puthash key val h)))
+                h)))
+
+    (let ((h1 (hashtab #'eq 'a (list 1) 'b (list 2))
+          (h2 (hashtab #'eq 'a (list 1) 'b (list 2)))))
+      (should (hash-table-equal-p h1 h2 #'equal))
+      (should (hash-table-equal-p h2 h1 #'equal))
+      (should (not (hash-table-equal-p h1 h2 #'eq)))
+      (should (not (hash-table-equal-p h2 h1 #'eq)))
+      (should (hash-table-equal-p h1 h1 #'eq)))
+
+    (let ((h1 (hashtab #'eql 1 'a 2 'b)
+          (h2 (hashtab #'equal 1 'a 2 'b))))
+      (should (not (hash-table-equal-p h1 h2)))
+      (should (not (hash-table-equal-p h2 h1))))
+
+    (let ((h1 (hashtab #'eql 1 'a 2 'a)
+          (h2 (hashtab #'eql 1 'a))))
+      (should (not (hash-table-equal-p h1 h2)))
+      (should (not (hash-table-equal-p h2 h1))))
+
+    (let ((h1 (hashtab #'eql 1 'a 2 'a)
+          (h2 (hashtab #'eql 1 'a 2 'b))))
+      (should (not (hash-table-equal-p h1 h2)))
+      (should (not (hash-table-equal-p h2 h1))))
+
+    (let ((h1 (hashtab #'eql 1 'a 2 'a)
+          (h2 (hashtab #'eql 1 'a 3 'a))))
+      (should (not (hash-table-equal-p h1 h2)))
+      (should (not (hash-table-equal-p h2 h1))))
+
+    (let ((h1 (hashtab #'eql)
+          (h2 (hashtab #'eql))))
+      (should (hash-table-equal-p h1 h2))
+      (should (hash-table-equal-p h2 h1)))
+
+    (let ((h1 (make-hash-table :test #'eql :size 1000 :rehash-size 3.5))
+          (h2 (hashtab #'eql 10 'a 20 'b)))
+      (puthash 10 'a h1)
+      (puthash 20 'b h1)
+      (should (hash-table-equal-p h1 h2))
+      (should (hash-table-equal-p h2 h1)))
+    ))
 
 (provide 'subr-x-tests)
 ;;; subr-x-tests.el ends here