master 29c47ac: * lisp/emacs-lisp/macroexp.el (macroexp--fgrep): Break cycles

[Stefan Monnier]

branch: master
commit 29c47ac19a393d2544562fe8932bc4e1b6ddd7c9
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    * lisp/emacs-lisp/macroexp.el (macroexp--fgrep): Break cycles
    
    * test/lisp/emacs-lisp/macroexp-tests.el: New file.
---
 lisp/emacs-lisp/macroexp.el            | 43 +++++++++++++++++++++++-----------
 test/lisp/emacs-lisp/macroexp-tests.el | 36 ++++++++++++++++++++++++++++
 2 files changed, 65 insertions(+), 14 deletions(-)

diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el
index 042061c..13ff5ef 100644
--- a/lisp/emacs-lisp/macroexp.el
+++ b/lisp/emacs-lisp/macroexp.el
@@ -572,20 +572,35 @@ test of free variables in the following ways:
 - For the same reason it may cause the result to fail to include bindings
   which will be used if SEXP is not yet fully macro-expanded and the
   use of the binding will only be revealed by macro expansion."
-  (let ((res '()))
-    (while (and (consp sexp) bindings)
-      (dolist (binding (macroexp--fgrep bindings (pop sexp)))
-        (push binding res)
-        (setq bindings (remove binding bindings))))
-    (if (or (vectorp sexp) (byte-code-function-p sexp))
-        ;; With backquote, code can appear within vectors as well.
-        ;; This wouldn't be needed if we `macroexpand-all' before
-        ;; calling macroexp--fgrep, OTOH.
-        (macroexp--fgrep bindings (mapcar #'identity sexp))
-      (let ((tmp (assq sexp bindings)))
-        (if tmp
-            (cons tmp res)
-          res)))))
+  (let ((res '())
+        ;; Cyclic code should not happen, but code can contain cyclic data :-(
+        (seen (make-hash-table :test #'eq))
+        (sexpss (list (list sexp))))
+    ;; Use a nested while loop to reduce the amount of heap allocations for
+    ;; pushes to `sexpss' and the `gethash' overhead.
+    (while (and sexpss bindings)
+      (let ((sexps (pop sexpss)))
+        (unless (gethash sexps seen)
+          (puthash sexps t seen) ;; Using `setf' here causes bootstrap 
problems.
+          (if (vectorp sexps) (setq sexps (mapcar #'identity sexps)))
+          (let ((tortoise sexps) (skip t))
+            (while sexps
+              (let ((sexp (if (consp sexps) (pop sexps)
+                            (prog1 sexps (setq sexps nil)))))
+                (if skip
+                    (setq skip nil)
+                  (setq tortoise (cdr tortoise))
+                  (if (eq tortoise sexps)
+                      (setq sexps nil) ;; Found a cycle: we're done!
+                    (setq skip t)))
+                (cond
+                 ((or (consp sexp) (vectorp sexp)) (push sexp sexpss))
+                 (t
+                  (let ((tmp (assq sexp bindings)))
+                    (when tmp
+                      (push tmp res)
+                      (setq bindings (remove tmp bindings))))))))))))
+    res))
 
 ;;; Load-time macro-expansion.
 
diff --git a/test/lisp/emacs-lisp/macroexp-tests.el 
b/test/lisp/emacs-lisp/macroexp-tests.el
new file mode 100644
index 0000000..1124e3b
--- /dev/null
+++ b/test/lisp/emacs-lisp/macroexp-tests.el
@@ -0,0 +1,36 @@
+;;; macroexp-tests.el --- Tests for macroexp.el      -*- lexical-binding: t; 
-*-
+
+;; Copyright (C) 2021  Stefan Monnier
+
+;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; Keywords:
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;
+
+;;; Code:
+
+(ert-deftest macroexp--tests-fgrep ()
+  (should (equal (macroexp--fgrep '((x) (y)) '([x] z ((u))))
+                 '((x))))
+  (should (equal (macroexp--fgrep '((x) (y)) '#2=([y] ((y #2#))))
+                 '((y))))
+  (should (equal (macroexp--fgrep '((x) (y)) '#2=([r] ((a x)) a b c d . #2#))
+                 '((x)))))
+
+(provide 'macroexp-tests)
+;;; macroexp-tests.el ends here