summaryrefslogtreecommitdiff
path: root/lisp/emacs-lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/emacs-lisp')
-rw-r--r--lisp/emacs-lisp/advice.el315
-rw-r--r--lisp/emacs-lisp/byte-opt.el34
-rw-r--r--lisp/emacs-lisp/bytecomp.el53
-rw-r--r--lisp/emacs-lisp/cl-extra.el2
-rw-r--r--lisp/emacs-lisp/cl-lib.el6
-rw-r--r--lisp/emacs-lisp/cl-loaddefs.el23
-rw-r--r--lisp/emacs-lisp/gv.el20
7 files changed, 228 insertions, 225 deletions
diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el
index e358c756712..8239522c0f8 100644
--- a/lisp/emacs-lisp/advice.el
+++ b/lisp/emacs-lisp/advice.el
@@ -1,4 +1,4 @@
-;;; advice.el --- An overloading mechanism for Emacs Lisp functions
+;;; advice.el --- An overloading mechanism for Emacs Lisp functions -*- lexical-binding: t -*-
;; Copyright (C) 1993-1994, 2000-2012 Free Software Foundation, Inc.
@@ -1796,15 +1796,6 @@ generates a copy of TREE."
`((put ',saved-function 'byte-opcode
',(get function 'byte-opcode))))))))
-(defun ad-save-real-definitions ()
- ;; Macro expansion will hardcode the values of the various byte-compiler
- ;; properties into the compiled version of this function such that the
- ;; proper values will be available at runtime without loading the compiler:
- (ad-save-real-definition fset)
- (ad-save-real-definition documentation))
-
-(ad-save-real-definitions)
-
;; @@ Advice info access fns:
;; ==========================
@@ -1840,15 +1831,13 @@ generates a copy of TREE."
ad-advised-functions)))
(defmacro ad-do-advised-functions (varform &rest body)
- "`dolist'-style iterator that maps over `ad-advised-functions'.
-\(ad-do-advised-functions (VAR [RESULT-FORM])
+ "`dolist'-style iterator that maps over advised functions.
+\(ad-do-advised-functions (VAR)
BODY-FORM...)
On each iteration VAR will be bound to the name of an advised function
\(a symbol)."
(declare (indent 1))
- `(cl-dolist (,(car varform)
- ad-advised-functions
- ,(car (cdr varform)))
+ `(cl-dolist (,(car varform) ad-advised-functions)
(setq ,(car varform) (intern (car ,(car varform))))
,@body))
@@ -1858,8 +1847,12 @@ On each iteration VAR will be bound to the name of an advised function
(defmacro ad-get-advice-info-macro (function)
`(get ,function 'ad-advice-info))
-(defmacro ad-set-advice-info (function advice-info)
- `(put ,function 'ad-advice-info ,advice-info))
+(defsubst ad-set-advice-info (function advice-info)
+ (cond
+ (advice-info (put function 'defalias-fset-function #'ad--defalias-fset))
+ ((get function 'defalias-fset-function)
+ (put function 'defalias-fset-function nil)))
+ (put function 'ad-advice-info advice-info))
(defmacro ad-copy-advice-info (function)
`(copy-tree (get ,function 'ad-advice-info)))
@@ -1867,7 +1860,7 @@ On each iteration VAR will be bound to the name of an advised function
(defmacro ad-is-advised (function)
"Return non-nil if FUNCTION has any advice info associated with it.
This does not mean that the advice is also active."
- (list 'ad-get-advice-info-macro function))
+ `(ad-get-advice-info-macro ,function))
(defun ad-initialize-advice-info (function)
"Initialize the advice info for FUNCTION.
@@ -1950,7 +1943,7 @@ Redefining advices affect the construction of an advised definition."
(defun ad-has-any-advice (function)
"True if the advice info of FUNCTION defines at least one advice."
(and (ad-is-advised function)
- (cl-dolist (class ad-advice-classes nil)
+ (cl-dolist (class ad-advice-classes)
(if (ad-get-advice-info-field function class)
(cl-return t)))))
@@ -1966,18 +1959,10 @@ Redefining advices affect the construction of an advised definition."
;; @@ Dealing with automatic advice activation via `fset/defalias':
;; ================================================================
-;; Since Emacs 19.26 the built-in versions of `fset' and `defalias'
-;; take care of automatic advice activation, hence, we don't have to
-;; hack it anymore by advising `fset/defun/defmacro/byte-code/etc'.
+;; Automatic activation happens when a function gets defined via `defalias',
+;; which calls the `defalias-fset-function' (which we set to
+;; `ad--defalias-fset') instead of `fset', if non-nil.
-;; The functionality of the new `fset' is as follows:
-;;
-;; fset(sym,newdef)
-;; assign NEWDEF to SYM
-;; if (get SYM 'ad-advice-info)
-;; ad-activate-internal(SYM, nil)
-;; return (symbol-function SYM)
-;;
;; Whether advised definitions created by automatic activations will be
;; compiled depends on the value of `ad-default-compilation-action'.
@@ -1989,13 +1974,17 @@ Redefining advices affect the construction of an advised definition."
;; to `ad-activate' by using `ad-with-auto-activation-disabled' where
;; appropriate, especially in a safe version of `fset'.
+(defun ad--defalias-fset (function definition)
+ (fset function definition)
+ (ad-activate-internal function nil))
+
;; For now define `ad-activate-internal' to the dummy definition:
-(defun ad-activate-internal (function &optional compile)
+(defun ad-activate-internal (_function &optional _compile)
"Automatic advice activation is disabled. `ad-start-advice' enables it."
nil)
;; This is just a copy of the above:
-(defun ad-activate-internal-off (function &optional compile)
+(defun ad-activate-internal-off (_function &optional _compile)
"Automatic advice activation is disabled. `ad-start-advice' enables it."
nil)
@@ -2006,12 +1995,6 @@ Redefining advices affect the construction of an advised definition."
`(let ((ad-activate-on-top-level nil))
,@body))
-(defun ad-safe-fset (symbol definition)
- "A safe `fset' which will never call `ad-activate-internal' recursively."
- (ad-with-auto-activation-disabled
- (ad-real-fset symbol definition)))
-
-
;; @@ Access functions for original definitions:
;; ============================================
;; The advice-info of an advised function contains its `origname' which is
@@ -2031,8 +2014,7 @@ Redefining advices affect the construction of an advised definition."
(symbol-function origname))))
(defmacro ad-set-orig-definition (function definition)
- `(ad-safe-fset
- (ad-get-advice-info-field ,function 'origname) ,definition))
+ `(fset (ad-get-advice-info-field ,function 'origname) ,definition))
(defmacro ad-clear-orig-definition (function)
`(fmakunbound (ad-get-advice-info-field ,function 'origname)))
@@ -2053,7 +2035,7 @@ function at point for which PREDICATE returns non-nil)."
(error "ad-read-advised-function: There are no advised functions"))
(setq default
(or default
- ;; Prefer func name at point, if it's in ad-advised-functions etc.
+ ;; Prefer func name at point, if it's an advised function etc.
(let ((function (progn
(require 'help)
(function-called-at-point))))
@@ -2062,24 +2044,20 @@ function at point for which PREDICATE returns non-nil)."
(or (null predicate)
(funcall predicate function))
function))
- (ad-do-advised-functions (function)
- (if (or (null predicate)
- (funcall predicate function))
- (cl-return function)))
+ (cl-block nil
+ (ad-do-advised-functions (function)
+ (if (or (null predicate)
+ (funcall predicate function))
+ (cl-return function))))
(error "ad-read-advised-function: %s"
"There are no qualifying advised functions")))
- (let* ((ad-pReDiCaTe predicate)
- (function
+ (let* ((function
(completing-read
(format "%s (default %s): " (or prompt "Function") default)
ad-advised-functions
(if predicate
- (function
- (lambda (function)
- ;; Oops, no closures - the joys of dynamic scoping:
- ;; `predicate' clashed with the `predicate' argument
- ;; of `completing-read'.....
- (funcall ad-pReDiCaTe (intern (car function))))))
+ (lambda (function)
+ (funcall predicate (intern (car function)))))
t)))
(if (equal function "")
(if (ad-is-advised default)
@@ -2377,10 +2355,8 @@ See Info node `(elisp)Computed Advice' for detailed documentation."
(cdr definition))
(t nil)))
-(defun ad-arglist (definition &optional name)
- "Return the argument list of DEFINITION.
-If DEFINITION could be from a subr then its NAME should be
-supplied to make subr arglist lookup more efficient."
+(defun ad-arglist (definition)
+ "Return the argument list of DEFINITION."
(require 'help-fns)
(help-function-arglist
(if (or (ad-macro-p definition) (ad-advice-p definition))
@@ -2392,7 +2368,7 @@ supplied to make subr arglist lookup more efficient."
"Return the unexpanded docstring of DEFINITION."
(let ((docstring
(if (ad-compiled-p definition)
- (ad-real-documentation definition t)
+ (documentation definition t)
(car (cdr (cdr (ad-lambda-expression definition)))))))
(if (or (stringp docstring)
(natnump docstring))
@@ -2415,13 +2391,15 @@ Like `interactive-form', but also works on pieces of advice."
(if (ad-interactive-form definition) 1 0))
(cdr (cdr (ad-lambda-expression definition)))))))
-(defun ad-make-advised-definition-docstring (function)
+(defun ad-make-advised-definition-docstring (_function)
"Make an identifying docstring for the advised definition of FUNCTION.
Put function name into the documentation string so we can infer
the name of the advised function from the docstring. This is needed
to generate a proper advised docstring even if we are just given a
definition (see the code for `documentation')."
- (propertize "Advice doc string" 'ad-advice-info function))
+ (eval-when-compile
+ (propertize "Advice doc string" 'dynamic-docstring-function
+ #'ad--make-advised-docstring)))
(defun ad-advised-definition-p (definition)
"Return non-nil if DEFINITION was generated from advice information."
@@ -2430,7 +2408,7 @@ definition (see the code for `documentation')."
(ad-compiled-p definition))
(let ((docstring (ad-docstring definition)))
(and (stringp docstring)
- (get-text-property 0 'ad-advice-info docstring)))))
+ (get-text-property 0 'dynamic-docstring-function docstring)))))
(defun ad-definition-type (definition)
"Return symbol that describes the type of DEFINITION."
@@ -2474,6 +2452,7 @@ For that it has to be fbound with a non-autoload definition."
(ad-macro-p (symbol-function function)))
(not (ad-compiled-p (symbol-function function)))))
+(defvar warning-suppress-types) ;From warnings.el.
(defun ad-compile-function (function)
"Byte-compiles FUNCTION (or macro) if it is not yet compiled."
(interactive "aByte-compile function: ")
@@ -2604,24 +2583,20 @@ The assignment starts at position INDEX."
(let ((values-index 0)
argument-access set-forms)
(while (setq argument-access (ad-access-argument arglist index))
- (if (symbolp argument-access)
- (setq set-forms
- (cons (ad-set-argument
- arglist index
- (ad-element-access values-index 'ad-vAlUeS))
- set-forms))
- (setq set-forms
- (cons (if (= (car argument-access) 0)
- (list 'setq
- (car (cdr argument-access))
- (ad-list-access values-index 'ad-vAlUeS))
- (list 'setcdr
- (ad-list-access (1- (car argument-access))
- (car (cdr argument-access)))
- (ad-list-access values-index 'ad-vAlUeS)))
- set-forms))
- ;; terminate loop
- (setq arglist nil))
+ (push (if (symbolp argument-access)
+ (ad-set-argument
+ arglist index
+ (ad-element-access values-index 'ad-vAlUeS))
+ (setq arglist nil) ;; Terminate loop.
+ (if (= (car argument-access) 0)
+ `(setq
+ ,(car (cdr argument-access))
+ ,(ad-list-access values-index 'ad-vAlUeS))
+ `(setcdr
+ ,(ad-list-access (1- (car argument-access))
+ (car (cdr argument-access)))
+ ,(ad-list-access values-index 'ad-vAlUeS))))
+ set-forms)
(setq index (1+ index))
(setq values-index (1+ values-index)))
(if (null set-forms)
@@ -2630,8 +2605,8 @@ The assignment starts at position INDEX."
(if (= (length set-forms) 1)
;; For exactly one set-form we can use values-form directly,...
(ad-substitute-tree
- (function (lambda (form) (eq form 'ad-vAlUeS)))
- (function (lambda (form) values-form))
+ (lambda (form) (eq form 'ad-vAlUeS))
+ (lambda (_form) values-form)
(car set-forms))
;; ...if we have more we have to bind it to a variable:
`(let ((ad-vAlUeS ,values-form))
@@ -2701,11 +2676,10 @@ Example: `(ad-map-arglists '(a &rest args) '(w x y z))' will return
(cond (need-apply
;; `apply' can take care of that directly:
(append source-reqopt-args (list source-rest-arg)))
- (t (mapcar (function
- (lambda (arg)
- (setq target-arg-index (1+ target-arg-index))
- (ad-get-argument
- source-arglist target-arg-index)))
+ (t (mapcar (lambda (_arg)
+ (setq target-arg-index (1+ target-arg-index))
+ (ad-get-argument
+ source-arglist target-arg-index))
(append target-reqopt-args
(and target-rest-arg
;; If we have a rest arg gobble up
@@ -2753,6 +2727,13 @@ Example: `(ad-map-arglists '(a &rest args) '(w x y z))' will return
(require 'help-fns) ;For help-split-fundoc and help-add-fundoc-usage.
(defun ad-make-advised-docstring (function &optional style)
+ (let* ((origdef (ad-real-orig-definition function))
+ (origdoc
+ ;; Retrieve raw doc, key substitution will be taken care of later:
+ (documentation origdef t)))
+ (ad--make-advised-docstring origdoc function style)))
+
+(defun ad--make-advised-docstring (origdoc function &optional style)
"Construct a documentation string for the advised FUNCTION.
It concatenates the original documentation with the documentation
strings of the individual pieces of advice which will be formatted
@@ -2762,11 +2743,8 @@ strings corresponds to before/around/after and the individual ordering
in any of these classes."
(let* ((origdef (ad-real-orig-definition function))
(origtype (symbol-name (ad-definition-type origdef)))
- (origdoc
- ;; Retrieve raw doc, key substitution will be taken care of later:
- (ad-real-documentation origdef t))
(usage (help-split-fundoc origdoc function))
- paragraphs advice-docstring ad-usage)
+ paragraphs advice-docstring)
(setq usage (if (null usage) t (setq origdoc (cdr usage)) (car usage)))
(if origdoc (setq paragraphs (list origdoc)))
(unless (eq style 'plain)
@@ -2781,7 +2759,9 @@ in any of these classes."
(propertize
;; separate paragraphs with blank lines:
(mapconcat 'identity (nreverse paragraphs) "\n\n")
- 'ad-advice-info function)))
+ ;; FIXME: what is this for?
+ 'dynamic-docstring-function
+ #'ad--make-advised-docstring)))
(help-add-fundoc-usage origdoc usage)))
(defun ad-make-plain-docstring (function)
@@ -2827,7 +2807,7 @@ in any of these classes."
(orig-special-form-p (ad-special-form-p origdef))
(orig-macro-p (ad-macro-p origdef))
;; Construct the individual pieces that we need for assembly:
- (orig-arglist (ad-arglist origdef function))
+ (orig-arglist (ad-arglist origdef))
(advised-arglist (or (ad-advised-arglist function)
orig-arglist))
(advised-interactive-form (ad-advised-interactive-form function))
@@ -2922,8 +2902,8 @@ should be modified. The assembled function will be returned."
(setq around-form-protected t))
(setq around-form
(ad-substitute-tree
- (function (lambda (form) (eq form 'ad-do-it)))
- (function (lambda (form) around-form))
+ (lambda (form) (eq form 'ad-do-it))
+ (lambda (_form) around-form)
(macroexp-progn (ad-body-forms (ad-advice-definition advice))))))
(setq after-forms
@@ -3058,10 +3038,10 @@ advised definition from scratch."
(mapcar (function (lambda (advice) (ad-advice-name advice)))
(ad-get-enabled-advices function 'after))
(ad-definition-type original-definition)
- (if (equal (ad-arglist original-definition function)
+ (if (equal (ad-arglist original-definition)
(ad-arglist cached-definition))
t
- (ad-arglist original-definition function))
+ (ad-arglist original-definition))
(if (eq (ad-definition-type original-definition) 'function)
(equal (interactive-form original-definition)
(interactive-form cached-definition))))))
@@ -3106,7 +3086,7 @@ advised definition from scratch."
(and (eq (nth 3 cache-id) (ad-definition-type original-definition))
(setq code 'arglist-mismatch)
(equal (if (eq (nth 4 cache-id) t)
- (ad-arglist original-definition function)
+ (ad-arglist original-definition)
(nth 4 cache-id) )
(ad-arglist cached-definition))
(setq code 'interactive-form-mismatch)
@@ -3165,7 +3145,7 @@ advised definition from scratch."
(ad-set-advice-info function old-advice-info)
;; Don't `fset' function to nil if it was previously unbound:
(if function-defined-p
- (ad-safe-fset function old-definition)
+ (fset function old-definition)
(fmakunbound function)))))
@@ -3196,61 +3176,54 @@ advised definition from scratch."
(error
"ad-make-freeze-definition: `%s' is not yet defined"
function))
- (let* ((name (ad-advice-name advice))
- ;; With a unique origname we can have multiple freeze advices
- ;; for the same function, each overloading the previous one:
- (unique-origname
- (intern (format "%s-%s-%s" (ad-make-origname function) class name)))
- (orig-definition
- ;; If FUNCTION is already advised, we'll use its current origdef
- ;; as the original definition of the frozen advice:
- (or (ad-get-orig-definition function)
- (symbol-function function)))
- (old-advice-info
- (if (ad-is-advised function)
- (ad-copy-advice-info function)))
- (real-docstring-fn
- (symbol-function 'ad-make-advised-definition-docstring))
- (real-origname-fn
- (symbol-function 'ad-make-origname))
- (frozen-definition
- (unwind-protect
- (progn
- ;; Make sure we construct a proper docstring:
- (ad-safe-fset 'ad-make-advised-definition-docstring
- 'ad-make-freeze-docstring)
- ;; Make sure `unique-origname' is used as the origname:
- (ad-safe-fset 'ad-make-origname (lambda (x) unique-origname))
- ;; No we reset all current advice information to nil and
- ;; generate an advised definition that's solely determined
- ;; by ADVICE and the current origdef of FUNCTION:
- (ad-set-advice-info function nil)
- (ad-add-advice function advice class position)
- ;; The following will provide proper real docstrings as
- ;; well as a definition that will make the compiler happy:
- (ad-set-orig-definition function orig-definition)
- (ad-make-advised-definition function))
- ;; Restore the old advice state:
- (ad-set-advice-info function old-advice-info)
- ;; Restore functions:
- (ad-safe-fset
- 'ad-make-advised-definition-docstring real-docstring-fn)
- (ad-safe-fset 'ad-make-origname real-origname-fn))))
+ (cl-letf*
+ ((name (ad-advice-name advice))
+ ;; With a unique origname we can have multiple freeze advices
+ ;; for the same function, each overloading the previous one:
+ (unique-origname
+ (intern (format "%s-%s-%s" (ad-make-origname function) class name)))
+ (orig-definition
+ ;; If FUNCTION is already advised, we'll use its current origdef
+ ;; as the original definition of the frozen advice:
+ (or (ad-get-orig-definition function)
+ (symbol-function function)))
+ (old-advice-info
+ (if (ad-is-advised function)
+ (ad-copy-advice-info function)))
+ ;; Make sure we construct a proper docstring:
+ ((symbol-function 'ad-make-advised-definition-docstring)
+ #'ad-make-freeze-docstring)
+ ;; Make sure `unique-origname' is used as the origname:
+ ((symbol-function 'ad-make-origname) (lambda (_x) unique-origname))
+ (frozen-definition
+ (unwind-protect
+ (progn
+ ;; No we reset all current advice information to nil and
+ ;; generate an advised definition that's solely determined
+ ;; by ADVICE and the current origdef of FUNCTION:
+ (ad-set-advice-info function nil)
+ (ad-add-advice function advice class position)
+ ;; The following will provide proper real docstrings as
+ ;; well as a definition that will make the compiler happy:
+ (ad-set-orig-definition function orig-definition)
+ (ad-make-advised-definition function))
+ ;; Restore the old advice state:
+ (ad-set-advice-info function old-advice-info))))
(if frozen-definition
(let* ((macro-p (ad-macro-p frozen-definition))
(body (cdr (if macro-p
(ad-lambdafy frozen-definition)
- frozen-definition))))
+ frozen-definition))))
`(progn
- (if (not (fboundp ',unique-origname))
- (fset ',unique-origname
- ;; avoid infinite recursion in case the function
- ;; we want to freeze is already advised:
- (or (ad-get-orig-definition ',function)
- (symbol-function ',function))))
- (,(if macro-p 'defmacro 'defun)
- ,function
- ,@body))))))
+ (if (not (fboundp ',unique-origname))
+ (fset ',unique-origname
+ ;; avoid infinite recursion in case the function
+ ;; we want to freeze is already advised:
+ (or (ad-get-orig-definition ',function)
+ (symbol-function ',function))))
+ (,(if macro-p 'defmacro 'defun)
+ ,function
+ ,@body))))))
;; @@ Activation and definition handling:
@@ -3283,7 +3256,7 @@ The current definition and its cache-id will be put into the cache."
(let ((verified-cached-definition
(if (ad-verify-cache-id function)
(ad-get-cache-definition function))))
- (ad-safe-fset function
+ (fset function
(or verified-cached-definition
(ad-make-advised-definition function)))
(if (ad-should-compile function compile)
@@ -3325,7 +3298,7 @@ the value of `ad-redefinition-action' and de/activate again."
(error "ad-handle-definition (see its doc): `%s' %s"
function "invalidly redefined")
(if (eq ad-redefinition-action 'discard)
- (ad-safe-fset function original-definition)
+ (fset function original-definition)
(ad-set-orig-definition function current-definition)
(if (eq ad-redefinition-action 'warn)
(message "ad-handle-definition: `%s' got redefined"
@@ -3400,7 +3373,7 @@ a call to `ad-activate'."
(if (not (ad-get-orig-definition function))
(error "ad-deactivate: `%s' has no original definition"
function)
- (ad-safe-fset function (ad-get-orig-definition function))
+ (fset function (ad-get-orig-definition function))
(ad-set-advice-info-field function 'active nil)
(eval (ad-make-hook-form function 'deactivation))
function)))))
@@ -3438,7 +3411,7 @@ Use in emergencies."
(completing-read "Recover advised function: " obarray nil t))))
(cond ((ad-is-advised function)
(cond ((ad-get-orig-definition function)
- (ad-safe-fset function (ad-get-orig-definition function))
+ (fset function (ad-get-orig-definition function))
(ad-clear-orig-definition function)))
(ad-set-advice-info function nil)
(ad-pop-advised-function function))))
@@ -3670,28 +3643,22 @@ undone on exit of this macro."
;; Make forms to redefine functions to their
;; original definitions if they are advised:
(setq index -1)
- (mapcar
- (function
- (lambda (function)
- (setq index (1+ index))
- `(ad-safe-fset
- ',function
- (or (ad-get-orig-definition ',function)
- ,(car (nth index current-bindings))))))
- functions))
+ (mapcar (lambda (function)
+ (setq index (1+ index))
+ `(fset ',function
+ (or (ad-get-orig-definition ',function)
+ ,(car (nth index current-bindings)))))
+ functions))
,@body)
,@(progn
;; Make forms to back-define functions to the definitions
;; they had outside this macro call:
(setq index -1)
- (mapcar
- (function
- (lambda (function)
- (setq index (1+ index))
- `(ad-safe-fset
- ',function
- ,(car (nth index current-bindings)))))
- functions))))))
+ (mapcar (lambda (function)
+ (setq index (1+ index))
+ `(fset ',function
+ ,(car (nth index current-bindings))))
+ functions))))))
;; @@ Starting, stopping and recovering from the advice package magic:
@@ -3702,7 +3669,7 @@ undone on exit of this macro."
(interactive)
;; Advising `ad-activate-internal' means death!!
(ad-set-advice-info 'ad-activate-internal nil)
- (ad-safe-fset 'ad-activate-internal 'ad-activate))
+ (fset 'ad-activate-internal 'ad-activate))
(defun ad-stop-advice ()
"Stop the automatic advice handling magic.
@@ -3710,7 +3677,7 @@ You should only need this in case of Advice-related emergencies."
(interactive)
;; Advising `ad-activate-internal' means death!!
(ad-set-advice-info 'ad-activate-internal nil)
- (ad-safe-fset 'ad-activate-internal 'ad-activate-internal-off))
+ (fset 'ad-activate-internal 'ad-activate-internal-off))
(defun ad-recover-normality ()
"Undo all advice related redefinitions and unadvises everything.
@@ -3718,9 +3685,11 @@ Use only in REAL emergencies."
(interactive)
;; Advising `ad-activate-internal' means death!!
(ad-set-advice-info 'ad-activate-internal nil)
- (ad-safe-fset 'ad-activate-internal 'ad-activate-internal-off)
+ (fset 'ad-activate-internal 'ad-activate-internal-off)
(ad-recover-all)
- (setq ad-advised-functions nil))
+ (ad-do-advised-functions (function)
+ (message "Oops! Left over advised function %S" function)
+ (ad-pop-advised-function function)))
(ad-start-advice)
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index a4c3e8aac4e..07e95e7e4cd 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -1187,8 +1187,8 @@
boundp buffer-file-name buffer-local-variables buffer-modified-p
buffer-substring byte-code-function-p
capitalize car-less-than-car car cdr ceiling char-after char-before
- char-equal char-to-string char-width
- compare-strings concat coordinates-in-window-p
+ char-equal char-to-string char-width compare-strings
+ compare-window-configurations concat coordinates-in-window-p
copy-alist copy-sequence copy-marker cos count-lines
decode-char
decode-time default-boundp default-value documentation downcase
@@ -1196,17 +1196,18 @@
fboundp fceiling featurep ffloor
file-directory-p file-exists-p file-locked-p file-name-absolute-p
file-newer-than-file-p file-readable-p file-symlink-p file-writable-p
- float float-time floor format format-time-string frame-visible-p
- fround ftruncate
+ float float-time floor format format-time-string frame-first-window
+ frame-root-window frame-selected-window
+ frame-visible-p fround ftruncate
get gethash get-buffer get-buffer-window getenv get-file-buffer
hash-table-count
int-to-string intern-soft
keymap-parent
length local-variable-if-set-p local-variable-p log log10 logand
logb logior lognot logxor lsh langinfo
- make-list make-string make-symbol
- marker-buffer max member memq min mod multibyte-char-to-unibyte
- next-window nth nthcdr number-to-string
+ make-list make-string make-symbol marker-buffer max member memq min
+ minibuffer-selected-window minibuffer-window
+ mod multibyte-char-to-unibyte next-window nth nthcdr number-to-string
parse-colon-path plist-get plist-member
prefix-numeric-value previous-window prin1-to-string propertize
degrees-to-radians
@@ -1221,9 +1222,19 @@
unibyte-char-to-multibyte upcase user-full-name
user-login-name user-original-login-name custom-variable-p
vconcat
- window-buffer window-dedicated-p window-edges window-height
- window-hscroll window-minibuffer-p window-width
- zerop))
+ window-absolute-pixel-edges window-at window-body-height
+ window-body-width window-buffer window-dedicated-p window-display-table
+ window-combination-limit window-edges window-frame window-fringes
+ window-height window-hscroll window-inside-edges
+ window-inside-absolute-pixel-edges window-inside-pixel-edges
+ window-left-child window-left-column window-margins window-minibuffer-p
+ window-next-buffers window-next-sibling window-new-normal
+ window-new-total window-normal-size window-parameter window-parameters
+ window-parent window-pixel-edges window-point window-prev-buffers
+ window-prev-sibling window-redisplay-end-trigger window-scroll-bars
+ window-start window-text-height window-top-child window-top-line
+ window-total-height window-total-width window-use-time window-vscroll
+ window-width zerop))
(side-effect-and-error-free-fns
'(arrayp atom
bobp bolp bool-vector-p
@@ -1256,7 +1267,8 @@
this-single-command-raw-keys
user-real-login-name user-real-uid user-uid
vector vectorp visible-frame-list
- wholenump window-configuration-p window-live-p windowp)))
+ wholenump window-configuration-p window-live-p
+ window-valid-p windowp)))
(while side-effect-free-fns
(put (car side-effect-free-fns) 'side-effect-free t)
(setq side-effect-free-fns (cdr side-effect-free-fns)))
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 7534ce5eaca..a325e0f3e44 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -419,8 +419,8 @@ This list lives partly on the stack.")
(defconst byte-compile-initial-macro-environment
'(
-;; (byte-compiler-options . (lambda (&rest forms)
-;; (apply 'byte-compiler-options-handler forms)))
+ ;; (byte-compiler-options . (lambda (&rest forms)
+ ;; (apply 'byte-compiler-options-handler forms)))
(declare-function . byte-compile-macroexpand-declare-function)
(eval-when-compile . (lambda (&rest body)
(list
@@ -429,8 +429,19 @@ This list lives partly on the stack.")
(byte-compile-top-level
(byte-compile-preprocess (cons 'progn body)))))))
(eval-and-compile . (lambda (&rest body)
- (byte-compile-eval-before-compile (cons 'progn body))
- (cons 'progn body))))
+ ;; Byte compile before running it. Do it piece by
+ ;; piece, in case further expressions need earlier
+ ;; ones to be evaluated already, as is the case in
+ ;; eieio.el.
+ `(progn
+ ,@(mapcar (lambda (exp)
+ (let ((cexp
+ (byte-compile-top-level
+ (byte-compile-preprocess
+ exp))))
+ (eval cexp)
+ cexp))
+ body)))))
"The default macro-environment passed to macroexpand by the compiler.
Placing a macro here will cause a macro to have different semantics when
expanded by the compiler as when expanded by the interpreter.")
@@ -731,9 +742,11 @@ otherwise pop it")
;; Also, this lets us notice references to free variables.
(defmacro byte-compile-push-bytecodes (&rest args)
- "Push BYTE... onto BYTES, and increment PC by the number of bytes pushed.
-ARGS is of the form (BYTE... BYTES PC), where BYTES and PC are variable names.
-BYTES and PC are updated after evaluating all the arguments."
+ "Push bytes onto BVAR, and increment CVAR by the number of bytes pushed.
+BVAR and CVAR are variables which are updated after evaluating
+all the arguments.
+
+\(fn BYTE1 BYTE2 ... BYTEn BVAR CVAR)"
(let ((byte-exprs (butlast args 2))
(bytes-var (car (last args 2)))
(pc-var (car (last args))))
@@ -863,16 +876,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
(let ((xs (pop hist-new))
old-autoloads)
;; Make sure the file was not already loaded before.
- (unless (or (assoc (car xs) hist-orig)
- ;; Don't give both the "noruntime" and
- ;; "cl-functions" warning for the same function.
- ;; FIXME This seems incorrect - these are two
- ;; independent warnings. For example, you may be
- ;; choosing to see the cl warnings but ignore them.
- ;; You probably don't want to ignore noruntime in the
- ;; same way.
- (and (byte-compile-warning-enabled-p 'cl-functions)
- (byte-compile-cl-file-p (car xs))))
+ (unless (assoc (car xs) hist-orig)
(dolist (s xs)
(cond
((and (consp s) (eq t (car s)))
@@ -1106,8 +1110,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
(defun byte-compile-log-warning (string &optional fill level)
(let ((warning-prefix-function 'byte-compile-warning-prefix)
(warning-type-format "")
- (warning-fill-prefix (if fill " "))
- (inhibit-read-only t))
+ (warning-fill-prefix (if fill " ")))
(display-warning 'bytecomp string level byte-compile-log-buffer)))
(defun byte-compile-warn (format &rest args)
@@ -2198,7 +2201,10 @@ list that represents a doc string reference.
(when (and (consp (nth 1 form))
(eq (car (nth 1 form)) 'quote)
(consp (cdr (nth 1 form)))
- (symbolp (nth 1 (nth 1 form))))
+ (symbolp (nth 1 (nth 1 form)))
+ ;; Don't add it if it's already defined. Otherwise, it might
+ ;; hide the actual definition.
+ (not (fboundp (nth 1 (nth 1 form)))))
(push (cons (nth 1 (nth 1 form))
(cons 'autoload (cdr (cdr form))))
byte-compile-function-environment)
@@ -2817,7 +2823,8 @@ for symbols generated by the byte compiler itself."
(setq body (nreverse body))
(setq body (list
(if (and (eq tmp 'funcall)
- (eq (car-safe (car body)) 'quote))
+ (eq (car-safe (car body)) 'quote)
+ (symbolp (nth 1 (car body))))
(cons (nth 1 (car body)) (cdr body))
(cons tmp body))))
(or (eq output-type 'file)
@@ -3698,10 +3705,10 @@ If CONDITION's value is (not (featurep 'emacs)) or (featurep 'xemacs),
that suppresses all warnings during execution of BODY."
(declare (indent 1) (debug t))
`(let* ((fbound-list (byte-compile-find-bound-condition
- ,condition (list 'fboundp)
+ ,condition '(fboundp functionp)
byte-compile-unresolved-functions))
(bound-list (byte-compile-find-bound-condition
- ,condition (list 'boundp 'default-boundp)))
+ ,condition '(boundp default-boundp)))
;; Maybe add to the bound list.
(byte-compile-bound-variables
(append bound-list byte-compile-bound-variables)))
diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el
index 8f801b39d3d..7c25972835b 100644
--- a/lisp/emacs-lisp/cl-extra.el
+++ b/lisp/emacs-lisp/cl-extra.el
@@ -440,7 +440,7 @@ If STATE is t, return a new state object seeded from the time of day."
(cond ((null state) (cl-make-random-state cl--random-state))
((vectorp state) (copy-tree state t))
((integerp state) (vector 'cl-random-state-tag -1 30 state))
- (t (cl-make-random-state (cl-random-time)))))
+ (t (cl-make-random-state (cl--random-time)))))
;;;###autoload
(defun cl-random-state-p (object)
diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el
index e9b30a8f62d..a9be08b1383 100644
--- a/lisp/emacs-lisp/cl-lib.el
+++ b/lisp/emacs-lisp/cl-lib.el
@@ -269,12 +269,12 @@ so that they are registered at compile-time as well as run-time."
;;; Symbols.
-(defun cl-random-time ()
+(defun cl--random-time ()
(let* ((time (copy-sequence (current-time-string))) (i (length time)) (v 0))
(while (>= (cl-decf i) 0) (setq v (+ (* v 3) (aref time i))))
v))
-(defvar cl--gensym-counter (* (logand (cl-random-time) 1023) 100))
+(defvar cl--gensym-counter (* (logand (cl--random-time) 1023) 100))
;;; Numbers.
@@ -301,7 +301,7 @@ always returns nil."
"Return t if INTEGER is even."
(eq (logand integer 1) 0))
-(defvar cl--random-state (vector 'cl-random-state-tag -1 30 (cl-random-time)))
+(defvar cl--random-state (vector 'cl-random-state-tag -1 30 (cl--random-time)))
(defconst cl-most-positive-float nil
"The largest value that a Lisp float can hold.
diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el
index e18c32da996..551043caa5e 100644
--- a/lisp/emacs-lisp/cl-loaddefs.el
+++ b/lisp/emacs-lisp/cl-loaddefs.el
@@ -11,7 +11,7 @@
;;;;;; cl--map-overlays cl--map-intervals cl--map-keymap-recursively
;;;;;; cl-notevery cl-notany cl-every cl-some cl-mapcon cl-mapcan
;;;;;; cl-mapl cl-mapc cl-maplist cl-map cl--mapcar-many cl-equalp
-;;;;;; cl-coerce) "cl-extra" "cl-extra.el" "b7d4e24fe58609eaf4fb319c81eb829e")
+;;;;;; cl-coerce) "cl-extra" "cl-extra.el" "0e9284b6492cc98eee7c85ae4e5322ee")
;;; Generated autoloads from cl-extra.el
(autoload 'cl-coerce "cl-extra" "\
@@ -41,7 +41,7 @@ TYPE is the sequence type to return.
(autoload 'cl-maplist "cl-extra" "\
Map FUNCTION to each sublist of LIST or LISTs.
-Like `cl-mapcar', except applies to lists and their cdr's rather than to
+Like `mapcar', except applies to lists and their cdr's rather than to
the elements themselves.
\(fn FUNCTION LIST...)" nil nil)
@@ -57,7 +57,7 @@ Like `cl-maplist', but does not accumulate values returned by the function.
\(fn FUNCTION LIST...)" nil nil)
(autoload 'cl-mapcan "cl-extra" "\
-Like `cl-mapcar', but nconc's together the values returned by the function.
+Like `mapcar', but nconc's together the values returned by the function.
\(fn FUNCTION SEQUENCE...)" nil nil)
@@ -248,9 +248,7 @@ Remove from SYMBOL's plist the property PROPNAME and its value.
\(fn SYMBOL PROPNAME)" nil nil)
(autoload 'cl-prettyexpand "cl-extra" "\
-Expand macros in FORM and insert the pretty-printed result.
-Optional argument FULL non-nil means to expand all macros,
-including `cl-block' and `cl-eval-when'.
+
\(fn FORM &optional FULL)" nil nil)
@@ -267,7 +265,7 @@ including `cl-block' and `cl-eval-when'.
;;;;;; cl-typecase cl-ecase cl-case cl-load-time-value cl-eval-when
;;;;;; cl-destructuring-bind cl-function cl-defmacro cl-defun cl-gentemp
;;;;;; cl-gensym cl--compiler-macro-cXXr cl--compiler-macro-list*)
-;;;;;; "cl-macs" "cl-macs.el" "a7228877484d2b39e1c2bee40b011734")
+;;;;;; "cl-macs" "cl-macs.el" "57cf89149db1e8ea6bc1582713980cf8")
;;; Generated autoloads from cl-macs.el
(autoload 'cl--compiler-macro-list* "cl-macs" "\
@@ -322,7 +320,7 @@ its argument list allows full Common Lisp conventions.
\(fn FUNC)" nil t)
(autoload 'cl-destructuring-bind "cl-macs" "\
-Bind the variables in ARGS to the result of EXPR and execute BODY.
+
\(fn ARGS EXPR &rest BODY)" nil t)
@@ -566,12 +564,12 @@ values. For compatibility, (cl-values A B C) is a synonym for (list A B C).
(put 'cl-multiple-value-setq 'lisp-indent-function '1)
(autoload 'cl-locally "cl-macs" "\
-Equivalent to `progn'.
+
\(fn &rest BODY)" nil t)
(autoload 'cl-the "cl-macs" "\
-At present this ignores _TYPE and is simply equivalent to FORM.
+
\(fn TYPE FORM)" nil t)
@@ -723,10 +721,7 @@ and then returning foo.
\(fn FUNC ARGS &rest BODY)" nil t)
(autoload 'cl-compiler-macroexpand "cl-macs" "\
-Like `macroexpand', but for compiler macros.
-Expands FORM repeatedly until no further expansion is possible.
-Returns FORM unchanged if it has no compiler macro, or if it has a
-macro that returns its `&whole' argument.
+
\(fn FORM)" nil nil)
diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el
index 38bb6319a03..58bfae5b503 100644
--- a/lisp/emacs-lisp/gv.el
+++ b/lisp/emacs-lisp/gv.el
@@ -440,6 +440,26 @@ The return value is the last VAL in the list.
`(logior (logand ,v ,mask)
(logand ,getter (lognot ,mask))))))))))
+;;; References
+
+;;;###autoload
+(defmacro gv-ref (place)
+ "Return a reference to PLACE.
+This is like the `&' operator of the C language."
+ (gv-letplace (getter setter) place
+ `(cons (lambda () ,getter)
+ (lambda (gv--val) ,(funcall setter 'gv--val)))))
+
+(defsubst gv-deref (ref)
+ "Dereference REF, returning the referenced value.
+This is like the `*' operator of the C language.
+REF must have been previously obtained with `gv-ref'."
+ (funcall (car ref)))
+;; Don't use `declare' because it seems to introduce circularity problems:
+;; Warning: Eager macro-expansion skipped due to cycle:
+;; … => (load "gv.el") => (macroexpand-all (defsubst gv-deref …)) => (macroexpand (defun …)) => (load "gv.el")
+(gv-define-setter gv-deref (v ref) `(funcall (cdr ,ref) ,v))
+
;;; Vaguely related definitions that should be moved elsewhere.
;; (defun alist-get (key alist)
generated by cgit v1.2.3 (git 2.39.1) at 2025-06-18 00:57:44 +0000