master fa83b236111: eval-and-compile: Strip symbol positions for eval but not for compile.

[Alan Mackenzie]

branch: master
commit fa83b236111ea024b75a8bb33b78a99f437a9a67
Author: Alan Mackenzie <acm@muc.de>
Commit: Alan Mackenzie <acm@muc.de>

    eval-and-compile: Strip symbol positions for eval but not for compile.
    
    This fixes bug #61962.
    
    * lisp/subr.el (safe-copy-tree): New function.
    
    * lisp/emacs-lisp/bytecomp.el (byte-compile-initial-macro-environment): 
Amend
    the entry for eval-and-compile to use safe-copy-tree and
    byte-run-strip-symbol-positions for the eval part.
    
    * doc/lispref/lists.texi (Building Lists): Document safe-copy-tree.
    
    * etc/NEWS: Note the new function safe-copy-tree.
---
 doc/lispref/lists.texi      | 14 +++++++++++-
 etc/NEWS                    |  5 +++++
 lisp/emacs-lisp/bytecomp.el | 13 +++++++++--
 lisp/subr.el                | 53 +++++++++++++++++++++++++++++++++++++++++++++
 4 files changed, 82 insertions(+), 3 deletions(-)

diff --git a/doc/lispref/lists.texi b/doc/lispref/lists.texi
index f3758f5ce60..911defbc211 100644
--- a/doc/lispref/lists.texi
+++ b/doc/lispref/lists.texi
@@ -705,9 +705,21 @@ 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 too (and operates recursively on
-their elements).
+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.
+
 @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 7e0454b3b9e..540b59a628f 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -358,6 +358,11 @@ 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 6f3d7a70903..243d4b11b5f 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -533,7 +533,9 @@ Return the compile-time value of FORM."
                                       (macroexpand--all-toplevel
                                        form
                                        macroexpand-all-environment)))
-                                (eval expanded lexical-binding)
+                                (eval (byte-run-strip-symbol-positions
+                                       (safe-copy-tree expanded))
+                                      lexical-binding)
                                 expanded)))))
     (with-suppressed-warnings
         . ,(lambda (warnings &rest body)
@@ -2292,12 +2294,19 @@ With argument ARG, insert value in current buffer after 
the form."
            (symbols-with-pos-enabled t)
           (value (eval
                   (displaying-byte-compile-warnings
+;;;; NEW STOUGH, 2023-03-05
+                    (byte-run-strip-symbol-positions
+;;;; END OF NEW STOUGH
                    (byte-compile-sexp
                      (let ((form (read-positioning-symbols (current-buffer))))
                        (push form byte-compile-form-stack)
                        (eval-sexp-add-defvars
                         form
-                        start-read-position))))
+                        start-read-position)))
+;;;; NEW STOUGH, 2023-03-05
+                    )
+;;;; END OF NEW STOUGH
+                                              )
                    lexical-binding)))
       (cond (arg
             (message "Compiling from buffer... done.")
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 @@ argument VECP, this copies vectors as well as conses."
            (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))
+
 
 ;;;; Various list-search functions.