diff options
| -rw-r--r-- | lisp/emacs-lisp/cconv.el | 37 | ||||
| -rw-r--r-- | test/lisp/emacs-lisp/cconv-tests.el | 12 |
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 |