[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
feature/android 8687f9309f8: Merge remote-tracking branch 'origin/master
|
From: |
Po Lu |
|
Subject: |
feature/android 8687f9309f8: Merge remote-tracking branch 'origin/master' into feature/android |
|
Date: |
Sat, 20 May 2023 20:55:13 -0400 (EDT) |
branch: feature/android
commit 8687f9309f833074fcb8da14d0522a74a4e23a2e
Merge: d86643a7863 88d1e9b436c
Author: Po Lu <luangruo@yahoo.com>
Commit: Po Lu <luangruo@yahoo.com>
Merge remote-tracking branch 'origin/master' into feature/android
---
doc/lispref/lists.texi | 8 ++---
doc/lispref/records.texi | 5 +--
etc/NEWS | 6 ++--
lisp/calc/calc-graph.el | 7 ++--
lisp/calendar/appt.el | 2 +-
lisp/dired-aux.el | 8 ++---
lisp/emacs-lisp/bytecomp.el | 2 +-
lisp/emacs-lisp/shortdoc.el | 2 +-
lisp/net/tramp-compat.el | 1 +
lisp/net/tramp-sh.el | 13 +++-----
lisp/net/tramp.el | 15 +++++----
lisp/progmodes/cc-styles.el | 5 +--
lisp/subr.el | 34 +++++++++++++------
test/lisp/net/tramp-tests.el | 67 +++++++++++++++++++-------------------
test/lisp/subr-tests.el | 77 +++++++++++++++++++++++++++-----------------
15 files changed, 143 insertions(+), 109 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 614b4b9169a..71d20e9da82 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -406,6 +406,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
@@ -621,9 +624,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/calc/calc-graph.el b/lisp/calc/calc-graph.el
index 3de761e19f8..1b9d25daf3b 100644
--- a/lisp/calc/calc-graph.el
+++ b/lisp/calc/calc-graph.el
@@ -598,9 +598,10 @@
(math-build-var-name (car math-arglist))
'(var DUMMY var-DUMMY)))))
(setq calc-graph-ycache (assoc calc-graph-yvalue calc-graph-data-cache))
- (delq calc-graph-ycache calc-graph-data-cache)
- (nconc calc-graph-data-cache
- (list (or calc-graph-ycache (setq calc-graph-ycache (list
calc-graph-yvalue)))))
+ (setq calc-graph-data-cache
+ (nconc (delq calc-graph-ycache calc-graph-data-cache)
+ (list (or calc-graph-ycache
+ (setq calc-graph-ycache (list
calc-graph-yvalue))))))
(if (and (not (setq calc-graph-xvec (eq (car-safe calc-graph-xvalue)
'vec)))
calc-graph-refine (cdr (cdr calc-graph-ycache)))
(calc-graph-refine-2d)
diff --git a/lisp/calendar/appt.el b/lisp/calendar/appt.el
index 49597739446..11beee94e64 100644
--- a/lisp/calendar/appt.el
+++ b/lisp/calendar/appt.el
@@ -707,7 +707,7 @@ ARG is positive, otherwise off."
(not appt-active)))
(remove-hook 'write-file-functions #'appt-update-list)
(or global-mode-string (setq global-mode-string '("")))
- (delq 'appt-mode-string global-mode-string)
+ (setq global-mode-string (delq 'appt-mode-string global-mode-string))
(when appt-timer
(cancel-timer appt-timer)
(setq appt-timer nil))
diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el
index 96ac9da4508..a07406e4c0d 100644
--- a/lisp/dired-aux.el
+++ b/lisp/dired-aux.el
@@ -957,7 +957,7 @@ Also see the `dired-confirm-shell-command' variable."
;; "&" instead.
(cmd-sep (if (and (or (not w32-shell) file-remote)
(not parallel-in-background))
- ";" "&"))
+ "; " "& "))
(stuff-it
(if (dired--star-or-qmark-p command nil 'keep)
(lambda (x)
@@ -988,7 +988,7 @@ Also see the `dired-confirm-shell-command' variable."
;; Add 'wait' to force those POSIX shells to wait until
;; all commands finish.
(or (and parallel-in-background (not w32-shell)
- " &wait")
+ " & wait")
"")))
(t
(let ((files (mapconcat #'shell-quote-argument
@@ -1000,9 +1000,9 @@ Also see the `dired-confirm-shell-command' variable."
;; Be consistent in how we treat inputs to commands -- do
;; the same here as in the `on-each' case.
(if (and in-background (not w32-shell))
- " &wait"
+ " & wait"
"")))))
- (or (and in-background "&")
+ (or (and in-background "& ")
""))))
;; This is an extra function so that it can be redefined by ange-ftp.
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index deda4573229..b8d7b63a81a 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -3561,7 +3561,7 @@ lambda-expression."
;; These functions are side-effect-free except for the
;; behaviour of functions passed as argument.
mapcar mapcan mapconcat
- assoc plist-get plist-member
+ assoc assoc-string plist-get plist-member
;; It's safe to ignore the value of `sort' and `nreverse'
;; when used on arrays, but most calls pass lists.
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/net/tramp-compat.el b/lisp/net/tramp-compat.el
index 43544ae327e..40ea47ede40 100644
--- a/lisp/net/tramp-compat.el
+++ b/lisp/net/tramp-compat.el
@@ -29,6 +29,7 @@
;;; Code:
+(require 'ansi-color)
(require 'auth-source)
(require 'format-spec)
(require 'ls-lisp) ;; Due to `tramp-handle-insert-directory'.
diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el
index 49e6d2d7aa9..d4933ad7ba6 100644
--- a/lisp/net/tramp-sh.el
+++ b/lisp/net/tramp-sh.el
@@ -80,13 +80,6 @@ the default storage location, e.g. \"$HOME/.sh_history\"."
(const :tag "Unset HISTFILE" t)
(string :tag "Redirect to a file")))
-;;;###tramp-autoload
-(defconst tramp-display-escape-sequence-regexp (rx "\e" (+ (any ";[" digit))
"m")
- "Terminal control escape sequences for display attributes.")
-
-(defconst tramp-device-escape-sequence-regexp (rx "\e" (+ (any "[" digit)) "n")
- "Terminal control escape sequences for device status.")
-
;; ksh on OpenBSD 4.5 requires that $PS1 contains a `#' character for
;; root users. It uses the `$' character for other users. In order
;; to guarantee a proper prompt, we use "#$ " for the prompt.
@@ -2654,7 +2647,7 @@ The method used must be an out-of-band method."
(unless (tramp-compat-string-search
"color" (tramp-get-connection-property v "ls" ""))
(goto-char (point-min))
- (while (re-search-forward tramp-display-escape-sequence-regexp nil
t)
+ (while (re-search-forward ansi-color-control-seq-regexp nil t)
(replace-match "")))
;; Now decode what read if necessary. Stolen from
`insert-directory'.
@@ -4323,6 +4316,7 @@ seconds. If not, it produces an error message with the
given ERROR-ARGS."
proc timeout
(rx
(| (regexp shell-prompt-pattern) (regexp tramp-shell-prompt-pattern))
+ (? (regexp ansi-color-control-seq-regexp))
eos))
(error
(delete-process proc)
@@ -4831,6 +4825,7 @@ Goes through the list `tramp-inline-compress-commands'."
"Check, whether local ssh OPTION is applicable."
;; We don't want to cache it persistently.
(with-tramp-connection-property nil option
+ ;; "ssh -G" is introduced in OpenSSH 6.7.
;; We use a non-existing IP address for check, in order to avoid
;; useless connections, and DNS timeouts.
(zerop
@@ -5306,7 +5301,7 @@ function waits for output unless NOOUTPUT is set."
(regexp (rx
(* (not (any "#$\n")))
(literal tramp-end-of-output)
- (? (regexp tramp-device-escape-sequence-regexp))
+ (? (regexp ansi-color-control-seq-regexp))
(? "\r") eol))
;; Sometimes, the commands do not return a newline but a
;; null byte before the shell prompt, for example "git
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index 910d534330c..f986d65d944 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -624,9 +624,7 @@ Sometimes the prompt is reported to look like \"login
as:\"."
;; connection initialization; Tramp redefines the prompt afterwards.
(rx (| bol "\r")
(* (not (any "\n#$%>]")))
- (? "#") (any "#$%>]") (* blank)
- ;; Escape characters.
- (* "[" (* (any ";" digit)) alpha (* blank)))
+ (? "#") (any "#$%>]") (* blank))
"Regexp to match prompts from remote shell.
Normally, Tramp expects you to configure `shell-prompt-pattern'
correctly, but sometimes it happens that you are connecting to a
@@ -5711,6 +5709,12 @@ Wait, until the connection buffer changes."
"Wait for output from the shell and perform one action.
See `tramp-process-actions' for the format of ACTIONS."
(let ((case-fold-search t)
+ (shell-prompt-pattern
+ (rx (regexp shell-prompt-pattern)
+ (? (regexp ansi-color-control-seq-regexp))))
+ (tramp-shell-prompt-pattern
+ (rx (regexp tramp-shell-prompt-pattern)
+ (? (regexp ansi-color-control-seq-regexp))))
tramp-process-action-regexp
found todo item pattern action)
(while (not found)
@@ -5721,7 +5725,7 @@ See `tramp-process-actions' for the format of ACTIONS."
(while todo
(setq item (pop todo)
tramp-process-action-regexp (symbol-value (nth 0 item))
- pattern (format "\\(%s\\)\\'" tramp-process-action-regexp)
+ pattern (rx (group (regexp tramp-process-action-regexp)) eos)
action (nth 1 item))
(tramp-message
vec 5 "Looking for regexp \"%s\" from remote shell" pattern)
@@ -6278,8 +6282,7 @@ to cache the result. Return the modified ATTR."
(save-match-data
;; Remove color escape sequences from symlink.
(when (stringp (car attr))
- (while (string-match
- tramp-display-escape-sequence-regexp (car attr))
+ (while (string-match ansi-color-control-seq-regexp (car
attr))
(setcar attr (replace-match "" nil nil (car attr)))))
;; Convert uid and gid. Use `tramp-unknown-id-integer'
;; as indication of unusable value.
diff --git a/lisp/progmodes/cc-styles.el b/lisp/progmodes/cc-styles.el
index fc4f723915c..e412a52cfb8 100644
--- a/lisp/progmodes/cc-styles.el
+++ b/lisp/progmodes/cc-styles.el
@@ -658,8 +658,9 @@ any reason to call this function directly."
(let ((func (if this-buf-only-p
'make-local-variable
'make-variable-buffer-local))
- (varsyms (cons 'c-indentation-style (copy-alist c-style-variables))))
- (delq 'c-special-indent-hook varsyms)
+ (varsyms (cons 'c-indentation-style
+ (delq 'c-special-indent-hook
+ (copy-alist c-style-variables)))))
(mapc func varsyms)
;; Hooks must be handled specially
(if this-buf-only-p
diff --git a/lisp/subr.el b/lisp/subr.el
index b67d881c969..73f3cd4a28e 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)))
@@ -888,6 +893,7 @@ Non-strings in LIST are ignored."
Compare keys with TEST. Defaults to `equal'.
Return the modified alist.
Elements of ALIST that are not conses are ignored."
+ (declare (important-return-value t))
(unless test (setq test #'equal))
(while (and (consp (car alist))
(funcall test (caar alist) key))
@@ -904,12 +910,14 @@ Elements of ALIST that are not conses are ignored."
"Delete from ALIST all elements whose car is `eq' to KEY.
Return the modified alist.
Elements of ALIST that are not conses are ignored."
+ (declare (important-return-value t))
(assoc-delete-all key alist #'eq))
(defun rassq-delete-all (value alist)
"Delete from ALIST all elements whose cdr is `eq' to VALUE.
Return the modified alist.
Elements of ALIST that are not conses are ignored."
+ (declare (important-return-value t))
(while (and (consp (car alist))
(eq (cdr (car alist)) value))
(setq alist (cdr alist)))
@@ -952,6 +960,7 @@ Example:
(setf (alist-get \\='b foo nil \\='remove) nil)
foo => ((a . 1))"
+ (declare (important-return-value t))
(ignore remove) ;;Silence byte-compiler.
(let ((x (if (not testfn)
(assq key alist)
@@ -6973,7 +6982,10 @@ returned list are in the same order as in TREE.
"Trim STRING of leading string matching REGEXP.
REGEXP defaults to \"[ \\t\\n\\r]+\"."
- (if (string-match (concat "\\`\\(?:" (or regexp "[ \t\n\r]+") "\\)") string)
+ (if (string-match (if regexp
+ (concat "\\`\\(?:" regexp "\\)")
+ "\\`[ \t\n\r]+")
+ string)
(substring string (match-end 0))
string))
@@ -6982,7 +6994,9 @@ REGEXP defaults to \"[ \\t\\n\\r]+\"."
REGEXP defaults to \"[ \\t\\n\\r]+\"."
(declare (side-effect-free t))
- (let ((i (string-match-p (concat "\\(?:" (or regexp "[ \t\n\r]+") "\\)\\'")
+ (let ((i (string-match-p (if regexp
+ (concat "\\(?:" regexp "\\)\\'")
+ "[ \t\n\r]+\\'")
string)))
(if i (substring string 0 i) string)))
diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el
index 6c773908e26..eec4a66a329 100644
--- a/test/lisp/net/tramp-tests.el
+++ b/test/lisp/net/tramp-tests.el
@@ -66,7 +66,6 @@
(defvar ange-ftp-make-backup-files)
(defvar tramp-connection-properties)
(defvar tramp-copy-size-limit)
-(defvar tramp-display-escape-sequence-regexp)
(defvar tramp-fuse-remove-hidden-files)
(defvar tramp-fuse-unmount-on-cleanup)
(defvar tramp-inline-compress-start-size)
@@ -4941,8 +4940,7 @@ This tests also `make-symbolic-link', `file-truename' and
`add-name-to-file'."
(if (bufferp destination) destination (current-buffer))
;; "ls" could produce colorized output.
(goto-char (point-min))
- (while (re-search-forward
- tramp-display-escape-sequence-regexp nil t)
+ (while (re-search-forward ansi-color-control-seq-regexp nil t)
(replace-match "" nil nil))
(should
(string-equal (if destination (format "%s\n" fnnd) "")
@@ -4956,8 +4954,7 @@ This tests also `make-symbolic-link', `file-truename' and
`add-name-to-file'."
(if (bufferp destination) destination (current-buffer))
;; "ls" could produce colorized output.
(goto-char (point-min))
- (while (re-search-forward
- tramp-display-escape-sequence-regexp nil t)
+ (while (re-search-forward ansi-color-control-seq-regexp nil t)
(replace-match "" nil nil))
(should
(string-equal
@@ -5671,8 +5668,7 @@ INPUT, if non-nil, is a string sent to the process."
(current-buffer))
;; "ls" could produce colorized output.
(goto-char (point-min))
- (while
- (re-search-forward tramp-display-escape-sequence-regexp nil t)
+ (while (re-search-forward ansi-color-control-seq-regexp nil t)
(replace-match "" nil nil))
(should
(string-equal
@@ -7589,34 +7585,37 @@ process sentinels. They shall not disturb each other."
;; Send a string to the processes. Use a random order of
;; the buffers. Mix with regular operation.
- (let ((buffers (copy-sequence buffers)))
+ (let ((buffers (copy-sequence buffers))
+ buf)
(while buffers
- (let* ((buf (seq-random-elt buffers))
- (proc (get-buffer-process buf))
- (file (process-get proc 'foo))
- (count (process-get proc 'bar)))
- (tramp--test-message
- "Start action %d %s %s" count buf (current-time-string))
- ;; Regular operation prior process action.
- (dired-uncache file)
- (if (= count 0)
- (should-not (file-attributes file))
- (should (file-attributes file)))
- ;; Send string to process.
- (process-send-string proc (format "%s\n" (buffer-name buf)))
- (while (accept-process-output nil 0))
- (tramp--test-message
- "Continue action %d %s %s" count buf (current-time-string))
- ;; Regular operation post process action.
- (dired-uncache file)
- (if (= count 2)
- (should-not (file-attributes file))
- (should (file-attributes file)))
- (tramp--test-message
- "Stop action %d %s %s" count buf (current-time-string))
- (process-put proc 'bar (1+ count))
- (unless (process-live-p proc)
- (setq buffers (delq buf buffers))))))
+ (setq buf (seq-random-elt buffers))
+ (if-let ((proc (get-buffer-process buf))
+ (file (process-get proc 'foo))
+ (count (process-get proc 'bar)))
+ (progn
+ (tramp--test-message
+ "Start action %d %s %s" count buf (current-time-string))
+ ;; Regular operation prior process action.
+ (dired-uncache file)
+ (if (= count 0)
+ (should-not (file-attributes file))
+ (should (file-attributes file)))
+ ;; Send string to process.
+ (process-send-string proc (format "%s\n" (buffer-name
buf)))
+ (while (accept-process-output nil 0))
+ (tramp--test-message
+ "Continue action %d %s %s" count buf
(current-time-string))
+ ;; Regular operation post process action.
+ (dired-uncache file)
+ (if (= count 2)
+ (should-not (file-attributes file))
+ (should (file-attributes file)))
+ (tramp--test-message
+ "Stop action %d %s %s" count buf (current-time-string))
+ (process-put proc 'bar (1+ count))
+ (unless (process-live-p proc)
+ (setq buffers (delq buf buffers))))
+ (setq buffers (delq buf buffers)))))
;; Checks. All process output shall exist in the
;; respective buffers. All created files shall be
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