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
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,
(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)
form
macroexpand-all-environment)))
(eval (byte-run-strip-symbol-positions
- (safe-copy-tree expanded))
+ (bytecomp--copy-tree expanded))
lexical-binding)
expanded)))))
(with-suppressed-warnings
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)))
-
\f
;;;; Various list-search functions.
(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
(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
projects / emacs.git / commitdiff