diff options
| -rw-r--r-- | doc/lispref/lists.texi | 13 | ||||
| -rw-r--r-- | etc/NEWS | 5 | ||||
| -rw-r--r-- | lisp/emacs-lisp/bytecomp.el | 38 | ||||
| -rw-r--r-- | lisp/subr.el | 55 | ||||
| -rw-r--r-- | test/lisp/emacs-lisp/bytecomp-tests.el | 28 | ||||
| -rw-r--r-- | 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 @@ -392,11 +392,6 @@ 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, so it will return the remote UID for remote files (or -1 if the 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 |