diff options
author | Stefan Monnier <monnier@iro.umontreal.ca> | 2021-02-10 16:06:24 -0500 |
---|---|---|
committer | Stefan Monnier <monnier@iro.umontreal.ca> | 2021-02-10 16:06:24 -0500 |
commit | 29c47ac19a393d2544562fe8932bc4e1b6ddd7c9 (patch) | |
tree | 01f0b544a479bd826db22d397ad6cb006b53557a | |
parent | 6bfdfeed36fab4680c8db90c22da8f6611694186 (diff) | |
download | emacs-29c47ac19a393d2544562fe8932bc4e1b6ddd7c9.tar.gz |
* lisp/emacs-lisp/macroexp.el (macroexp--fgrep): Break cycles
* test/lisp/emacs-lisp/macroexp-tests.el: New file.
-rw-r--r-- | lisp/emacs-lisp/macroexp.el | 43 | ||||
-rw-r--r-- | 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 042061c44fc..13ff5ef2eda 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 00000000000..1124e3b8d91 --- /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 |