Let `define-symbol-prop' take effect during compilation

* src/fns.c (syms_of_fns): New variable `overriding-plist-environment'.
(Fget): Consult it.
* lisp/emacs-lisp/bytecomp.el (byte-compile-close-variables): Let-bind
it to nil.
(byte-compile-define-symbol-prop): New function, handles compilation
of top-level `define-symbol-prop' and `function-put' calls by putting
the symbol setting into `overriding-plist-environment'.

Co-authored-by: Noam Postavsky <npostavs@gmail.com>

lisp/emacs-lisp/bytecomp.el

@@ -1572,6 +1572,7 @@ extra args."
           ;; macroenvironment.
           (copy-alist byte-compile-initial-macro-environment))
          (byte-compile--outbuffer nil)
+         (overriding-plist-environment nil)
          (byte-compile-function-environment nil)
          (byte-compile-bound-variables nil)
          (byte-compile-lexical-variables nil)
@@ -4714,6 +4715,34 @@ binding slots have been popped."
      '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))
+
+(put 'function-put 'byte-hunk-handler 'byte-compile-define-symbol-prop)
+(put 'define-symbol-prop 'byte-hunk-handler 'byte-compile-define-symbol-prop)
+(defun byte-compile-define-symbol-prop (form)
+  (pcase form
+    ((and `(,op ,fun ,prop ,val)
+          (guard (and (macroexp-const-p fun)
+                      (macroexp-const-p prop)
+                      (or (macroexp-const-p val)
+                          ;; Also accept anonymous functions, since
+                          ;; we're at top-level which implies they're
+                          ;; also constants.
+                          (pcase val (`(function (lambda . ,_)) t))))))
+     (byte-compile-push-constant op)
+     (byte-compile-form fun)
+     (byte-compile-form prop)
+     (let* ((fun (eval fun))
+            (prop (eval prop))
+            (val (if (macroexp-const-p val)
+                     (eval val)
+                   (byte-compile-lambda (cadr val)))))
+       (push `(,fun
+               . (,prop ,val ,@(alist-get fun overriding-plist-environment)))
+             overriding-plist-environment)
+       (byte-compile-push-constant val)
+       (byte-compile-out 'byte-call 3)))
+
+    (_ (byte-compile-keep-pending form))))
 
 ;;; tags
 

src/fns.c

@@ -1987,6 +1987,10 @@ This is the last value stored with `(put SYMBOL PROPNAME VALUE)'.  */)
   (Lisp_Object symbol, Lisp_Object propname)
 {
   CHECK_SYMBOL (symbol);
+  Lisp_Object propval = Fplist_get (CDR (Fassq (symbol, Voverriding_plist_environment)),
+                                    propname);
+  if (!NILP (propval))
+    return propval;
   return Fplist_get (XSYMBOL (symbol)->plist, propname);
 }
 
@@ -5163,6 +5167,13 @@ syms_of_fns (void)
   DEFSYM (Qcursor_in_echo_area, "cursor-in-echo-area");
   DEFSYM (Qwidget_type, "widget-type");
 
+  DEFVAR_LISP ("overriding-plist-environment", Voverriding_plist_environment,
+               doc: /* An alist overrides the plists of the symbols which it lists.
+Used by the byte-compiler to apply `define-symbol-prop' during
+compilation.  */);
+  Voverriding_plist_environment = Qnil;
+  DEFSYM (Qoverriding_plist_environment, "overriding-plist-environment");
+
   staticpro (&string_char_byte_cache_string);
   string_char_byte_cache_string = Qnil;
 

test/lisp/emacs-lisp/bytecomp-tests.el

@@ -545,6 +545,23 @@ literals (Bug#20852)."
 This functionality has been obsolete for more than 10 years already
 and will be removed soon.  See (elisp)Backquote in the manual.")))))))
 
+
+(ert-deftest bytecomp-tests-function-put ()
+  "Check `function-put' operates during compilation."
+  (should (boundp 'lread--old-style-backquotes))
+  (bytecomp-tests--with-temp-file source
+    (dolist (form '((function-put 'bytecomp-tests--foo 'foo 1)
+                    (function-put 'bytecomp-tests--foo 'bar 2)
+                    (defmacro bytecomp-tests--foobar ()
+                      `(cons ,(function-get 'bytecomp-tests--foo 'foo)
+                             ,(function-get 'bytecomp-tests--foo 'bar)))
+                    (defvar bytecomp-tests--foobar 1)
+                    (setq bytecomp-tests--foobar (bytecomp-tests--foobar))))
+      (print form (current-buffer)))
+    (write-region (point-min) (point-max) source nil 'silent)
+    (byte-compile-file source t)
+    (should (equal bytecomp-tests--foobar (cons 1 2)))))
+
 ;; Local Variables:
 ;; no-byte-compile: t
 ;; End: