From 75f04848a653e70f12f0e5a62b756c5bba0dd204 Mon Sep 17 00:00:00 2001 From: =?utf8?q?Mattias=20Engdeg=C3=A5rd?= Date: Sun, 12 Mar 2023 17:00:25 +0100 Subject: [PATCH] Repair and speed up safe-copy-tree and make it internal (bug#61962) There is no particular requirement for safe-copy-tree so let's make it internal for now. The new implementation is faster and more correct. * doc/lispref/lists.texi (Building Lists): * etc/NEWS: Remove doc and announcement. * lisp/subr.el (safe-copy-tree--seen, safe-copy-tree--1) (safe-copy-tree): Remove old version. * lisp/emacs-lisp/bytecomp.el (bytecomp--copy-tree-seen) (bytecomp--copy-tree-1, bytecomp--copy-tree): Add new version. (byte-compile-initial-macro-environment): Use it. * test/lisp/subr-tests.el (subr--safe-copy-tree): * test/lisp/emacs-lisp/bytecomp-tests.el (bytecomp--copy-tree): Move and improve tests. --- doc/lispref/lists.texi | 13 ------ etc/NEWS | 5 --- lisp/emacs-lisp/bytecomp.el | 38 +++++++++++++++++- lisp/subr.el | 55 -------------------------- test/lisp/emacs-lisp/bytecomp-tests.el | 28 +++++++++++++ test/lisp/subr-tests.el | 26 ------------ 6 files changed, 65 insertions(+), 100 deletions(-) diff --git a/doc/lispref/lists.texi b/doc/lispref/lists.texi index 3478049c84f..a509325854f 100644 --- a/doc/lispref/lists.texi +++ b/doc/lispref/lists.texi @@ -708,19 +708,6 @@ non-@code{nil}, it copies vectors too (and operates recursively on their elements). This function cannot cope with circular lists. @end defun -@defun safe-copy-tree tree &optional vecp -This function returns a copy of the tree @var{tree}. If @var{tree} is -a cons cell, this make a new cons cell with the same @sc{car} and -@sc{cdr}, then recursively copies the @sc{car} and @sc{cdr} in the -same way. - -Normally, when @var{tree} is anything other than a cons cell, -@code{copy-tree} simply returns @var{tree}. However, if @var{vecp} is -non-@code{nil}, it copies vectors and records too (and operates -recursively on their elements). This function handles circular lists -and vectors, and is thus slower than @code{copy-tree} for typical cases. -@end defun - @defun flatten-tree tree This function returns a ``flattened'' copy of @var{tree}, that is, a list containing all the non-@code{nil} terminal nodes, or leaves, of diff --git a/etc/NEWS b/etc/NEWS index e31203689e3..3b02e85b691 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -391,11 +391,6 @@ was to catch all errors, add an explicit handler for 'error', or use This warning can be suppressed using 'with-suppressed-warnings' with the warning name 'suspicious'. -+++ -** New function 'safe-copy-tree' -This function is a version of copy-tree which handles circular lists -and circular vectors/records. - +++ ** New function 'file-user-uid'. This function is like 'user-uid', but is aware of file name handlers, diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 12850c27b88..a122e81ba3c 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -495,6 +495,42 @@ Return the compile-time value of FORM." (cdr form))) (funcall non-toplevel-case form))) + +(defvar bytecomp--copy-tree-seen) + +(defun bytecomp--copy-tree-1 (tree) + ;; TREE must be a cons. + (or (gethash tree bytecomp--copy-tree-seen) + (let* ((next (cdr tree)) + (result (cons nil next)) + (copy result)) + (while (progn + (puthash tree copy bytecomp--copy-tree-seen) + (let ((a (car tree))) + (setcar copy (if (consp a) + (bytecomp--copy-tree-1 a) + a))) + (and (consp next) + (let ((tail (gethash next bytecomp--copy-tree-seen))) + (if tail + (progn (setcdr copy tail) + nil) + (setq tree next) + (setq next (cdr next)) + (let ((prev copy)) + (setq copy (cons nil next)) + (setcdr prev copy) + t)))))) + result))) + +(defun bytecomp--copy-tree (tree) + "Make a copy of TREE, preserving any circular structure therein. +Only conses are traversed and duplicated, not arrays or any other structure." + (if (consp tree) + (let ((bytecomp--copy-tree-seen (make-hash-table :test #'eq))) + (bytecomp--copy-tree-1 tree)) + tree)) + (defconst byte-compile-initial-macro-environment `( ;; (byte-compiler-options . (lambda (&rest forms) @@ -534,7 +570,7 @@ Return the compile-time value of FORM." form macroexpand-all-environment))) (eval (byte-run-strip-symbol-positions - (safe-copy-tree expanded)) + (bytecomp--copy-tree expanded)) lexical-binding) expanded))))) (with-suppressed-warnings diff --git a/lisp/subr.el b/lisp/subr.el index 40bec544b73..8aedce934d1 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -846,61 +846,6 @@ argument VECP, this copies vectors as well as conses." tree) tree))) -(defvar safe-copy-tree--seen nil - "A hash table for conses/vectors/records already seen by safe-copy-tree-1. -Its 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)) - (unwind-protect - (safe-copy-tree--1 tree vecp) - (clrhash safe-copy-tree--seen) - (setq safe-copy-tree--seen nil))) - ;;;; Various list-search functions. diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index 10b009a261c..2cd4dd75742 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -1850,6 +1850,34 @@ EXPECTED-POINT BINDINGS (MODES \\='\\='(ruby-mode js-mode python-mode)) \ (should (eq (byte-compile-file src-file) 'no-byte-compile)) (should-not (file-exists-p dest-file)))) +(ert-deftest bytecomp--copy-tree () + (should (null (bytecomp--copy-tree nil))) + (let ((print-circle t)) + (let* ((x '(1 2 (3 4))) + (y (bytecomp--copy-tree x))) + (should (equal (prin1-to-string (list x y)) + "((1 2 (3 4)) (1 2 (3 4)))"))) + (let* ((x '#1=(a #1#)) + (y (bytecomp--copy-tree x))) + (should (equal (prin1-to-string (list x y)) + "(#1=(a #1#) #2=(a #2#))"))) + (let* ((x '#1=(#1# a)) + (y (bytecomp--copy-tree x))) + (should (equal (prin1-to-string (list x y)) + "(#1=(#1# a) #2=(#2# a))"))) + (let* ((x '((a . #1=(b)) #1#)) + (y (bytecomp--copy-tree x))) + (should (equal (prin1-to-string (list x y)) + "(((a . #1=(b)) #1#) ((a . #2=(b)) #2#))"))) + (let* ((x '#1=(a #2=(#1# b . #3=(#2# c . #1#)) (#3# d))) + (y (bytecomp--copy-tree x))) + (should (equal (prin1-to-string (list x y)) + (concat + "(" + "#1=(a #2=(#1# b . #3=(#2# c . #1#)) (#3# d))" + " " + "#4=(a #5=(#4# b . #6=(#5# c . #4#)) (#6# d))" + ")")))))) ;; Local Variables: ;; no-byte-compile: t diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el index 37fe09c1716..050ee22ac18 100644 --- a/test/lisp/subr-tests.el +++ b/test/lisp/subr-tests.el @@ -1205,31 +1205,5 @@ final or penultimate step during initialization.")) (should (equal a-dedup '("a" "b" "a" "b" "c"))) (should (eq a a-dedup)))) -(ert-deftest subr--safe-copy-tree () - (should (null (safe-copy-tree nil))) - (let* ((foo '(1 2 (3 4))) (bar (safe-copy-tree foo))) - (should (equal bar foo)) - (should-not (eq bar foo)) - (should-not (eq (caddr bar) (caddr foo)))) - (let* ((foo '#1=(a #1#)) (bar (safe-copy-tree foo))) - (should (eq (car bar) (car foo))) -; (should-not (proper-list-p bar)) - (should (eq (caadr bar) (caadr foo))) - (should (eq (caadr bar) 'a))) - (let* ((foo [1 2 3 4]) (bar (safe-copy-tree foo))) - (should (eq bar foo))) - (let* ((foo [1 (2 3) 4]) (bar (safe-copy-tree foo t))) - (should-not (eq bar foo)) - (should (equal bar foo)) - (should-not (eq (aref bar 1) (aref foo 1)))) - (let* ((foo [1 [2 3] 4]) (bar (safe-copy-tree foo t))) - (should (equal bar foo)) - (should-not (eq bar foo)) - (should-not (eq (aref bar 1) (aref foo 1)))) - (let* ((foo (record 'foo 1 "two" 3)) (bar (safe-copy-tree foo t))) - (should (equal bar foo)) - (should-not (eq bar foo)) - (should (eq (aref bar 2) (aref foo 2))))) - (provide 'subr-tests) ;;; subr-tests.el ends here -- 2.39.2