master c244d4af57: cconv.el: Fix interactive closure bug#51695

[Stefan Monnier]

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

    cconv.el: Fix interactive closure bug#51695
    
    Make cconv.el detect when a closure's interactive form needs to
    capture variables from the context and tweak the code accordingly
    if so.
    
    * lisp/emacs-lisp/cconv.el (cconv--interactive-form-funs): New var.
    (cconv-convert): Handle the case where the interactive form captures
    vars from the surrounding context.  Remove left over handling of
    `declare` which was already removed from the cconv-analyze` phase.
    (cconv-analyze-form): Adjust analysis of interactive forms accordingly.
    
    * lisp/emacs-lisp/oclosure.el (cconv--interactive-helper): New type and
    function.
    * lisp/simple.el (function-documentation, oclosure-interactive-form):
    Add methods for it.
    
    * test/lisp/emacs-lisp/cconv-tests.el
    (cconv-tests-interactive-closure-bug51695): New test.
---
 lisp/emacs-lisp/cconv.el            | 51 ++++++++++++++++++++++++++-----------
 lisp/emacs-lisp/oclosure.el         | 15 +++++++++++
 lisp/simple.el                      |  6 +++++
 test/lisp/emacs-lisp/cconv-tests.el | 10 ++++++++
 4 files changed, 67 insertions(+), 15 deletions(-)

diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el
index 7f95fa94fa..23d0f12194 100644
--- a/lisp/emacs-lisp/cconv.el
+++ b/lisp/emacs-lisp/cconv.el
@@ -137,6 +137,11 @@ is less than this number.")
   ;; Alist associating to each function body the list of its free variables.
   )
 
+(defvar cconv--interactive-form-funs
+  ;; Table used to hold the functions we create internally for
+  ;; interactive forms.
+  (make-hash-table :test #'eq :weakness 'key))
+
 ;;;###autoload
 (defun cconv-closure-convert (form)
   "Main entry point for closure conversion.
@@ -503,9 +508,23 @@ places where they originally did not directly appear."
                               cond-forms)))
 
     (`(function (lambda ,args . ,body) . ,_)
-     (let ((docstring (if (eq :documentation (car-safe (car body)))
-                          (cconv-convert (cadr (pop body)) env extend))))
-       (cconv--convert-function args body env form docstring)))
+     (let* ((docstring (if (eq :documentation (car-safe (car body)))
+                           (cconv-convert (cadr (pop body)) env extend)))
+            (bf (if (stringp (car body)) (cdr body) body))
+            (if (when (eq 'interactive (car-safe (car bf)))
+                  (gethash form cconv--interactive-form-funs)))
+            (cif (when if (cconv-convert if env extend)))
+            (_ (pcase cif
+                 (`#'(lambda () ,form) (setf (cadr (car bf)) form) (setq cif 
nil))
+                 ('nil nil)
+                 ;; The interactive form needs special treatment, so the form
+                 ;; inside the `interactive' won't be used any further.
+                 (_ (setf (cadr (car bf)) nil))))
+            (cf (cconv--convert-function args body env form docstring)))
+       (if (not cif)
+           ;; Normal case, the interactive form needs no special treatment.
+           cf
+         `(cconv--interactive-helper ,cf ,cif))))
 
     (`(internal-make-closure . ,_)
      (byte-compile-report-error
@@ -589,12 +608,12 @@ places where they originally did not directly appear."
                                    (cconv-convert arg env extend))
                                  (cons fun args)))))))
 
-    (`(interactive . ,forms)
-     `(,(car form) . ,(mapcar (lambda (form)
-                                (cconv-convert form nil nil))
-                              forms)))
+    ;; The form (if any) is converted beforehand as part of the `lambda' case.
+    (`(interactive . ,_) form)
 
-    (`(declare . ,_) form)              ;The args don't contain code.
+    ;; `declare' should now be macro-expanded away (and if they're not, we're
+    ;; in trouble because they *can* contain code nowadays).
+    ;; (`(declare . ,_) form)              ;The args don't contain code.
 
     (`(oclosure--fix-type (ignore . ,vars) ,exp)
      (dolist (var vars)
@@ -739,6 +758,13 @@ This function does not return anything but instead fills 
the
     (`(function (lambda ,vrs . ,body-forms))
      (when (eq :documentation (car-safe (car body-forms)))
        (cconv-analyze-form (cadr (pop body-forms)) env))
+     (let ((bf (if (stringp (car body-forms)) (cdr body-forms) body-forms)))
+       (when (eq 'interactive (car-safe (car bf)))
+         (let ((if (cadr (car bf))))
+           (unless (macroexp-const-p if) ;Optimize this common case.
+             (let ((f `#'(lambda () ,if)))
+               (setf (gethash form cconv--interactive-form-funs) f)
+               (cconv-analyze-form f env))))))
      (cconv--analyze-function vrs body-forms env form))
 
     (`(setq ,var ,expr)
@@ -803,13 +829,8 @@ This function does not return anything but instead fills 
the
          (cconv-analyze-form fun env)))
      (dolist (form args) (cconv-analyze-form form env)))
 
-    (`(interactive . ,forms)
-     ;; These appear within the function body but they don't have access
-     ;; to the function's arguments.
-     ;; We could extend this to allow interactive specs to refer to
-     ;; variables in the function's enclosing environment, but it doesn't
-     ;; seem worth the trouble.
-     (dolist (form forms) (cconv-analyze-form form nil)))
+    ;; The form (if any) is converted beforehand as part of the `lambda' case.
+    (`(interactive . ,_) nil)
 
     ;; `declare' should now be macro-expanded away (and if they're not, we're
     ;; in trouble because they *can* contain code nowadays).
diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el
index 9775e8cc65..c77ac151d7 100644
--- a/lisp/emacs-lisp/oclosure.el
+++ b/lisp/emacs-lisp/oclosure.el
@@ -557,6 +557,21 @@ This has 2 uses:
 (oclosure-define (save-some-buffers-function
                   (:predicate save-some-buffers-function--p)))
 
+;; This OClosure type is used internally by `cconv.el' to handle
+;; the case where we need to build a closure whose `interactive' spec
+;; captures variables from the context.
+;; It arguably belongs with `cconv.el' but is needed at runtime,
+;; so we placed it here.
+(oclosure-define (cconv--interactive-helper) fun if)
+(defun cconv--interactive-helper (fun if)
+  "Add interactive \"form\" IF to FUN.
+Returns a new command that otherwise behaves like FUN.
+IF should actually not be a form but a function of no arguments."
+  (oclosure-lambda (cconv--interactive-helper (fun fun) (if if))
+      (&rest args)
+    (apply (if (called-interactively-p 'any)
+               #'funcall-interactively #'funcall)
+           fun args)))
 
 (provide 'oclosure)
 ;;; oclosure.el ends here
diff --git a/lisp/simple.el b/lisp/simple.el
index aed1547b15..10a610e0c6 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -2653,6 +2653,9 @@ function as needed."
 (cl-defmethod function-documentation ((function accessor))
   (oclosure--accessor-docstring function)) ;; FIXME: η-reduce!
 
+(cl-defmethod function-documentation ((f cconv--interactive-helper))
+  (function-documentation (cconv--interactive-helper--fun f)))
+
 ;; This should be in `oclosure.el' but that file is loaded before `cl-generic'.
 (cl-defgeneric oclosure-interactive-form (_function)
   "Return the interactive form of FUNCTION or nil if none.
@@ -2664,6 +2667,9 @@ instead."
   ;; (interactive-form function)
   nil)
 
+(cl-defmethod oclosure-interactive-form ((f cconv--interactive-helper))
+  `(interactive (funcall ',(cconv--interactive-helper--if f))))
+
 (defun command-execute (cmd &optional record-flag keys special)
   ;; BEWARE: Called directly from the C code.
   "Execute CMD as an editor command.
diff --git a/test/lisp/emacs-lisp/cconv-tests.el 
b/test/lisp/emacs-lisp/cconv-tests.el
index 9904c6a969..37470f863f 100644
--- a/test/lisp/emacs-lisp/cconv-tests.el
+++ b/test/lisp/emacs-lisp/cconv-tests.el
@@ -347,5 +347,15 @@
                       (list x (funcall g closed-x) (funcall h closed-x))))))))
   )
 
+(ert-deftest cconv-tests-interactive-closure-bug51695 ()
+  (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))))))
+
 (provide 'cconv-tests)
 ;;; cconv-tests.el ends here