bug#27016: possible bug in `defsetf'

[npostavs]

Stefan Monnier <monnier@IRO.UMontreal.CA> writes:

> I don't know what to do when a macro calls it (I can't think of any
> reason we'd want to do that), but I know how to handle the case where
> a macro outputs code that uses it: Add (byte-defop-compiler-1
> function-put) as well as a byte-compile-function-put function.
> See byte-compile-autoload and byte-compile-make-obsolete-variable
> for examples.

Oh, I think I get it now.

>From 565dd64e74b78f56982bd7ca92f34ab71e6d669a Mon Sep 17 00:00:00 2001
From: Noam Postavsky <npostavs@gmail.com>
Date: Thu, 13 Jul 2017 00:40:35 -0400
Subject: [PATCH v3 1/2] Let `function-put' affect compilation of the current
 file

* lisp/emacs-lisp/bytecomp.el (byte-compile-plist-environment): New
variable.
(byte-compile-close-variables): Let-bind it to nil.
(byte-compile-function-put): New byte-defop-compiler.
* lisp/subr.el (function-get): Consult
`byte-compile-plist-environment'.
---
 lisp/emacs-lisp/bytecomp.el | 18 ++++++++++++++++++
 lisp/subr.el                |  7 ++++++-
 2 files changed, 24 insertions(+), 1 deletion(-)

diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index e5b9b47b1d..028efbce26 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -498,6 +498,10 @@ (defvar byte-compile-macro-environment 
byte-compile-initial-macro-environment
 Each element looks like (MACRONAME . DEFINITION).  It is
 \(MACRONAME . nil) when a macro is redefined as a function.")
 
+(defvar byte-compile-plist-environment nil
+  "Alist of property lists defined in the file being compiled.
+Each element looks like (SYMBOL . PLIST).")
+
 (defvar byte-compile-function-environment nil
   "Alist of functions defined in the file being compiled.
 This is so we can inline them when necessary.
@@ -1585,6 +1589,7 @@ (defmacro byte-compile-close-variables (&rest body)
           ;; macroenvironment.
           (copy-alist byte-compile-initial-macro-environment))
          (byte-compile--outbuffer nil)
+         (byte-compile-plist-environment nil)
          (byte-compile-function-environment nil)
          (byte-compile-bound-variables nil)
          (byte-compile-lexical-variables nil)
@@ -4577,6 +4582,7 @@ (byte-defop-compiler-1 defvar)
 (byte-defop-compiler-1 defconst byte-compile-defvar)
 (byte-defop-compiler-1 autoload)
 (byte-defop-compiler-1 lambda byte-compile-lambda-form)
+(byte-defop-compiler-1 function-put)
 
 ;; If foo.el declares `toto' as obsolete, it is likely that foo.el will
 ;; actually use `toto' in order for this obsolete variable to still work
@@ -4725,6 +4731,18 @@ (put 'make-variable-buffer-local
      'byte-hunk-handler 'byte-compile-form-make-variable-buffer-local)
 (defun byte-compile-form-make-variable-buffer-local (form)
   (byte-compile-keep-pending form 'byte-compile-normal-call))
+
+(defun byte-compile-function-put (form)
+  (pcase form
+    (`(,_ (,(or 'quote 'function) ,(and fun (guard (symbolp fun))))
+          ',prop ,(or `#',value (and value (guard (functionp value)))))
+     (let ((fplist (assq fun byte-compile-plist-environment)))
+       (if fplist
+           (setcdr fplist (plist-put (cdr fplist) prop value))
+         (push (cons fun (list prop value))
+               byte-compile-plist-environment)))))
+  (byte-compile-normal-call form))
+
 
 ;;; tags
 
diff --git a/lisp/subr.el b/lisp/subr.el
index 42b4e1c211..3e4a3dedf5 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -2971,7 +2971,12 @@ (defun function-get (f prop &optional autoload)
 if it's an autoloaded macro."
   (let ((val nil))
     (while (and (symbolp f)
-                (null (setq val (get f prop)))
+                (null (setq val (or (plist-get
+                                     (alist-get
+                                      f (bound-and-true-p
+                                         byte-compile-plist-environment))
+                                     prop)
+                                    (get f prop))))
                 (fboundp f))
       (let ((fundef (symbol-function f)))
         (if (and autoload (autoloadp fundef)
-- 
2.11.1

>From bb2165c72cc7fa436ab911ab756cacec6384927d Mon Sep 17 00:00:00 2001
From: Noam Postavsky <npostavs@gmail.com>
Date: Thu, 13 Jul 2017 00:42:38 -0400
Subject: [PATCH v3 2/2] Don't define gv expanders in compiler's runtime
 (Bug#27016)

This prevents definitions being compiled from leaking into the current
Emacs doing the compilation.
* lisp/emacs-lisp/gv.el (gv-define-expander): Use function-put instead
of `put' with `eval-and-compile'.
* test/lisp/emacs-lisp/gv-tests.el: New tests.
---
 lisp/emacs-lisp/gv.el            |   7 +--
 test/lisp/emacs-lisp/gv-tests.el | 103 +++++++++++++++++++++++++++++++++++++++
 2 files changed, 104 insertions(+), 6 deletions(-)
 create mode 100644 test/lisp/emacs-lisp/gv-tests.el

diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el
index c5c12a6414..54105f89af 100644
--- a/lisp/emacs-lisp/gv.el
+++ b/lisp/emacs-lisp/gv.el
@@ -146,12 +146,7 @@ (defmacro gv-define-expander (name handler)
 HANDLER is a function which takes an argument DO followed by the same
 arguments as NAME.  DO is a function as defined in `gv-get'."
   (declare (indent 1) (debug (sexp form)))
-  ;; Use eval-and-compile so the method can be used in the same file as it
-  ;; is defined.
-  ;; FIXME: Just like byte-compile-macro-environment, we should have something
-  ;; like byte-compile-symbolprop-environment so as to handle these things
-  ;; cleanly without affecting the running Emacs.
-  `(eval-and-compile (put ',name 'gv-expander ,handler)))
+  `(function-put ',name 'gv-expander ,handler))
 
 ;;;###autoload
 (defun gv--defun-declaration (symbol name args handler &optional fix)
diff --git a/test/lisp/emacs-lisp/gv-tests.el b/test/lisp/emacs-lisp/gv-tests.el
new file mode 100644
index 0000000000..affc7ce455
--- /dev/null
+++ b/test/lisp/emacs-lisp/gv-tests.el
@@ -0,0 +1,103 @@
+;;; gv-tests.el --- tests for gv.el  -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2017 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert)
+(eval-when-compile (require 'cl-lib))
+
+(cl-defmacro gv-tests--in-temp-dir ((elvar elcvar)
+                                    (&rest filebody)
+                                    &rest body)
+  (declare (indent 2))
+  `(let ((default-directory (make-temp-file "gv-test" t)))
+     (unwind-protect
+         (let ((,elvar "gv-test-deffoo.el")
+               (,elcvar "gv-test-deffoo.elc"))
+           (with-temp-file ,elvar
+             (insert ";; -*- lexical-binding: t; -*-\n")
+             (dolist (form ',filebody)
+               (pp form (current-buffer))))
+           ,@body)
+       (delete-directory default-directory t))))
+
+(ert-deftest gv-define-expander-in-file ()
+  (gv-tests--in-temp-dir (el elc)
+      ((gv-define-setter gv-test-foo (newval cons)
+         `(setcar ,cons ,newval))
+       (defvar gv-test-pair (cons 1 2))
+       (setf (gv-test-foo gv-test-pair) 99)
+       (message "%d" (car gv-test-pair)))
+    (with-temp-buffer
+      (call-process (concat invocation-directory invocation-name)
+                    nil '(t t) nil
+                    "-Q" "-batch" "--eval" (prin1-to-string 
`(byte-compile-file ,el))
+                    "-l" elc)
+      (should (equal (buffer-string) "99\n")))))
+
+(ert-deftest gv-dont-define-expander-in-file ()
+  ;; The expander is defined while we are compiling the file, even
+  ;; though it's inside (when nil ...).
+  :expected-result :failed
+  (gv-tests--in-temp-dir (el elc)
+      ((when nil (gv-define-setter gv-test-foo (newval cons)
+                   `(setcar ,cons ,newval)))
+       (defvar gv-test-pair (cons 1 2))
+       (setf (gv-test-foo gv-test-pair) 99)
+       (message "%d" (car gv-test-pair)))
+    (with-temp-buffer
+      (call-process (concat invocation-directory invocation-name)
+                    nil '(t t) nil
+                    "-Q" "-batch" "--eval" (prin1-to-string 
`(byte-compile-file ,el))
+                    "-l" elc)
+      (should (equal (buffer-string)
+                     "Symbol's function definition is void: \\(setf\\ 
gv-test-foo\\)\n")))))
+
+(ert-deftest gv-define-expander-out-of-file ()
+  (gv-tests--in-temp-dir (el elc)
+      ((gv-define-setter gv-test-foo (newval cons)
+         `(setcar ,cons ,newval))
+       (defvar gv-test-pair (cons 1 2)))
+    (with-temp-buffer
+      (call-process (concat invocation-directory invocation-name)
+                    nil '(t t) nil
+                    "-Q" "-batch" "--eval" (prin1-to-string 
`(byte-compile-file ,el))
+                    "-l" elc
+                    "--eval"
+                    (prin1-to-string '(progn (setf (gv-test-foo gv-test-pair) 
99)
+                                             (message "%d" (car 
gv-test-pair)))))
+      (should (equal (buffer-string) "99\n")))))
+
+(ert-deftest gv-dont-define-expander-other-file ()
+  (gv-tests--in-temp-dir (el elc)
+      ((if nil (gv-define-setter gv-test-foo (newval cons)
+                 `(setcar ,cons ,newval)))
+       (defvar gv-test-pair (cons 1 2)))
+    (with-temp-buffer
+      (call-process (concat invocation-directory invocation-name)
+                    nil '(t t) nil
+                    "-Q" "-batch" "--eval" (prin1-to-string 
`(byte-compile-file ,el))
+                    "-l" elc
+                    "--eval"
+                    (prin1-to-string '(progn (setf (gv-test-foo gv-test-pair) 
99)
+                                             (message "%d" (car 
gv-test-pair)))))
+      (should (equal (buffer-string)
+                     "Symbol's function definition is void: \\(setf\\ 
gv-test-foo\\)\n")))))
+
+;;; gv-tests.el ends here
-- 
2.11.1