Fix crash if user test munges hash table

* src/fns.c (restore_mutability)
(hash_table_user_defined_call): New functions.
(cmpfn_user_defined, hashfn_user_defined): Use them.
(make_hash_table, copy_hash_table):
Mark new hash table as mutable.
(check_mutable_hash_table): New function.
(Fclrhash, Fputhash, Fremhash): Use it instead of CHECK_IMPURE.
* src/lisp.h (struct hash_table_test): User-defined functions
now take pointers to struct Lisp_Hash_Table, not to struct
hash_table_test.  All uses changed.
(struct Lisp_Hash_Table): New member ‘mutable’.
* src/pdumper.c (dump_hash_table): Copy it.
* test/src/fns-tests.el (test-hash-function-that-mutates-hash-table):
New test, which tests for the bug.

8 files changed, 87 insertions, 31 deletions

diff --git a/src/alloc.c b/src/alloc.c
index 09b3a4ea7e4..1718ce0fafc 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -5352,6 +5352,7 @@ purecopy_hash_table (struct Lisp_Hash_Table *table)
   pure->count = table->count;
   pure->next_free = table->next_free;
   pure->purecopy = table->purecopy;
+  eassert (!pure->mutable);
   pure->rehash_threshold = table->rehash_threshold;
   pure->rehash_size = table->rehash_size;
   pure->key_and_value = purecopy (table->key_and_value);
diff --git a/src/bytecode.c b/src/bytecode.c
index e82de026a82..d668a9a6a15 100644
--- a/src/bytecode.c
+++ b/src/bytecode.c
@@ -1410,14 +1410,13 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
               { /* Do a linear search if there are not many cases
                    FIXME: 5 is arbitrarily chosen.  */
 		Lisp_Object hash_code
-		  = h->test.cmpfn ? h->test.hashfn (v1, &h->test) : Qnil;
+		  = h->test.cmpfn ? h->test.hashfn (v1, h) : Qnil;
 
                 for (i = h->count; 0 <= --i; )
                   if (EQ (v1, HASH_KEY (h, i))
                       || (h->test.cmpfn
                           && EQ (hash_code, HASH_HASH (h, i))
-			  && !NILP (h->test.cmpfn (v1, HASH_KEY (h, i),
-						   &h->test))))
+			  && !NILP (h->test.cmpfn (v1, HASH_KEY (h, i), h))))
                     break;
               }
             else
diff --git a/src/composite.c b/src/composite.c
index c36663f8e97..a6606d5fc45 100644
--- a/src/composite.c
+++ b/src/composite.c
@@ -655,7 +655,7 @@ composition_gstring_put_cache (Lisp_Object gstring, ptrdiff_t len)
   struct Lisp_Hash_Table *h = XHASH_TABLE (gstring_hash_table);
   hash_rehash_if_needed (h);
   Lisp_Object header = LGSTRING_HEADER (gstring);
-  Lisp_Object hash = h->test.hashfn (header, &h->test);
+  Lisp_Object hash = h->test.hashfn (header, h);
   if (len < 0)
     {
       ptrdiff_t glyph_len = LGSTRING_GLYPH_LEN (gstring);
diff --git a/src/fns.c b/src/fns.c
index d9503c491eb..5f1ed07a120 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -3931,11 +3931,37 @@ HASH_INDEX (struct Lisp_Hash_Table *h, ptrdiff_t idx)
   return XFIXNUM (AREF (h->index, idx));
 }
 
+/* Restore a hash table's mutability after the critical section exits.  */
+
+static void
+restore_mutability (void *ptr)
+{
+  struct Lisp_Hash_Table *h = ptr;
+  h->mutable = true;
+}
+
+/* Return the result of calling a user-defined hash or comparison
+   function ARGS[0] with arguments ARGS[1] through ARGS[NARGS - 1].
+   Signal an error if the function attempts to modify H, which
+   otherwise might lead to undefined behavior.  */
+
+static Lisp_Object
+hash_table_user_defined_call (ptrdiff_t nargs, Lisp_Object *args,
+			      struct Lisp_Hash_Table *h)
+{
+  if (!h->mutable)
+    return Ffuncall (nargs, args);
+  ptrdiff_t count = inhibit_garbage_collection ();
+  record_unwind_protect_ptr (restore_mutability, h);
+  h->mutable = false;
+  return unbind_to (count, Ffuncall (nargs, args));
+}
+
 /* Ignore HT and compare KEY1 and KEY2 using 'eql'.
    Value is true if KEY1 and KEY2 are the same.  */
 
 static Lisp_Object
-cmpfn_eql (Lisp_Object key1, Lisp_Object key2, struct hash_table_test *ht)
+cmpfn_eql (Lisp_Object key1, Lisp_Object key2, struct Lisp_Hash_Table *h)
 {
   return Feql (key1, key2);
 }
@@ -3944,7 +3970,7 @@ cmpfn_eql (Lisp_Object key1, Lisp_Object key2, struct hash_table_test *ht)
    Value is true if KEY1 and KEY2 are the same.  */
 
 static Lisp_Object
-cmpfn_equal (Lisp_Object key1, Lisp_Object key2, struct hash_table_test *ht)
+cmpfn_equal (Lisp_Object key1, Lisp_Object key2, struct Lisp_Hash_Table *h)
 {
   return Fequal (key1, key2);
 }
@@ -3955,16 +3981,17 @@ cmpfn_equal (Lisp_Object key1, Lisp_Object key2, struct hash_table_test *ht)
 
 static Lisp_Object
 cmpfn_user_defined (Lisp_Object key1, Lisp_Object key2,
-		    struct hash_table_test *ht)
+		    struct Lisp_Hash_Table *h)
 {
-  return call2 (ht->user_cmp_function, key1, key2);
+  Lisp_Object args[] = { h->test.user_cmp_function, key1, key2 };
+  return hash_table_user_defined_call (ARRAYELTS (args), args, h);
 }
 
 /* Ignore HT and return a hash code for KEY which uses 'eq' to compare
    keys.  */
 
 static Lisp_Object
-hashfn_eq (Lisp_Object key, struct hash_table_test *ht)
+hashfn_eq (Lisp_Object key, struct Lisp_Hash_Table *h)
 {
   return make_fixnum (XHASH (key) ^ XTYPE (key));
 }
@@ -3973,7 +4000,7 @@ hashfn_eq (Lisp_Object key, struct hash_table_test *ht)
    The hash code is at most INTMASK.  */
 
 Lisp_Object
-hashfn_equal (Lisp_Object key, struct hash_table_test *ht)
+hashfn_equal (Lisp_Object key, struct Lisp_Hash_Table *h)
 {
   return make_fixnum (sxhash (key, 0));
 }
@@ -3982,19 +4009,19 @@ hashfn_equal (Lisp_Object key, struct hash_table_test *ht)
    The hash code is at most INTMASK.  */
 
 Lisp_Object
-hashfn_eql (Lisp_Object key, struct hash_table_test *ht)
+hashfn_eql (Lisp_Object key, struct Lisp_Hash_Table *h)
 {
-  return (FLOATP (key) || BIGNUMP (key) ? hashfn_equal : hashfn_eq) (key, ht);
+  return (FLOATP (key) || BIGNUMP (key) ? hashfn_equal : hashfn_eq) (key, h);
 }
 
 /* Given HT, return a hash code for KEY which uses a user-defined
    function to compare keys.  */
 
 static Lisp_Object
-hashfn_user_defined (Lisp_Object key, struct hash_table_test *ht)
+hashfn_user_defined (Lisp_Object key, struct Lisp_Hash_Table *h)
 {
-  Lisp_Object hash = call1 (ht->user_hash_function, key);
-  return hashfn_eq (hash, ht);
+  Lisp_Object args[] = { h->test.user_hash_function, key };
+  return hash_table_user_defined_call (ARRAYELTS (args), args, h);
 }
 
 struct hash_table_test const
@@ -4088,6 +4115,7 @@ make_hash_table (struct hash_table_test test, EMACS_INT size,
   h->index = make_vector (index_size, make_fixnum (-1));
   h->next_weak = NULL;
   h->purecopy = purecopy;
+  h->mutable = true;
 
   /* Set up the free list.  */
   for (i = 0; i < size - 1; ++i)
@@ -4113,6 +4141,7 @@ copy_hash_table (struct Lisp_Hash_Table *h1)
 
   h2 = allocate_hash_table ();
   *h2 = *h1;
+  h2->mutable = true;
   h2->key_and_value = Fcopy_sequence (h1->key_and_value);
   h2->hash = Fcopy_sequence (h1->hash);
   h2->next = Fcopy_sequence (h1->next);
@@ -4217,7 +4246,7 @@ hash_table_rehash (struct Lisp_Hash_Table *h)
     if (!NILP (HASH_HASH (h, i)))
       {
         Lisp_Object key = HASH_KEY (h, i);
-	Lisp_Object hash_code = h->test.hashfn (key, &h->test);
+	Lisp_Object hash_code = h->test.hashfn (key, h);
 	set_hash_hash_slot (h, i, hash_code);
       }
 
@@ -4255,7 +4284,7 @@ hash_lookup (struct Lisp_Hash_Table *h, Lisp_Object key, Lisp_Object *hash)
 
   hash_rehash_if_needed (h);
 
-  Lisp_Object hash_code = h->test.hashfn (key, &h->test);
+  Lisp_Object hash_code = h->test.hashfn (key, h);
   if (hash)
     *hash = hash_code;
 
@@ -4265,12 +4294,19 @@ hash_lookup (struct Lisp_Hash_Table *h, Lisp_Object key, Lisp_Object *hash)
     if (EQ (key, HASH_KEY (h, i))
 	|| (h->test.cmpfn
 	    && EQ (hash_code, HASH_HASH (h, i))
-	    && !NILP (h->test.cmpfn (key, HASH_KEY (h, i), &h->test))))
+	    && !NILP (h->test.cmpfn (key, HASH_KEY (h, i), h))))
       break;
 
   return i;
 }
 
+static void
+check_mutable_hash_table (Lisp_Object obj, struct Lisp_Hash_Table *h)
+{
+  if (!h->mutable)
+    signal_error ("hash table test modifies table", obj);
+  eassert (!PURE_P (h));
+}
 
 /* Put an entry into hash table H that associates KEY with VALUE.
    HASH is a previously computed hash code of KEY.
@@ -4310,7 +4346,7 @@ hash_put (struct Lisp_Hash_Table *h, Lisp_Object key, Lisp_Object value,
 void
 hash_remove_from_table (struct Lisp_Hash_Table *h, Lisp_Object key)
 {
-  Lisp_Object hash_code = h->test.hashfn (key, &h->test);
+  Lisp_Object hash_code = h->test.hashfn (key, h);
   ptrdiff_t start_of_bucket = XUFIXNUM (hash_code) % ASIZE (h->index);
   ptrdiff_t prev = -1;
 
@@ -4323,7 +4359,7 @@ hash_remove_from_table (struct Lisp_Hash_Table *h, Lisp_Object key)
       if (EQ (key, HASH_KEY (h, i))
 	  || (h->test.cmpfn
 	      && EQ (hash_code, HASH_HASH (h, i))
-	      && !NILP (h->test.cmpfn (key, HASH_KEY (h, i), &h->test))))
+	      && !NILP (h->test.cmpfn (key, HASH_KEY (h, i), h))))
 	{
 	  /* Take entry out of collision chain.  */
 	  if (prev < 0)
