diff options
Diffstat (limited to 'lisp/emacs-lisp')
| -rw-r--r-- | lisp/emacs-lisp/bytecomp.el | 43 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-generic.el | 16 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-lib.el | 10 | ||||
| -rw-r--r-- | lisp/emacs-lisp/edebug.el | 2 | ||||
| -rw-r--r-- | lisp/emacs-lisp/eldoc.el | 49 | ||||
| -rw-r--r-- | lisp/emacs-lisp/ert.el | 15 | ||||
| -rw-r--r-- | lisp/emacs-lisp/gv.el | 6 | ||||
| -rw-r--r-- | lisp/emacs-lisp/map.el | 19 | ||||
| -rw-r--r-- | lisp/emacs-lisp/nadvice.el | 12 | ||||
| -rw-r--r-- | lisp/emacs-lisp/pcase.el | 1 | ||||
| -rw-r--r-- | lisp/emacs-lisp/rx.el | 56 |
11 files changed, 160 insertions, 69 deletions
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index e5b9b47b1d0..fdd4276e4e7 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1263,12 +1263,6 @@ when printing the error message." (defun byte-compile-arglist-signature (arglist) (cond - ;; New style byte-code arglist. - ((integerp arglist) - (cons (logand arglist 127) ;Mandatory. - (if (zerop (logand arglist 128)) ;No &rest. - (lsh arglist -8)))) ;Nonrest. - ;; Old style byte-code, or interpreted function. ((listp arglist) (let ((args 0) opts @@ -1289,6 +1283,19 @@ when printing the error message." ;; Unknown arglist. (t '(0)))) +(defun byte-compile--function-signature (f) + ;; Similar to help-function-arglist, except that it returns the info + ;; in a different format. + (and (eq 'macro (car-safe f)) (setq f (cdr f))) + ;; Advice wrappers have "catch all" args, so fetch the actual underlying + ;; function to find the real arguments. + (while (advice--p f) (setq f (advice--cdr f))) + (if (eq (car-safe f) 'declared) + (byte-compile-arglist-signature (nth 1 f)) + (condition-case nil + (let ((sig (func-arity f))) + (if (numberp (cdr sig)) sig (list (car sig)))) + (error '(0))))) (defun byte-compile-arglist-signatures-congruent-p (old new) (not (or @@ -1330,19 +1337,7 @@ when printing the error message." (defun byte-compile-callargs-warn (form) (let* ((def (or (byte-compile-fdefinition (car form) nil) (byte-compile-fdefinition (car form) t))) - (sig (if (and def (not (eq def t))) - (progn - (and (eq (car-safe def) 'macro) - (eq (car-safe (cdr-safe def)) 'lambda) - (setq def (cdr def))) - (byte-compile-arglist-signature - (if (memq (car-safe def) '(declared lambda)) - (nth 1 def) - (if (byte-code-function-p def) - (aref def 0) - '(&rest def))))) - (if (subrp (symbol-function (car form))) - (subr-arity (symbol-function (car form)))))) + (sig (byte-compile--function-signature def)) (ncall (length (cdr form)))) ;; Check many or unevalled from subr-arity. (if (and (cdr-safe sig) @@ -1461,15 +1456,7 @@ extra args." (and initial (symbolp initial) (setq old (byte-compile-fdefinition initial nil))) (when (and old (not (eq old t))) - (and (eq 'macro (car-safe old)) - (eq 'lambda (car-safe (cdr-safe old))) - (setq old (cdr old))) - (let ((sig1 (byte-compile-arglist-signature - (pcase old - (`(lambda ,args . ,_) args) - (`(closure ,_ ,args . ,_) args) - ((pred byte-code-function-p) (aref old 0)) - (_ '(&rest def))))) + (let ((sig1 (byte-compile--function-signature old)) (sig2 (byte-compile-arglist-signature arglist))) (unless (byte-compile-arglist-signatures-congruent-p sig1 sig2) (byte-compile-set-symbol-position name) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index c64376b940f..6a4ee47ac24 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -182,8 +182,7 @@ SPECIALIZERS-FUNCTION takes as first argument a tag value TAG origname)) (if generic (cl-assert (eq name (cl--generic-name generic))) - (setf (cl--generic name) (setq generic (cl--generic-make name))) - (defalias name (cl--generic-make-function generic))) + (setf (cl--generic name) (setq generic (cl--generic-make name)))) generic)) ;;;###autoload @@ -1210,5 +1209,18 @@ Used internally for the (major-mode MODE) context specializers." (progn (cl-assert (null modes)) mode) `(derived-mode ,mode . ,modes)))) +;;; Support for unloading. + +(cl-defmethod loadhist-unload-element ((x (head cl-defmethod))) + (pcase-let* + ((`(,name ,qualifiers . ,specializers) (cdr x)) + (generic (cl-generic-ensure-function name 'noerror))) + (when generic + (let* ((mt (cl--generic-method-table generic)) + (me (cl--generic-member-method specializers qualifiers mt))) + (when me + (setf (cl--generic-method-table generic) (delq (car me) mt))))))) + + (provide 'cl-generic) ;;; cl-generic.el ends here diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index 936c852526c..6ac08d839b1 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -288,14 +288,6 @@ If true return the decimal value of digit CHAR in RADIX." (let ((n (aref cl-digit-char-table char))) (and n (< n (or radix 10)) n))) -(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--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. If your system supports infinities, this is the largest finite value. @@ -639,7 +631,7 @@ If ALIST is non-nil, the new pairs are prepended to it." (require 'cl-seq)) (defun cl--old-struct-type-of (orig-fun object) - (or (and (vectorp object) + (or (and (vectorp object) (> (length object) 0) (let ((tag (aref object 0))) (when (and (symbolp tag) (string-prefix-p "cl-struct-" (symbol-name tag))) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 65e30f86778..1494ed1d9c3 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -906,7 +906,7 @@ circular objects. Let `read' read everything else." ;; with the object itself, wherever it occurs. (forward-char 1) (let ((obj (edebug-read-storing-offsets stream))) - (substitute-object-in-subtree obj placeholder) + (lread--substitute-object-in-subtree obj placeholder t) (throw 'return (setf (cdr elem) obj))))) ((eq ?# (following-char)) ;; #n# returns a previously read object. diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index a05bd7cc4d4..bca40ab87da 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -160,6 +160,10 @@ This is used to determine if `eldoc-idle-delay' is changed by the user.") It should receive the same arguments as `message'.") (defun eldoc-edit-message-commands () + "Return an obarray containing common editing commands. + +When `eldoc-print-after-edit' is non-nil, ElDoc messages are only +printed after commands contained in this obarray." (let ((cmds (make-vector 31 0)) (re (regexp-opt '("delete" "insert" "edit" "electric" "newline")))) (mapatoms (lambda (s) @@ -211,16 +215,21 @@ expression point is on." ;;;###autoload (defun turn-on-eldoc-mode () - "Turn on `eldoc-mode' if the buffer has eldoc support enabled. + "Turn on `eldoc-mode' if the buffer has ElDoc support enabled. See `eldoc-documentation-function' for more detail." (when (eldoc--supported-p) (eldoc-mode 1))) (defun eldoc--supported-p () + "Non-nil if an ElDoc function is set for this buffer." (not (memq eldoc-documentation-function '(nil ignore)))) (defun eldoc-schedule-timer () + "Ensure `eldoc-timer' is running. + +If the user has changed `eldoc-idle-delay', update the timer to +reflect the change." (or (and eldoc-timer (memq eldoc-timer timer-idle-list)) ;FIXME: Why? (setq eldoc-timer @@ -229,8 +238,7 @@ See `eldoc-documentation-function' for more detail." (lambda () (when (or eldoc-mode (and global-eldoc-mode - (not (memq eldoc-documentation-function - '(nil ignore))))) + (eldoc--supported-p))) (eldoc-print-current-symbol-info)))))) ;; If user has changed the idle delay, update the timer. @@ -268,16 +276,19 @@ Otherwise work like `message'." (force-mode-line-update))) (apply 'message format-string args))) -(defun eldoc-message (&rest args) +(defun eldoc-message (&optional format-string &rest args) + "Display FORMAT-STRING formatted with ARGS as an ElDoc message. + +Store the message (if any) in `eldoc-last-message', and return it." (let ((omessage eldoc-last-message)) (setq eldoc-last-message - (cond ((eq (car args) eldoc-last-message) eldoc-last-message) - ((null (car args)) nil) + (cond ((eq format-string eldoc-last-message) eldoc-last-message) + ((null format-string) nil) ;; If only one arg, no formatting to do, so put it in ;; eldoc-last-message so eq test above might succeed on ;; subsequent calls. - ((null (cdr args)) (car args)) - (t (apply #'format-message args)))) + ((null args) format-string) + (t (apply #'format-message format-string args)))) ;; In emacs 19.29 and later, and XEmacs 19.13 and later, all messages ;; are recorded in a log. Do not put eldoc messages in that log since ;; they are Legion. @@ -289,6 +300,7 @@ Otherwise work like `message'." eldoc-last-message) (defun eldoc--message-command-p (command) + "Return non-nil if COMMAND is in `eldoc-message-commands'." (and (symbolp command) (intern-soft (symbol-name command) eldoc-message-commands))) @@ -299,6 +311,7 @@ Otherwise work like `message'." ;; before the next command executes, which does away with the flicker. ;; This doesn't seem to be required for Emacs 19.28 and earlier. (defun eldoc-pre-command-refresh-echo-area () + "Reprint `eldoc-last-message' in the echo area." (and eldoc-last-message (not (minibufferp)) ;We don't use the echo area when in minibuffer. (if (and (eldoc-display-message-no-interference-p) @@ -310,6 +323,7 @@ Otherwise work like `message'." ;; Decide whether now is a good time to display a message. (defun eldoc-display-message-p () + "Return non-nil when it is appropriate to display an ElDoc message." (and (eldoc-display-message-no-interference-p) ;; If this-command is non-nil while running via an idle ;; timer, we're still in the middle of executing a command, @@ -322,6 +336,7 @@ Otherwise work like `message'." ;; Check various conditions about the current environment that might make ;; it undesirable to print eldoc messages right this instant. (defun eldoc-display-message-no-interference-p () + "Return nil if displaying a message would cause interference." (not (or executing-kbd-macro (bound-and-true-p edebug-active)))) @@ -347,6 +362,7 @@ variable) is taken into account if the major mode specific function does not return any documentation.") (defun eldoc-print-current-symbol-info () + "Print the text produced by `eldoc-documentation-function'." ;; This is run from post-command-hook or some idle timer thing, ;; so we need to be careful that errors aren't ignored. (with-demoted-errors "eldoc error: %s" @@ -361,6 +377,13 @@ return any documentation.") ;; truncated or eliminated entirely from the output to make room for the ;; description. (defun eldoc-docstring-format-sym-doc (prefix doc &optional face) + "Combine PREFIX and DOC, and shorten the result to fit in the echo area. + +When PREFIX is a symbol, propertize its symbol name with FACE +before combining it with DOC. If FACE is not provided, just +apply the nil face. + +See also: `eldoc-echo-area-use-multiline-p'." (when (symbolp prefix) (setq prefix (concat (propertize (symbol-name prefix) 'face face) ": "))) (let* ((ea-multi eldoc-echo-area-use-multiline-p) @@ -390,22 +413,26 @@ return any documentation.") ;; These functions do display-command table management. (defun eldoc-add-command (&rest cmds) + "Add each of CMDS to the obarray `eldoc-message-commands'." (dolist (name cmds) (and (symbolp name) (setq name (symbol-name name))) (set (intern name eldoc-message-commands) t))) (defun eldoc-add-command-completions (&rest names) + "Pass every prefix completion of NAMES to `eldoc-add-command'." (dolist (name names) (apply #'eldoc-add-command (all-completions name obarray 'commandp)))) (defun eldoc-remove-command (&rest cmds) + "Remove each of CMDS from the obarray `eldoc-message-commands'." (dolist (name cmds) (and (symbolp name) (setq name (symbol-name name))) (unintern name eldoc-message-commands))) (defun eldoc-remove-command-completions (&rest names) + "Pass every prefix completion of NAMES to `eldoc-remove-command'." (dolist (name names) (apply #'eldoc-remove-command (all-completions name eldoc-message-commands)))) @@ -418,9 +445,9 @@ return any documentation.") "down-list" "end-of-" "exchange-point-and-mark" "forward-" "goto-" "handle-select-window" "indent-for-tab-command" "left-" "mark-page" "mark-paragraph" "mouse-set-point" "move-" "move-beginning-of-" - "move-end-of-" "newline" "next-" "other-window" "pop-global-mark" "previous-" - "recenter" "right-" "scroll-" "self-insert-command" "split-window-" - "up-list") + "move-end-of-" "newline" "next-" "other-window" "pop-global-mark" + "previous-" "recenter" "right-" "scroll-" "self-insert-command" + "split-window-" "up-list") (provide 'eldoc) diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index eb2b2e3e11b..5c88b070f65 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -136,8 +136,15 @@ Emacs bug 6581 at URL `http://debbugs.gnu.org/cgi/bugreport.cgi?bug=6581'." ;; ert-test objects. It designates an anonymous test. (error "Attempt to define a test named nil")) (put symbol 'ert--test definition) + ;; Register in load-history, so `symbol-file' can find us, and so + ;; unload-feature can unload our tests. + (cl-pushnew `(ert-deftest . ,symbol) current-load-list :test #'equal) definition) +(cl-defmethod loadhist-unload-element ((x (head ert-deftest))) + (let ((name (cdr x))) + (put name 'ert--test nil))) + (defun ert-make-test-unbound (symbol) "Make SYMBOL name no test. Return SYMBOL." (cl-remprop symbol 'ert--test) @@ -214,12 +221,6 @@ description of valid values for RESULT-TYPE. ,@(when tags-supplied-p `(:tags ,tags)) :body (lambda () ,@body))) - ;; This hack allows `symbol-file' to associate `ert-deftest' - ;; forms with files, and therefore enables `find-function' to - ;; work with tests. However, it leads to warnings in - ;; `unload-feature', which doesn't know how to undefine tests - ;; and has no mechanism for extension. - (push '(ert-deftest . ,name) current-load-list) ',name)))) ;; We use these `put' forms in addition to the (declare (indent)) in @@ -1512,7 +1513,7 @@ Ran \\([0-9]+\\) tests, \\([0-9]+\\) results as expected\ (message "%d files contained unexpected results:" (length unexpected)) (mapc (lambda (l) (message " %s" l)) unexpected)) ;; More details on hydra, where the logs are harder to get to. - (when (and (getenv "NIX_STORE") + (when (and (getenv "EMACS_HYDRA_CI") (not (zerop (+ nunexpected nskipped)))) (message "\nDETAILS") (message "-------") diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index c5c12a6414c..27376fc7f95 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -377,10 +377,12 @@ The return value is the last VAL in the list. `(with-current-buffer ,buf (set (make-local-variable ,var) ,v)))) (gv-define-expander alist-get - (lambda (do key alist &optional default remove) + (lambda (do key alist &optional default remove testfn) (macroexp-let2 macroexp-copyable-p k key (gv-letplace (getter setter) alist - (macroexp-let2 nil p `(assq ,k ,getter) + (macroexp-let2 nil p `(if (and ,testfn (not (eq ,testfn 'eq))) + (assoc ,k ,getter ,testfn) + (assq ,k ,getter)) (funcall do (if (null default) `(cdr ,p) `(if ,p (cdr ,p) ,default)) (lambda (v) diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el index a89457e877d..e098eef8294 100644 --- a/lisp/emacs-lisp/map.el +++ b/lisp/emacs-lisp/map.el @@ -4,7 +4,7 @@ ;; Author: Nicolas Petton <nicolas@petton.fr> ;; Keywords: convenience, map, hash-table, alist, array -;; Version: 1.1 +;; Version: 1.2 ;; Package: map ;; Maintainer: emacs-devel@gnu.org @@ -93,11 +93,13 @@ Returns the result of evaluating the form associated with MAP-VAR's type." ((arrayp ,map-var) ,(plist-get args :array)) (t (error "Unsupported map: %s" ,map-var))))) -(defun map-elt (map key &optional default) +(defun map-elt (map key &optional default testfn) "Lookup KEY in MAP and return its associated value. If KEY is not found, return DEFAULT which defaults to nil. -If MAP is a list, `eql' is used to lookup KEY. +If MAP is a list, `eql' is used to lookup KEY. Optional argument +TESTFN, if non-nil, means use its function definition instead of +`eql'. MAP can be a list, hash-table or array." (declare @@ -106,30 +108,31 @@ MAP can be a list, hash-table or array." (gv-letplace (mgetter msetter) `(gv-delay-error ,map) (macroexp-let2* nil ;; Eval them once and for all in the right order. - ((key key) (default default)) + ((key key) (default default) (testfn testfn)) `(if (listp ,mgetter) ;; Special case the alist case, since it can't be handled by the ;; map--put function. ,(gv-get `(alist-get ,key (gv-synthetic-place ,mgetter ,msetter) - ,default) + ,default nil ,testfn) do) ,(funcall do `(map-elt ,mgetter ,key ,default) (lambda (v) `(map--put ,mgetter ,key ,v))))))))) (map--dispatch map - :list (alist-get key map default) + :list (alist-get key map default nil testfn) :hash-table (gethash key map default) :array (if (and (>= key 0) (< key (seq-length map))) (seq-elt map key) default))) -(defmacro map-put (map key value) +(defmacro map-put (map key value &optional testfn) "Associate KEY with VALUE in MAP and return VALUE. If KEY is already present in MAP, replace the associated value with VALUE. +When MAP is a list, test equality with TESTFN if non-nil, otherwise use `eql'. MAP can be a list, hash-table or array." - `(setf (map-elt ,map ,key) ,value)) + `(setf (map-elt ,map ,key nil ,testfn) ,value)) (defun map-delete (map key) "Delete KEY from MAP and return MAP. diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index fd1cd2c7aaf..c68ecbc59ee 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -385,6 +385,18 @@ of the piece of advice." (defun advice--defalias-fset (fsetfun symbol newdef) (unless fsetfun (setq fsetfun #'fset)) + ;; `newdef' shouldn't include advice wrappers, since that's what *we* manage! + ;; So if `newdef' includes advice wrappers, it's usually because someone + ;; naively took (symbol-function F) and then passed that back to `defalias': + ;; let's strip them away. + (cond + ((advice--p newdef) (setq newdef (advice--cd*r newdef))) + ((and (eq 'macro (car-safe newdef)) + (advice--p (cdr newdef))) + (setq newdef `(macro . ,(advice--cd*r (cdr newdef)))))) + ;; The saved-rewrite is specific to the current value, so since we are about + ;; to overwrite that current value with new value, the old saved-rewrite is + ;; not relevant any more. (when (get symbol 'advice--saved-rewrite) (put symbol 'advice--saved-rewrite nil)) (setq newdef (advice--normalize symbol newdef)) diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 4a06ab25d3e..b40161104d2 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -930,6 +930,5 @@ QPAT can take the following forms: ((or (stringp qpat) (integerp qpat) (symbolp qpat)) `',qpat) (t (error "Unknown QPAT: %S" qpat)))) - (provide 'pcase) ;;; pcase.el ends here diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el index 386232c6eef..b66f2c6d512 100644 --- a/lisp/emacs-lisp/rx.el +++ b/lisp/emacs-lisp/rx.el @@ -1169,6 +1169,62 @@ enclosed in `(and ...)'. (rx-to-string `(and ,@regexps) t)) (t (rx-to-string (car regexps) t)))) + + +(pcase-defmacro rx (&rest regexps) + "Build a `pcase' pattern matching `rx' regexps. +The REGEXPS are interpreted as by `rx'. The pattern matches if +the regular expression so constructed matches the object, as if +by `string-match'. + +In addition to the usual `rx' constructs, REGEXPS can contain the +following constructs: + + (let VAR FORM...) creates a new explicitly numbered submatch + that matches FORM and binds the match to + VAR. + (backref VAR) creates a backreference to the submatch + introduced by a previous (let VAR ...) + construct. + +The VARs are associated with explicitly numbered submatches +starting from 1. Multiple occurrences of the same VAR refer to +the same submatch. + +If a case matches, the match data is modified as usual so you can +use it in the case body, but you still have to pass the correct +string as argument to `match-string'." + (let* ((vars ()) + (rx-constituents + `((let + ,(lambda (form) + (rx-check form) + (let ((var (cadr form))) + (cl-check-type var symbol) + (let ((i (or (cl-position var vars :test #'eq) + (prog1 (length vars) + (setq vars `(,@vars ,var)))))) + (rx-form `(submatch-n ,(1+ i) ,@(cddr form)))))) + 1 nil) + (backref + ,(lambda (form) + (rx-check form) + (rx-backref + `(backref ,(let ((var (cadr form))) + (if (integerp var) var + (1+ (cl-position var vars :test #'eq))))))) + 1 1 + ,(lambda (var) + (cond ((integerp var) (rx-check-backref var)) + ((memq var vars) t) + (t (error "rx `backref' variable must be one of %s: %s" + vars var))))) + ,@rx-constituents)) + (regexp (rx-to-string `(seq ,@regexps) :no-group))) + `(and (pred (string-match ,regexp)) + ,@(cl-loop for i from 1 + for var in vars + collect `(app (match-string ,i) ,var))))) ;; ;; sregex.el replacement |