master bd6bba4780d 1/2: Improved copy-tree documentation and test (bug#63509)

[Mattias Engdegård]

branch: master
commit bd6bba4780dcfdec97ab5e6469f7777c4b2a1b0d
Author: Mattias Engdegård <mattiase@acm.org>
Commit: Mattias Engdegård <mattiase@acm.org>

    Improved copy-tree documentation and test (bug#63509)
    
    * etc/NEWS: Move entry since it's an incompatible change.
    * lisp/emacs-lisp/shortdoc.el (vector): Make the example relevant.
    * lisp/subr.el (copy-tree): Rename second argument,
    since 'vector-like' is a term with a specific meaning in Emacs
    but not the one intended here.
    * doc/lispref/lists.texi (Building Lists): Rename second argument,
    and make it clear that the input must be acyclic.
    * doc/lispref/records.texi (Record Functions):
    Be more precise: `copy-sequence` is used to copy records,
    `copy-tree` copies trees made of records etc.
    * test/lisp/subr-tests.el (subr--copy-tree): Extend and strengthen the
    test considerably, using the print-circle trick to detect structure
    sharing precisely.
---
 doc/lispref/lists.texi      |  8 ++---
 doc/lispref/records.texi    |  5 +--
 etc/NEWS                    |  6 ++--
 lisp/emacs-lisp/shortdoc.el |  2 +-
 lisp/subr.el                | 21 ++++++++-----
 test/lisp/subr-tests.el     | 77 ++++++++++++++++++++++++++++-----------------
 6 files changed, 72 insertions(+), 47 deletions(-)

diff --git a/doc/lispref/lists.texi b/doc/lispref/lists.texi
index 16ed0358974..6a00f2887e7 100644
--- a/doc/lispref/lists.texi
+++ b/doc/lispref/lists.texi
@@ -696,7 +696,7 @@ not a list, the sequence's elements do not become elements 
of the
 resulting list.  Instead, the sequence becomes the final @sc{cdr}, like
 any other non-list final argument.
 
-@defun copy-tree tree &optional vector-like-p
+@defun copy-tree tree &optional vectors-and-records
 This function returns a copy of the tree @var{tree}.  If @var{tree} is a
 cons cell, this makes a new cons cell with the same @sc{car} and
 @sc{cdr}, then recursively copies the @sc{car} and @sc{cdr} in the
@@ -704,9 +704,9 @@ same way.
 
 Normally, when @var{tree} is anything other than a cons cell,
 @code{copy-tree} simply returns @var{tree}.  However, if
-@var{vector-like-p} is non-@code{nil}, it copies vectors and records
-too (and operates recursively on their elements).  This function
-cannot cope with circular lists.
+@var{vectors-and-records} is non-@code{nil}, it copies vectors and records
+too (and operates recursively on their elements).  The @var{tree}
+argument must not contain cycles.
 @end defun
 
 @defun flatten-tree tree
diff --git a/doc/lispref/records.texi b/doc/lispref/records.texi
index ebc4569c388..287ad869297 100644
--- a/doc/lispref/records.texi
+++ b/doc/lispref/records.texi
@@ -81,8 +81,9 @@ This function returns a new record with type @var{type} and
 @end example
 @end defun
 
-To copy records, use @code{copy-tree} with its optional second argument
-non-@code{nil}.  @xref{Building Lists, copy-tree}.
+To copy trees consisting of records, vectors and conses (lists), use
+@code{copy-tree} with its optional second argument non-@code{nil}.
+@xref{Building Lists, copy-tree}.
 
 @node Backward Compatibility
 @section Backward Compatibility
diff --git a/etc/NEWS b/etc/NEWS
index f1fb70c5fc6..04ef976a8d1 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -388,6 +388,9 @@ These hooks were named incorrectly, and so they never 
actually ran
 when unloading the correspending feature.  Instead, you should use
 hooks named after the feature name, like 'esh-mode-unload-hook'.
 
++++
+** 'copy-tree' now copies records when its optional 2nd argument is non-nil.
+
 
 * Lisp Changes in Emacs 30.1
 
@@ -585,9 +588,6 @@ Since circular alias chains now cannot occur, 
'function-alias-p',
 'indirect-function' and 'indirect-variable' will never signal an error.
 Their 'noerror' arguments have no effect and are therefore obsolete.
 
-+++
-** 'copy-tree' now copies records when its optional 2nd argument is non-nil.
-
 
 * Changes in Emacs 30.1 on Non-Free Operating Systems
 
diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el
index 6580e0e4e0c..1e8ab4ad46d 100644
--- a/lisp/emacs-lisp/shortdoc.el
+++ b/lisp/emacs-lisp/shortdoc.el
@@ -834,7 +834,7 @@ A FUNC form can have any number of `:no-eval' (or 
`:no-value'),
    :eval (seq-subseq [1 2 3 4 5] 1 3)
    :eval (seq-subseq [1 2 3 4 5] 1))
   (copy-tree
-   :eval (copy-tree [1 2 3 4]))
+   :eval (copy-tree [1 (2 3) [4 5]] t))
   "Mapping Over Vectors"
   (mapcar
    :eval (mapcar #'identity [1 2 3]))
diff --git a/lisp/subr.el b/lisp/subr.el
index 83735933963..5a641965659 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -824,26 +824,31 @@ of course, also replace TO with a slightly larger value
                 next (+ from (* n inc)))))
       (nreverse seq))))
 
-(defun copy-tree (tree &optional vector-like-p)
+(defun copy-tree (tree &optional vectors-and-records)
   "Make a copy of TREE.
 If TREE is a cons cell, this recursively copies both its car and its cdr.
-Contrast to `copy-sequence', which copies only along the cdrs.  With second
-argument VECTOR-LIKE-P, this copies vectors and records as well as conses."
+Contrast to `copy-sequence', which copies only along the cdrs.
+With the second argument VECTORS-AND-RECORDS non-nil, this
+traverses and copies vectors and records as well as conses."
   (declare (side-effect-free error-free))
   (if (consp tree)
       (let (result)
        (while (consp tree)
          (let ((newcar (car tree)))
-           (if (or (consp (car tree)) (and vector-like-p (or (vectorp (car 
tree)) (recordp (car tree)))))
-               (setq newcar (copy-tree (car tree) vector-like-p)))
+           (if (or (consp (car tree))
+                    (and vectors-and-records
+                         (or (vectorp (car tree)) (recordp (car tree)))))
+               (setq newcar (copy-tree (car tree) vectors-and-records)))
            (push newcar result))
          (setq tree (cdr tree)))
        (nconc (nreverse result)
-               (if (and vector-like-p (or (vectorp tree) (recordp tree))) 
(copy-tree tree vector-like-p) tree)))
-    (if (and vector-like-p (or (vectorp tree) (recordp tree)))
+               (if (and vectors-and-records (or (vectorp tree) (recordp tree)))
+                   (copy-tree tree vectors-and-records)
+                 tree)))
+    (if (and vectors-and-records (or (vectorp tree) (recordp tree)))
        (let ((i (length (setq tree (copy-sequence tree)))))
          (while (>= (setq i (1- i)) 0)
-           (aset tree i (copy-tree (aref tree i) vector-like-p)))
+           (aset tree i (copy-tree (aref tree i) vectors-and-records)))
          tree)
       tree)))
 
diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el
index 4ebb68556be..1c220b1da18 100644
--- a/test/lisp/subr-tests.el
+++ b/test/lisp/subr-tests.el
@@ -1207,35 +1207,54 @@ final or penultimate step during initialization."))
     (should (eq a a-dedup))))
 
 (ert-deftest subr--copy-tree ()
-  (should (eq (copy-tree nil) nil))
-  (let* ((a (list (list "a") "b" (list "c") "g"))
-         (copy1 (copy-tree a))
-         (copy2 (copy-tree a t)))
-    (should (equal a copy1))
-    (should (equal a copy2))
-    (should-not (eq a copy1))
-    (should-not (eq a copy2)))
-  (let* ((a (list (list "a") "b" (list "c" (record 'foo "d")) (list ["e" "f"]) 
"g"))
-         (copy1 (copy-tree a))
-         (copy2 (copy-tree a t)))
-    (should (equal a copy1))
-    (should (equal a copy2))
-    (should-not (eq a copy1))
-    (should-not (eq a copy2)))
-  (let* ((a (record 'foo "a" (record 'bar "b")))
-         (copy1 (copy-tree a))
-         (copy2 (copy-tree a t)))
-    (should (equal a copy1))
-    (should (equal a copy2))
-    (should (eq a copy1))
-    (should-not (eq a copy2)))
-  (let* ((a ["a" "b" ["c" ["d"]]])
-         (copy1 (copy-tree a))
-         (copy2 (copy-tree a t)))
-    (should (equal a copy1))
-    (should (equal a copy2))
-    (should (eq a copy1))
-    (should-not (eq a copy2))))
+  ;; Check that values other than conses, vectors and records are
+  ;; neither copied nor traversed.
+  (let ((s (propertize "abc" 'prop (list 11 12)))
+        (h (make-hash-table :test #'equal)))
+    (puthash (list 1 2) (list 3 4) h)
+    (dolist (x (list nil 'a "abc" s h))
+      (should (eq (copy-tree x) x))
+      (should (eq (copy-tree x t) x))))
+
+  ;; Use the printer to detect common parts of Lisp values.
+  (let ((print-circle t))
+    (cl-labels ((prn3 (x y z) (prin1-to-string (list x y z)))
+                (cat3 (x y z) (concat "(" x " " y " " z ")")))
+      (let ((x '(a (b ((c) . d) e) (f))))
+        (should (equal (prn3 x (copy-tree x) (copy-tree x t))
+                       (cat3 "(a (b ((c) . d) e) (f))"
+                             "(a (b ((c) . d) e) (f))"
+                             "(a (b ((c) . d) e) (f))"))))
+      (let ((x '(a [b (c d)] #s(e (f [g])))))
+        (should (equal (prn3 x (copy-tree x) (copy-tree x t))
+                       (cat3 "(a #1=[b (c d)] #2=#s(e (f [g])))"
+                             "(a #1# #2#)"
+                             "(a [b (c d)] #s(e (f [g])))"))))
+      (let ((x [a (b #s(c d))]))
+        (should (equal (prn3 x (copy-tree x) (copy-tree x t))
+                       (cat3 "#1=[a (b #s(c d))]"
+                             "#1#"
+                             "[a (b #s(c d))]"))))
+      (let ((x #s(a (b [c d]))))
+        (should (equal (prn3 x (copy-tree x) (copy-tree x t))
+                       (cat3 "#1=#s(a (b [c d]))"
+                             "#1#"
+                             "#s(a (b [c d]))"))))
+      ;; Check cdr recursion.
+      (let ((x '(a b . [(c . #s(d))])))
+        (should (equal (prn3 x (copy-tree x) (copy-tree x t))
+                       (cat3 "(a b . #1=[(c . #s(d))])"
+                             "(a b . #1#)"
+                             "(a b . [(c . #s(d))])"))))
+      ;; Check that we can copy DAGs (the result is a tree).
+      (let ((x (list '(a b) nil [c d] nil #s(e f) nil)))
+        (setf (nth 1 x) (nth 0 x))
+        (setf (nth 3 x) (nth 2 x))
+        (setf (nth 5 x) (nth 4 x))
+        (should (equal (prn3 x (copy-tree x) (copy-tree x t))
+                       (cat3 "(#1=(a b) #1# #2=[c d] #2# #3=#s(e f) #3#)"
+                             "((a b) (a b) #2# #2# #3# #3#)"
+                             "((a b) (a b) [c d] [c d] #s(e f) #s(e f))")))))))
 
 (provide 'subr-tests)
 ;;; subr-tests.el ends here