From 768a35279388106f83842b7e029aa4a61b142df2 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 8 Jan 2021 17:57:26 -0500 Subject: [PATCH] * lisp/emacs-lisp/macroexp.el (macroexp--fgrep): Rename from `pcase--fgrep` * lisp/emacs-lisp/cl-generic.el (cl--generic-fgrep): Delete. (cl--generic-lambda): Use `macroexp--pacse` instead. * lisp/emacs-lisp/pcase.el (pcase--fgrep): Rename to `macroexp--fgrep`. --- lisp/emacs-lisp/cl-generic.el | 24 ++++++++---------------- lisp/emacs-lisp/macroexp.el | 29 +++++++++++++++++++++++++++++ lisp/emacs-lisp/pcase.el | 27 +++++---------------------- 3 files changed, 42 insertions(+), 38 deletions(-) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 19dd54c8645..529de9346d0 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -304,15 +304,6 @@ the specializer used will be the one returned by BODY." (lambda ,args ,@body)))) (eval-and-compile ;Needed while compiling the cl-defmethod calls below! - (defun cl--generic-fgrep (vars sexp) ;Copied from pcase.el. - "Check which of the symbols VARS appear in SEXP." - (let ((res '())) - (while (consp sexp) - (dolist (var (cl--generic-fgrep vars (pop sexp))) - (unless (memq var res) (push var res)))) - (and (memq sexp vars) (not (memq sexp res)) (push sexp res)) - res)) - (defun cl--generic-split-args (args) "Return (SPEC-ARGS . PLAIN-ARGS)." (let ((plain-args ()) @@ -375,7 +366,7 @@ the specializer used will be the one returned by BODY." ;; is used. ;; FIXME: Also, optimize the case where call-next-method is ;; only called with explicit arguments. - (uses-cnm (cl--generic-fgrep (list cnm nmp) nbody))) + (uses-cnm (macroexp--fgrep `((,cnm) (,nmp)) nbody))) (cons (not (not uses-cnm)) `#'(lambda (,@(if uses-cnm (list cnm)) ,@args) ,@(car parsed-body) @@ -617,11 +608,11 @@ The set of acceptable TYPEs (also called \"specializers\") is defined (lambda (,@fixedargs &rest args) (let ,bindings (apply (cl--generic-with-memoization - (gethash ,tag-exp method-cache) - (cl--generic-cache-miss - generic ',dispatch-arg dispatches-left methods - ,(if (cdr typescodes) - `(append ,@typescodes) (car typescodes)))) + (gethash ,tag-exp method-cache) + (cl--generic-cache-miss + generic ',dispatch-arg dispatches-left methods + ,(if (cdr typescodes) + `(append ,@typescodes) (car typescodes)))) ,@fixedargs args))))))))) (defun cl--generic-make-function (generic) @@ -1110,7 +1101,8 @@ These match if the argument is a cons cell whose car is `eql' to VAL." (if (not (eq (car-safe specializer) 'head)) (cl-call-next-method) (cl--generic-with-memoization - (gethash (cadr specializer) cl--generic-head-used) specializer) + (gethash (cadr specializer) cl--generic-head-used) + specializer) (list cl--generic-head-generalizer))) (cl--generic-prefill-dispatchers 0 (head eql)) diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 82a8cd2d777..d5fda528b4f 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -480,6 +480,35 @@ itself or not." v (list 'quote v))) +(defun macroexp--fgrep (bindings sexp) + "Return those of the BINDINGS which might be used in SEXP. +It is used as a poor-man's \"free variables\" test. It differs from a true +test of free variables in the following ways: +- It does not distinguish variables from functions, so it can be used + both to detect whether a given variable is used by SEXP and to + detect whether a given function is used by SEXP. +- It does not actually know ELisp syntax, so it only looks for the presence + of symbols in SEXP and can't distinguish if those symbols are truly + references to the given variable (or function). That can make the result + include bindings which actually aren't used. +- 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 (vectorp 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))))) + ;;; Load-time macro-expansion. ;; Because macro-expansion used to be more lazy, eager macro-expansion diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 8fb79d220de..72ea1ba0188 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -344,7 +344,7 @@ of the elements of LIST is performed as if by `pcase-let'. (seen '()) (codegen (lambda (code vars) - (let ((vars (pcase--fgrep vars code)) + (let ((vars (macroexp--fgrep vars code)) (prev (assq code seen))) (if (not prev) (let ((res (pcase-codegen code vars))) @@ -401,7 +401,7 @@ of the elements of LIST is performed as if by `pcase-let'. ;; occurrences of this leaf since it's small. (lambda (code vars) (pcase-codegen code - (pcase--fgrep vars code))) + (macroexp--fgrep vars code))) codegen) (cdr case) vars)))) @@ -668,7 +668,7 @@ MATCH is the pattern that needs to be matched, of the form: ;; run, but we don't have the environment in which `pat' will ;; run, so we can't do a reliable verification. But let's try ;; and catch at least the easy cases such as (bug#14773). - (not (pcase--fgrep (mapcar #'car vars) (cadr upat))))) + (not (macroexp--fgrep (mapcar #'car vars) (cadr upat))))) '(:pcase--succeed . :pcase--fail)) ((and (eq 'pred (car upat)) (let ((otherpred @@ -692,23 +692,6 @@ MATCH is the pattern that needs to be matched, of the form: '(nil . :pcase--fail) '(:pcase--fail . nil)))))) -(defun pcase--fgrep (bindings sexp) - "Return those of the BINDINGS which might be used in SEXP." - (let ((res '())) - (while (and (consp sexp) bindings) - (dolist (binding (pcase--fgrep bindings (pop sexp))) - (push binding res) - (setq bindings (remove binding bindings)))) - (if (vectorp sexp) - ;; With backquote, code can appear within vectors as well. - ;; This wouldn't be needed if we `macroexpand-all' before - ;; calling pcase--fgrep, OTOH. - (pcase--fgrep bindings (mapcar #'identity sexp)) - (let ((tmp (assq sexp bindings))) - (if tmp - (cons tmp res) - res))))) - (defun pcase--self-quoting-p (upat) (or (keywordp upat) (integerp upat) (stringp upat))) @@ -749,7 +732,7 @@ MATCH is the pattern that needs to be matched, of the form: `(,fun ,arg) (let* (;; `env' is an upper bound on the bindings we need. (env (mapcar (lambda (x) (list (car x) (cdr x))) - (pcase--fgrep vars fun))) + (macroexp--fgrep vars fun))) (call (progn (when (assq arg env) ;; `arg' is shadowed by `env'. @@ -770,7 +753,7 @@ MATCH is the pattern that needs to be matched, of the form: "Build an expression that will evaluate EXP." (let* ((found (assq exp vars))) (if found (cdr found) - (let* ((env (pcase--fgrep vars exp))) + (let* ((env (macroexp--fgrep vars exp))) (if env (macroexp-let* (mapcar (lambda (x) (list (car x) (cdr x))) env) -- 2.39.2