master d79cdcd4ff: cconv.el: Fix regression in cconv-tests-interactive-closure-bug51695

[Stefan Monnier]

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

    cconv.el: Fix regression in cconv-tests-interactive-closure-bug51695
    
    The new code to make interpreted closures safe-for-space introduced
    a regression in `cconv-tests-interactive-closure-bug51695`, only seen
    when using TEST_LOAD_EL.
    A few other issues were found and fixed along the way.
    
    * lisp/emacs-lisp/cconv.el (cconv-fv): Change calling convention and
    focus on finding the free variables.
    (cconv-make-interpreted-closure): New function.
    
    * lisp/loadup.el: Use `compiled-function-p` rather than
    `byte-code-function-p` so we also use safe-for-space interpreted
    closures when we build with native compilation.
    (internal-make-interpreted-closure-function):
    Use `cconv-make-interpreted-closure`.
    
    * src/eval.c (syms_of_eval): Rename `internal-filter-closure-env-function`
    to `internal-make-interpreted-closure-function`.
    (Ffunction): Let that new var build the actual closure.
    
    * test/lisp/emacs-lisp/cconv-tests.el
    (cconv-tests-interactive-closure-bug51695): Test specifically the
    interpreted case.
---
 lisp/emacs-lisp/cconv.el            | 101 +++++++++++++++++++++++-------------
 lisp/loadup.el                      |   7 +--
 src/eval.c                          |  21 ++++----
 test/lisp/emacs-lisp/cconv-tests.el |  17 ++++--
 4 files changed, 90 insertions(+), 56 deletions(-)

diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el
index 289e2b0eee..f3431db415 100644
--- a/lisp/emacs-lisp/cconv.el
+++ b/lisp/emacs-lisp/cconv.el
@@ -828,49 +828,78 @@ This function does not return anything but instead fills 
the
          (setf (nth 1 dv) t))))))
 (define-obsolete-function-alias 'cconv-analyse-form #'cconv-analyze-form 
"25.1")
 