@@ -4912,7 +4948,7 @@ DEFUN ("clrhash", Fclrhash, Sclrhash, 1, 1, 0,
   (Lisp_Object table)
 {
   struct Lisp_Hash_Table *h = check_hash_table (table);
-  CHECK_IMPURE (table, h);
+  check_mutable_hash_table (table, h);
   hash_clear (h);
   /* Be compatible with XEmacs.  */
   return table;
@@ -4937,7 +4973,7 @@ VALUE.  In any case, return VALUE.  */)
   (Lisp_Object key, Lisp_Object value, Lisp_Object table)
 {
   struct Lisp_Hash_Table *h = check_hash_table (table);
-  CHECK_IMPURE (table, h);
+  check_mutable_hash_table (table, h);
 
   Lisp_Object hash;
   ptrdiff_t i = hash_lookup (h, key, &hash);
@@ -4955,7 +4991,7 @@ DEFUN ("remhash", Fremhash, Sremhash, 2, 2, 0,
   (Lisp_Object key, Lisp_Object table)
 {
   struct Lisp_Hash_Table *h = check_hash_table (table);
-  CHECK_IMPURE (table, h);
+  check_mutable_hash_table (table, h);
   hash_remove_from_table (h, key);
   return Qnil;
 }
diff --git a/src/lisp.h b/src/lisp.h
index e5edb8fd125..6d101fed908 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -2225,6 +2225,8 @@ INLINE int
 
 /* The structure of a Lisp hash table.  */
 
+struct Lisp_Hash_Table;
+
 struct hash_table_test
 {
   /* Name of the function used to compare keys.  */
@@ -2237,10 +2239,10 @@ struct hash_table_test
   Lisp_Object user_cmp_function;
 
   /* C function to compare two keys.  */
-  Lisp_Object (*cmpfn) (Lisp_Object, Lisp_Object, struct hash_table_test *t);
+  Lisp_Object (*cmpfn) (Lisp_Object, Lisp_Object, struct Lisp_Hash_Table *);
 
   /* C function to compute hash code.  */
-  Lisp_Object (*hashfn) (Lisp_Object, struct hash_table_test *t);
+  Lisp_Object (*hashfn) (Lisp_Object, struct Lisp_Hash_Table *);
 };
 
 struct Lisp_Hash_Table
@@ -2289,6 +2291,11 @@ struct Lisp_Hash_Table
      changed afterwards.  */
   bool purecopy;
 
+  /* True if the table is mutable.  Ordinarily tables are mutable, but
+     pure tables are not, and while a table is being mutated it is
+     immutable for recursive attempts to mutate it.  */
+  bool mutable;
+
   /* Resize hash table when number of entries / table size is >= this
      ratio.  */
   float rehash_threshold;
@@ -3591,8 +3598,8 @@ extern void hexbuf_digest (char *, void const *, int);
 extern char *extract_data_from_object (Lisp_Object, ptrdiff_t *, ptrdiff_t *);
 EMACS_UINT hash_string (char const *, ptrdiff_t);
 EMACS_UINT sxhash (Lisp_Object, int);
-Lisp_Object hashfn_eql (Lisp_Object, struct hash_table_test *);
-Lisp_Object hashfn_equal (Lisp_Object, struct hash_table_test *);
+Lisp_Object hashfn_eql (Lisp_Object, struct Lisp_Hash_Table *);
+Lisp_Object hashfn_equal (Lisp_Object, struct Lisp_Hash_Table *);
 Lisp_Object make_hash_table (struct hash_table_test, EMACS_INT, float, float,
                              Lisp_Object, bool);
 ptrdiff_t hash_lookup (struct Lisp_Hash_Table *, Lisp_Object, Lisp_Object *);
diff --git a/src/pdumper.c b/src/pdumper.c
index 206a1968909..2abac80a372 100644
--- a/src/pdumper.c
+++ b/src/pdumper.c
@@ -2742,6 +2742,7 @@ dump_hash_table (struct dump_context *ctx,
   DUMP_FIELD_COPY (out, hash, count);
   DUMP_FIELD_COPY (out, hash, next_free);
   DUMP_FIELD_COPY (out, hash, purecopy);
+  DUMP_FIELD_COPY (out, hash, mutable);
   DUMP_FIELD_COPY (out, hash, rehash_threshold);
   DUMP_FIELD_COPY (out, hash, rehash_size);
   dump_field_lv (ctx, out, hash, &hash->key_and_value, WEIGHT_STRONG);
diff --git a/src/profiler.c b/src/profiler.c
index e9b6a37d06b..ed0e9ddd881 100644
--- a/src/profiler.c
+++ b/src/profiler.c
@@ -37,8 +37,8 @@ saturated_add (EMACS_INT a, EMACS_INT b)
 typedef struct Lisp_Hash_Table log_t;
 
 static Lisp_Object cmpfn_profiler (Lisp_Object, Lisp_Object,
-				   struct hash_table_test *);
-static Lisp_Object hashfn_profiler (Lisp_Object, struct hash_table_test *);
+				   struct Lisp_Hash_Table *);
+static Lisp_Object hashfn_profiler (Lisp_Object, struct Lisp_Hash_Table *);
 
 static const struct hash_table_test hashtest_profiler =
   {
@@ -528,7 +528,7 @@ the same lambda expression, or are really unrelated function.  */)
 }
 
 static Lisp_Object
-cmpfn_profiler (Lisp_Object bt1, Lisp_Object bt2, struct hash_table_test *t)
+cmpfn_profiler (Lisp_Object bt1, Lisp_Object bt2, struct Lisp_Hash_Table *h)
 {
   if (VECTORP (bt1) && VECTORP (bt2))
     {
@@ -545,7 +545,7 @@ cmpfn_profiler (Lisp_Object bt1, Lisp_Object bt2, struct hash_table_test *t)
 }
 
 static Lisp_Object
-hashfn_profiler (Lisp_Object bt, struct hash_table_test *ht)
+hashfn_profiler (Lisp_Object bt, struct Lisp_Hash_Table *h)
 {
   EMACS_UINT hash;
   if (VECTORP (bt))
diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el
index 9d4ae4fdf30..7d56da77cf5 100644
--- a/test/src/fns-tests.el
+++ b/test/src/fns-tests.el
@@ -846,4 +846,16 @@
   (should (not (proper-list-p (make-bool-vector 0 nil))))
   (should (not (proper-list-p (make-symbol "a")))))
 
+(ert-deftest test-hash-function-that-mutates-hash-table ()
+  (define-hash-table-test 'badeq 'eq 'bad-hash)
+  (let ((h (make-hash-table :test 'badeq :size 1 :rehash-size 1)))
+    (defun bad-hash (k)
+      (if (eq k 100)
+	  (clrhash h))
+      (sxhash-eq k))
+    (should-error
+     (dotimes (k 200)
+       (puthash k k h)))
+    (should (= 100 (hash-table-count h)))))
+
 (provide 'fns-tests)