aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--lisp/emacs-lisp/cconv.el37
-rw-r--r--test/lisp/emacs-lisp/cconv-tests.el12
2 files changed, 39 insertions, 10 deletions
diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el
index ad9d8ab0a51..601e2c13d61 100644
--- a/lisp/emacs-lisp/cconv.el
+++ b/lisp/emacs-lisp/cconv.el
@@ -477,7 +477,7 @@ places where they originally did not directly appear."
477 branch)) 477 branch))
478 cond-forms))) 478 cond-forms)))
479 479
480 (`(function (lambda ,args . ,body) . ,_) 480 (`(function (lambda ,args . ,body) . ,rest)
481 (let* ((docstring (if (eq :documentation (car-safe (car body))) 481 (let* ((docstring (if (eq :documentation (car-safe (car body)))
482 (cconv-convert (cadr (pop body)) env extend))) 482 (cconv-convert (cadr (pop body)) env extend)))
483 (bf (if (stringp (car body)) (cdr body) body)) 483 (bf (if (stringp (car body)) (cdr body) body))
@@ -485,15 +485,32 @@ places where they originally did not directly appear."
485 (gethash form cconv--interactive-form-funs))) 485 (gethash form cconv--interactive-form-funs)))
486 (wrapped (pcase if (`#'(lambda (&rest _cconv--dummy) .,_) t) (_ nil))) 486 (wrapped (pcase if (`#'(lambda (&rest _cconv--dummy) .,_) t) (_ nil)))
487 (cif (when if (cconv-convert if env extend))) 487 (cif (when if (cconv-convert if env extend)))
488 (_ (pcase cif 488 (cf nil))
489 ('nil nil) 489 ;; TODO: Because we need to non-destructively modify body, this code
490 (`#',f 490 ;; is particularly ugly. This should ideally be moved to
491 (setf (cadr (car bf)) (if wrapped (nth 2 f) cif)) 491 ;; cconv--convert-function.
492 (setq cif nil)) 492 (pcase cif
493 ;; The interactive form needs special treatment, so the form 493 ('nil (setq bf nil))
494 ;; inside the `interactive' won't be used any further. 494 (`#',f
495 (_ (setf (cadr (car bf)) nil)))) 495 (pcase-let ((`((,f1 . (,_ . ,f2)) . ,f3) bf))
496 (cf (cconv--convert-function args body env form docstring))) 496 (setq bf `((,f1 . (,(if wrapped (nth 2 f) cif) . ,f2)) . ,f3)))
497 (setq cif nil))
498 ;; The interactive form needs special treatment, so the form
499 ;; inside the `interactive' won't be used any further.
500 (_ (pcase-let ((`((,f1 . (,_ . ,f2)) . ,f3) bf))
501 (setq bf `((,f1 . (nil . ,f2)) . ,f3)))))
502 (when bf
503 ;; If we modified bf, re-build body and form as
504 ;; copies with the modified bits.
505 (setq body (if (stringp (car body))
506 (cons (car body) bf)
507 bf)
508 form `(function (lambda ,args . ,body) . ,rest))
509 ;; Also, remove the current old entry on the alist, replacing
510 ;; it with the new one.
511 (let ((entry (pop cconv-freevars-alist)))
512 (push (cons body (cdr entry)) cconv-freevars-alist)))
513 (setq cf (cconv--convert-function args body env form docstring))
497 (if (not cif) 514 (if (not cif)
498 ;; Normal case, the interactive form needs no special treatment. 515 ;; Normal case, the interactive form needs no special treatment.
499 cf 516 cf
diff --git a/test/lisp/emacs-lisp/cconv-tests.el b/test/lisp/emacs-lisp/cconv-tests.el
index 349ffeb7e47..6facd3452ea 100644
--- a/test/lisp/emacs-lisp/cconv-tests.el
+++ b/test/lisp/emacs-lisp/cconv-tests.el
@@ -376,6 +376,18 @@
376 (eval '(lambda (x) :closure-dont-trim-context (+ x 1)) 376 (eval '(lambda (x) :closure-dont-trim-context (+ x 1))
377 `((y . ,magic-string))))))) 377 `((y . ,magic-string)))))))
378 378
379(ert-deftest cconv-tests-interactive-form-modify-bug60974 ()
380 (let* ((f '(function (lambda (&optional arg)
381 (interactive
382 (list (if current-prefix-arg
383 (prefix-numeric-value current-prefix-arg)
384 'toggle)))
385 (ignore arg))))
386 (if (cadr (nth 2 (cadr f))))
387 (if2))
388 (cconv-closure-convert f)
389 (setq if2 (cadr (nth 2 (cadr f))))
390 (should (eq if if2))))
379 391
380(provide 'cconv-tests) 392(provide 'cconv-tests)
381;;; cconv-tests.el ends here 393;;; cconv-tests.el ends here