-(defun cconv-fv (form env &optional no-macroexpand)
+(defun cconv-fv (form lexvars dynvars)
   "Return the list of free variables in FORM.
-ENV is the lexical environment from which the variables can be taken.
-It should be a list of pairs of the form (VAR . VAL).
-The return value is a list of those (VAR . VAL) bindings,
-in the same order as they appear in ENV.
-If NO-MACROEXPAND is non-nil, we do not macro-expand FORM,
-which means that the result may be incorrect if there are non-expanded
-macro calls in FORM."
-  (let* ((fun `#'(lambda () ,form))
-         ;; Make dummy bindings to avoid warnings about the var being
-         ;; left uninitialized.
-         (analysis-env
-          (delq nil (mapcar (lambda (b) (if (consp b)
-                                       (list (car b) nil nil nil nil)))
-                            env)))
-         (cconv--dynbound-variables
-          (delq nil (mapcar (lambda (b) (if (symbolp b) b)) env)))
+LEXVARS is the list of statically scoped vars in the context
+and DYNVARS is the list of dynamically scoped vars in the context.
+Returns a pair (LEXV . DYNV) of those vars actually used by FORM."
+  (let* ((fun
+          ;; Wrap FORM into a function because the analysis code we
+          ;; have only computes freevars for functions.
+          ;; In practice FORM is always already of the form
+          ;; #'(lambda ...), so optimize for this case.
+          (if (and (eq 'function (car-safe form))
+                   (eq 'lambda (car-safe (cadr form)))
+                   ;; To get correct results, FUN needs to be a "simple lambda"
+                   ;; without nested forms that aren't part of the body.  :-(
+                   (not (assq 'interactive (cadr form)))
+                   (not (assq ':documentation (cadr form))))
+              form
+            `#'(lambda () ,form)))
+         (analysis-env (mapcar (lambda (v) (list v nil nil nil nil)) lexvars))
+         (cconv--dynbound-variables dynvars)
          (byte-compile-lexical-variables nil)
          (cconv--dynbindings nil)
          (cconv-freevars-alist '())
         (cconv-var-classification '()))
-    (if (null analysis-env)
+    (let* ((body (cddr (cadr fun))))
+      ;; Analyze form - fill these variables with new information.
+      (cconv-analyze-form fun analysis-env)
+      (setq cconv-freevars-alist (nreverse cconv-freevars-alist))
+      (unless (equal (if (eq :documentation (car-safe (car body)))
+                            (cdr body) body)
+                     (caar cconv-freevars-alist))
+        (message "BOOH!\n%S\n%S"
+                 body (caar cconv-freevars-alist)))
+      (cl-assert (equal (if (eq :documentation (car-safe (car body)))
+                            (cdr body) body)
+                        (caar cconv-freevars-alist)))
+      (let ((fvs (nreverse (cdar cconv-freevars-alist)))
+            (dyns (delq nil (mapcar (lambda (var) (car (memq var dynvars)))
+                                    (delete-dups cconv--dynbindings)))))
+        (cons fvs dyns)))))
+
+(defun cconv-make-interpreted-closure (fun env)
+  (cl-assert (eq (car-safe fun) 'lambda))
+  (let ((lexvars (delq nil (mapcar #'car-safe env))))
+    (if (null lexvars)
         ;; The lexical environment is empty, so there's no need to
         ;; look for free variables.
-        env
-      (let* ((fun (if no-macroexpand fun
-                    (macroexpand-all fun macroexpand-all-environment)))
-             (body (cddr (cadr fun))))
-        ;; Analyze form - fill these variables with new information.
-        (cconv-analyze-form fun analysis-env)
-        (setq cconv-freevars-alist (nreverse cconv-freevars-alist))
-        (cl-assert (equal (if (eq :documentation (car-safe (car body)))
-                              (cdr body) body)
-                          (caar cconv-freevars-alist)))
-        (let ((fvs (nreverse (cdar cconv-freevars-alist)))
-              (dyns (mapcar (lambda (var) (car (memq var env)))
-                            (delete-dups cconv--dynbindings))))
-          (or (nconc (mapcar (lambda (fv) (assq fv env)) fvs)
-                     (delq nil dyns))
-              ;; Never return nil, since nil means to use the dynbind
-              ;; dialect of ELisp.
-              '(t)))))))
+        `(closure ,env . ,(cdr fun))
+      ;; We could try and cache the result of the macroexpansion and
+      ;; `cconv-fv' analysis.  Not sure it's worth the trouble.
+      (let* ((form `#',fun)
+             (expanded-form
+              (let ((lexical-binding t) ;; Tell macros which dialect is in use.
+                   ;; Make the macro aware of any defvar declarations in scope.
+                    (macroexp--dynvars
+                     (if macroexp--dynvars
+                         (append env macroexp--dynvars) env)))
+                (macroexpand-all form macroexpand-all-environment)))
+             ;; Since we macroexpanded the body, we may as well use that.
+             (expanded-fun-cdr
+              (pcase expanded-form
+                (`#'(lambda . ,cdr) cdr)
+                (_ (cdr fun))))
+         
+             (dynvars (delq nil (mapcar (lambda (b) (if (symbolp b) b)) env)))
+             (fvs (cconv-fv expanded-form lexvars dynvars))
+             (newenv (nconc (mapcar (lambda (fv) (assq fv env)) (car fvs))
+                            (cdr fvs))))
+        ;; Never return a nil env, since nil means to use the dynbind
+        ;; dialect of ELisp.
+        `(closure ,(or newenv '(t)) . ,expanded-fun-cdr)))))
+
 
 (provide 'cconv)
 ;;; cconv.el ends here
diff --git a/lisp/loadup.el b/lisp/loadup.el
index 63806ae456..2a9aff4c1f 100644
--- a/lisp/loadup.el
+++ b/lisp/loadup.el
@@ -367,9 +367,10 @@
 
 (load "emacs-lisp/eldoc")
 (load "emacs-lisp/cconv")
-(when (and (byte-code-function-p (symbol-function 'cconv-fv))
-           (byte-code-function-p (symbol-function 'macroexpand-all)))
-  (setq internal-filter-closure-env-function #'cconv-fv))
+(when (and (compiled-function-p (symbol-function 'cconv-fv))
+           (compiled-function-p (symbol-function 'macroexpand-all)))
+  (setq internal-make-interpreted-closure-function
+        #'cconv-make-interpreted-closure))
 (load "cus-start") ;Late to reduce customize-rogue (needs loaddefs.el anyway)
 (if (not (eq system-type 'ms-dos))
     (load "tooltip"))
diff --git a/src/eval.c b/src/eval.c
index d2cab006d1..2928a45ac1 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -550,15 +550,12 @@ usage: (function ARG)  */)
          CHECK_STRING (docstring);
          cdr = Fcons (XCAR (cdr), Fcons (docstring, XCDR (XCDR (cdr))));
        }
-      Lisp_Object env
-        = NILP (Vinternal_filter_closure_env_function)
-          ? Vinternal_interpreter_environment
-          /* FIXME: This macroexpands the body, so we should use the resulting
-             macroexpanded code!  */
-          : call2 (Vinternal_filter_closure_env_function,
-                   Fcons (Qprogn, CONSP (cdr) ? XCDR (cdr) : cdr),
-                   Vinternal_interpreter_environment);
-      return Fcons (Qclosure, Fcons (env, cdr));
+      if (NILP (Vinternal_make_interpreted_closure_function))
+        return Fcons (Qclosure, Fcons (Vinternal_interpreter_environment, 
cdr));
+      else
+        return call2 (Vinternal_make_interpreted_closure_function,
+                      Fcons (Qlambda, cdr),
+                      Vinternal_interpreter_environment);
     }
   else
     /* Simply quote the argument.  */
@@ -4361,10 +4358,10 @@ alist of active lexical bindings.  */);
      (Just imagine if someone makes it buffer-local).  */
   Funintern (Qinternal_interpreter_environment, Qnil);
 
-  DEFVAR_LISP ("internal-filter-closure-env-function",
-              Vinternal_filter_closure_env_function,
+  DEFVAR_LISP ("internal-make-interpreted-closure-function",
+              Vinternal_make_interpreted_closure_function,
               doc: /* Function to filter the env when constructing a closure.  
*/);
-  Vinternal_filter_closure_env_function = Qnil;
+  Vinternal_make_interpreted_closure_function = Qnil;
 
   Vrun_hooks = intern_c_string ("run-hooks");
   staticpro (&Vrun_hooks);
diff --git a/test/lisp/emacs-lisp/cconv-tests.el 
b/test/lisp/emacs-lisp/cconv-tests.el
index 37470f863f..e666fe0a4c 100644
--- a/test/lisp/emacs-lisp/cconv-tests.el
+++ b/test/lisp/emacs-lisp/cconv-tests.el
@@ -351,11 +351,18 @@
   (let ((f (let ((d 51695))
              (lambda (data)
                (interactive (progn (setq d (1+ d)) (list d)))
-               (list (called-interactively-p 'any) data)))))
-    (should (equal (list (call-interactively f)
-                         (funcall f 51695)
-                         (call-interactively f))
-                   '((t 51696) (nil 51695) (t 51697))))))
+               (list (called-interactively-p 'any) data))))
+        (f-interp
+         (eval '(let ((d 51695))
+                  (lambda (data)
+                    (interactive (progn (setq d (1+ d)) (list d)))
+                    (list (called-interactively-p 'any) data)))
+               t)))
+    (dolist (f (list f f-interp))
+      (should (equal (list (call-interactively f)
+                           (funcall f 51695)
+                           (call-interactively f))
+                     '((t 51696) (nil 51695) (t 51697)))))))
 
 (provide 'cconv-tests)
 ;;; cconv-tests.el ends here