Commit cc30d77e authored by Stefan Monnier's avatar Stefan Monnier Committed by Noam Postavsky
Browse files

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: default avatarNoam Postavsky <npostavs@gmail.com>
parent 00f7e311
......@@ -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
......
......@@ -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;
......
......@@ -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:
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment