New function safe-copy-tree.

[Alan Mackenzie <acm@muc.de>]

Hello, Emacs.

In order to fix bug #61962, I'm intending to introduce a new function
safe-copy-tree in subr.el.  It is like copy-tree, except it works with
circular lists as well as normal ones.

My current implementation looks like this:



diff --git a/lisp/subr.el b/lisp/subr.el
index 8ff3b868fab..2066be581d1 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -845,6 +845,59 @@ copy-tree
 	    (aset tree i (copy-tree (aref tree i) vecp)))
 	  tree)
       tree)))
+
+(defvar safe-copy-tree--seen nil
+  "A hash table for conses/vectors/records already seen by safe-copy-tree-1.
+It's key is a cons or vector/record seen by the algorithm, and its value is
+the corresponding cons/vector/record in the copy.")
+
+(defun safe-copy-tree--1 (tree &optional vecp)
+  "Make a copy of TREE, taking circular structure into account.
+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 VECP, this copies vectors and records as well as conses."
+  (cond
+   ((gethash tree safe-copy-tree--seen))
+   ((consp tree)
+    (let* ((result (cons (car tree) (cdr tree)))
+	   (newcons result)
+	   hash)
+      (while (and (not hash) (consp tree))
+	(if (setq hash (gethash tree safe-copy-tree--seen))
+            (setq newcons hash)
+	  (puthash tree newcons safe-copy-tree--seen))
+        (setq tree newcons)
+        (unless hash
+	  (if (or (consp (car tree))
+                  (and vecp (or (vectorp (car tree)) (recordp (car tree)))))
+	      (let ((newcar (safe-copy-tree--1 (car tree) vecp)))
+	        (setcar tree newcar)))
+          (setq newcons (if (consp (cdr tree))
+                            (cons (cadr tree) (cddr tree))
+                          (cdr tree)))
+          (setcdr tree newcons)
+          (setq tree (cdr tree))))
+      (nconc result
+             (if (and vecp (or (vectorp tree) (recordp tree)))
+		 (safe-copy-tree--1 tree vecp) tree))))
+   ((and vecp (or (vectorp tree) (recordp tree)))
+    (let* ((newvec (copy-sequence tree))
+           (i (length newvec)))
+      (puthash tree newvec safe-copy-tree--seen)
+      (setq tree newvec)
+      (while (>= (setq i (1- i)) 0)
+	(aset tree i (safe-copy-tree--1 (aref tree i) vecp)))
+      tree))
+   (t tree)))
+
+(defun safe-copy-tree (tree &optional vecp)
+  "Make a copy of TREE, taking circular structure into account.
+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 VECP, this copies vectors and records as well as conses."
+  (setq safe-copy-tree--seen (make-hash-table :test #'eq))
+  (safe-copy-tree--1 tree vecp))
+
 \f
 ;;;; Various list-search functions.
 

Comments and criticism would be welcome.

-- 
Alan Mackenzie (Nuremberg, Germany).