[Emacs-diffs] master 55838e4: * lisp/emacs-lisp/map.el: Avoid special casing lists.

[Stefan Monnier]

branch: master
commit 55838e4e6a176317367c6759e0520395e80c856f
Author: Stefan Monnier <address@hidden>
Commit: Stefan Monnier <address@hidden>

    * lisp/emacs-lisp/map.el: Avoid special casing lists.
    
    (map-not-inplace, map-inplace): New errors.
    (map-insert): New generic function.
    (map-put!): Signal map-not-inplace rather than a generic 'error'.
    (map-elt): Use map-not-inplace and map-insert to avoid hardcoding
    a special case for lists.
    
    * test/lisp/emacs-lisp/map-tests.el (test-map-put!): Rename from
    test-map-put.  Also test the errors signaled.
---
 etc/NEWS                          |  3 ++-
 lisp/emacs-lisp/map.el            | 51 +++++++++++++++++++++++++++------------
 test/lisp/emacs-lisp/map-tests.el | 20 ++++++++++++---
 3 files changed, 54 insertions(+), 20 deletions(-)

diff --git a/etc/NEWS b/etc/NEWS
index 327276e..95647bb 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -307,8 +307,9 @@ the node "(emacs) Directory Variables" of the user manual.
 ** map.el
 *** Now defined via generic functions that can be extended via cl-defmethod.
 *** Deprecate the 'map-put' macro in favor of a new 'map-put!' function.
-*** map-contains-key now returns a boolean rather than the key.
+*** 'map-contains-key' now returns a boolean rather than the key.
 *** Deprecate the 'testfn' args of 'map-elt' and 'map-contains-key'.
+*** New generic function 'map-insert'.
 
 ---
 ** Follow mode
diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el
index 78cedd3..d5051fc 100644
--- a/lisp/emacs-lisp/map.el
+++ b/lisp/emacs-lisp/map.el
@@ -95,12 +95,13 @@ Returns the result of evaluating the form associated with 
MAP-VAR's type."
            (t (error "Unsupported map type `%S': %S"
                      (type-of ,map-var) ,map-var)))))
 
+(define-error 'map-not-inplace "Cannot modify map in-place: %S")
+
 (cl-defgeneric map-elt (map key &optional default testfn)
   "Lookup KEY in MAP and return its associated value.
 If KEY is not found, return DEFAULT which defaults to nil.
 
 TESTFN is deprecated.  Its default depends on the MAP argument.
-If MAP is a list, the default is `eql' to lookup KEY.
 
 In the base definition, MAP can be an alist, hash-table, or array."
   (declare
@@ -110,15 +111,16 @@ In the base definition, MAP can be an alist, hash-table, 
or array."
         (macroexp-let2* nil
             ;; Eval them once and for all in the right order.
             ((key key) (default default) (testfn testfn))
-          `(if (listp ,mgetter)
-               ;; Special case the alist case, since it can't be handled by the
-               ;; map--put function.
-               ,(gv-get `(alist-get ,key (gv-synthetic-place
-                                          ,mgetter ,msetter)
-                                    ,default nil ,testfn)
-                        do)
-             ,(funcall do `(map-elt ,mgetter ,key ,default)
-                       (lambda (v) `(map-put! ,mgetter ,key ,v)))))))))
+          (funcall do `(map-elt ,mgetter ,key ,default)
+                   (lambda (v)
+                     `(condition-case nil
+                          ;; Silence warnings about the hidden 4th arg.
+                          (with-no-warnings (map-put! ,mgetter ,key ,v 
,testfn))
+                        (map-not-inplace
+                         ,(funcall msetter
+                                   `(map-insert ,mgetter ,key ,v))))))))))
+   ;; `testfn' is deprecated.
+   (advertised-calling-convention (map key &optional default) "27.1"))
   (map--dispatch map
     :list (alist-get key map default nil testfn)
     :hash-table (gethash key map default)
@@ -336,17 +338,36 @@ MAP can be a list, hash-table or array."
 ;; FIXME: I wish there was a way to avoid this η-redex!
 (cl-defmethod map-into (map (_type (eql list))) (map-pairs map))
 
-(cl-defgeneric map-put! (map key value)
+(cl-defgeneric 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."
+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'."
+  ;; `testfn' only exists for backward compatibility with `map-put'!
+  (declare (advertised-calling-convention (map key value) "27.1"))
   (map--dispatch map
-    :list (let ((p (assoc key map)))
-            (if p (setcdr p value)
-              (error "No place to change the mapping for %S" key)))
+    :list (let ((oldmap map))
+            (setf (alist-get key map key nil (or testfn #'equal)) value)
+            (unless (eq oldmap map)
+              (signal 'map-not-inplace (list map))))
     :hash-table (puthash key value map)
+    ;; FIXME: If `key' is too large, should we signal `map-not-inplace'
+    ;; and let `map-insert' grow the array?
     :array (aset map key value)))
 
+(define-error 'map-inplace "Can only modify map in place: %S")
+
+(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)
+      (cons (cons key value) map)
+    ;; FIXME: Should we signal an error or use copy+put! ?
+    (signal 'map-inplace (list map))))
+
 ;; There shouldn't be old source code referring to `map--put', yet we do
 ;; need to keep it for backward compatibility with .elc files where the
 ;; expansion of `setf' may call this function.
diff --git a/test/lisp/emacs-lisp/map-tests.el 
b/test/lisp/emacs-lisp/map-tests.el
index 885b09b..4dd67d4 100644
--- a/test/lisp/emacs-lisp/map-tests.el
+++ b/test/lisp/emacs-lisp/map-tests.el
@@ -76,13 +76,25 @@ Evaluate BODY for each created map.
                          'b
                          '2))))
 
-(ert-deftest test-map-put ()
+(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)
     (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 (hash-table-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.
+                      :type (if (listp 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)
@@ -92,7 +104,7 @@ Evaluate BODY for each created map.
     (should (eq (map-elt alist 2)
                 'a)))
   (let ((vec [3 4 5]))
-   (should-error (setf (map-elt vec 3) 6))))
+    (should-error (setf (map-elt vec 3) 6))))
 
 (ert-deftest test-map-put-alist-new-key ()
   "Regression test for Bug#23105."
@@ -105,9 +117,9 @@ Evaluate BODY for each created map.
   (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)
+    (map-put alist noneq-key 3 #'equal)
     (should-not (cddr alist))
-    (map-put alist noneq-key 9)
+    (map-put alist noneq-key 9 #'eql)
     (should (cddr alist))))
 
 (ert-deftest test-map-put-return-value ()