From fa83b236111ea024b75a8bb33b78a99f437a9a67 Mon Sep 17 00:00:00 2001 From: Alan Mackenzie Date: Tue, 7 Mar 2023 08:00:25 +0000 Subject: [PATCH] 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. -- 2.39.2