diff options
author | Tom Tromey <tromey@redhat.com> | 2013-08-19 21:53:07 -0600 |
---|---|---|
committer | Tom Tromey <tromey@redhat.com> | 2013-08-19 21:53:07 -0600 |
commit | 6d75555c5cc3d2a629646cee7629e67530fa7a36 (patch) | |
tree | 3852804dd234ad613ea8691332e10b92c027e87d /lisp/emacs-lisp | |
parent | cc231cbe45d27a1906d268fb72d3b4105a2e9c65 (diff) | |
parent | 8c2f38aaab7a7a2f0605416fc2ee38701e41ab61 (diff) | |
download | emacs-6d75555c5cc3d2a629646cee7629e67530fa7a36.tar.gz emacs-6d75555c5cc3d2a629646cee7629e67530fa7a36.tar.bz2 emacs-6d75555c5cc3d2a629646cee7629e67530fa7a36.zip |
merge from trunk
Diffstat (limited to 'lisp/emacs-lisp')
-rw-r--r-- | lisp/emacs-lisp/advice.el | 31 | ||||
-rw-r--r-- | lisp/emacs-lisp/byte-run.el | 1 | ||||
-rw-r--r-- | lisp/emacs-lisp/bytecomp.el | 115 | ||||
-rw-r--r-- | lisp/emacs-lisp/checkdoc.el | 126 | ||||
-rw-r--r-- | lisp/emacs-lisp/cl-lib.el | 3 | ||||
-rw-r--r-- | lisp/emacs-lisp/cl-macs.el | 2 | ||||
-rw-r--r-- | lisp/emacs-lisp/debug.el | 81 | ||||
-rw-r--r-- | lisp/emacs-lisp/easy-mmode.el | 14 | ||||
-rw-r--r-- | lisp/emacs-lisp/edebug.el | 25 | ||||
-rw-r--r-- | lisp/emacs-lisp/ert.el | 3 | ||||
-rw-r--r-- | lisp/emacs-lisp/gv.el | 6 | ||||
-rw-r--r-- | lisp/emacs-lisp/helper.el | 2 | ||||
-rw-r--r-- | lisp/emacs-lisp/lisp-mode.el | 21 | ||||
-rw-r--r-- | lisp/emacs-lisp/nadvice.el | 108 | ||||
-rw-r--r-- | lisp/emacs-lisp/package.el | 2 | ||||
-rw-r--r-- | lisp/emacs-lisp/pcase.el | 31 | ||||
-rw-r--r-- | lisp/emacs-lisp/re-builder.el | 2 | ||||
-rw-r--r-- | lisp/emacs-lisp/timer.el | 34 |
18 files changed, 308 insertions, 299 deletions
diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 3d03e894534..861054e777f 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -2140,14 +2140,6 @@ See Info node `(elisp)Computed Advice' for detailed documentation." "Take a macro function DEFINITION and make a lambda out of it." `(cdr ,definition)) -(defmacro ad-subr-p (definition) - ;;"non-nil if DEFINITION is a subr." - (list 'subrp definition)) - -(defmacro ad-macro-p (definition) - ;;"non-nil if DEFINITION is a macro." - `(eq (car-safe ,definition) 'macro)) - (defmacro ad-lambda-p (definition) ;;"non-nil if DEFINITION is a lambda expression." `(eq (car-safe ,definition) 'lambda)) @@ -2160,12 +2152,12 @@ See Info node `(elisp)Computed Advice' for detailed documentation." (defmacro ad-compiled-p (definition) "Return non-nil if DEFINITION is a compiled byte-code object." `(or (byte-code-function-p ,definition) - (and (ad-macro-p ,definition) - (byte-code-function-p (ad-lambdafy ,definition))))) + (and (macrop ,definition) + (byte-code-function-p (ad-lambdafy ,definition))))) (defmacro ad-compiled-code (compiled-definition) "Return the byte-code object of a COMPILED-DEFINITION." - `(if (ad-macro-p ,compiled-definition) + `(if (macrop ,compiled-definition) (ad-lambdafy ,compiled-definition) ,compiled-definition)) @@ -2173,7 +2165,7 @@ See Info node `(elisp)Computed Advice' for detailed documentation." "Return the lambda expression of a function/macro/advice DEFINITION." (cond ((ad-lambda-p definition) definition) - ((ad-macro-p definition) + ((macrop definition) (ad-lambdafy definition)) ((ad-advice-p definition) (cdr definition)) @@ -2183,7 +2175,7 @@ See Info node `(elisp)Computed Advice' for detailed documentation." "Return the argument list of DEFINITION." (require 'help-fns) (help-function-arglist - (if (or (ad-macro-p definition) (ad-advice-p definition)) + (if (or (macrop definition) (ad-advice-p definition)) (cdr definition) definition) 'preserve-names)) @@ -2229,7 +2221,7 @@ definition (see the code for `documentation')." (defun ad-advised-definition-p (definition) "Return non-nil if DEFINITION was generated from advice information." (if (or (ad-lambda-p definition) - (ad-macro-p definition) + (macrop definition) (ad-compiled-p definition)) (let ((docstring (ad-docstring definition))) (and (stringp docstring) @@ -2242,8 +2234,8 @@ definition (see the code for `documentation')." ;; representations, so cache entries preactivated with version ;; 1 can't be used. (cond - ((ad-macro-p definition) 'macro2) - ((ad-subr-p definition) 'subr2) + ((macrop definition) 'macro2) + ((subrp definition) 'subr2) ((or (ad-lambda-p definition) (ad-compiled-p definition)) 'fun2) ((ad-advice-p definition) 'advice2))) ;; FIXME: Can this ever happen? @@ -2273,14 +2265,13 @@ For that it has to be fbound with a non-autoload definition." "True if FUNCTION has an interpreted definition that can be compiled." (and (ad-has-proper-definition function) (or (ad-lambda-p (symbol-function function)) - (ad-macro-p (symbol-function function))) + (macrop (symbol-function function))) (not (ad-compiled-p (symbol-function function))))) (defvar warning-suppress-types) ;From warnings.el. (defun ad-compile-function (function) "Byte-compile the assembled advice function." (require 'bytecomp) - (require 'warnings) ;To define warning-suppress-types before we let-bind it. (let ((byte-compile-warnings byte-compile-warnings) ;; Don't pop up windows showing byte-compiler warnings. (warning-suppress-types '((bytecomp)))) @@ -2903,7 +2894,7 @@ If COMPILE is nil then the result depends on the value of ((eq ad-default-compilation-action 'never) nil) ((eq ad-default-compilation-action 'always) t) ((eq ad-default-compilation-action 'like-original) - (or (ad-subr-p (ad-get-orig-definition function)) + (or (subrp (ad-get-orig-definition function)) (ad-compiled-p (ad-get-orig-definition function)))) ;; everything else means `maybe': (t (featurep 'byte-compile)))) @@ -3250,7 +3241,7 @@ usage: (defadvice FUNCTION (CLASS NAME [POSITION] [ARGLIST] FLAG...) `((ad-set-cache ',function ;; the function will get compiled: - ,(cond ((ad-macro-p (car preactivation)) + ,(cond ((macrop (car preactivation)) `(ad-macrofy (function ,(ad-lambdafy diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 8f0999b2f80..0bb04950dfd 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -83,7 +83,6 @@ The return value of this function is not used." (list 'quote f) (list 'quote new-name) (list 'quote when)))) (list 'compiler-macro #'(lambda (f args compiler-function) - ;; FIXME: Make it possible to just reuse `args'. `(eval-and-compile (put ',f 'compiler-macro ,(if (eq (car-safe compiler-function) 'lambda) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index f4e79dc4886..c6612024fa6 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1224,6 +1224,24 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (format "%d" (car signature))) (t (format "%d-%d" (car signature) (cdr signature))))) +(defun byte-compile-function-warn (f nargs def) + (when (get f 'byte-obsolete-info) + (byte-compile-warn-obsolete f)) + + ;; Check to see if the function will be available at runtime + ;; and/or remember its arity if it's unknown. + (or (and (or def (fboundp f)) ; might be a subr or autoload. + (not (memq f byte-compile-noruntime-functions))) + (eq f byte-compile-current-form) ; ## This doesn't work + ; with recursion. + ;; It's a currently-undefined function. + ;; Remember number of args in call. + (let ((cons (assq f byte-compile-unresolved-functions))) + (if cons + (or (memq nargs (cdr cons)) + (push nargs (cdr cons))) + (push (list f nargs) + byte-compile-unresolved-functions))))) ;; Warn if the form is calling a function with the wrong number of arguments. (defun byte-compile-callargs-warn (form) @@ -1261,21 +1279,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." "accepts only") (byte-compile-arglist-signature-string sig)))) (byte-compile-format-warn form) - ;; Check to see if the function will be available at runtime - ;; and/or remember its arity if it's unknown. - (or (and (or def (fboundp (car form))) ; might be a subr or autoload. - (not (memq (car form) byte-compile-noruntime-functions))) - (eq (car form) byte-compile-current-form) ; ## This doesn't work - ; with recursion. - ;; It's a currently-undefined function. - ;; Remember number of args in call. - (let ((cons (assq (car form) byte-compile-unresolved-functions)) - (n (length (cdr form)))) - (if cons - (or (memq n (cdr cons)) - (setcdr cons (cons n (cdr cons)))) - (push (list (car form) n) - byte-compile-unresolved-functions)))))) + (byte-compile-function-warn (car form) (length (cdr form)) def))) (defun byte-compile-format-warn (form) "Warn if FORM is `format'-like with inconsistent args. @@ -1364,7 +1368,10 @@ extra args." ;; This is the first definition. See if previous calls are compatible. (let ((calls (assq name byte-compile-unresolved-functions)) nums sig min max) - (when calls + (setq byte-compile-unresolved-functions + (delq calls byte-compile-unresolved-functions)) + (setq calls (delq t calls)) ;Ignore higher-order uses of the function. + (when (cdr calls) (when (and (symbolp name) (eq (function-get name 'byte-optimizer) 'byte-compile-inline-expand)) @@ -1382,10 +1389,7 @@ extra args." name (byte-compile-arglist-signature-string sig) (if (equal sig '(1 . 1)) " arg" " args") - (byte-compile-arglist-signature-string (cons min max)))) - - (setq byte-compile-unresolved-functions - (delq calls byte-compile-unresolved-functions))))))) + (byte-compile-arglist-signature-string (cons min max))))))))) (defvar byte-compile-cl-functions nil "List of functions defined in CL.") @@ -2214,37 +2218,33 @@ list that represents a doc string reference. (defun byte-compile-file-form-autoload (form) (and (let ((form form)) (while (if (setq form (cdr form)) (macroexp-const-p (car form)))) - (null form)) ;Constants only + (null form)) ;Constants only (memq (eval (nth 5 form)) '(t macro)) ;Macro - (eval form)) ;Define the autoload. + (eval form)) ;Define the autoload. ;; Avoid undefined function warnings for the autoload. - (when (and (consp (nth 1 form)) - (eq (car (nth 1 form)) 'quote) - (consp (cdr (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. However, do remove any entry from - ;; byte-compile-noruntime-functions, in case we have an autoload - ;; of foo-func following an (eval-when-compile (require 'foo)). - (unless (fboundp (nth 1 (nth 1 form))) - (push (cons (nth 1 (nth 1 form)) - (cons 'autoload (cdr (cdr form)))) - byte-compile-function-environment)) - ;; If an autoload occurs _before_ the first call to a function, - ;; byte-compile-callargs-warn does not add an entry to - ;; byte-compile-unresolved-functions. Here we mimic the logic - ;; of byte-compile-callargs-warn so as not to warn if the - ;; autoload comes _after_ the function call. - ;; Alternatively, similar logic could go in - ;; byte-compile-warn-about-unresolved-functions. - (if (memq (nth 1 (nth 1 form)) byte-compile-noruntime-functions) - (setq byte-compile-noruntime-functions - (delq (nth 1 (nth 1 form)) byte-compile-noruntime-functions) - byte-compile-noruntime-functions) - (setq byte-compile-unresolved-functions - (delq (assq (nth 1 (nth 1 form)) - byte-compile-unresolved-functions) - byte-compile-unresolved-functions)))) + (pcase (nth 1 form) + (`',(and (pred symbolp) funsym) + ;; Don't add it if it's already defined. Otherwise, it might + ;; hide the actual definition. However, do remove any entry from + ;; byte-compile-noruntime-functions, in case we have an autoload + ;; of foo-func following an (eval-when-compile (require 'foo)). + (unless (fboundp funsym) + (push (cons funsym (cons 'autoload (cdr (cdr form)))) + byte-compile-function-environment)) + ;; If an autoload occurs _before_ the first call to a function, + ;; byte-compile-callargs-warn does not add an entry to + ;; byte-compile-unresolved-functions. Here we mimic the logic + ;; of byte-compile-callargs-warn so as not to warn if the + ;; autoload comes _after_ the function call. + ;; Alternatively, similar logic could go in + ;; byte-compile-warn-about-unresolved-functions. + (if (memq funsym byte-compile-noruntime-functions) + (setq byte-compile-noruntime-functions + (delq funsym byte-compile-noruntime-functions) + byte-compile-noruntime-functions) + (setq byte-compile-unresolved-functions + (delq (assq funsym byte-compile-unresolved-functions) + byte-compile-unresolved-functions))))) (if (stringp (nth 3 form)) form ;; No doc string, so we can compile this as a normal form. @@ -2964,8 +2964,6 @@ That command is designed for interactive use only" fn)) '(custom-declare-group custom-declare-variable custom-declare-face)) (byte-compile-nogroup-warn form)) - (when (get (car form) 'byte-obsolete-info) - (byte-compile-warn-obsolete (car form))) (byte-compile-callargs-warn form)) (if byte-compile-generate-call-tree (byte-compile-annotate-call-tree form)) @@ -3574,10 +3572,15 @@ discarding." ;; and (funcall (function foo)) will lose with autoloads. (defun byte-compile-function-form (form) - (byte-compile-constant (if (eq 'lambda (car-safe (nth 1 form))) - (byte-compile-lambda (nth 1 form)) - (nth 1 form)))) - + (let ((f (nth 1 form))) + (when (and (symbolp f) + (byte-compile-warning-enabled-p 'callargs)) + (byte-compile-function-warn f t (byte-compile-fdefinition f nil))) + + (byte-compile-constant (if (eq 'lambda (car-safe f)) + (byte-compile-lambda f) + f)))) + (defun byte-compile-indent-to (form) (let ((len (length form))) (cond ((= len 2) @@ -4271,7 +4274,7 @@ binding slots have been popped." (if (and (eq (car-safe (car-safe (cdr-safe form))) 'quote) (byte-compile-warning-enabled-p 'make-local)) (byte-compile-warn - "`make-variable-buffer-local' should be called at toplevel")) + "`make-variable-buffer-local' not called at toplevel")) (byte-compile-normal-call form)) (put 'make-variable-buffer-local 'byte-hunk-handler 'byte-compile-form-make-variable-buffer-local) diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index 6540a8e9f14..9c5b408637f 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -186,7 +186,6 @@ (defcustom checkdoc-minor-mode-string " CDoc" "String to display in mode line when Checkdoc mode is enabled; nil for none." :type '(choice string (const :tag "None" nil)) - :group 'checkdoc :version "23.1") (defcustom checkdoc-autofix-flag 'semiautomatic @@ -197,7 +196,6 @@ made without asking unless the change is very-complex. If the value is `semiautomatic' or any other value, then simple fixes are made without asking, and complex changes are made by asking the user first. The value `never' is the same as nil, never ask or change anything." - :group 'checkdoc :type '(choice (const automatic) (const query) (const never) @@ -207,7 +205,6 @@ The value `never' is the same as nil, never ask or change anything." "Non-nil means to \"bounce\" to auto-fix locations. Setting this to nil will silently make fixes that require no user interaction. See `checkdoc-autofix-flag' for auto-fixing details." - :group 'checkdoc :type 'boolean) (defcustom checkdoc-force-docstrings-flag t @@ -215,16 +212,14 @@ interaction. See `checkdoc-autofix-flag' for auto-fixing details." Style guide dictates that interactive functions MUST have documentation, and that it's good but not required practice to make non user visible items have doc strings." - :group 'checkdoc :type 'boolean) -;;;###autoload(put 'checkdoc-force-docstrings-flag 'safe-local-variable 'booleanp) +;;;###autoload(put 'checkdoc-force-docstrings-flag 'safe-local-variable #'booleanp) (defcustom checkdoc-force-history-flag nil "Non-nil means that files should have a History section or ChangeLog file. This helps document the evolution of, and recent changes to, the package." - :group 'checkdoc :type 'boolean) -;;;###autoload(put 'checkdoc-force-history-flag 'safe-local-variable 'booleanp) +;;;###autoload(put 'checkdoc-force-history-flag 'safe-local-variable #'booleanp) (defcustom checkdoc-permit-comma-termination-flag nil "Non-nil means the first line of a docstring may end with a comma. @@ -232,9 +227,8 @@ Ordinarily, a full sentence is required. This may be misleading when there is a substantial caveat to the one-line description -- the comma should be used when the first part could stand alone as a sentence, but it indicates that a modifying clause follows." - :group 'checkdoc :type 'boolean) -;;;###autoload(put 'checkdoc-permit-comma-termination-flag 'safe-local-variable 'booleanp) +;;;###autoload(put 'checkdoc-permit-comma-termination-flag 'safe-local-variable #'booleanp) (defcustom checkdoc-spellcheck-documentation-flag nil "Non-nil means run Ispell on text based on value. @@ -246,22 +240,22 @@ system. Possible values are: buffer - Spell-check when style checking the whole buffer interactive - Spell-check during any interactive check. t - Always spell-check" - :group 'checkdoc :type '(choice (const nil) (const defun) (const buffer) (const interactive) (const t))) +;;;###autoload(put 'checkdoc-spellcheck-documentation-flag 'safe-local-variable #'booleanp) (defvar checkdoc-ispell-lisp-words '("alist" "emacs" "etags" "keymap" "paren" "regexp" "sexp" "xemacs") "List of words that are correct when spell-checking Lisp documentation.") +;;;###autoload(put 'checkdoc-ispell-list-words 'safe-local-variable #'checkdoc-list-of-strings-p) (defcustom checkdoc-max-keyref-before-warn 10 "The number of \\ [command-to-keystroke] tokens allowed in a doc string. Any more than this and a warning is generated suggesting that the construct \\ {keymap} be used instead." - :group 'checkdoc :type 'integer) (defcustom checkdoc-arguments-in-order-flag t @@ -270,9 +264,8 @@ Setting this to nil will mean only checking that all the arguments appear in the proper form in the documentation, not that they are in the same order as they appear in the argument list. No mention is made in the style guide relating to order." - :group 'checkdoc :type 'boolean) -;;;###autoload(put 'checkdoc-arguments-in-order-flag 'safe-local-variable 'booleanp) +;;;###autoload(put 'checkdoc-arguments-in-order-flag 'safe-local-variable #'booleanp) (define-obsolete-variable-alias 'checkdoc-style-hooks 'checkdoc-style-functions "24.3") @@ -305,8 +298,8 @@ A search leaves the cursor in front of the parameter list.") "Non-nil means to attempt to check the voice of the doc string. This check keys off some words which are commonly misused. See the variable `checkdoc-common-verbs-wrong-voice' if you wish to add your own." - :group 'checkdoc :type 'boolean) +;;;###autoload(put 'checkdoc-verb-check-experimental-flag 'safe-local-variable #'booleanp) (defvar checkdoc-generate-compile-warnings-flag nil "Non-nil means generate warnings in a buffer for browsing. @@ -317,16 +310,15 @@ with a universal argument.") "A list of symbol names (strings) which also happen to make good words. These words are ignored when unquoted symbols are searched for. This should be set in an Emacs Lisp file's local variables." - :group 'checkdoc :type '(repeat (symbol :tag "Word"))) -;;;###autoload(put 'checkdoc-symbol-words 'safe-local-variable 'checkdoc-list-of-strings-p) +;;;###autoload(put 'checkdoc-symbol-words 'safe-local-variable #'checkdoc-list-of-strings-p) ;;;###autoload (defun checkdoc-list-of-strings-p (obj) ;; this is a function so it might be shared by checkdoc-proper-noun-list ;; and/or checkdoc-ispell-lisp-words in the future (and (listp obj) - (not (memq nil (mapcar 'stringp obj))))) + (not (memq nil (mapcar #'stringp obj))))) (defvar checkdoc-proper-noun-list '("ispell" "xemacs" "emacs" "lisp") @@ -340,9 +332,11 @@ This should be set in an Emacs Lisp file's local variables." (regexp-opt checkdoc-proper-noun-list t) "\\(\\_>\\|[.!?][ \t\n\"]\\)") "Regular expression derived from `checkdoc-proper-noun-regexp'.") +;;;###autoload(put 'checkdoc-proper-noun-regexp 'safe-local-variable 'stringp) (defvar checkdoc-common-verbs-regexp nil "Regular expression derived from `checkdoc-common-verbs-regexp'.") +;;;###autoload(put 'checkdoc-common-verbs-regexp 'safe-local-variable 'stringp) (defvar checkdoc-common-verbs-wrong-voice '(("adds" . "add") @@ -443,19 +437,19 @@ be re-created.") ;;; Compatibility ;; (defalias 'checkdoc-make-overlay - (if (featurep 'xemacs) 'make-extent 'make-overlay)) + (if (featurep 'xemacs) #'make-extent #'make-overlay)) (defalias 'checkdoc-overlay-put - (if (featurep 'xemacs) 'set-extent-property 'overlay-put)) + (if (featurep 'xemacs) #'set-extent-property #'overlay-put)) (defalias 'checkdoc-delete-overlay - (if (featurep 'xemacs) 'delete-extent 'delete-overlay)) + (if (featurep 'xemacs) #'delete-extent #'delete-overlay)) (defalias 'checkdoc-overlay-start - (if (featurep 'xemacs) 'extent-start 'overlay-start)) + (if (featurep 'xemacs) #'extent-start #'overlay-start)) (defalias 'checkdoc-overlay-end - (if (featurep 'xemacs) 'extent-end 'overlay-end)) + (if (featurep 'xemacs) #'extent-end #'overlay-end)) (defalias 'checkdoc-mode-line-update - (if (featurep 'xemacs) 'redraw-modeline 'force-mode-line-update)) + (if (featurep 'xemacs) #'redraw-modeline #'force-mode-line-update)) (defalias 'checkdoc-char= - (if (featurep 'xemacs) 'char= '=)) + (if (featurep 'xemacs) #'char= #'=)) ;;; User level commands ;; @@ -540,7 +534,7 @@ checkdoc status window instead of the usual behavior." ;; Due to a design flaw, this will never spell check ;; docstrings. (checkdoc-interactive-loop start-here showstatus - 'checkdoc-next-error) + #'checkdoc-next-error) ;; This is a workaround to perform spell checking. (checkdoc-interactive-ispell-loop start-here)))) @@ -560,7 +554,7 @@ checkdoc status window instead of the usual behavior." (prog1 ;; Due to a design flaw, this will never spell check messages. (checkdoc-interactive-loop start-here showstatus - 'checkdoc-next-message-error) + #'checkdoc-next-message-error) ;; This is a workaround to perform spell checking. (checkdoc-message-interactive-ispell-loop start-here)))) @@ -639,7 +633,7 @@ style." (goto-char (cdr (car err-list))) ;; `automatic-then-never' tells the autofix function ;; to only allow one fix to be automatic. The autofix - ;; function will then set the flag to 'never, allowing + ;; function will then set the flag to `never', allowing ;; the checker to return a different error. (let ((checkdoc-autofix-flag 'automatic-then-never) (fixed nil)) @@ -1004,7 +998,7 @@ Evaluation is done first so the form will be read before the documentation is checked. If there is a documentation error, then the display of what was evaluated will be overwritten by the diagnostic message." (interactive) - (call-interactively 'eval-defun) + (call-interactively #'eval-defun) (checkdoc-defun)) ;;;###autoload @@ -1046,85 +1040,86 @@ space at the end of each line." ;; ;;;###autoload -(defun checkdoc-ispell (&optional take-notes) +(defun checkdoc-ispell () "Check the style and spelling of everything interactively. Calls `checkdoc' with spell-checking turned on. -Prefix argument TAKE-NOTES is the same as for `checkdoc'" +Prefix argument is the same as for `checkdoc'" (interactive) (let ((checkdoc-spellcheck-documentation-flag t)) - (call-interactively 'checkdoc nil current-prefix-arg))) + (call-interactively #'checkdoc nil current-prefix-arg))) ;;;###autoload -(defun checkdoc-ispell-current-buffer (&optional take-notes) +(defun checkdoc-ispell-current-buffer () "Check the style and spelling of the current buffer. Calls `checkdoc-current-buffer' with spell-checking turned on. -Prefix argument TAKE-NOTES is the same as for `checkdoc-current-buffer'" +Prefix argument is the same as for `checkdoc-current-buffer'" (interactive) (let ((checkdoc-spellcheck-documentation-flag t)) - (call-interactively 'checkdoc-current-buffer nil current-prefix-arg))) + (call-interactively #'checkdoc-current-buffer nil current-prefix-arg))) ;;;###autoload -(defun checkdoc-ispell-interactive (&optional take-notes) +(defun checkdoc-ispell-interactive () "Check the style and spelling of the current buffer interactively. Calls `checkdoc-interactive' with spell-checking turned on. -Prefix argument TAKE-NOTES is the same as for `checkdoc-interactive'" +Prefix argument is the same as for `checkdoc-interactive'" (interactive) (let ((checkdoc-spellcheck-documentation-flag t)) - (call-interactively 'checkdoc-interactive nil current-prefix-arg))) + (call-interactively #'checkdoc-interactive nil current-prefix-arg))) ;;;###autoload -(defun checkdoc-ispell-message-interactive (&optional take-notes) +(defun checkdoc-ispell-message-interactive () "Check the style and spelling of message text interactively. Calls `checkdoc-message-interactive' with spell-checking turned on. -Prefix argument TAKE-NOTES is the same as for `checkdoc-message-interactive'" +Prefix argument is the same as for `checkdoc-message-interactive'" (interactive) (let ((checkdoc-spellcheck-documentation-flag t)) - (call-interactively 'checkdoc-message-interactive nil current-prefix-arg))) + (call-interactively #'checkdoc-message-interactive + nil current-prefix-arg))) ;;;###autoload -(defun checkdoc-ispell-message-text (&optional take-notes) +(defun checkdoc-ispell-message-text () "Check the style and spelling of message text interactively. Calls `checkdoc-message-text' with spell-checking turned on. -Prefix argument TAKE-NOTES is the same as for `checkdoc-message-text'" +Prefix argument is the same as for `checkdoc-message-text'" (interactive) (let ((checkdoc-spellcheck-documentation-flag t)) - (call-interactively 'checkdoc-message-text nil current-prefix-arg))) + (call-interactively #'checkdoc-message-text nil current-prefix-arg))) ;;;###autoload -(defun checkdoc-ispell-start (&optional take-notes) +(defun checkdoc-ispell-start () "Check the style and spelling of the current buffer. Calls `checkdoc-start' with spell-checking turned on. -Prefix argument TAKE-NOTES is the same as for `checkdoc-start'" +Prefix argument is the same as for `checkdoc-start'" (interactive) (let ((checkdoc-spellcheck-documentation-flag t)) - (call-interactively 'checkdoc-start nil current-prefix-arg))) + (call-interactively #'checkdoc-start nil current-prefix-arg))) ;;;###autoload -(defun checkdoc-ispell-continue (&optional take-notes) +(defun checkdoc-ispell-continue () "Check the style and spelling of the current buffer after point. Calls `checkdoc-continue' with spell-checking turned on. -Prefix argument TAKE-NOTES is the same as for `checkdoc-continue'" +Prefix argument is the same as for `checkdoc-continue'" (interactive) (let ((checkdoc-spellcheck-documentation-flag t)) - (call-interactively 'checkdoc-continue nil current-prefix-arg))) + (call-interactively #'checkdoc-continue nil current-prefix-arg))) ;;;###autoload -(defun checkdoc-ispell-comments (&optional take-notes) +(defun checkdoc-ispell-comments () "Check the style and spelling of the current buffer's comments. Calls `checkdoc-comments' with spell-checking turned on. -Prefix argument TAKE-NOTES is the same as for `checkdoc-comments'" +Prefix argument is the same as for `checkdoc-comments'" (interactive) (let ((checkdoc-spellcheck-documentation-flag t)) - (call-interactively 'checkdoc-comments nil current-prefix-arg))) + (call-interactively #'checkdoc-comments nil current-prefix-arg))) ;;;###autoload -(defun checkdoc-ispell-defun (&optional take-notes) +(defun checkdoc-ispell-defun () "Check the style and spelling of the current defun with Ispell. Calls `checkdoc-defun' with spell-checking turned on. -Prefix argument TAKE-NOTES is the same as for `checkdoc-defun'" +Prefix argument is the same as for `checkdoc-defun'" (interactive) (let ((checkdoc-spellcheck-documentation-flag t)) - (call-interactively 'checkdoc-defun nil current-prefix-arg))) + (call-interactively #'checkdoc-defun nil current-prefix-arg))) ;;; Error Management ;; @@ -1254,10 +1249,10 @@ checking of documentation strings. (defsubst checkdoc-run-hooks (hookvar &rest args) "Run hooks in HOOKVAR with ARGS." (if (fboundp 'run-hook-with-args-until-success) - (apply 'run-hook-with-args-until-success hookvar args) + (apply #'run-hook-with-args-until-success hookvar args) ;; This method was similar to above. We ignore the warning ;; since we will use the above for future Emacs versions - (apply 'run-hook-with-args hookvar args))) + (apply #'run-hook-with-args hookvar args))) (defsubst checkdoc-create-common-verbs-regexp () "Rebuild the contents of `checkdoc-common-verbs-regexp'." @@ -2198,8 +2193,8 @@ Code:, and others referenced in the style guide." nil (require 'lisp-mnt) ;; Old XEmacs don't have `lm-commentary-mark' - (if (and (not (fboundp 'lm-commentary-mark)) (boundp 'lm-commentary)) - (defalias 'lm-commentary-mark 'lm-commentary))) + (if (and (not (fboundp 'lm-commentary-mark)) (fboundp 'lm-commentary)) + (defalias 'lm-commentary-mark #'lm-commentary))) (save-excursion (let* ((f1 (file-name-nondirectory (buffer-file-name))) (fn (file-name-sans-extension f1)) @@ -2260,8 +2255,7 @@ Code:, and others referenced in the style guide." (if (or (not checkdoc-force-history-flag) (file-exists-p "ChangeLog") (file-exists-p "../ChangeLog") - (let ((fn 'lm-history-mark)) ;bestill byte-compiler - (and (fboundp fn) (funcall fn)))) + (and (fboundp 'lm-history-mark) (funcall #'lm-history-mark))) nil (progn (goto-char (or (lm-commentary-mark) (point-min))) @@ -2585,10 +2579,10 @@ This function will not modify `match-data'." (define-derived-mode checkdoc-output-mode compilation-mode "Checkdoc" "Set up the major mode for the buffer containing the list of errors." - (set (make-local-variable 'compilation-error-regexp-alist) - checkdoc-output-error-regex-alist) - (set (make-local-variable 'compilation-mode-font-lock-keywords) - checkdoc-output-font-lock-keywords)) + (setq-local compilation-error-regexp-alist + checkdoc-output-error-regex-alist) + (setq-local compilation-mode-font-lock-keywords + checkdoc-output-font-lock-keywords)) (defun checkdoc-buffer-label () "The name to use for a checkdoc buffer in the error list." @@ -2620,7 +2614,7 @@ function called to create the messages." (with-current-buffer (get-buffer checkdoc-diagnostic-buffer) (goto-char (point-max)) (let ((inhibit-read-only t)) - (apply 'insert text))))) + (apply #'insert text))))) (defun checkdoc-show-diagnostics () "Display the checkdoc diagnostic buffer in a temporary window." diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index 2ab6b7ad089..e826cf4375a 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -714,6 +714,9 @@ If ALIST is non-nil, the new pairs are prepended to it." ;;;###autoload (progn + ;; The `assert' macro from the cl package signals + ;; `cl-assertion-failed' at runtime so always define it. + (define-error 'cl-assertion-failed (purecopy "Assertion failed")) ;; Make sure functions defined with cl-defsubst can be inlined even in ;; packages which do not require CL. We don't put an autoload cookie ;; directly on that function, since those cookies only go to cl-loaddefs. diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index c47c9b61030..d9d6658811f 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -616,7 +616,7 @@ The result of the body appears to the compiler as a quoted constant." (declare (debug (form &optional sexp))) (if (cl--compiling-file) (let* ((temp (cl-gentemp "--cl-load-time--")) - (set `(set ',temp ,form))) + (set `(setq ,temp ,form))) (if (and (fboundp 'byte-compile-file-form-defmumble) (boundp 'this-kind) (boundp 'that-one)) (fset 'byte-compile-file-form diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index aee48eef668..709a094e73b 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -288,33 +288,41 @@ That buffer should be current already." (insert "Debugger entered") ;; lambda is for debug-on-call when a function call is next. ;; debug is for debug-on-entry function called. - (pcase (car args) - ((or `lambda `debug) - (insert "--entering a function:\n")) - ;; Exiting a function. - (`exit - (insert "--returning value: ") - (setq debugger-value (nth 1 args)) - (prin1 debugger-value (current-buffer)) - (insert ?\n) - (delete-char 1) - (insert ? ) - (beginning-of-line)) - ;; Debugger entered for an error. - (`error - (insert "--Lisp error: ") - (prin1 (nth 1 args) (current-buffer)) - (insert ?\n)) - ;; debug-on-call, when the next thing is an eval. - (`t - (insert "--beginning evaluation of function call form:\n")) - ;; User calls debug directly. - (_ - (insert ": ") - (prin1 (if (eq (car args) 'nil) - (cdr args) args) - (current-buffer)) - (insert ?\n))) + (let ((pos (point))) + (pcase (car args) + ((or `lambda `debug) + (insert "--entering a function:\n") + (setq pos (1- (point)))) + ;; Exiting a function. + (`exit + (insert "--returning value: ") + (setq pos (point)) + (setq debugger-value (nth 1 args)) + (prin1 debugger-value (current-buffer)) + (insert ?\n) + (delete-char 1) + (insert ? ) + (beginning-of-line)) + ;; Debugger entered for an error. + (`error + (insert "--Lisp error: ") + (setq pos (point)) + (prin1 (nth 1 args) (current-buffer)) + (insert ?\n)) + ;; debug-on-call, when the next thing is an eval. + (`t + (insert "--beginning evaluation of function call form:\n") + (setq pos (1- (point)))) + ;; User calls debug directly. + (_ + (insert ": ") + (setq pos (point)) + (prin1 (if (eq (car args) 'nil) + (cdr args) args) + (current-buffer)) + (insert ?\n))) + ;; Place point on "stack frame 0" (bug#15101). + (goto-char pos)) ;; After any frame that uses eval-buffer, ;; insert a line that states the buffer position it's reading at. (save-excursion @@ -533,16 +541,15 @@ Applies to the frame whose line point is on in the backtrace." (progn ,@body) (setq debugger-outer-match-data (match-data))))) -(defun debugger-eval-expression (exp) +(defun debugger-eval-expression (exp &optional nframe) "Eval an expression, in an environment like that outside the debugger. The environment used is the one when entering the activation frame at point." (interactive - (list (read-from-minibuffer "Eval: " - nil read-expression-map t - 'read-expression-history))) - (let ((nframe (condition-case nil (1+ (debugger-frame-number 'skip-base)) - (error 0))) ;; If on first line. - (base (if (eq 'debug--implement-debug-on-entry + (list (read--expression "Eval in stack frame: "))) + (let ((nframe (or nframe + (condition-case nil (1+ (debugger-frame-number 'skip-base)) + (error 0)))) ;; If on first line. + (base (if (eq 'debug--implement-debug-on-entry (cadr (backtrace-frame 1 'debug))) 'debug--implement-debug-on-entry 'debug))) (debugger-env-macro @@ -651,11 +658,7 @@ Complete list of commands: (defun debugger-record-expression (exp) "Display a variable's value and record it in `*Backtrace-record*' buffer." (interactive - (list (read-from-minibuffer - "Record Eval: " - nil - read-expression-map t - 'read-expression-history))) + (list (read--expression "Record Eval: "))) (let* ((buffer (get-buffer-create debugger-record-buffer)) (standard-output buffer)) (princ (format "Debugger Eval (%s): " exp)) diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index ed10080cc35..1301b70bb85 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -419,7 +419,7 @@ See `%s' for more information on %s." ;; Go through existing buffers. (dolist (buf (buffer-list)) (with-current-buffer buf - (if ,global-mode (,turn-on) (when ,mode (,mode -1)))))) + (if ,global-mode (funcall #',turn-on) (when ,mode (,mode -1)))))) ;; Autoloading define-globalized-minor-mode autoloads everything ;; up-to-here. @@ -449,8 +449,8 @@ See `%s' for more information on %s." (if ,mode (progn (,mode -1) - (,turn-on)) - (,turn-on)))) + (funcall #',turn-on)) + (funcall #',turn-on)))) (setq ,MODE-major-mode major-mode))))) (put ',MODE-enable-in-buffers 'definition-name ',global-mode) @@ -589,7 +589,7 @@ BODY is executed after moving to the destination location." (prog1 (or (< (- (point-max) (point-min)) (buffer-size))) (widen)))) ,body - (when was-narrowed (,narrowfun))))))) + (when was-narrowed (funcall #',narrowfun))))))) (unless name (setq name base-name)) `(progn (defun ,next-sym (&optional count) @@ -601,13 +601,13 @@ BODY is executed after moving to the destination location." ,(funcall when-narrowed `(if (not (re-search-forward ,re nil t count)) (if (looking-at ,re) - (goto-char (or ,(if endfun `(,endfun)) (point-max))) + (goto-char (or ,(if endfun `(funcall #',endfun)) (point-max))) (user-error "No next %s" ,name)) (goto-char (match-beginning 0)) - (when (and (eq (current-buffer) (window-buffer (selected-window))) + (when (and (eq (current-buffer) (window-buffer)) (called-interactively-p 'interactive)) (let ((endpt (or (save-excursion - ,(if endfun `(,endfun) + ,(if endfun `(funcall #',endfun) `(re-search-forward ,re nil t 2))) (point-max)))) (unless (pos-visible-in-window-p endpt nil t) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index ae20e5270e1..ec343eab631 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -293,20 +293,7 @@ A lambda list keyword is a symbol that starts with `&'." "Return t if there are two windows." (and (not (one-window-p)) (eq (selected-window) - (next-window (next-window (selected-window)))))) - -(defsubst edebug-lookup-function (object) - (while (and (symbolp object) (fboundp object)) - (setq object (symbol-function object))) - object) - -(defun edebug-macrop (object) - "Return the macro named by OBJECT, or nil if it is not a macro." - (setq object (edebug-lookup-function object)) - (if (and (listp object) - (eq 'macro (car object)) - (functionp (cdr object))) - object)) + (next-window (next-window))))) (defun edebug-sort-alist (alist function) ;; Return the ALIST sorted with comparison function FUNCTION. @@ -347,7 +334,7 @@ Return the result of the last expression in BODY." ((and (edebug-window-live-p window) (eq (window-buffer window) buffer)) window) - ((eq (window-buffer (selected-window)) buffer) + ((eq (window-buffer) buffer) ;; Selected window already displays BUFFER. (selected-window)) ((get-buffer-window buffer 0)) @@ -1416,7 +1403,7 @@ expressions; a `progn' form will be returned enclosing these forms." ; but leave it in for compatibility. )) ;; No edebug-form-spec provided. - ((edebug-macrop head) + ((macrop head) (if edebug-eval-macro-args (edebug-forms cursor) (edebug-sexps cursor))) @@ -2327,8 +2314,7 @@ MSG is printed after `::::} '." (if edebug-global-break-condition (condition-case nil (setq edebug-global-break-result - ;; FIXME: lexbind. - (eval edebug-global-break-condition)) + (edebug-eval edebug-global-break-condition)) (error nil)))) (edebug-break)) @@ -2339,8 +2325,7 @@ MSG is printed after `::::} '." (and edebug-break-data (or (not edebug-break-condition) (setq edebug-break-result - ;; FIXME: lexbind. - (eval edebug-break-condition)))))) + (edebug-eval edebug-break-condition)))))) (if (and edebug-break (nth 2 edebug-break-data)) ; is it temporary? ;; Delete the breakpoint. diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index 1f5edefea08..98576687f3d 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -236,8 +236,7 @@ description of valid values for RESULT-TYPE. "The regexp the `find-function' mechanisms use for finding test definitions.") -(put 'ert-test-failed 'error-conditions '(error ert-test-failed)) -(put 'ert-test-failed 'error-message "Test failed") +(define-error 'ert-test-failed "Test failed") (defun ert-pass () "Terminate the current test and mark it passed. Does not return." diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index cf090e5e758..279ae582a05 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -217,13 +217,15 @@ instead the assignment is turned into something equivalent to temp) so as to preserve the semantics of `setf'." (declare (debug (sexp (&or symbolp lambda-expr) &optional sexp))) + (when (eq 'lambda (car-safe setter)) + (message "Use `gv-define-setter' or name %s's setter function" name)) `(gv-define-setter ,name (val &rest args) ,(if fix-return `(macroexp-let2 nil v val `(progn - (,',setter ,@(append args (list v))) + (,',setter ,@args ,v) ,v)) - `(cons ',setter (append args (list val)))))) + ``(,',setter ,@args ,val)))) ;;; Typical operations on generalized variables. diff --git a/lisp/emacs-lisp/helper.el b/lisp/emacs-lisp/helper.el index f3b7de521cf..5bef0b06fd4 100644 --- a/lisp/emacs-lisp/helper.el +++ b/lisp/emacs-lisp/helper.el @@ -59,7 +59,7 @@ Helper-return-blurb) "return"))) (save-window-excursion - (goto-char (window-start (selected-window))) + (goto-char (window-start)) (if (get-buffer-window "*Help*") (pop-to-buffer "*Help*") (switch-to-buffer "*Help*")) diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index af30deca4cc..f7105b7d3b4 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -110,7 +110,9 @@ It has `lisp-mode-abbrev-table' as its parent." "define-compiler-macro" "define-modify-macro" "defsetf" "define-setf-expander" "define-method-combination" - "defgeneric" "defmethod") t)) + "defgeneric" "defmethod" + "cl-defun" "cl-defsubst" "cl-defmacro" + "cl-define-compiler-macro") t)) "\\s-+\\(\\(\\sw\\|\\s_\\)+\\)")) 2) (list (purecopy "Variables") @@ -132,7 +134,8 @@ It has `lisp-mode-abbrev-table' as its parent." (regexp-opt '("defgroup" "deftheme" "deftype" "defstruct" "defclass" "define-condition" "define-widget" - "defface" "defpackage") t)) + "defface" "defpackage" "cl-deftype" + "cl-defstruct") t)) "\\s-+'?\\(\\(\\sw\\|\\s_\\)+\\)")) 2)) @@ -572,7 +575,7 @@ if that value is non-nil." (defalias 'common-lisp-mode 'lisp-mode) ;; This will do unless inf-lisp.el is loaded. -(defun lisp-eval-defun (&optional and-go) +(defun lisp-eval-defun (&optional _and-go) "Send the current defun to the Lisp process made by \\[run-lisp]." (interactive) (error "Process lisp does not exist")) @@ -659,7 +662,7 @@ alternative printed representations that can be displayed." printed-value))))) -(defun last-sexp-toggle-display (&optional arg) +(defun last-sexp-toggle-display (&optional _arg) "Toggle between abbreviated and unabbreviated printed representations." (interactive "P") (save-restriction @@ -999,12 +1002,12 @@ function is `common-lisp-indent-function'." :type 'function :group 'lisp) -(defun lisp-indent-line (&optional whole-exp) +(defun lisp-indent-line (&optional _whole-exp) "Indent current line as Lisp code. With argument, indent any additional lines of the same expression rigidly along with this one." (interactive "P") - (let ((indent (calculate-lisp-indent)) shift-amt end + (let ((indent (calculate-lisp-indent)) shift-amt (pos (- (point-max) (point))) (beg (progn (beginning-of-line) (point)))) (skip-chars-forward " \t") @@ -1044,7 +1047,7 @@ is the buffer position of the start of the containing expression." (save-excursion (beginning-of-line) (let ((indent-point (point)) - state paren-depth + state ;; setting this to a number inhibits calling hook (desired-indent nil) (retry t) @@ -1058,7 +1061,7 @@ is the buffer position of the start of the containing expression." ;; Find innermost containing sexp (while (and retry state - (> (setq paren-depth (elt state 0)) 0)) + (> (elt state 0) 0)) (setq retry nil) (setq calculate-lisp-indent-last-sexp (elt state 2)) (setq containing-sexp (elt state 1)) @@ -1287,7 +1290,7 @@ Lisp function does not specify a special indentation." body-indent normal-indent)))) -(defun lisp-indent-defform (state indent-point) +(defun lisp-indent-defform (state _indent-point) (goto-char (car (cdr state))) (forward-line 1) (if (> (point) (car (cdr (cdr state)))) diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index edcfc409085..576e72088e9 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -193,7 +193,11 @@ WHERE is a symbol to select an entry in `advice--where-alist'." (equal function (cdr (assq 'name props)))) (list rest)))))) -(defvar advice--buffer-local-function-sample nil) +(defvar advice--buffer-local-function-sample nil + "keeps an example of the special \"run the default value\" functions. +These functions play the same role as t in buffer-local hooks, and to recognize +them, we keep a sample here against which to compare. Each instance is +different, but `function-equal' will hopefully ignore those differences.") (defun advice--set-buffer-local (var val) (if (function-equal val advice--buffer-local-function-sample) @@ -206,6 +210,7 @@ WHERE is a symbol to select an entry in `advice--where-alist'." (declare (gv-setter advice--set-buffer-local)) (if (local-variable-p var) (symbol-value var) (setq advice--buffer-local-function-sample + ;; This function acts like the t special value in buffer-local hooks. (lambda (&rest args) (apply (default-value var) args))))) ;;;###autoload @@ -284,6 +289,20 @@ of the piece of advice." (macroexp-let2 nil new `(advice--remove-function ,getter ,function) `(unless (eq ,new ,getter) ,(funcall setter new))))) +(defun advice-function-mapc (f function-def) + "Apply F to every advice function in FUNCTION-DEF. +F is called with two arguments: the function that was added, and the +properties alist that was specified when it was added." + (while (advice--p function-def) + (funcall f (advice--car function-def) (advice--props function-def)) + (setq function-def (advice--cdr function-def)))) + +(defun advice-function-member-p (advice function-def) + "Return non-nil if ADVICE is already in FUNCTION-DEF. +Instead of ADVICE being the actual function, it can also be the `name' +of the piece of advice." + (advice--member-p advice advice function-def)) + ;;;; Specific application of add-function to `symbol-function' for advice. (defun advice--subst-main (old new) @@ -294,11 +313,10 @@ of the piece of advice." (cond ((special-form-p def) ;; Not worth the trouble trying to handle this, I think. - (error "advice-add failure: %S is a special form" symbol)) - ((and (symbolp def) - (eq 'macro (car-safe (ignore-errors (indirect-function def))))) - (let ((newval (cons 'macro (cdr (indirect-function def))))) - (put symbol 'advice--saved-rewrite (cons def newval)) + (error "Advice impossible: %S is a special form" symbol)) + ((and (symbolp def) (macrop def)) + (let ((newval `(macro . ,(lambda (&rest r) (macroexpand `(,def . ,r)))))) + (put symbol 'advice--saved-rewrite (cons def (cdr newval))) newval)) ;; `f' might be a pure (hence read-only) cons! ((and (eq 'macro (car-safe def)) @@ -309,32 +327,39 @@ of the piece of advice." (defsubst advice--strip-macro (x) (if (eq 'macro (car-safe x)) (cdr x) x)) +(defun advice--symbol-function (symbol) + ;; The value conceptually stored in `symbol-function' is split into two + ;; parts: + ;; - the normal function definition. + ;; - the list of advice applied to it. + ;; `advice--symbol-function' is intended to return the second part (i.e. the + ;; list of advice, which includes a hole at the end which typically holds the + ;; first part, but this function doesn't care much which value is found + ;; there). + ;; In the "normal" state both parts are combined into a single value stored + ;; in the "function slot" of the symbol. But the way they are combined is + ;; different depending on whether the definition is a function or a macro. + ;; Also if the function definition is nil (i.e. unbound) or is an autoload, + ;; the second part is stashed away temporarily in the `advice--pending' + ;; symbol property. + (or (get symbol 'advice--pending) + (advice--strip-macro (symbol-function symbol)))) + (defun advice--defalias-fset (fsetfun symbol newdef) + (unless fsetfun (setq fsetfun #'fset)) (when (get symbol 'advice--saved-rewrite) (put symbol 'advice--saved-rewrite nil)) (setq newdef (advice--normalize symbol newdef)) - (let* ((olddef (advice--strip-macro (symbol-function symbol))) - (oldadv - (cond - ((null (get symbol 'advice--pending)) - (or olddef - (progn - (message "Delayed advice activation failed for %s: no data" - symbol) - nil))) - ((or (not olddef) (autoloadp olddef)) - (get symbol 'advice--pending)) - (t (message "Dropping left-over advice--pending for %s" symbol) - olddef)))) + (let ((oldadv (advice--symbol-function symbol))) (if (and newdef (not (autoloadp newdef))) (let* ((snewdef (advice--strip-macro newdef)) (snewadv (advice--subst-main oldadv snewdef))) (put symbol 'advice--pending nil) - (funcall (or fsetfun #'fset) symbol + (funcall fsetfun symbol (if (eq snewdef newdef) snewadv (cons 'macro snewadv)))) (unless (eq oldadv (get symbol 'advice--pending)) (put symbol 'advice--pending (advice--subst-main oldadv nil))) - (funcall (or fsetfun #'fset) symbol newdef)))) + (funcall fsetfun symbol newdef)))) ;;;###autoload @@ -345,12 +370,10 @@ is defined as a macro, alias, command, ..." ;; TODO: ;; - record the advice location, to display in describe-function. ;; - change all defadvice in lisp/**/*.el. - ;; - rewrite advice.el on top of this. ;; - obsolete advice.el. (let* ((f (symbol-function symbol)) (nf (advice--normalize symbol f))) - (unless (eq f nf) ;; Most importantly, if nf == nil! - (fset symbol nf)) + (unless (eq f nf) (fset symbol nf)) (add-function where (cond ((eq (car-safe nf) 'macro) (cdr nf)) ;; Reasons to delay installation of the advice: @@ -377,39 +400,34 @@ or an autoload and it preserves `fboundp'. Instead of the actual function to remove, FUNCTION can also be the `name' of the piece of advice." (let ((f (symbol-function symbol))) - ;; Can't use the `if' place here, because the body is too large, - ;; resulting in use of code that only works with lexical-scoping. - (remove-function (if (eq (car-safe f) 'macro) - (cdr f) - (symbol-function symbol)) + (remove-function (cond ;This is `advice--symbol-function' but as a "place". + ((get symbol 'advice--pending) + (get symbol 'advice--pending)) + ((eq (car-safe f) 'macro) (cdr f)) + (t (symbol-function symbol))) function) - (unless (advice--p - (if (eq (car-safe f) 'macro) (cdr f) (symbol-function symbol))) + (unless (advice--p (advice--symbol-function symbol)) ;; Not advised any more. (remove-function (get symbol 'defalias-fset-function) #'advice--defalias-fset) - (if (eq (symbol-function symbol) - (cdr (get symbol 'advice--saved-rewrite))) - (fset symbol (car (get symbol 'advice--saved-rewrite)))))) + (let ((asr (get symbol 'advice--saved-rewrite))) + (and asr (eq (cdr-safe (symbol-function symbol)) + (cdr asr)) + (fset symbol (car (get symbol 'advice--saved-rewrite))))))) nil) -(defun advice-mapc (fun def) - "Apply FUN to every advice function in DEF. +(defun advice-mapc (fun symbol) + "Apply FUN to every advice function in SYMBOL. FUN is called with a two arguments: the function that was added, and the properties alist that was specified when it was added." - (while (advice--p def) - (funcall fun (advice--car def) (advice--props def)) - (setq def (advice--cdr def)))) + (advice-function-mapc fun (advice--symbol-function symbol))) ;;;###autoload -(defun advice-member-p (advice function-name) - "Return non-nil if ADVICE has been added to FUNCTION-NAME. +(defun advice-member-p (advice symbol) + "Return non-nil if ADVICE has been added to SYMBOL. Instead of ADVICE being the actual function, it can also be the `name' of the piece of advice." - (advice--member-p advice advice - (or (get function-name 'advice--pending) - (advice--strip-macro - (symbol-function function-name))))) + (advice-function-member-p advice (advice--symbol-function symbol))) ;; When code is advised, called-interactively-p needs to be taught to skip ;; the advising frames. diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 68d2880d33e..add73fd4bde 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -296,7 +296,7 @@ contrast, `package-user-dir' contains packages for personal use." (:constructor package-desc-from-define (name-string version-string &optional summary requirements - &key kind archive + &key kind archive &allow-other-keys &aux (name (intern name-string)) (version (version-to-list version-string)) diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 50c92518b02..eb2c7f002e8 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -353,23 +353,34 @@ MATCH is the pattern that needs to be matched, of the form: (symbolp . numberp) (symbolp . consp) (symbolp . arrayp) + (symbolp . vectorp) (symbolp . stringp) (symbolp . byte-code-function-p) (integerp . consp) (integerp . arrayp) + (integerp . vectorp) (integerp . stringp) (integerp . byte-code-function-p) (numberp . consp) (numberp . arrayp) + (numberp . vectorp) (numberp . stringp) (numberp . byte-code-function-p) (consp . arrayp) + (consp . vectorp) (consp . stringp) (consp . byte-code-function-p) - (arrayp . stringp) (arrayp . byte-code-function-p) + (vectorp . byte-code-function-p) + (stringp . vectorp) (stringp . byte-code-function-p))) +(defun pcase--mutually-exclusive-p (pred1 pred2) + (or (member (cons pred1 pred2) + pcase-mutually-exclusive-predicates) + (member (cons pred2 pred1) + pcase-mutually-exclusive-predicates))) + (defun pcase--split-match (sym splitter match) (cond ((eq (car match) 'match) @@ -433,10 +444,7 @@ MATCH is the pattern that needs to be matched, of the form: ;; A QPattern but not for a cons, can only go to the `else' side. ((eq (car-safe pat) '\`) '(:pcase--fail . nil)) ((and (eq (car-safe pat) 'pred) - (or (member (cons 'consp (cadr pat)) - pcase-mutually-exclusive-predicates) - (member (cons (cadr pat) 'consp) - pcase-mutually-exclusive-predicates))) + (pcase--mutually-exclusive-p #'consp (cadr pat))) '(:pcase--fail . nil)))) (defun pcase--split-equal (elem pat) @@ -496,11 +504,14 @@ MATCH is the pattern that needs to be matched, of the form: (not (pcase--fgrep (mapcar #'car vars) (cadr upat))))) '(:pcase--succeed . :pcase--fail)) ((and (eq 'pred (car upat)) - (eq 'pred (car-safe pat)) - (or (member (cons (cadr upat) (cadr pat)) - pcase-mutually-exclusive-predicates) - (member (cons (cadr pat) (cadr upat)) - pcase-mutually-exclusive-predicates))) + (let ((otherpred + (cond ((eq 'pred (car-safe pat)) (cadr pat)) + ((not (eq '\` (car-safe pat))) nil) + ((consp (cadr pat)) #'consp) + ((vectorp (cadr pat)) #'vectorp) + ((byte-code-function-p (cadr pat)) + #'byte-code-function-p)))) + (pcase--mutually-exclusive-p (cadr upat) otherpred))) '(:pcase--fail . nil)) ((and (eq 'pred (car upat)) (eq '\` (car-safe pat)) diff --git a/lisp/emacs-lisp/re-builder.el b/lisp/emacs-lisp/re-builder.el index 9b73bea065f..d463bfac412 100644 --- a/lisp/emacs-lisp/re-builder.el +++ b/lisp/emacs-lisp/re-builder.el @@ -319,7 +319,7 @@ Except for Lisp syntax this is the same as `reb-regexp'.") (eq 'color ;; emacs/xemacs compatibility (if (fboundp 'frame-parameter) - (frame-parameter (selected-frame) 'display-type) + (frame-parameter nil 'display-type) (if (fboundp 'frame-property) (frame-property (selected-frame) 'display-type))))) diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el index 0aa31f717ed..1ee3cec15a6 100644 --- a/lisp/emacs-lisp/timer.el +++ b/lisp/emacs-lisp/timer.el @@ -55,31 +55,29 @@ (defsubst timer--check (timer) (or (timerp timer) (signal 'wrong-type-argument (list #'timerp timer)))) +(defun timer--time-setter (timer time) + (timer--check timer) + (setf (timer--high-seconds timer) (pop time)) + (let ((low time) (usecs 0) (psecs 0)) + (when (consp time) + (setq low (pop time)) + (when time + (setq usecs (pop time)) + (when time + (setq psecs (car time))))) + (setf (timer--low-seconds timer) low) + (setf (timer--usecs timer) usecs) + (setf (timer--psecs timer) psecs) + time)) + ;; Pseudo field `time'. (defun timer--time (timer) + (declare (gv-setter timer--time-setter)) (list (timer--high-seconds timer) (timer--low-seconds timer) (timer--usecs timer) (timer--psecs timer))) -(gv-define-simple-setter timer--time - (lambda (timer time) - (timer--check timer) - (setf (timer--high-seconds timer) (pop time)) - (let ((low time) (usecs 0) (psecs 0)) - (if (consp time) - (progn - (setq low (pop time)) - (if time - (progn - (setq usecs (pop time)) - (if time - (setq psecs (car time))))))) - (setf (timer--low-seconds timer) low) - (setf (timer--usecs timer) usecs) - (setf (timer--psecs timer) psecs)))) - - (defun timer-set-time (timer time &optional delta) "Set the trigger time of TIMER to TIME. TIME must be in the internal format returned by, e.g., `current-time'. |