mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-15 10:30:25 -08:00
Code Issues Projects Releases Wiki Activity

Don't modify interactive closures destructively (Bug#60974).

Browse source 
* lisp/emacs-lisp/cconv.el (cconv-convert): When form is an
interactive lambda form, don't destructively modify it, as it might be
a constant literal. Instead, create a new list with the relevant
place(s) changed.

* test/lisp/emacs-lisp/cconv-tests.el
(cconv-tests-interactive-form-modify-bug60974): New test.
This commit is contained in:
Vibhav Pant 2023-03-01 15:04:34 +05:30
parent 186643ea8a
commit 1e5393a57a
No known key found for this signature in database
GPG key ID: E3FB28CB6AB59598
2 changed files with 39 additions and 10 deletions
Download patch file Download diff file Expand all files Collapse all files

37
lisp/emacs-lisp/cconv.el
View file

@ -477,7 +477,7 @@ places where they originally did not directly appear."
branch)) branch))
cond-forms))) cond-forms)))
(`(function (lambda ,args . ,body) . ,_) (`(function (lambda ,args . ,body) . ,rest)
(let* ((docstring (if (eq :documentation (car-safe (car body))) (let* ((docstring (if (eq :documentation (car-safe (car body)))
(cconv-convert (cadr (pop body)) env extend))) (cconv-convert (cadr (pop body)) env extend)))
(bf (if (stringp (car body)) (cdr body) body)) (bf (if (stringp (car body)) (cdr body) body))
@ -485,15 +485,32 @@ places where they originally did not directly appear."
(gethash form cconv--interactive-form-funs))) (gethash form cconv--interactive-form-funs)))
(wrapped (pcase if (`#'(lambda (&rest _cconv--dummy) .,_) t) (_ nil))) (wrapped (pcase if (`#'(lambda (&rest _cconv--dummy) .,_) t) (_ nil)))
(cif (when if (cconv-convert if env extend))) (cif (when if (cconv-convert if env extend)))
(_ (pcase cif (cf nil))
('nil nil) ;; TODO: Because we need to non-destructively modify body, this code
(`#',f ;; is particularly ugly. This should ideally be moved to
(setf (cadr (car bf)) (if wrapped (nth 2 f) cif)) ;; cconv--convert-function.
(setq cif nil)) (pcase cif
;; The interactive form needs special treatment, so the form ('nil (setq bf nil))
;; inside the `interactive' won't be used any further. (`#',f
(_ (setf (cadr (car bf)) nil)))) (pcase-let ((`((,f1 . (,_ . ,f2)) . ,f3) bf))
(cf (cconv--convert-function args body env form docstring))) (setq bf `((,f1 . (,(if wrapped (nth 2 f) cif) . ,f2)) . ,f3)))
(setq cif nil))
;; The interactive form needs special treatment, so the form
;; inside the `interactive' won't be used any further.
(_ (pcase-let ((`((,f1 . (,_ . ,f2)) . ,f3) bf))
(setq bf `((,f1 . (nil . ,f2)) . ,f3)))))
(when bf
;; If we modified bf, re-build body and form as
;; copies with the modified bits.
(setq body (if (stringp (car body))
(cons (car body) bf)
bf)
form `(function (lambda ,args . ,body) . ,rest))
;; Also, remove the current old entry on the alist, replacing
;; it with the new one.
(let ((entry (pop cconv-freevars-alist)))
(push (cons body (cdr entry)) cconv-freevars-alist)))
(setq cf (cconv--convert-function args body env form docstring))
(if (not cif) (if (not cif)
;; Normal case, the interactive form needs no special treatment. ;; Normal case, the interactive form needs no special treatment.
cf cf

12
test/lisp/emacs-lisp/cconv-tests.el
View file

@ -376,6 +376,18 @@
(eval '(lambda (x) :closure-dont-trim-context (+ x 1)) (eval '(lambda (x) :closure-dont-trim-context (+ x 1))
`((y . ,magic-string))))))) `((y . ,magic-string)))))))
(ert-deftest cconv-tests-interactive-form-modify-bug60974 ()
(let* ((f '(function (lambda (&optional arg)
(interactive
(list (if current-prefix-arg
(prefix-numeric-value current-prefix-arg)
'toggle)))
(ignore arg))))
(if (cadr (nth 2 (cadr f))))
(if2))
(cconv-closure-convert f)
(setq if2 (cadr (nth 2 (cadr f))))
(should (eq if if2))))
(provide 'cconv-tests) (provide 'cconv-tests)
;;; cconv-tests.el ends here ;;; cconv-tests.el ends here